paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-27 13:17:10 +01:00
Code Issues Packages Projects Releases Wiki Activity

* update tdbf to 6.9.2

Browse Source 
git-svn-id: trunk@8883 -
This commit is contained in:
micha 2007-10-21 13:51:12 +00:00
parent 17b81890cd
commit 89c07a2aef
12 changed files with 164 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
packages/fcl-db/src/dbase/dbf.pas
View File

@ -300,10 +300,10 @@ type
{$endif} {$endif}
{$ifdef SUPPORT_OVERLOAD} {$ifdef SUPPORT_OVERLOAD}
function GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean): Boolean; overload; function GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean): Boolean;
{$ifdef SUPPORT_BACKWARD_FIELDDATA} override; {$endif} {$ifdef SUPPORT_BACKWARD_FIELDDATA} overload; override; {$else} reintroduce; overload; {$endif}
procedure SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean); overload; procedure SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean);
{$ifdef SUPPORT_BACKWARD_FIELDDATA} override; {$endif} {$ifdef SUPPORT_BACKWARD_FIELDDATA} overload; override; {$else} reintroduce; overload; {$endif}
{$endif} {$endif}
function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override; function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;
@ -440,8 +440,10 @@ type
property AfterCancel; property AfterCancel;
property BeforeDelete; property BeforeDelete;
property AfterDelete; property AfterDelete;
{$ifdef SUPPORT_REFRESHEVENTS}
property BeforeRefresh; property BeforeRefresh;
property AfterRefresh; property AfterRefresh;
{$endif}
property BeforeScroll; property BeforeScroll;
property AfterScroll; property AfterScroll;
property OnCalcFields; property OnCalcFields;
@ -2223,7 +2225,7 @@ begin
begin begin
FParser := TDbfParser.Create(FDbfFile); FParser := TDbfParser.Create(FDbfFile);
// we need truncated, translated (to ANSI) strings // we need truncated, translated (to ANSI) strings
FParser.RawStringFields := false; FParser.StringFieldMode := smAnsiTrim;
end; end;
// have a parser now? // have a parser now?
if FParser <> nil then if FParser <> nil then

29
packages/fcl-db/src/dbase/dbf_avl.pas
View File

@ -38,7 +38,7 @@ type
FOnDelete: TAvlTreeEvent; FOnDelete: TAvlTreeEvent;
FHeightChange: Boolean; FHeightChange: Boolean;
procedure InternalInsert(X: PNode; var P: PNode); function InternalInsert(X: PNode; var P: PNode): Boolean;
procedure InternalDelete(X: TKeyType; var P: PNode); procedure InternalDelete(X: TKeyType; var P: PNode);
procedure DeleteNode(X: PNode); procedure DeleteNode(X: PNode);
@ -49,7 +49,7 @@ type
procedure Clear; procedure Clear;
function Find(Key: TKeyType): TExtraData; function Find(Key: TKeyType): TExtraData;
procedure Insert(Key: TKeyType; Extra: TExtraData); function Insert(Key: TKeyType; Extra: TExtraData): Boolean;
procedure Delete(Key: TKeyType); procedure Delete(Key: TKeyType);
function Lowest: PData; function Lowest: PData;
@ -271,7 +271,7 @@ begin
Result := nil; Result := nil;
end; end;
procedure TAvlTree.Insert(Key: TKeyType; Extra: TExtraData); function TAvlTree.Insert(Key: TKeyType; Extra: TExtraData): boolean;
var var
H: PNode; H: PNode;
begin begin
@ -286,7 +286,9 @@ begin
Bal := 0; Bal := 0;
end; end;
// insert new node // insert new node
InternalInsert(H, FRoot); Result := InternalInsert(H, FRoot);
if not Result then
Dispose(H);
// check tree // check tree
// assert(CheckTree(FRoot)); // assert(CheckTree(FRoot));
end; end;
@ -297,15 +299,19 @@ begin
// assert(CheckTree(FRoot)); // assert(CheckTree(FRoot));
end; end;
procedure TAvlTree.InternalInsert(X: PNode; var P: PNode); function TAvlTree.InternalInsert(X: PNode; var P: PNode): boolean;
begin begin
if P = nil if P = nil then
then begin P := X; Inc(FCount); FHeightChange := true end begin
else P := X;
Inc(FCount);
FHeightChange := true;
Result := true;
end else begin
if X^.Data.ID < P^.Data.ID then if X^.Data.ID < P^.Data.ID then
begin begin
{ less } { less }
InternalInsert(X, P^.Left); Result := InternalInsert(X, P^.Left);
if FHeightChange then {Left branch has grown higher} if FHeightChange then {Left branch has grown higher}
case P^.Bal of case P^.Bal of
1: begin P^.Bal := 0; FHeightChange := false end; 1: begin P^.Bal := 0; FHeightChange := false end;
@ -338,7 +344,7 @@ begin
if X^.Data.ID > P^.Data.ID then if X^.Data.ID > P^.Data.ID then
begin begin
{ greater } { greater }
InternalInsert(X, P^.Right); Result := InternalInsert(X, P^.Right);
if FHeightChange then {Right branch has grown higher} if FHeightChange then {Right branch has grown higher}
case P^.Bal of case P^.Bal of
-1: begin P^.Bal := 0; FHeightChange := false end; -1: begin P^.Bal := 0; FHeightChange := false end;
@ -370,8 +376,9 @@ begin
end {greater} else begin end {greater} else begin
{X already present; do not insert again} {X already present; do not insert again}
FHeightChange := false; FHeightChange := false;
Result := false;
end;
end; end;
// assert(CheckTree(P)); // assert(CheckTree(P));
end;{InternalInsert} end;{InternalInsert}

88
packages/fcl-db/src/dbase/dbf_collate.pas
View File

@ -1,4 +1,4 @@
unit Dbf_Collate; unit dbf_collate;
{$i dbf_common.inc} {$i dbf_common.inc}
@ -763,7 +763,7 @@ const
db866ru0 :PCollationTable = @_db866ru0; db866ru0 :PCollationTable = @_db866ru0;
{$ifdef USE_BORLAND_COLLATION_TABLES}
// BLLT1DA0 64770 // BLLT1DA0 64770
@ -926,7 +926,7 @@ const
); );
BLLT1NO0 :PCollationTable = @_BLLT1NO0; BLLT1NO0 :PCollationTable = @_BLLT1NO0;
{$endif}
// DB850US0 Checksum: 43413 // DB850US0 Checksum: 43413
@ -954,7 +954,7 @@ const
{$IFDEF PARADOX_COLLATIONS} {$ifdef USE_PARADOX_COLLATIONS}
// intl850 43039 // intl850 43039
@ -978,12 +978,6 @@ const
); );
intl850 :PCollationTable = @_intl850; intl850 :PCollationTable = @_intl850;
{$ENDIF}
{$IFDEF PARADOX_COLLATIONS}
// SPANISH 20109 // SPANISH 20109
@ -1007,12 +1001,10 @@ const
); );
SPANISH :PCollationTable = @_SPANISH; SPANISH :PCollationTable = @_SPANISH;
{$ENDIF}
{$IFDEF PARADOX_COLLATIONS}
// iceland 23936 // iceland 23936
@ -1036,12 +1028,10 @@ const
); );
iceland :PCollationTable = @_iceland; iceland :PCollationTable = @_iceland;
{$ENDIF}
{$IFDEF PARADOX_COLLATIONS}
// ANSIINTL 58462 // ANSIINTL 58462
@ -1065,12 +1055,10 @@ const
); );
ANSIINTL :PCollationTable = @_ANSIINTL; ANSIINTL :PCollationTable = @_ANSIINTL;
{$ENDIF}
{$IFDEF PARADOX_COLLATIONS}
// ANSII850 29000 // ANSII850 29000
@ -1094,12 +1082,10 @@ const
); );
ANSII850 :PCollationTable = @_ANSII850; ANSII850 :PCollationTable = @_ANSII850;
{$ENDIF}
{$IFDEF PARADOX_COLLATIONS}
// ANSISPAN 33308 // ANSISPAN 33308
@ -1123,12 +1109,10 @@ const
); );
ANSISPAN :PCollationTable = @_ANSISPAN; ANSISPAN :PCollationTable = @_ANSISPAN;
{$ENDIF}
{$IFDEF PARADOX_COLLATIONS}
// ANSISWFN 44782 // ANSISWFN 44782
@ -1152,12 +1136,10 @@ const
); );
ANSISWFN :PCollationTable = @_ANSISWFN; ANSISWFN :PCollationTable = @_ANSISWFN;
{$ENDIF}
{$IFDEF PARADOX_COLLATIONS}
// ANSINOR4 55290 // ANSINOR4 55290
@ -1181,7 +1163,7 @@ const
); );
ANSINOR4 :PCollationTable = @_ANSINOR4; ANSINOR4 :PCollationTable = @_ANSINOR4;
{$ENDIF} {$endif}
@ -1206,11 +1188,6 @@ const
096, 097, 098, 099, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 096, 097, 098, 099, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111,
112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127
); );
china :PCollationTable = @_china;
korea :PCollationTable = @_china;
taiwan :PCollationTable = @_china;
DB936CN0 :PCollationTable = @_china; DB936CN0 :PCollationTable = @_china;
@ -1241,7 +1218,16 @@ const
247, 248, 249, 250, 251, 195, 196, 176, 177, 178, 179, 180, 181, 182, 197, 198, 247, 248, 249, 250, 251, 195, 196, 176, 177, 178, 179, 180, 181, 182, 197, 198,
199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 252, 253, 254, 255 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, 252, 253, 254, 255
); );
{$ifdef USE_PARADOX_COLLATIONS}
china :PCollationTable = @_china;
korea :PCollationTable = @_china;
taiwan :PCollationTable = @_china;
thai :PCollationTable = @_thai; thai :PCollationTable = @_thai;
{$endif}
db874th0 :PCollationTable = @_thai; db874th0 :PCollationTable = @_thai;
@ -1298,7 +1284,7 @@ const
DBWINES0 :PCollationTable = @_DBWINWE0; DBWINES0 :PCollationTable = @_DBWINWE0;
{$ifdef USE_ACCESS_COLLATIONS}
// ACCGEN 19621 // ACCGEN 19621
@ -1372,7 +1358,7 @@ const
); );
ACCSWFIN :PCollationTable = @_ACCSWFIN; ACCSWFIN :PCollationTable = @_ACCSWFIN;
{$endif}
// FOXDE437 Checksum: 21075 // FOXDE437 Checksum: 21075
@ -1500,7 +1486,7 @@ const
{$IFDEF PARADOX_COLLATIONS} {$ifdef USE_PARADOX_COLLATIONS}
// czech 30844 // czech 30844
@ -1531,7 +1517,6 @@ const
czechw :PCollationTable = @_czech; czechw :PCollationTable = @_czech;
{$ENDIF}
@ -1561,7 +1546,6 @@ const
{$IFDEF PARADOX_COLLATIONS}
// polish 59020 // polish 59020
@ -1585,12 +1569,10 @@ const
); );
polish :PCollationTable = @_polish; polish :PCollationTable = @_polish;
{$ENDIF}
{$IFDEF PARADOX_COLLATIONS}
// cyrr 20081 // cyrr 20081
@ -1614,12 +1596,10 @@ const
); );
cyrr :PCollationTable = @_cyrr; cyrr :PCollationTable = @_cyrr;
{$ENDIF}
{$IFDEF PARADOX_COLLATIONS}
// hun852dc 62898 // hun852dc 62898
@ -1643,7 +1623,7 @@ const
); );
hun852dc :PCollationTable = @_hun852dc; hun852dc :PCollationTable = @_hun852dc;
{$ENDIF} {$endif}
@ -1668,7 +1648,6 @@ const
180, 149, 154, 157, 160, 161, 168, 176, 175, 181, 118, 123, 126, 129, 136, 142, 180, 149, 154, 157, 160, 161, 168, 176, 175, 181, 118, 123, 126, 129, 136, 142,
147, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255 147, 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 254, 255
); );
grcp437 :PCollationTable = @_grcp437;
db437gr0 :PCollationTable = @_grcp437; db437gr0 :PCollationTable = @_grcp437;
@ -1697,7 +1676,6 @@ const
); );
dbhebrew :PCollationTable = @_dbhebrew; dbhebrew :PCollationTable = @_dbhebrew;
Hebrew :PCollationTable = @_dbhebrew;
@ -1722,10 +1700,15 @@ const
142, 158, 143, 133, 130, 131, 163, 162, 153, 177, 150, 178, 187, 189, 166, 242, 142, 158, 143, 133, 130, 131, 163, 162, 153, 177, 150, 178, 187, 189, 166, 242,
243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 173, 154, 151, 254, 255 243, 244, 245, 246, 247, 248, 249, 250, 251, 252, 253, 173, 154, 151, 254, 255
); );
slovene :PCollationTable = @_slovene;
db852sl0 :PCollationTable = @_slovene; db852sl0 :PCollationTable = @_slovene;
{$ifdef USE_PARADOX_COLLATIONS}
grcp437 :PCollationTable = @_grcp437;
hebrew :PCollationTable = @_dbhebrew;
slovene :PCollationTable = @_slovene;
{$endif}
@ -1790,6 +1773,7 @@ const
{$IFDEF PARADOX_COLLATIONS}
// cskamenw 40577 // cskamenw 40577
@ -1815,6 +1799,8 @@ const
cskamen :PCollationTable = @_cskamenw; cskamen :PCollationTable = @_cskamenw;
{$ENDIF}
@ -1904,6 +1890,7 @@ const
{$IFDEF PARADOX_COLLATIONS}
// angreek1 39126 // angreek1 39126
@ -1929,8 +1916,9 @@ const
ACCGREEK :PCollationTable = @_angreek1; ACCGREEK :PCollationTable = @_angreek1;
{$ENDIF}
{$IFDEF PARADOX_COLLATIONS}
// ansislov 61480 // ansislov 61480
@ -1954,9 +1942,12 @@ const
); );
ansislov :PCollationTable = @_ansislov; ansislov :PCollationTable = @_ansislov;
{$ENDIF}
{$IFDEF USE_PARADOX_COLLATIONS}
// ANTURK 24004 // ANTURK 24004
_ANTURK :TCollationTable = ( _ANTURK :TCollationTable = (
@ -1979,6 +1970,7 @@ const
); );
ANTURK :PCollationTable = @_ANTURK; ANTURK :PCollationTable = @_ANTURK;
{$ENDIF}
@ -2056,6 +2048,7 @@ const
{$IFDEF USE_ACCESS_COLLATIONS}
// BLROM800 28847 // BLROM800 28847
@ -2079,8 +2072,10 @@ const
); );
BLROM800 :PCollationTable = @_BLROM800; BLROM800 :PCollationTable = @_BLROM800;
{$ENDIF}
{$IFDEF USE_ORACLE_COLLATIONS}
// ORAWE850 31378 // ORAWE850 31378
@ -2104,9 +2099,12 @@ const
); );
ORAWE850 :PCollationTable = @_ORAWE850 ; ORAWE850 :PCollationTable = @_ORAWE850 ;
{$ENDIF}
{$IFDEF USE_SYBASE_COLLATIONS}
// SYDC850 46023 // SYDC850 46023
_SYDC850 :TCollationTable = ( _SYDC850 :TCollationTable = (
@ -2154,8 +2152,10 @@ const
); );
SYDC437 :PCollationTable = @_SYDC437; SYDC437 :PCollationTable = @_SYDC437;
{$ENDIF}
{$IFDEF USE_DB2_COLLATIONS}
// db2andeu 8683 // db2andeu 8683
@ -2179,6 +2179,8 @@ const
); );
db2andeu :PCollationTable = @_db2andeu; db2andeu :PCollationTable = @_db2andeu;
{$ENDIF}
initialization initialization
InitialiseCollationTables; InitialiseCollationTables;

13
packages/fcl-db/src/dbase/dbf_common.inc
View File

@ -144,16 +144,9 @@
{$define DELPHI_3} {$define DELPHI_3}
{$endif} {$endif}
{$ifdef VER190} // Delphi 2007 {$ifdef VER185} // Delphi 2007
{$define DELPHI_2007} {$define DELPHI_2007}
{$define DELPHI_2006} { Delphi 2007 also defines VER180, so other DELPHI defines already done }
{$define DELPHI_2005}
{$define DELPHI_8}
{$define DELPHI_7}
{$define DELPHI_6}
{$define DELPHI_5}
{$define DELPHI_4}
{$define DELPHI_3}
{$endif} {$endif}
//------------------------------------------------------- //-------------------------------------------------------
@ -186,6 +179,7 @@
{$define SUPPORT_BACKWARD_FIELDDATA} {$define SUPPORT_BACKWARD_FIELDDATA}
{$define SUPPORT_INITDEFSFROMFIELDS} {$define SUPPORT_INITDEFSFROMFIELDS}
{$define SUPPORT_REFRESHEVENTS}
{$define SUPPORT_DEF_DELETE} {$define SUPPORT_DEF_DELETE}
{$define SUPPORT_FREEANDNIL} {$define SUPPORT_FREEANDNIL}
@ -227,6 +221,7 @@
{$define SUPPORT_MATH_UNIT} {$define SUPPORT_MATH_UNIT}
{$define SUPPORT_VARIANTS} {$define SUPPORT_VARIANTS}
{$define SUPPORT_SEPARATE_VARIANTS_UNIT} {$define SUPPORT_SEPARATE_VARIANTS_UNIT}
{$define SUPPORT_REFRESHEVENTS}
// FPC 2.0.x improvements // FPC 2.0.x improvements
{$ifdef VER2} {$ifdef VER2}

2
packages/fcl-db/src/dbase/dbf_common.pas
View File

@ -18,7 +18,7 @@ uses
const const
TDBF_MAJOR_VERSION = 6; TDBF_MAJOR_VERSION = 6;
TDBF_MINOR_VERSION = 9; TDBF_MINOR_VERSION = 9;
TDBF_SUB_MINOR_VERSION = 1; TDBF_SUB_MINOR_VERSION = 2;
TDBF_TABLELEVEL_FOXPRO = 25; TDBF_TABLELEVEL_FOXPRO = 25;

8
packages/fcl-db/src/dbase/dbf_cursor.pas
View File

@ -18,11 +18,11 @@ type
FFile: TPagedFile; FFile: TPagedFile;
protected protected
function GetPhysicalRecno: Integer; virtual; abstract; function GetPhysicalRecNo: Integer; virtual; abstract;
function GetSequentialRecno: Integer; virtual; abstract; function GetSequentialRecNo: Integer; virtual; abstract;
function GetSequentialRecordCount: Integer; virtual; abstract; function GetSequentialRecordCount: Integer; virtual; abstract;
procedure SetPhysicalRecno(Recno: Integer); virtual; abstract; procedure SetPhysicalRecNo(RecNo: Integer); virtual; abstract;
procedure SetSequentialRecno(Recno: Integer); virtual; abstract; procedure SetSequentialRecNo(RecNo: Integer); virtual; abstract;
public public
constructor Create(pFile: TPagedFile); constructor Create(pFile: TPagedFile);

27
packages/fcl-db/src/dbase/dbf_idxcur.pas
View File

@ -10,6 +10,9 @@ uses
dbf_cursor, dbf_cursor,
dbf_idxfile, dbf_idxfile,
dbf_prsdef, dbf_prsdef,
{$ifndef WINDOWS}
dbf_wtil,
{$endif}
dbf_common; dbf_common;
type type
@ -27,6 +30,7 @@ type
procedure SetPhysicalRecNo(RecNo: Integer); override; procedure SetPhysicalRecNo(RecNo: Integer); override;
procedure SetSequentialRecNo(RecNo: Integer); override; procedure SetSequentialRecNo(RecNo: Integer); override;
procedure VariantStrToBuffer(Key: Variant; ABuffer: PChar);
public public
constructor Create(DbfIndexFile: TIndexFile); constructor Create(DbfIndexFile: TIndexFile);
destructor Destroy; override; destructor Destroy; override;
@ -55,6 +59,11 @@ type
//==================================================================== //====================================================================
implementation implementation
{$ifdef WINDOWS}
uses
Windows;
{$endif}
//========================================================== //==========================================================
//============ TIndexCursor //============ TIndexCursor
//========================================================== //==========================================================
@ -128,10 +137,19 @@ end;
{$ifdef SUPPORT_VARIANTS} {$ifdef SUPPORT_VARIANTS}
function TIndexCursor.VariantToBuffer(Key: Variant; ABuffer: PChar): TExpressionType; procedure TIndexCursor.VariantStrToBuffer(Key: Variant; ABuffer: PChar);
// assumes ABuffer is large enough ie. at least max key size
var var
currLen: Integer; currLen: Integer;
StrKey: string;
begin
StrKey := Key;
currLen := TranslateString(GetACP, FIndexFile.CodePage, PChar(StrKey), ABuffer, -1);
// we have null-terminated string, pad with spaces if string too short
FillChar(ABuffer[currLen], TIndexFile(PagedFile).KeyLen-currLen, ' ');
end;
function TIndexCursor.VariantToBuffer(Key: Variant; ABuffer: PChar): TExpressionType;
// assumes ABuffer is large enough ie. at least max key size
begin begin
if (TIndexFile(PagedFile).KeyType='N') then if (TIndexFile(PagedFile).KeyType='N') then
begin begin
@ -143,10 +161,7 @@ begin
end; end;
Result := etInteger; Result := etInteger;
end else begin end else begin
StrPLCopy(ABuffer, Key, TIndexFile(PagedFile).KeyLen); VariantStrToBuffer(Key, ABuffer);
// we have null-terminated string, pad with spaces if string too short
currLen := StrLen(ABuffer);
FillChar(ABuffer[currLen], TIndexFile(PagedFile).KeyLen-currLen, ' ');
Result := etString; Result := etString;
end; end;
end; end;

26
packages/fcl-db/src/dbase/dbf_idxfile.pas
View File

@ -409,6 +409,7 @@ uses
dbf_fields, dbf_fields,
dbf_str, dbf_str,
dbf_prssupp, dbf_prssupp,
dbf_prscore,
dbf_lang; dbf_lang;
const const
@ -1717,9 +1718,32 @@ end;
{ TDbfIndexParser } { TDbfIndexParser }
procedure TDbfIndexParser.ValidateExpression(AExpression: string); procedure TDbfIndexParser.ValidateExpression(AExpression: string);
const
AnsiStrFuncs: array[0..13] of TExprFunc = (FuncUppercase, FuncLowercase, FuncStrI_EQ,
FuncStrIP_EQ, FuncStrI_NEQ, FuncStrI_LT, FuncStrI_GT, FuncStrI_LTE, FuncStrI_GTE,
FuncStrP_EQ, FuncStr_LT, FuncStr_GT, FuncStr_LTE, FuncStr_GTE);
AnsiFuncsToMode: array[boolean] of TStringFieldMode = (smRaw, smAnsi);
var var
TempRec: PExpressionRec;
TempBuffer: pchar; TempBuffer: pchar;
I: integer;
hasAnsiFuncs: boolean;
begin begin
TempRec := CurrentRec;
hasAnsiFuncs := false;
while not hasAnsiFuncs and (TempRec <> nil) do
begin
for I := Low(AnsiStrFuncs) to High(AnsiStrFuncs) do
if @TempRec^.Oper = @AnsiStrFuncs[I] then
begin
hasAnsiFuncs := true;
break;
end;
TempRec := TempRec^.Next;
end;
StringFieldMode := AnsiFuncsToMode[hasAnsiFuncs];
FResultLen := inherited ResultLen; FResultLen := inherited ResultLen;
if FResultLen = -1 then if FResultLen = -1 then
@ -2980,7 +3004,7 @@ function TIndexFile.ExtractKeyFromBuffer(Buffer: PChar): PChar;
begin begin
// execute expression to get key // execute expression to get key
Result := PrepareKey(FCurrentParser.ExtractFromBuffer(Buffer), FCurrentParser.ResultType); Result := PrepareKey(FCurrentParser.ExtractFromBuffer(Buffer), FCurrentParser.ResultType);
if not FCurrentParser.RawStringFields then if FCurrentParser.StringFieldMode <> smRaw then
TranslateString(GetACP, FCodePage, Result, Result, KeyLen); TranslateString(GetACP, FCodePage, Result, Result, KeyLen);
end; end;

55
packages/fcl-db/src/dbase/dbf_parser.pas
View File

@ -22,6 +22,8 @@ uses
type type
TStringFieldMode = (smRaw, smAnsi, smAnsiTrim);
TDbfParser = class(TCustomExpressionParser) TDbfParser = class(TCustomExpressionParser)
private private
FDbfFile: Pointer; FDbfFile: Pointer;
@ -29,7 +31,7 @@ type
FIsExpression: Boolean; // expression or simple field? FIsExpression: Boolean; // expression or simple field?
FFieldType: TExpressionType; FFieldType: TExpressionType;
FCaseInsensitive: Boolean; FCaseInsensitive: Boolean;
FRawStringFields: Boolean; FStringFieldMode: TStringFieldMode;
FPartialMatch: boolean; FPartialMatch: boolean;
protected protected
@ -44,7 +46,7 @@ type
function GetResultLen: Integer; function GetResultLen: Integer;
procedure SetCaseInsensitive(NewInsensitive: Boolean); procedure SetCaseInsensitive(NewInsensitive: Boolean);
procedure SetRawStringFields(NewRawFields: Boolean); procedure SetStringFieldMode(NewMode: TStringFieldMode);
procedure SetPartialMatch(NewPartialMatch: boolean); procedure SetPartialMatch(NewPartialMatch: boolean);
public public
constructor Create(ADbfFile: Pointer); constructor Create(ADbfFile: Pointer);
@ -60,7 +62,7 @@ type
property ResultLen: Integer read GetResultLen; property ResultLen: Integer read GetResultLen;
property CaseInsensitive: Boolean read FCaseInsensitive write SetCaseInsensitive; property CaseInsensitive: Boolean read FCaseInsensitive write SetCaseInsensitive;
property RawStringFields: Boolean read FRawStringFields write SetRawStringFields; property StringFieldMode: TStringFieldMode read FStringFieldMode write SetStringFieldMode;
property PartialMatch: boolean read FPartialMatch write SetPartialMatch; property PartialMatch: boolean read FPartialMatch write SetPartialMatch;
end; end;
@ -106,20 +108,19 @@ type
TStringFieldVar = class(TFieldVar) TStringFieldVar = class(TFieldVar)
protected protected
FFieldVal: PChar; FFieldVal: PChar;
FRawStringField: boolean; FMode: TStringFieldMode;
function GetFieldVal: Pointer; override; function GetFieldVal: Pointer; override;
function GetFieldType: TExpressionType; override; function GetFieldType: TExpressionType; override;
procedure SetExprWord(NewExprWord: TExprWord); override; procedure SetExprWord(NewExprWord: TExprWord); override;
procedure SetRawStringField(NewRaw: boolean); procedure SetMode(NewMode: TStringFieldMode);
procedure UpdateExprWord; procedure UpdateExprWord;
public public
constructor Create(UseFieldDef: TDbfFieldDef; ADbfFile: TDbfFile);
destructor Destroy; override; destructor Destroy; override;
procedure Refresh(Buffer: PChar); override; procedure Refresh(Buffer: PChar); override;
property RawStringField: boolean read FRawStringField write SetRawStringField; property Mode: TStringFieldMode read FMode write SetMode;
end; end;
TFloatFieldVar = class(TFieldVar) TFloatFieldVar = class(TFieldVar)
@ -193,15 +194,9 @@ end;
{ TStringFieldVar } { TStringFieldVar }
constructor TStringFieldVar.Create(UseFieldDef: TDbfFieldDef; ADbfFile: TDbfFile);
begin
inherited;
FRawStringField := true;
end;
destructor TStringFieldVar.Destroy; destructor TStringFieldVar.Destroy;
begin begin
if not FRawStringField then if FMode <> smRaw then
FreeMem(FFieldVal); FreeMem(FFieldVal);
inherited; inherited;
@ -223,10 +218,11 @@ var
Src: PChar; Src: PChar;
begin begin
Src := Buffer+FieldDef.Offset; Src := Buffer+FieldDef.Offset;
if not FRawStringField then if FMode <> smRaw then
begin begin
// copy field data // copy field data
Len := FieldDef.Size; Len := FieldDef.Size;
if FMode = smAnsiTrim then
while (Len >= 1) and (Src[Len-1] = ' ') do Dec(Len); while (Len >= 1) and (Src[Len-1] = ' ') do Dec(Len);
// translate to ANSI // translate to ANSI
Len := TranslateString(DbfFile.UseCodePage, GetACP, Src, FFieldVal, Len); Len := TranslateString(DbfFile.UseCodePage, GetACP, Src, FFieldVal, Len);
@ -243,19 +239,21 @@ end;
procedure TStringFieldVar.UpdateExprWord; procedure TStringFieldVar.UpdateExprWord;
begin begin
if FRawStringField then if FMode <> smAnsiTrim then
FExprWord.FixedLen := FieldDef.Size FExprWord.FixedLen := FieldDef.Size
else else
FExprWord.FixedLen := -1; FExprWord.FixedLen := -1;
end; end;
procedure TStringFieldVar.SetRawStringField(NewRaw: boolean); procedure TStringFieldVar.SetMode(NewMode: TStringFieldMode);
begin begin
if NewRaw = FRawStringField then exit; if NewMode = FMode then exit;
FRawStringField := NewRaw; FMode := NewMode;
if NewRaw then if NewMode = smRaw then
FreeMem(FFieldVal) begin
else FreeMem(FFieldVal);
FFieldVal := nil;
end else
GetMem(FFieldVal, FieldDef.Size*3+1); GetMem(FFieldVal, FieldDef.Size*3+1);
UpdateExprWord; UpdateExprWord;
end; end;
@ -361,7 +359,6 @@ begin
FDbfFile := ADbfFile; FDbfFile := ADbfFile;
FFieldVarList := TStringList.Create; FFieldVarList := TStringList.Create;
FCaseInsensitive := true; FCaseInsensitive := true;
FRawStringFields := true;
inherited Create; inherited Create;
end; end;
@ -391,7 +388,7 @@ begin
etDateTime: Result := 8; etDateTime: Result := 8;
etString: etString:
begin begin
if not FIsExpression and (TStringFieldVar(FFieldVarList.Objects[0]).RawStringField) then if not FIsExpression and (TStringFieldVar(FFieldVarList.Objects[0]).Mode <> smAnsiTrim) then
Result := TStringFieldVar(FFieldVarList.Objects[0]).FieldDef.Size Result := TStringFieldVar(FFieldVarList.Objects[0]).FieldDef.Size
else else
Result := -1; Result := -1;
@ -421,17 +418,17 @@ begin
end; end;
end; end;
procedure TDbfParser.SetRawStringFields(NewRawFields: Boolean); procedure TDbfParser.SetStringFieldMode(NewMode: TStringFieldMode);
var var
I: integer; I: integer;
begin begin
if FRawStringFields <> NewRawFields then if FStringFieldMode <> NewMode then
begin begin
// clear and regenerate functions, custom fields will be deleted too // clear and regenerate functions, custom fields will be deleted too
FRawStringFields := NewRawFields; FStringFieldMode := NewMode;
for I := 0 to FFieldVarList.Count - 1 do for I := 0 to FFieldVarList.Count - 1 do
if FFieldVarList.Objects[I] is TStringFieldVar then if FFieldVarList.Objects[I] is TStringFieldVar then
TStringFieldVar(FFieldVarList.Objects[I]).RawStringField := NewRawFields; TStringFieldVar(FFieldVarList.Objects[I]).Mode := NewMode;
end; end;
end; end;
@ -486,7 +483,7 @@ begin
begin begin
TempFieldVar := TStringFieldVar.Create(FieldInfo, TDbfFile(FDbfFile)); TempFieldVar := TStringFieldVar.Create(FieldInfo, TDbfFile(FDbfFile));
TempFieldVar.ExprWord := DefineStringVariable(VarName, TempFieldVar.FieldVal); TempFieldVar.ExprWord := DefineStringVariable(VarName, TempFieldVar.FieldVal);
TStringFieldVar(TempFieldVar).RawStringField := FRawStringFields; TStringFieldVar(TempFieldVar).Mode := FStringFieldMode;
end; end;
ftBoolean: ftBoolean:
begin begin

2
packages/fcl-db/src/dbase/dbf_prscore.pas
View File

@ -174,6 +174,8 @@ procedure FuncStrI_LT(Param: PExpressionRec);
procedure FuncStrI_GT(Param: PExpressionRec); procedure FuncStrI_GT(Param: PExpressionRec);
procedure FuncStrI_LTE(Param: PExpressionRec); procedure FuncStrI_LTE(Param: PExpressionRec);
procedure FuncStrI_GTE(Param: PExpressionRec); procedure FuncStrI_GTE(Param: PExpressionRec);
procedure FuncStrIP_EQ(Param: PExpressionRec);
procedure FuncStrP_EQ(Param: PExpressionRec);
procedure FuncStr_EQ(Param: PExpressionRec); procedure FuncStr_EQ(Param: PExpressionRec);
procedure FuncStr_NEQ(Param: PExpressionRec); procedure FuncStr_NEQ(Param: PExpressionRec);
procedure FuncStr_LT(Param: PExpressionRec); procedure FuncStr_LT(Param: PExpressionRec);

1
packages/fcl-db/src/dbase/dbf_prsdef.pas
View File

@ -26,6 +26,7 @@ type
PExpressionRec = ^TExpressionRec; PExpressionRec = ^TExpressionRec;
PDynamicType = ^TDynamicType; PDynamicType = ^TDynamicType;
PDateTimeRec = ^TDateTimeRec; PDateTimeRec = ^TDateTimeRec;
PDouble = ^Double;
{$ifdef SUPPORT_INT64} {$ifdef SUPPORT_INT64}
PLargeInt = ^Int64; PLargeInt = ^Int64;
{$endif} {$endif}

8
packages/fcl-db/src/dbase/history.txt
View File

@ -32,6 +32,14 @@ BUGS & WARNINGS
------------------------
V6.9.2
- compile fixes for delphi 4, 5 (pdouble)
- fix indexes to work properly with ansi upper/lower casing
- fix memory leak when inserting duplicate item in AVL tree
- add german localization strings (thx heiko)
------------------------ ------------------------
V6.9.1 V6.9.1