paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-25 19:49:07 +02:00
Code Issues Packages Projects Releases Wiki Activity

* update tdbf to tdbf svn

Browse Source 
git-svn-id: trunk@5622 -
This commit is contained in:
micha 2006-12-17 14:55:56 +00:00
parent e62b7ae4b1
commit b3ef974403
16 changed files with 636 additions and 732 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

145
fcl/db/dbase/dbf.pas
View File

@ -117,6 +117,7 @@ type
FParser: TDbfParser;
FFieldNames: string;
FValidExpression: Boolean;
FKeyTranslation: boolean;
FOnMasterChange: TNotifyEvent;
FOnMasterDisable: TNotifyEvent;
@ -134,6 +135,7 @@ type
destructor Destroy; override;
property FieldNames: string read FFieldNames write SetFieldNames;
property KeyTranslation: boolean read FKeyTranslation;
property ValidExpression: Boolean read FValidExpression write FValidExpression;
property FieldsVal: PChar read GetFieldsVal;
property Parser: TDbfParser read FParser;
@ -256,7 +258,7 @@ type
function IsCursorOpen: Boolean; override; {virtual abstract}
procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override; {virtual abstract}
procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override; {virtual abstract}
procedure SetFieldData(Field: TField; Buffer: Pointer); override; {virtual abstract}
procedure SetFieldData(Field: TField; Buffer: Pointer); overload; override; {virtual abstract}
{ virtual methods (mostly optionnal) }
function GetDataSource: TDataSource; {$ifndef VER1_0}override;{$endif}
@ -286,7 +288,7 @@ type
destructor Destroy; override;
{ abstract methods }
function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override; {virtual abstract}
function GetFieldData(Field: TField; Buffer: Pointer): Boolean; overload; override; {virtual abstract}
{ virtual methods (mostly optionnal) }
procedure Resync(Mode: TResyncMode); override;
function CreateBlobStream(Field: TField; Mode: TBlobStreamMode): TStream; override; {virtual}
@ -296,10 +298,10 @@ type
procedure Translate(Src, Dest: PChar; ToOem: Boolean); override; {virtual}
{$endif}
{$ifdef SUPPORT_BACKWARD_FIELDDATA}
function GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean): Boolean; overload; override;
procedure SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean); overload; override;
{$endif}
function GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean): Boolean; overload;
{$ifdef SUPPORT_BACKWARD_FIELDDATA} override; {$endif}
procedure SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean); overload;
{$ifdef SUPPORT_BACKWARD_FIELDDATA} override; {$endif}
function CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer; override;
procedure CheckDbfFieldDefs(ADbfFieldDefs: TDbfFieldDefs);
@ -323,12 +325,16 @@ type
procedure CancelRange;
procedure CheckMasterRange;
{$ifdef SUPPORT_VARIANTS}
function SearchKey(Key: Variant; SearchType: TSearchKeyType): Boolean;
procedure SetRange(LowRange: Variant; HighRange: Variant);
function SearchKey(Key: Variant; SearchType: TSearchKeyType; KeyIsANSI: boolean
{$ifdef SUPPORT_DEFAULT_PARAMS}= false{$endif}): Boolean;
procedure SetRange(LowRange: Variant; HighRange: Variant; KeyIsANSI: boolean
{$ifdef SUPPORT_DEFAULT_PARAMS}= false{$endif});
{$endif}
function PrepareKey(Buffer: Pointer; BufferType: TExpressionType): PChar;
function SearchKeyPChar(Key: PChar; SearchType: TSearchKeyType): Boolean;
procedure SetRangePChar(LowRange: PChar; HighRange: PChar);
function SearchKeyPChar(Key: PChar; SearchType: TSearchKeyType; KeyIsANSI: boolean
{$ifdef SUPPORT_DEFAULT_PARAMS}= false{$endif}): Boolean;
procedure SetRangePChar(LowRange: PChar; HighRange: PChar; KeyIsANSI: boolean
{$ifdef SUPPORT_DEFAULT_PARAMS}= false{$endif});
function GetCurrentBuffer: PChar;
procedure ExtractKey(KeyBuffer: PChar);
procedure UpdateIndexDefs; override;
@ -353,7 +359,7 @@ type
{$ifdef SUPPORT_VARIANTS}
function Lookup(const KeyFields: string; const KeyValues: Variant; const ResultFields: string): Variant; override;
function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; {$ifndef FPC}override;{$endif}
function Locate(const KeyFields: string; const KeyValues: Variant; Options: TLocateOptions): Boolean; override;
{$endif}
function IsDeleted: Boolean;
@ -453,7 +459,7 @@ uses
{$ifndef FPC}
DBConsts,
{$endif}
{$ifdef WIN32}
{$ifdef WINDOWS}
Windows,
{$else}
{$ifdef KYLIX}
@ -551,7 +557,7 @@ begin
Translate(true);
Dbf.FDbfFile.MemoFile.WriteMemo(FMemoRecNo, FReadSize, Self);
Dbf.FDbfFile.SetFieldData(FBlobField.FieldNo-1, ftInteger, @FMemoRecNo,
@pDbfRecord(TDbf(FBlobField.DataSet).ActiveBuffer)^.DeletedFlag);
@pDbfRecord(TDbf(FBlobField.DataSet).ActiveBuffer)^.DeletedFlag, false);
FDirty := false;
end;
end;
@ -693,6 +699,18 @@ begin
end;
function TDbf.GetFieldData(Field: TField; Buffer: Pointer): Boolean; {override virtual abstract from TDataset}
begin
Result := GetFieldData(Field, Buffer, true);
end;
// we don't want converted data formats, we want native :-)
// it makes coding easier in TDbfFile.GetFieldData
// ftCurrency:
// Delphi 3,4: BCD array
// ftBCD:
// ftDateTime is more difficult though
function TDbf.GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean): Boolean; {overload; override;}
var
Src: PChar;
begin
@ -705,7 +723,7 @@ begin
if Field.FieldNo>0 then
begin
Result := FDbfFile.GetFieldData(Field.FieldNo-1, Field.DataType, Src, Buffer);
Result := FDbfFile.GetFieldData(Field.FieldNo-1, Field.DataType, Src, Buffer, NativeFormat);
end else begin { weird calculated fields voodoo (from dbtables).... }
Inc(PChar(Src), Field.Offset + GetRecordSize);
Result := Boolean(Src[0]);
@ -714,29 +732,26 @@ begin
end;
end;
{$ifdef SUPPORT_BACKWARD_FIELDDATA}
// we don't want converted data formats, we want native :-)
// it makes coding easier in TDbfFile.GetFieldData
// ftCurrency:
// Delphi 3,4: BCD array
// ftBCD:
// ftDateTime is more difficult though
function TDbf.GetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean): Boolean; {overload; override;}
begin
// pretend nativeformat is true
Result := inherited GetFieldData(Field, Buffer, True);
end;
procedure TDbf.SetFieldData(Field: TField; Buffer: Pointer; NativeFormat: Boolean); {overload; override;}
var
Dst: PChar;
begin
// pretend nativeformat is true
inherited SetFieldData(Field, Buffer, True);
if (Field.FieldNo >= 0) then
begin
Dst := @PDbfRecord(ActiveBuffer)^.DeletedFlag;
FDbfFile.SetFieldData(Field.FieldNo - 1, Field.DataType, Buffer, Dst, NativeFormat);
end else begin { ***** fkCalculated, fkLookup ***** }
Dst := @PDbfRecord(CalcBuffer)^.DeletedFlag;
Inc(PChar(Dst), RecordSize + Field.Offset);
Boolean(Dst[0]) := Buffer <> nil;
if Buffer <> nil then
Move(Buffer^, Dst[1], Field.DataSize)
end; { end of ***** fkCalculated, fkLookup ***** }
if not (State in [dsCalcFields, dsFilter, dsNewValue]) then begin
DataEvent(deFieldChange, PtrInt(Field));
end;
end;
{$endif}
procedure TDbf.DoFilterRecord(var Acceptable: Boolean);
begin
// check filtertext
@ -1792,7 +1807,8 @@ begin
searchFlag := stGreaterEqual
else
searchFlag := stEqual;
TIndexCursor(FCursor).VariantToBuffer(KeyValues, @lTempBuffer[0]);
if TIndexCursor(FCursor).VariantToBuffer(KeyValues, @lTempBuffer[0]) = etString then
Translate(@lTempBuffer[0], @lTempBuffer[0], true);
Result := FIndexFile.SearchKey(@lTempBuffer[0], searchFlag);
if Result then
begin
@ -1918,7 +1934,7 @@ begin
FBlobStreams^[MemoFieldNo] := TDbfBlobStream.Create(Field);
lBlob := FBlobStreams^[MemoFieldNo].AddReference;
// update pageno of blob <-> location where to read/write in memofile
if FDbfFile.GetFieldData(Field.FieldNo-1, ftInteger, GetCurrentBuffer, @MemoPageNo) then
if FDbfFile.GetFieldData(Field.FieldNo-1, ftInteger, GetCurrentBuffer, @MemoPageNo, false) then
begin
// read blob? different blob?
if (Mode = bmRead) or (Mode = bmReadWrite) then
@ -2061,23 +2077,8 @@ begin
end;
procedure TDbf.SetFieldData(Field: TField; Buffer: Pointer); {override virtual abstract from TDataset}
var
Dst: PChar;
begin
if (Field.FieldNo >= 0) then
begin
Dst := @PDbfRecord(ActiveBuffer)^.DeletedFlag;
FDbfFile.SetFieldData(Field.FieldNo - 1,Field.DataType,Buffer,Dst);
end else begin { ***** fkCalculated, fkLookup ***** }
Dst := @PDbfRecord(CalcBuffer)^.DeletedFlag;
Inc(PChar(Dst), RecordSize + Field.Offset);
Boolean(Dst[0]) := Buffer <> nil;
if Buffer <> nil then
Move(Buffer^, Dst[1], Field.DataSize)
end; { end of ***** fkCalculated, fkLookup ***** }
if not (State in [dsCalcFields, dsFilter, dsNewValue]) then begin
DataEvent(deFieldChange, PtrInt(Field));
end;
SetFieldData(Field, Buffer, true);
end;
// this function counts real number of records: skip deleted records, filter, etc.
@ -2181,7 +2182,7 @@ begin
if (FParser = nil) and (FDbfFile <> nil) then
begin
FParser := TDbfParser.Create(FDbfFile);
// we need translated (to ANSI) strings
// we need truncated, translated (to ANSI) strings
FParser.RawStringFields := false;
end;
// have a parser now?
@ -2616,7 +2617,7 @@ end;
{$ifdef SUPPORT_VARIANTS}
procedure TDbf.SetRange(LowRange: Variant; HighRange: Variant);
procedure TDbf.SetRange(LowRange: Variant; HighRange: Variant; KeyIsANSI: boolean);
var
LowBuf, HighBuf: array[0..100] of Char;
begin
@ -2624,14 +2625,16 @@ begin
exit;
// convert variants to index key type
TIndexCursor(FCursor).VariantToBuffer(LowRange, @LowBuf[0]);
TIndexCursor(FCursor).VariantToBuffer(HighRange, @HighBuf[0]);
if (TIndexCursor(FCursor).VariantToBuffer(LowRange, @LowBuf[0]) = etString) and KeyIsANSI then
Translate(@LowBuf[0], @LowBuf[0], true);
if (TIndexCursor(FCursor).VariantToBuffer(HighRange, @HighBuf[0]) = etString) and KeyIsANSI then
Translate(@HighBuf[0], @HighBuf[0], true);
SetRangeBuffer(@LowBuf[0], @HighBuf[0]);
end;
{$endif}
procedure TDbf.SetRangePChar(LowRange: PChar; HighRange: PChar);
procedure TDbf.SetRangePChar(LowRange: PChar; HighRange: PChar; KeyIsANSI: boolean);
var
LowBuf, HighBuf: array [0..100] of Char;
LowPtr, HighPtr: PChar;
@ -2640,6 +2643,13 @@ begin
exit;
// convert to pchars
if KeyIsANSI then
begin
Translate(LowRange, @LowBuf[0], true);
Translate(HighRange, @HighBuf[0], true);
LowRange := @LowBuf[0];
HighRange := @HighBuf[0];
end;
LowPtr := TIndexCursor(FCursor).CheckUserKey(LowRange, @LowBuf[0]);
HighPtr := TIndexCursor(FCursor).CheckUserKey(HighRange, @HighBuf[0]);
SetRangeBuffer(LowPtr, HighPtr);
@ -2663,7 +2673,7 @@ end;
{$ifdef SUPPORT_VARIANTS}
function TDbf.SearchKey(Key: Variant; SearchType: TSearchKeyType): Boolean;
function TDbf.SearchKey(Key: Variant; SearchType: TSearchKeyType; KeyIsANSI: boolean): Boolean;
var
TempBuffer: array [0..100] of Char;
begin
@ -2674,7 +2684,8 @@ begin
end;
// FIndexFile <> nil -> FCursor as TIndexCursor <> nil
TIndexCursor(FCursor).VariantToBuffer(Key, @TempBuffer[0]);
if (TIndexCursor(FCursor).VariantToBuffer(Key, @TempBuffer[0]) = etString) and KeyIsANSI then
Translate(@TempBuffer[0], @TempBuffer[0], true);
Result := SearchKeyBuffer(@TempBuffer[0], SearchType);
end;
@ -2691,7 +2702,7 @@ begin
Result := TIndexCursor(FCursor).IndexFile.PrepareKey(Buffer, BufferType);
end;
function TDbf.SearchKeyPChar(Key: PChar; SearchType: TSearchKeyType): Boolean;
function TDbf.SearchKeyPChar(Key: PChar; SearchType: TSearchKeyType; KeyIsANSI: boolean): Boolean;
var
StringBuf: array [0..100] of Char;
begin
@ -2701,6 +2712,11 @@ begin
exit;
end;
if KeyIsANSI then
begin
Translate(Key, @StringBuf[0], true);
Key := @StringBuf[0];
end;
Result := SearchKeyBuffer(TIndexCursor(FCursor).CheckUserKey(Key, @StringBuf[0]), SearchType);
end;
@ -2759,8 +2775,15 @@ end;
procedure TDbf.UpdateRange;
var
fieldsVal: PChar;
tempBuffer: array[0..300] of char;
begin
fieldsVal := FMasterLink.FieldsVal;
if FMasterLink.KeyTranslation then
begin
FMasterLink.DataSet.Translate(fieldsVal, @tempBuffer[0], false);
fieldsVal := @tempBuffer[0];
Translate(fieldsVal, fieldsVal, true);
end;
fieldsVal := TIndexCursor(FCursor).IndexFile.PrepareKey(fieldsVal, FMasterLink.Parser.ResultType);
SetRangeBuffer(fieldsVal, fieldsVal);
end;
@ -2905,8 +2928,10 @@ begin
if Active and (FFieldNames <> EmptyStr) then
begin
FValidExpression := false;
FParser.DbfFile := TDbf(DataSet).DbfFile;
FParser.DbfFile := (DataSet as TDbf).DbfFile;
FParser.ParseExpression(FFieldNames);
FKeyTranslation := TDbfFile(FParser.DbfFile).UseCodePage <>
FDetailDataSet.DbfFile.UseCodePage;
FValidExpression := true;
end else begin
FParser.ClearExpressions;

7
fcl/db/dbase/dbf_common.inc
View File

@ -163,6 +163,7 @@
{$ifdef DELPHI_3}
{$define SUPPORT_VARIANTS}
{$define WINDOWS}
{$ifdef DELPHI_4}
@ -182,7 +183,6 @@
{$ifdef DELPHI_5}
{$define SUPPORT_BACKWARD_FIELDDATA}
{$define SUPPORT_NEW_FIELDDATA}
{$define SUPPORT_INITDEFSFROMFIELDS}
{$define SUPPORT_DEF_DELETE}
{$define SUPPORT_FREEANDNIL}
@ -217,7 +217,6 @@
{$define SUPPORT_INT64}
{$define SUPPORT_DEFAULT_PARAMS}
{$define SUPPORT_NEW_TRANSLATE}
{$define SUPPORT_NEW_FIELDDATA}
{$define SUPPORT_FIELDDEF_TPERSISTENT}
{$define SUPPORT_FIELDTYPES_V4}
{$define SUPPORT_UINT32_CARDINAL}
@ -246,10 +245,10 @@
{$endif}
//----------------------------------------------------------
//--- Conclude supported features in non-Win32 platforms ---
//--- Conclude supported features in non-Windows platforms ---
//----------------------------------------------------------
{$ifndef WIN32}
{$ifndef WINDOWS}
{$define SUPPORT_PATHDELIM}
{$define SUPPORT_INCLUDETRAILPATHDELIM}

72
fcl/db/dbase/dbf_common.pas
View File

@ -4,14 +4,16 @@ interface
{$I dbf_common.inc}
{$ifndef FPC_LITTLE_ENDIAN}
{$ifdef FPC}
{$ifndef FPC_LITTLE_ENDIAN}
{$message error TDbf is not compatible with non little-endian CPUs. Please contact the author.}
{$endif}
{$endif}
uses
SysUtils, Classes, DB
{$ifndef WIN32}
{$ifndef WINDOWS}
, Types, dbf_wtil
{$ifdef KYLIX}
, Libc
@ -22,8 +24,8 @@ uses
const
TDBF_MAJOR_VERSION = 6;
TDBF_MINOR_VERSION = 49;
TDBF_SUB_MINOR_VERSION = 0;
TDBF_MINOR_VERSION = 9;
TDBF_SUB_MINOR_VERSION = 1;
TDBF_TABLELEVEL_FOXPRO = 25;
@ -51,11 +53,6 @@ type
PCardinal = ^Cardinal;
PDouble = ^Double;
PString = ^String;
PDateTimeRec = ^TDateTimeRec;
{$ifdef SUPPORT_INT64}
PLargeInt = ^Int64;
{$endif}
{$ifdef DELPHI_3}
dword = cardinal;
@ -73,7 +70,7 @@ procedure FreeMemAndNil(var P: Pointer);
{$ifndef SUPPORT_PATHDELIM}
const
{$ifdef WIN32}
{$ifdef WINDOWS}
PathDelim = '\';
{$else}
PathDelim = '/';
@ -91,10 +88,6 @@ function GetCompleteFileName(const Base, FileName: string): string;
function IsFullFilePath(const Path: string): Boolean; // full means not relative
function DateTimeToBDETimeStamp(aDT: TDateTime): double;
function BDETimeStampToDateTime(aBT: double): TDateTime;
{$ifdef SUPPORT_INT64}
function GetStrFromInt64(Val: Int64; const Dst: PChar): Integer;
procedure GetStrFromInt64_Width(Val: Int64; const Width: Integer; const Dst: PChar; const PadChar: Char);
{$endif}
procedure FindNextName(BaseName: string; var OutName: string; var Modifier: Integer);
{$ifdef USE_CACHE}
function GetFreeMemory: Integer;
@ -122,7 +115,7 @@ function Max(x, y: integer): integer;
implementation
{$ifdef WIN32}
{$ifdef WINDOWS}
uses
Windows;
{$endif}
@ -148,7 +141,7 @@ end;
function IsFullFilePath(const Path: string): Boolean; // full means not relative
begin
{$ifdef WIN32}
{$ifdef WINDOWS}
Result := Length(Path) > 1;
if Result then
// check for 'x:' or '\\' at start of path
@ -174,49 +167,6 @@ begin
result := lpath;
end;
{$ifdef SUPPORT_INT64}
procedure GetStrFromInt64_Width(Val: Int64; const Width: Integer; const Dst: PChar; const PadChar: Char);
var
Temp: array[0..19] of Char;
I, J: Integer;
NegSign: boolean;
begin
{$I getstrfromint.inc}
end;
{$endif}
{$ifdef SUPPORT_INT64}
function GetStrFromInt64(Val: Int64; const Dst: PChar): Integer;
var
Temp: array[0..19] of Char;
I, J: Integer;
begin
Val := Abs(Val);
// we'll have to store characters backwards first
I := 0;
J := 0;
repeat
Temp[I] := Chr((Val mod 10) + Ord('0'));
Val := Val div 10;
Inc(I);
until Val = 0;
// remember number of digits
Result := I;
// copy value, remember: stored backwards
repeat
Dst[J] := Temp[I-1];
inc(J);
dec(I);
until I = 0;
// done!
end;
{$endif}
function DateTimeToBDETimeStamp(aDT: TDateTime): double;
var
aTS: TTimeStamp;
@ -229,7 +179,7 @@ function BDETimeStampToDateTime(aBT: double): TDateTime;
var
aTS: TTimeStamp;
begin
aTS := MSecsToTimeStamp(aBT);
aTS := MSecsToTimeStamp(Round(aBT));
Result := TimeStampToDateTime(aTS);
end;
@ -279,7 +229,7 @@ end;
function IncludeTrailingPathDelimiter(const Path: string): string;
begin
{$ifdef WIN32}
{$ifdef WINDOWS}
Result := IncludeTrailingBackslash(Path);
{$else}
Result := IncludeTrailingSlash(Path);

117
fcl/db/dbase/dbf_dbffile.pas
View File

@ -6,10 +6,7 @@ interface
uses
Classes, SysUtils,
{$ifdef SUPPORT_MATH_UNIT}
Math,
{$endif}
{$ifdef WIN32}
{$ifdef WINDOWS}
Windows,
{$else}
{$ifdef KYLIX}
@ -107,9 +104,11 @@ type
procedure RestructureTable(DbfFieldDefs: TDbfFieldDefs; Pack: Boolean);
procedure Rename(DestFileName: string; NewIndexFileNames: TStrings; DeleteFiles: boolean);
function GetFieldInfo(FieldName: string): TDbfFieldDef;
function GetFieldData(Column: Integer; DataType: TFieldType; Src,Dst: Pointer): Boolean;
function GetFieldDataFromDef(AFieldDef: TDbfFieldDef; DataType: TFieldType; Src, Dst: Pointer): Boolean;
procedure SetFieldData(Column: Integer; DataType: TFieldType; Src,Dst: Pointer);
function GetFieldData(Column: Integer; DataType: TFieldType; Src,Dst: Pointer;
NativeFormat: boolean): Boolean;
function GetFieldDataFromDef(AFieldDef: TDbfFieldDef; DataType: TFieldType;
Src, Dst: Pointer; NativeFormat: boolean): Boolean;
procedure SetFieldData(Column: Integer; DataType: TFieldType; Src,Dst: Pointer; NativeFormat: boolean);
procedure InitRecord(DestBuf: PChar);
procedure PackIndex(lIndexFile: TIndexFile; AIndexName: string);
procedure RegenerateIndexes;
@ -190,14 +189,17 @@ var
implementation
uses
{$ifndef WIN32}
{$ifndef WINDOWS}
{$ifndef FPC}
RTLConsts,
{$else}
BaseUnix,
{$endif}
{$endif}
dbf_str, dbf_lang, dbf_prssupp;
{$ifdef SUPPORT_MATH_UNIT}
Math,
{$endif}
dbf_str, dbf_lang, dbf_prssupp, dbf_prsdef;
const
sDBF_DEC_SEP = '.';
@ -1288,7 +1290,7 @@ begin
if TempDstDef.IsBlob and ((DbfFieldDefs = nil) or (TempDstDef.CopyFrom >= 0)) then
begin
// get current blob blockno
GetFieldData(lFieldNo, ftInteger, pBuff, @lBlobPageNo);
GetFieldData(lFieldNo, ftInteger, pBuff, @lBlobPageNo, false);
// valid blockno read?
if lBlobPageNo > 0 then
begin
@ -1299,7 +1301,7 @@ begin
DestDbfFile.FMemoFile.WriteMemo(lBlobPageNo, 0, BlobStream);
end;
// write new blockno
DestDbfFile.SetFieldData(lFieldNo, ftInteger, @lBlobPageNo, pDestBuff);
DestDbfFile.SetFieldData(lFieldNo, ftInteger, @lBlobPageNo, pDestBuff, false);
end else if (DbfFieldDefs <> nil) and (TempDstDef.CopyFrom >= 0) then
begin
// copy content of field
@ -1387,16 +1389,18 @@ begin
end;
// NOTE: Dst may be nil!
function TDbfFile.GetFieldData(Column: Integer; DataType: TFieldType; Src, Dst: Pointer): Boolean;
function TDbfFile.GetFieldData(Column: Integer; DataType: TFieldType;
Src, Dst: Pointer; NativeFormat: boolean): Boolean;
var
TempFieldDef: TDbfFieldDef;
begin
TempFieldDef := TDbfFieldDef(FFieldDefs.Items[Column]);
Result := GetFieldDataFromDef(TempFieldDef, DataType, Src, Dst);
Result := GetFieldDataFromDef(TempFieldDef, DataType, Src, Dst, NativeFormat);
end;
// NOTE: Dst may be nil!
function TDbfFile.GetFieldDataFromDef(AFieldDef: TDbfFieldDef; DataType: TFieldType; Src, Dst: Pointer): Boolean;
function TDbfFile.GetFieldDataFromDef(AFieldDef: TDbfFieldDef; DataType: TFieldType;
Src, Dst: Pointer; NativeFormat: boolean): Boolean;
var
FieldOffset, FieldSize: Integer;
// s: string;
@ -1444,20 +1448,21 @@ var
procedure SaveDateToDst;
begin
{$ifdef SUPPORT_NEW_FIELDDATA}
// Delphi 5 requests a TDateTime
PDateTime(Dst)^ := date;
{$else}
// Delphi 3 and 4 request a TDateTimeRec
// date is TTimeStamp.date
// datetime = msecs == BDE timestamp as we implemented it
if DataType = ftDateTime then
if not NativeFormat then
begin
PDateTimeRec(Dst)^.DateTime := date;
// Delphi 5 requests a TDateTime
PDateTime(Dst)^ := date;
end else begin
PLongInt(Dst)^ := DateTimeToTimeStamp(date).Date;
// Delphi 3 and 4 request a TDateTimeRec
// date is TTimeStamp.date
// datetime = msecs == BDE timestamp as we implemented it
if DataType = ftDateTime then
begin
PDateTimeRec(Dst)^.DateTime := date;
end else begin
PLongInt(Dst)^ := DateTimeToTimeStamp(date).Date;
end;
end;
{$endif}
end;
begin
@ -1562,9 +1567,13 @@ begin
end;
'B': // foxpro double
begin
Result := true;
if Dst <> nil then
PDouble(Dst)^ := PDouble(Src)^;
if FDbfVersion = xFoxPro then
begin
Result := true;
if Dst <> nil then
PDouble(Dst)^ := PDouble(Src)^;
end else
asciiContents := true;
end;
'M':
begin
@ -1683,7 +1692,8 @@ begin
end;
end;
procedure TDbfFile.SetFieldData(Column: Integer; DataType: TFieldType; Src, Dst: Pointer);
procedure TDbfFile.SetFieldData(Column: Integer; DataType: TFieldType;
Src, Dst: Pointer; NativeFormat: boolean);
const
IsBlobFieldToPadChar: array[Boolean] of Char = (#32, '0');
SrcNilToUpdateNullField: array[boolean] of TUpdateNullField = (unClear, unSet);
@ -1700,22 +1710,23 @@ var
procedure LoadDateFromSrc;
begin
{$ifdef SUPPORT_NEW_FIELDDATA}
// Delphi 5 passes a TDateTime
date := PDateTime(Src)^;
{$else}
// Delphi 3 and 4 pass a TDateTimeRec with a time stamp
// date = integer
// datetime = msecs == BDETimeStampToDateTime as we implemented it
if DataType = ftDateTime then
if not NativeFormat then
begin
date := PDouble(Src)^;
// Delphi 5, new format, passes a TDateTime
date := PDateTime(Src)^;
end else begin
timeStamp.Time := 0;
timeStamp.Date := PLongInt(Src)^;
date := TimeStampToDateTime(timeStamp);
// Delphi 3 and 4, old "native" format, pass a TDateTimeRec with a time stamp
// date = integer
// datetime = msecs == BDETimeStampToDateTime as we implemented it
if DataType = ftDateTime then
begin
date := PDouble(Src)^;
end else begin
timeStamp.Time := 0;
timeStamp.Date := PLongInt(Src)^;
date := TimeStampToDateTime(timeStamp);
end;
end;
{$endif}
end;
begin
@ -1811,10 +1822,14 @@ begin
end;
'B':
begin
if Src = nil then
PDouble(Dst)^ := 0
else
PDouble(Dst)^ := PDouble(Src)^;
if DbfVersion = xFoxPro then
begin
if Src = nil then
PDouble(Dst)^ := 0
else
PDouble(Dst)^ := PDouble(Src)^;
end else
asciiContents := true;
end;
'M':
begin
@ -2025,6 +2040,7 @@ var
lIndexFile: TIndexFile;
lIndexFileName: string;
createMdxFile: Boolean;
tempExclusive: boolean;
addedIndexFile: Integer;
addedIndexName: Integer;
begin
@ -2110,7 +2126,8 @@ begin
if CreateIndex then
begin
// try get exclusive mode
if IsSharedAccess then TryExclusive;
tempExclusive := IsSharedAccess;
if tempExclusive then TryExclusive;
// always uppercase index expression
IndexField := AnsiUpperCase(IndexField);
try
@ -2153,7 +2170,7 @@ begin
end;
finally
// return to previous mode
if TempMode <> pfNone then EndExclusive;
if tempExclusive then EndExclusive;
end;
end;
end;
@ -2682,13 +2699,13 @@ end;
procedure TDbfGlobals.InitUserName;
{$ifdef FPC}
{$ifndef WIN32}
{$ifndef WINDOWS}
var
TempName: UTSName;
{$endif}
{$endif}
begin
{$ifdef WIN32}
{$ifdef WINDOWS}
FUserNameLen := MAX_COMPUTERNAME_LENGTH+1;
SetLength(FUserName, FUserNameLen);
Windows.GetComputerName(PChar(FUserName),

20
fcl/db/dbase/dbf_fields.pas
View File

@ -332,7 +332,9 @@ begin
case FNativeFieldType of
// OH 2000-11-15 dBase7 support.
// Add the new fieldtypes
'+' : FFieldType := ftAutoInc;
'+' :
if DbfVersion = xBaseVII then
FFieldType := ftAutoInc;
'I' : FFieldType := ftInteger;
'O' : FFieldType := ftFloat;
'@', 'T':
@ -501,11 +503,21 @@ begin
FSize := 8;
FPrecision := 0;
end;
'M','G','B':
'B':
begin
if DbfVersion <> xFoxPro then
begin
FSize := 10;
FPrecision := 0;
end;
end;
'M','G':
begin
if DbfVersion = xFoxPro then
FSize := 4
else
begin
if (FSize <> 4) and (FSize <> 10) then
FSize := 4;
end else
FSize := 10;
FPrecision := 0;
end;

8
fcl/db/dbase/dbf_idxcur.pas
View File

@ -40,7 +40,7 @@ type
procedure Update(RecNo: Integer; PrevBuffer, NewBuffer: PChar);
{$ifdef SUPPORT_VARIANTS}
procedure VariantToBuffer(Key: Variant; ABuffer: PChar);
function VariantToBuffer(Key: Variant; ABuffer: PChar): TExpressionType;
{$endif}
function CheckUserKey(Key: PChar; StringBuf: PChar): PChar;
@ -128,7 +128,7 @@ end;
{$ifdef SUPPORT_VARIANTS}
procedure TIndexCursor.VariantToBuffer(Key: Variant; ABuffer: PChar);
function TIndexCursor.VariantToBuffer(Key: Variant; ABuffer: PChar): TExpressionType;
// assumes ABuffer is large enough ie. at least max key size
var
currLen: Integer;
@ -140,12 +140,14 @@ begin
begin
// make copy of userbcd to buffer
Move(TIndexFile(PagedFile).PrepareKey(ABuffer, etFloat)[0], ABuffer[0], 11);
end
end;
Result := etInteger;
end else begin
StrPLCopy(ABuffer, Key, TIndexFile(PagedFile).KeyLen);
// we have null-terminated string, pad with spaces if string too short
currLen := StrLen(ABuffer);
FillChar(ABuffer[currLen], TIndexFile(PagedFile).KeyLen-currLen, ' ');
Result := etString;
end;
end;

214
fcl/db/dbase/dbf_idxfile.pas
View File

@ -5,7 +5,7 @@ interface
{$I dbf_common.inc}
uses
{$ifdef WIN32}
{$ifdef WINDOWS}
Windows,
{$else}
{$ifdef KYLIX}
@ -23,6 +23,7 @@ uses
dbf_parser,
dbf_prsdef,
dbf_cursor,
dbf_collate,
dbf_common;
{$ifdef _DEBUG}
@ -46,7 +47,6 @@ type
TIndexModifyMode = (mmNormal, mmDeleteRecall);
TDbfLocaleErrorEvent = procedure(var Error: TLocaleError; var Solution: TLocaleSolution) of object;
TDbfCompareKeyEvent = function(Key: PChar): Integer of object;
TDbfCompareKeysEvent = function(Key1, Key2: PChar): Integer of object;
PDouble = ^Double;
@ -77,6 +77,14 @@ type
property Options: TIndexOptions read FOptions write FOptions;
end;
TDbfIndexParser = class(TDbfParser)
protected
FResultLen: Integer;
procedure ValidateExpression(AExpression: string); override;
public
property ResultLen: Integer read FResultLen;
end;
//===========================================================================
TIndexFile = class;
TIndexPageClass = class of TIndexPage;
@ -216,14 +224,14 @@ type
{$endif}
protected
FIndexName: string;
FParsers: array[0..MaxIndexes-1] of TDbfParser;
FParsers: array[0..MaxIndexes-1] of TDbfIndexParser;
FIndexHeaders: array[0..MaxIndexes-1] of Pointer;
FIndexHeaderModified: array[0..MaxIndexes-1] of Boolean;
FIndexHeader: Pointer;
FIndexVersion: TXBaseVersion;
FRoots: array[0..MaxIndexes-1] of TIndexPage;
FLeaves: array[0..MaxIndexes-1] of TIndexPage;
FCurrentParser: TDbfParser;
FCurrentParser: TDbfIndexParser;
FRoot: TIndexPage;
FLeaf: TIndexPage;
FMdxTag: TIndexTag;
@ -254,10 +262,8 @@ type
FUserNumeric: Double;
FForceClose: Boolean;
FForceReadOnly: Boolean;
FLocaleID: LCID;
FLocaleCP: Integer;
FCodePage: Integer;
FCompareKey: TDbfCompareKeyEvent;
FCollation: PCollationTable;
FCompareKeys: TDbfCompareKeysEvent;
FOnLocaleError: TDbfLocaleErrorEvent;
@ -291,10 +297,6 @@ type
function WalkPrev: boolean;
function WalkNext: boolean;
procedure TranslateToANSI(Src, Dest: PChar);
function CompareKeyNumericNDX(Key: PChar): Integer;
function CompareKeyNumericMDX(Key: PChar): Integer;
function CompareKeyString(Key: PChar): Integer;
function CompareKeysNumericNDX(Key1, Key2: PChar): Integer;
function CompareKeysNumericMDX(Key1, Key2: PChar): Integer;
function CompareKeysString(Key1, Key2: PChar): Integer;
@ -313,9 +315,6 @@ type
procedure SetPhysicalRecNo(RecNo: Integer);
procedure SetUpdateMode(NewMode: TIndexUpdateMode);
procedure SetIndexName(const AIndexName: string);
procedure SetLocaleID(const NewID: LCID);
property InternalLocaleID: LCID read FLocaleID write SetLocaleID;
public
constructor Create(ADbfFile: Pointer);
@ -387,7 +386,6 @@ type
property ForceClose: Boolean read FForceClose;
property ForceReadOnly: Boolean read FForceReadOnly;
property LocaleID: LCID read FLocaleID;
property CodePage: Integer read FCodePage write FCodePage;
property OnLocaleError: TDbfLocaleErrorEvent read FOnLocaleError write FOnLocaleError;
@ -1684,6 +1682,31 @@ begin
PMdx7Tag(Tag)^.KeyType := NewType;
end;
{ TDbfIndexParser }
procedure TDbfIndexParser.ValidateExpression(AExpression: string);
var
TempBuffer: pchar;
begin
FResultLen := inherited ResultLen;
if FResultLen = -1 then
begin
// make empty record
GetMem(TempBuffer, TDbfFile(DbfFile).RecordSize);
try
TDbfFile(DbfFile).InitRecord(TempBuffer);
FResultLen := StrLen(ExtractFromBuffer(TempBuffer));
finally
FreeMem(TempBuffer);
end;
end;
// check if expression not too long
if FResultLen > 100 then
raise EDbfError.CreateFmt(STRING_INDEX_EXPRESSION_TOO_LONG, [AExpression, FResultLen]);
end;
//==============================================================================
//============ TIndexFile
//==============================================================================
@ -1804,7 +1827,7 @@ begin
FIndexHeaders[0] := Header;
FIndexHeader := Header;
// create default root
FParsers[0] := TDbfParser.Create(FDbfFile);
FParsers[0] := TDbfIndexParser.Create(FDbfFile);
FRoots[0] := TNdxPage.Create(Self);
FCurrentParser := FParsers[0];
FRoot := FRoots[0];
@ -1812,7 +1835,7 @@ begin
// parse index expression
FCurrentParser.ParseExpression(PIndexHdr(FIndexHeader)^.KeyDesc);
// set index locale
InternalLocaleID := LCID(lcidBinary);
FCollation := BINARY_COLLATION;
end;
// determine how to open file
@ -1832,27 +1855,27 @@ begin
begin
// if dbf is version 3, no language id, if no MDX language, use binary
if PMdxHdr(Header)^.Language = 0 then
InternalLocaleID := lcidBinary
FCollation := BINARY_COLLATION
else
InternalLocaleID := LangId_To_Locale[PMdxHdr(Header)^.Language];
FCollation := GetCollationTable(PMdxHdr(Header)^.Language);
end else begin
// check if MDX - DBF language id's match
if (PMdxHdr(Header)^.Language = 0) or (PMdxHdr(Header)^.Language = DbfLangId) then
InternalLocaleID := LangId_To_Locale[DbfLangId]
FCollation := GetCollationTable(DbfLangId)
else
localeError := leTableIndexMismatch;
end;
// don't overwrite previous error
if (FLocaleID = DbfLocale_NotFound) and (localeError = leNone) then
if (FCollation = UNKNOWN_COLLATION) and (localeError = leNone) then
localeError := leUnknown;
end else begin
// dbase III always binary?
InternalLocaleID := lcidBinary;
FCollation := BINARY_COLLATION;
end;
// check if selected locale is available, binary is always available...
if (localeError <> leNone) and (FLocaleID <> LCID(lcidBinary)) then
if (localeError <> leNone) and (FCollation <> BINARY_COLLATION) then
begin
if LCIDList.IndexOf(Pointer(FLocaleID)) < 0 then
if LCIDList.IndexOf(Pointer(FCollation)) < 0 then
localeError := leNotAvailable;
end;
// check if locale error detected
@ -1868,8 +1891,8 @@ begin
lsNotOpen: FForceClose := true;
lsNoEdit: FForceReadOnly := true;
else
// `trust' user knows correct locale
InternalLocaleID := LCID(localeSolution);
{ lsBinary }
FCollation := BINARY_COLLATION;
end;
end;
// now read info
@ -1997,9 +2020,9 @@ begin
// use locale id of parent
DbfLangId := GetDbfLanguageId;
if DbfLangId = 0 then
InternalLocaleID := lcidBinary
FCollation := BINARY_COLLATION
else
InternalLocaleID := LangID_To_Locale[DbfLangId];
FCollation := GetCollationTable(DbfLangId);
// write index headers
prevSelIndex := FSelectedIndex;
for pos := 0 to PMdxHdr(Header)^.TagsUsed - 1 do
@ -2093,12 +2116,12 @@ procedure TIndexFile.CreateIndex(FieldDesc, TagName: string; Options: TIndexOpti
var
tagNo: Integer;
fieldType: Char;
TempParser: TDbfParser;
TempParser: TDbfIndexParser;
begin
// check if we have exclusive access to table
TDbfFile(FDbfFile).CheckExclusiveAccess;
// parse index expression; if it cannot be parsed, why bother making index?
TempParser := TDbfParser.Create(FDbfFile);
TempParser := TDbfIndexParser.Create(FDbfFile);
try
TempParser.ParseExpression(FieldDesc);
// check if result type is correct
@ -2123,7 +2146,7 @@ begin
// get memory for root
if FRoots[tagNo] = nil then
begin
FParsers[tagNo] := TDbfParser.Create(FDbfFile);
FParsers[tagNo] := TDbfIndexParser.Create(FDbfFile);
FRoots[tagNo] := TMdxPage.Create(Self)
end else begin
FreeAndNil(FRoots[tagNo].FLowerPage);
@ -2283,7 +2306,7 @@ begin
// create root if needed
if FRoots[I] = nil then
begin
FParsers[I] := TDbfParser.Create(FDbfFile);
FParsers[I] := TDbfIndexParser.Create(FDbfFile);
FRoots[I] := TMdxPage.Create(Self);
end;
// check header integrity
@ -2324,7 +2347,7 @@ var
I, found, numTags, moveItems: Integer;
tempHeader: Pointer;
tempRoot, tempLeaf: TIndexPage;
tempParser: TDbfParser;
tempParser: TDbfIndexParser;
begin
// check if we have exclusive access to table
TDbfFile(FDbfFile).CheckExclusiveAccess;
@ -2913,6 +2936,8 @@ function TIndexFile.ExtractKeyFromBuffer(Buffer: PChar): PChar;
begin
// execute expression to get key
Result := PrepareKey(FCurrentParser.ExtractFromBuffer(Buffer), FCurrentParser.ResultType);
if not FCurrentParser.RawStringFields then
TranslateString(GetACP, FCodePage, Result, Result, KeyLen);
end;
procedure TIndexFile.InsertKey(Buffer: PChar);
@ -2933,21 +2958,11 @@ end;
procedure TIndexFile.InsertCurrent;
// insert in current index
// assumes: FUserKey is an OEM key
var
lSearchKey: array[0..100] of Char;
OemKey: PChar;
begin
// only insert if not recalling or mode = distinct
// modify = mmDeleteRecall /\ unique <> distinct -> key already present
if (FModifyMode <> mmDeleteRecall) or (FUniqueMode = iuDistinct) then
begin
// translate OEM key to ANSI key for searching
OemKey := FUserKey;
if KeyType = 'C' then
begin
FUserKey := @lSearchKey[0];
TranslateToANSI(OemKey, FUserKey);
end;
// temporarily remove range to find correct location of key
ResetRange;
// find this record as closely as possible
@ -2955,8 +2970,6 @@ begin
// if unique index, then don't insert key if already present
if (FindKey(true) <> 0) or (FUniqueMode = iuNormal) then
begin
// switch to oem key
FUserKey := OemKey;
// if we found eof, write to pagebuffer
FLeaf.GotoInsertEntry;
// insert requested entry, we know there is an entry available
@ -3020,9 +3033,6 @@ end;
procedure TIndexFile.DeleteCurrent;
// deletes from current index
var
lSearchKey: array[0..100] of Char;
OemKey: PChar;
begin
// only delete if not delete record or mode = distinct
// modify = mmDeleteRecall /\ unique = distinct -> key needs to be deleted from index
@ -3033,13 +3043,6 @@ begin
// search correct entry to delete
if FLeaf.PhysicalRecNo <> FUserRecNo then
begin
// translate OEM key to ANSI key for searching
OemKey := FUserKey;
if KeyType = 'C' then
begin
FUserKey := @lSearchKey[0];
TranslateToANSI(OemKey, FUserKey);
end;
FindKey(false);
end;
// delete selected entry
@ -3085,7 +3088,7 @@ begin
FUserKey := ExtractKeyFromBuffer(PrevBuffer);
// compare to see if anything changed
if CompareKeys(@TempBuffer[0], FUserKey) <> 0 then
if CompareKey(@TempBuffer[0]) <> 0 then
begin
// first set userkey to key to delete
// FUserKey = KeyFrom(PrevBuffer)
@ -3329,28 +3332,6 @@ begin
FModifyMode := mmNormal;
end;
procedure TIndexFile.SetLocaleID(const NewID: LCID);
{$ifdef WIN32}
var
InfoStr: array[0..7] of Char;
{$endif}
begin
FLocaleID := NewID;
if NewID = lcidBinary then
begin
// no conversion on binary sort order
FLocaleCP := FCodePage;
end else begin
// get default ansi codepage for comparestring
{$ifdef WIN32}
GetLocaleInfo(NewID, LOCALE_IDEFAULTANSICODEPAGE, InfoStr, 8);
FLocaleCP := StrToIntDef(InfoStr, GetACP);
{$else}
FLocaleCP := GetACP;
{$endif}
end;
end;
procedure TIndexFile.SetPhysicalRecNo(RecNo: Integer);
begin
// check if already at specified recno
@ -3364,9 +3345,6 @@ begin
TDbfFile(FDbfFile).ReadRecord(RecNo, TDbfFile(FDbfFile).PrevBuffer);
// extract key
FUserKey := ExtractKeyFromBuffer(TDbfFile(FDbfFile).PrevBuffer);
// translate to a search key
if KeyType = 'C' then
TranslateToANSI(FUserKey, FUserKey);
// find this key
FUserRecNo := RecNo;
FindKey(false);
@ -3490,9 +3468,6 @@ begin
end else begin
// read current key into buffer
Move(FLeaf.Key^, FKeyBuffer, PIndexHdr(FIndexHeader)^.KeyLen);
// translate to searchable key
if KeyType = 'C' then
TranslateToANSI(FKeyBuffer, FKeyBuffer);
recno := FLeaf.PhysicalRecNo;
action := 2;
end;
@ -3757,64 +3732,15 @@ begin
end;
function TIndexFile.CompareKeysString(Key1, Key2: PChar): Integer;
var
Key1T, Key2T: array [0..100] of Char;
FromCP, ToCP: Integer;
begin
if FLocaleID = LCID(lcidBinary) then
begin
Result := StrLComp(Key1, Key2, KeyLen)
end else begin
FromCP := FCodePage;
ToCP := FLocaleCP;
TranslateString(FromCP, ToCP, Key1, Key1T, KeyLen);
TranslateString(FromCP, ToCP, Key2, Key2T, KeyLen);
Result := CompareString(FLocaleID, 0, Key1T, KeyLen, Key2T, KeyLen);
if Result > 0 then
Dec(Result, 2);
end
Result := DbfCompareString(FCollation, Key1, KeyLen, Key2, KeyLen);
if Result > 0 then
Dec(Result, 2);
end;
function TIndexFile.CompareKey(Key: PChar): Integer;
begin
// call compare routine
Result := FCompareKey(Key);
// if descending then reverse order
if FIsDescending then
Result := -Result;
end;
function TIndexFile.CompareKeyNumericNDX(Key: PChar): Integer;
begin
Result := CompareKeysNumericNDX(FUserKey, Key);
end;
function TIndexFile.CompareKeyNumericMDX(Key: PChar): Integer;
begin
Result := CompareKeysNumericMDX(FUserKey, Key);
end;
procedure TIndexFile.TranslateToANSI(Src, Dest: PChar);
begin
{ FromCP = FCodePage; }
{ ToCP = FLocaleCP; }
TranslateString(FCodePage, FLocaleCP, Src, Dest, KeyLen);
end;
function TIndexFile.CompareKeyString(Key: PChar): Integer;
var
KeyT: array [0..100] of Char;
begin
if FLocaleID = LCID(lcidBinary) then
begin
Result := StrLComp(FUserKey, Key, KeyLen)
end else begin
TranslateToANSI(Key, KeyT);
Result := CompareString(FLocaleID, 0, FUserKey, KeyLen, KeyT, KeyLen);
if Result > 0 then
Dec(Result, 2);
end
Result := CompareKeys(FUserKey, Key);
end;
function TIndexFile.IndexOf(const AIndexName: string): Integer;
@ -3900,18 +3826,12 @@ begin
FUniqueMode := iuDistinct;
// select key compare routine
if PIndexHdr(FIndexHeader)^.KeyType = 'C' then
begin
FCompareKeys := CompareKeysString;
FCompareKey := CompareKeyString;
end else
FCompareKeys := CompareKeysString
else
if FIndexVersion >= xBaseIV then
begin
FCompareKeys := CompareKeysNumericMDX;
FCompareKey := CompareKeyNumericMDX;
end else begin
FCompareKeys := CompareKeysNumericMDX
else
FCompareKeys := CompareKeysNumericNDX;
FCompareKey := CompareKeyNumericNDX;
end;
end;
procedure TIndexFile.Flush;

2
fcl/db/dbase/dbf_lang.pas
View File

@ -5,7 +5,7 @@ unit dbf_lang;
interface
uses
{$ifdef WIN32}
{$ifdef WINDOWS}
Windows;
{$else}
{$ifdef KYLIX}

2
fcl/db/dbase/dbf_memo.pas
View File

@ -238,7 +238,7 @@ begin
exit;
end else
if numBytes < RecordSize then
FillChar(FBuffer[RecordSize-numBytes], numBytes, #0);
FillChar(FBuffer[numBytes], RecordSize-numBytes, #0);
bytesLeft := GetMemoSize;
// bytesLeft <> -1 -> memo size is known (FoxPro, dBase4)

356
fcl/db/dbase/dbf_parser.pas
View File

@ -10,7 +10,7 @@ uses
{$ifdef KYLIX}
Libc,
{$endif}
{$ifndef WIN32}
{$ifndef WINDOWS}
dbf_wtil,
{$endif}
db,
@ -26,7 +26,6 @@ type
private
FDbfFile: Pointer;
FFieldVarList: TStringList;
FResultLen: Integer;
FIsExpression: Boolean; // expression or simple field?
FFieldType: TExpressionType;
FCaseInsensitive: Boolean;
@ -40,7 +39,9 @@ type
procedure HandleUnknownVariable(VarName: string); override;
function GetVariableInfo(VarName: string): TDbfFieldDef;
function CurrentExpression: string; override;
procedure ValidateExpression(AExpression: string); virtual;
function GetResultType: TExpressionType; override;
function GetResultLen: Integer;
procedure SetCaseInsensitive(NewInsensitive: Boolean);
procedure SetRawStringFields(NewRawFields: Boolean);
@ -56,21 +57,20 @@ type
property DbfFile: Pointer read FDbfFile write FDbfFile;
property Expression: string read FCurrentExpression;
property ResultLen: Integer read FResultLen;
property ResultLen: Integer read GetResultLen;
property CaseInsensitive: Boolean read FCaseInsensitive write SetCaseInsensitive;
property RawStringFields: Boolean read FRawStringFields write SetRawStringFields;
property PartialMatch: boolean read FPartialMatch write SetPartialMatch;
end;
implementation
uses
dbf,
dbf_dbffile,
dbf_str
{$ifdef WIN32}
{$ifdef WINDOWS}
,Windows
{$endif}
;
@ -103,22 +103,18 @@ type
TStringFieldVar = class(TFieldVar)
protected
FFieldVal: PChar;
FRawStringField: boolean;
function GetFieldVal: Pointer; override;
function GetFieldType: TExpressionType; override;
end;
TRawStringFieldVar = class(TStringFieldVar)
public
procedure Refresh(Buffer: PChar); override;
end;
TAnsiStringFieldVar = class(TStringFieldVar)
procedure SetRawStringField(NewRaw: boolean);
public
constructor Create(UseFieldDef: TDbfFieldDef; ADbfFile: TDbfFile);
destructor Destroy; override;
procedure Refresh(Buffer: PChar); override;
property RawStringField: boolean read FRawStringField write SetRawStringField;
end;
TFloatFieldVar = class(TFieldVar)
@ -184,7 +180,20 @@ begin
FFieldName := UseFieldDef.FieldName;
end;
//--TStringFieldVar-------------------------------------------------------------
//--TStringFieldVar---------------------------------------------------------
constructor TStringFieldVar.Create(UseFieldDef: TDbfFieldDef; ADbfFile: TDbfFile);
begin
inherited;
end;
destructor TStringFieldVar.Destroy;
begin
if not FRawStringField then
FreeMem(FFieldVal);
inherited;
end;
function TStringFieldVar.GetFieldVal: Pointer;
begin
Result := @FFieldVal;
@ -195,39 +204,37 @@ begin
Result := etString;
end;
//--TRawStringFieldVar----------------------------------------------------------
procedure TRawStringFieldVar.Refresh(Buffer: PChar);
begin
FFieldVal := Buffer + FieldDef.Offset;
end;
//--TAnsiStringFieldVar---------------------------------------------------------
constructor TAnsiStringFieldVar.Create(UseFieldDef: TDbfFieldDef; ADbfFile: TDbfFile);
begin
inherited;
GetMem(FFieldVal, UseFieldDef.Size+1);
end;
destructor TAnsiStringFieldVar.Destroy;
begin
FreeMem(FFieldVal);
inherited;
end;
procedure TAnsiStringFieldVar.Refresh(Buffer: PChar);
procedure TStringFieldVar.Refresh(Buffer: PChar);
var
Len: Integer;
Src: PChar;
begin
// copy field data
Len := FieldDef.Size;
Move(Buffer[FieldDef.Offset], FFieldVal[0], Len);
Src := Buffer+FieldDef.Offset;
// trim right side spaces by null-termination
while (Len >= 1) and (FFieldVal[Len-1] = ' ') do Dec(Len);
FFieldVal[Len] := #0;
// translate to ANSI
TranslateString(DbfFile.UseCodePage, GetACP, FFieldVal, FFieldVal, Len);
if not FRawStringField then
begin
while (Len >= 1) and (Buffer[Len-1] = ' ') do Dec(Len);
FFieldVal[Len] := #0;
// translate to ANSI
TranslateString(DbfFile.UseCodePage, GetACP, Src, FFieldVal, Len);
end else
FFieldVal := Src;
end;
procedure TStringFieldVar.SetRawStringField(NewRaw: boolean);
begin
if NewRaw = FRawStringField then exit;
FRawStringField := NewRaw;
if NewRaw then
begin
FExprWord.FixedLen := FieldDef.Size;
FreeMem(FFieldVal);
end else begin
FExprWord.FixedLen := -1;
GetMem(FFieldVal, FieldDef.Size*3+1);
end;
end;
//--TFloatFieldVar-----------------------------------------------------------
@ -244,7 +251,7 @@ end;
procedure TFloatFieldVar.Refresh(Buffer: PChar);
begin
// database width is default 64-bit double
if not FDbfFile.GetFieldDataFromDef(FieldDef, FieldDef.FieldType, Buffer, @FFieldVal) then
if not FDbfFile.GetFieldDataFromDef(FieldDef, FieldDef.FieldType, Buffer, @FFieldVal, false) then
FFieldVal := 0.0;
end;
@ -262,7 +269,7 @@ end;
procedure TIntegerFieldVar.Refresh(Buffer: PChar);
begin
FFieldVal := 0;
FDbfFile.GetFieldDataFromDef(FieldDef, FieldDef.FieldType, Buffer, @FFieldVal);
FDbfFile.GetFieldDataFromDef(FieldDef, FieldDef.FieldType, Buffer, @FFieldVal, false);
end;
{$ifdef SUPPORT_INT64}
@ -280,7 +287,7 @@ end;
procedure TLargeIntFieldVar.Refresh(Buffer: PChar);
begin
if not FDbfFile.GetFieldDataFromDef(FieldDef, FieldDef.FieldType, Buffer, @FFieldVal) then
if not FDbfFile.GetFieldDataFromDef(FieldDef, FieldDef.FieldType, Buffer, @FFieldVal, false) then
FFieldVal := 0;
end;
@ -299,7 +306,7 @@ end;
procedure TDateTimeFieldVar.Refresh(Buffer: PChar);
begin
if not FDbfFile.GetFieldDataFromDef(FieldDef, ftDateTime, Buffer, @FFieldVal) then
if not FDbfFile.GetFieldDataFromDef(FieldDef, ftDateTime, Buffer, @FFieldVal, false) then
FFieldVal.DateTime := 0.0;
end;
@ -318,21 +325,14 @@ procedure TBooleanFieldVar.Refresh(Buffer: PChar);
var
lFieldVal: word;
begin
if FDbfFile.GetFieldDataFromDef(FieldDef, ftBoolean, Buffer, @lFieldVal) then
if FDbfFile.GetFieldDataFromDef(FieldDef, ftBoolean, Buffer, @lFieldVal, false) then
FFieldVal := lFieldVal <> 0
else
FFieldVal := false;
end;
//--TDbfParser---------------------------------------------------------------
(*
var
DbfWordsSensGeneralList, DbfWordsInsensGeneralList: TExpressList;
DbfWordsSensPartialList, DbfWordsInsensPartialList: TExpressList;
DbfWordsSensNoPartialList, DbfWordsInsensNoPartialList: TExpressList;
DbfWordsGeneralList: TExpressList;
*)
constructor TDbfParser.Create(ADbfFile: Pointer);
begin
FDbfFile := ADbfFile;
@ -358,6 +358,26 @@ begin
Result := FFieldType;
end;
function TDbfParser.GetResultLen: Integer;
begin
// set result len for fixed length expressions / fields
case ResultType of
etBoolean: Result := 1;
etInteger: Result := 4;
etFloat: Result := 8;
etDateTime: Result := 8;
etString:
begin
if not FIsExpression and (TStringFieldVar(FFieldVarList.Objects[0]).RawStringField) then
Result := TStringFieldVar(FFieldVarList.Objects[0]).FieldDef.Size
else
Result := -1;
end;
else
Result := -1;
end;
end;
procedure TDbfParser.SetCaseInsensitive(NewInsensitive: Boolean);
begin
if FCaseInsensitive <> NewInsensitive then
@ -379,13 +399,16 @@ begin
end;
procedure TDbfParser.SetRawStringFields(NewRawFields: Boolean);
var
I: integer;
begin
if FRawStringFields <> NewRawFields then
begin
// clear and regenerate functions, custom fields will be deleted too
FRawStringFields := NewRawFields;
if Length(Expression) > 0 then
ParseExpression(Expression);
for I := 0 to FFieldVarList.Count - 1 do
if FFieldVarList.Objects[I] is TStringFieldVar then
TStringFieldVar(FFieldVarList.Objects[I]).RawStringField := NewRawFields;
end;
end;
@ -438,16 +461,9 @@ begin
case FieldInfo.FieldType of
ftString:
begin
if RawStringFields then
begin
{ raw string fields have fixed length, not null-terminated }
TempFieldVar := TRawStringFieldVar.Create(FieldInfo, TDbfFile(FDbfFile));
TempFieldVar.FExprWord := DefineStringVariableFixedLen(VarName, TempFieldVar.FieldVal, FieldInfo.Size);
end else begin
{ ansi string field function translates and null-terminates field value }
TempFieldVar := TAnsiStringFieldVar.Create(FieldInfo, TDbfFile(FDbfFile));
TempFieldVar.FExprWord := DefineStringVariable(VarName, TempFieldVar.FieldVal);
end;
TempFieldVar := TStringFieldVar.Create(FieldInfo, TDbfFile(FDbfFile));
TempFieldVar.FExprWord := DefineStringVariable(VarName, TempFieldVar.FieldVal);
TStringFieldVar(TempFieldVar).RawStringField := FRawStringFields;
end;
ftBoolean:
begin
@ -512,9 +528,11 @@ begin
FCurrentExpression := EmptyStr;
end;
procedure TDbfParser.ValidateExpression(AExpression: string);
begin
end;
procedure TDbfParser.ParseExpression(AExpression: string);
var
TempBuffer: pchar;
begin
// clear any current expression
ClearExpressions;
@ -525,39 +543,13 @@ begin
begin
// parse requested
CompileExpression(AExpression);
// determine length of string length expressions
if ResultType = etString then
begin
// make empty record
GetMem(TempBuffer, TDbfFile(FDbfFile).RecordSize);
try
TDbfFile(FDbfFile).InitRecord(TempBuffer);
FResultLen := StrLen(ExtractFromBuffer(TempBuffer));
finally
FreeMem(TempBuffer);
end;
end;
end else begin
// simple field, create field variable for it
HandleUnknownVariable(AExpression);
FFieldType := TFieldVar(FFieldVarList.Objects[0]).FieldType;
// set result len of variable length fields
if FFieldType = etString then
FResultLen := TFieldVar(FFieldVarList.Objects[0]).FieldDef.Size
end;
// set result len for fixed length expressions / fields
case ResultType of
etBoolean: FResultLen := 1;
etInteger: FResultLen := 4;
etFloat: FResultLen := 8;
etDateTime: FResultLen := 8;
end;
// check if expression not too long
if FResultLen > 100 then
raise EDbfError.CreateFmt(STRING_INDEX_EXPRESSION_TOO_LONG, [AExpression, FResultLen]);
ValidateExpression(AExpression);
// if no errors, assign current expression
FCurrentExpression := AExpression;
@ -585,180 +577,6 @@ begin
Result := PPChar(Result)^;
end;
end;
(*
initialization
DbfWordsGeneralList := TExpressList.Create;
DbfWordsInsensGeneralList := TExpressList.Create;
DbfWordsInsensNoPartialList := TExpressList.Create;
DbfWordsInsensPartialList := TExpressList.Create;
DbfWordsSensGeneralList := TExpressList.Create;
DbfWordsSensNoPartialList := TExpressList.Create;
DbfWordsSensPartialList := TExpressList.Create;
with DbfWordsGeneralList do
begin
// basic function functionality
Add(TLeftBracket.Create('(', nil));
Add(TRightBracket.Create(')', nil));
Add(TComma.Create(',', nil));
// operators - name, param types, result type, func addr, precedence
Add(TFunction.CreateOper('+', 'SS', etString, nil, 40));
Add(TFunction.CreateOper('+', 'FF', etFloat, FuncAdd_F_FF, 40));
Add(TFunction.CreateOper('+', 'FI', etFloat, FuncAdd_F_FI, 40));
Add(TFunction.CreateOper('+', 'IF', etFloat, FuncAdd_F_IF, 40));
Add(TFunction.CreateOper('+', 'II', etInteger, FuncAdd_F_II, 40));
{$ifdef SUPPORT_INT64}
Add(TFunction.CreateOper('+', 'FL', etFloat, FuncAdd_F_FL, 40));
Add(TFunction.CreateOper('+', 'IL', etLargeInt, FuncAdd_F_IL, 40));
Add(TFunction.CreateOper('+', 'LF', etFloat, FuncAdd_F_LF, 40));
Add(TFunction.CreateOper('+', 'LL', etLargeInt, FuncAdd_F_LI, 40));
Add(TFunction.CreateOper('+', 'LI', etLargeInt, FuncAdd_F_LL, 40));
{$endif}
Add(TFunction.CreateOper('-', 'FF', etFloat, FuncSub_F_FF, 40));
Add(TFunction.CreateOper('-', 'FI', etFloat, FuncSub_F_FI, 40));
Add(TFunction.CreateOper('-', 'IF', etFloat, FuncSub_F_IF, 40));
Add(TFunction.CreateOper('-', 'II', etInteger, FuncSub_F_II, 40));
{$ifdef SUPPORT_INT64}
Add(TFunction.CreateOper('-', 'FL', etFloat, FuncSub_F_FL, 40));
Add(TFunction.CreateOper('-', 'IL', etLargeInt, FuncSub_F_IL, 40));
Add(TFunction.CreateOper('-', 'LF', etFloat, FuncSub_F_LF, 40));
Add(TFunction.CreateOper('-', 'LL', etLargeInt, FuncSub_F_LI, 40));
Add(TFunction.CreateOper('-', 'LI', etLargeInt, FuncSub_F_LL, 40));
{$endif}
Add(TFunction.CreateOper('*', 'FF', etFloat, FuncMul_F_FF, 40));
Add(TFunction.CreateOper('*', 'FI', etFloat, FuncMul_F_FI, 40));
Add(TFunction.CreateOper('*', 'IF', etFloat, FuncMul_F_IF, 40));
Add(TFunction.CreateOper('*', 'II', etInteger, FuncMul_F_II, 40));
{$ifdef SUPPORT_INT64}
Add(TFunction.CreateOper('*', 'FL', etFloat, FuncMul_F_FL, 40));
Add(TFunction.CreateOper('*', 'IL', etLargeInt, FuncMul_F_IL, 40));
Add(TFunction.CreateOper('*', 'LF', etFloat, FuncMul_F_LF, 40));
Add(TFunction.CreateOper('*', 'LL', etLargeInt, FuncMul_F_LI, 40));
Add(TFunction.CreateOper('*', 'LI', etLargeInt, FuncMul_F_LL, 40));
{$endif}
Add(TFunction.CreateOper('/', 'FF', etFloat, FuncDiv_F_FF, 40));
Add(TFunction.CreateOper('/', 'FI', etFloat, FuncDiv_F_FI, 40));
Add(TFunction.CreateOper('/', 'IF', etFloat, FuncDiv_F_IF, 40));
Add(TFunction.CreateOper('/', 'II', etInteger, FuncDiv_F_II, 40));
{$ifdef SUPPORT_INT64}
Add(TFunction.CreateOper('/', 'FL', etFloat, FuncDiv_F_FL, 40));
Add(TFunction.CreateOper('/', 'IL', etLargeInt, FuncDiv_F_IL, 40));
Add(TFunction.CreateOper('/', 'LF', etFloat, FuncDiv_F_LF, 40));
Add(TFunction.CreateOper('/', 'LL', etLargeInt, FuncDiv_F_LI, 40));
Add(TFunction.CreateOper('/', 'LI', etLargeInt, FuncDiv_F_LL, 40));
{$endif}
Add(TFunction.CreateOper('=', 'FF', etBoolean, Func_FF_EQ , 80));
Add(TFunction.CreateOper('<', 'FF', etBoolean, Func_FF_LT , 80));
Add(TFunction.CreateOper('>', 'FF', etBoolean, Func_FF_GT , 80));
Add(TFunction.CreateOper('<=','FF', etBoolean, Func_FF_LTE, 80));
Add(TFunction.CreateOper('>=','FF', etBoolean, Func_FF_GTE, 80));
Add(TFunction.CreateOper('<>','FF', etBoolean, Func_FF_NEQ, 80));
Add(TFunction.CreateOper('=', 'FI', etBoolean, Func_FI_EQ , 80));
Add(TFunction.CreateOper('<', 'FI', etBoolean, Func_FI_LT , 80));
Add(TFunction.CreateOper('>', 'FI', etBoolean, Func_FI_GT , 80));
Add(TFunction.CreateOper('<=','FI', etBoolean, Func_FI_LTE, 80));
Add(TFunction.CreateOper('>=','FI', etBoolean, Func_FI_GTE, 80));
Add(TFunction.CreateOper('<>','FI', etBoolean, Func_FI_NEQ, 80));
Add(TFunction.CreateOper('=', 'II', etBoolean, Func_II_EQ , 80));
Add(TFunction.CreateOper('<', 'II', etBoolean, Func_II_LT , 80));
Add(TFunction.CreateOper('>', 'II', etBoolean, Func_II_GT , 80));
Add(TFunction.CreateOper('<=','II', etBoolean, Func_II_LTE, 80));
Add(TFunction.CreateOper('>=','II', etBoolean, Func_II_GTE, 80));
Add(TFunction.CreateOper('<>','II', etBoolean, Func_II_NEQ, 80));
Add(TFunction.CreateOper('=', 'IF', etBoolean, Func_IF_EQ , 80));
Add(TFunction.CreateOper('<', 'IF', etBoolean, Func_IF_LT , 80));
Add(TFunction.CreateOper('>', 'IF', etBoolean, Func_IF_GT , 80));
Add(TFunction.CreateOper('<=','IF', etBoolean, Func_IF_LTE, 80));
Add(TFunction.CreateOper('>=','IF', etBoolean, Func_IF_GTE, 80));
Add(TFunction.CreateOper('<>','IF', etBoolean, Func_IF_NEQ, 80));
{$ifdef SUPPORT_INT64}
Add(TFunction.CreateOper('=', 'LL', etBoolean, Func_LL_EQ , 80));
Add(TFunction.CreateOper('<', 'LL', etBoolean, Func_LL_LT , 80));
Add(TFunction.CreateOper('>', 'LL', etBoolean, Func_LL_GT , 80));
Add(TFunction.CreateOper('<=','LL', etBoolean, Func_LL_LTE, 80));
Add(TFunction.CreateOper('>=','LL', etBoolean, Func_LL_GTE, 80));
Add(TFunction.CreateOper('<>','LL', etBoolean, Func_LL_NEQ, 80));
Add(TFunction.CreateOper('=', 'LF', etBoolean, Func_LF_EQ , 80));
Add(TFunction.CreateOper('<', 'LF', etBoolean, Func_LF_LT , 80));
Add(TFunction.CreateOper('>', 'LF', etBoolean, Func_LF_GT , 80));
Add(TFunction.CreateOper('<=','LF', etBoolean, Func_LF_LTE, 80));
Add(TFunction.CreateOper('>=','LF', etBoolean, Func_LF_GTE, 80));
Add(TFunction.CreateOper('<>','FI', etBoolean, Func_LF_NEQ, 80));
Add(TFunction.CreateOper('=', 'LI', etBoolean, Func_LI_EQ , 80));
Add(TFunction.CreateOper('<', 'LI', etBoolean, Func_LI_LT , 80));
Add(TFunction.CreateOper('>', 'LI', etBoolean, Func_LI_GT , 80));
Add(TFunction.CreateOper('<=','LI', etBoolean, Func_LI_LTE, 80));
Add(TFunction.CreateOper('>=','LI', etBoolean, Func_LI_GTE, 80));
Add(TFunction.CreateOper('<>','LI', etBoolean, Func_LI_NEQ, 80));
Add(TFunction.CreateOper('=', 'FL', etBoolean, Func_FL_EQ , 80));
Add(TFunction.CreateOper('<', 'FL', etBoolean, Func_FL_LT , 80));
Add(TFunction.CreateOper('>', 'FL', etBoolean, Func_FL_GT , 80));
Add(TFunction.CreateOper('<=','FL', etBoolean, Func_FL_LTE, 80));
Add(TFunction.CreateOper('>=','FL', etBoolean, Func_FL_GTE, 80));
Add(TFunction.CreateOper('<>','FL', etBoolean, Func_FL_NEQ, 80));
Add(TFunction.CreateOper('=', 'IL', etBoolean, Func_IL_EQ , 80));
Add(TFunction.CreateOper('<', 'IL', etBoolean, Func_IL_LT , 80));
Add(TFunction.CreateOper('>', 'IL', etBoolean, Func_IL_GT , 80));
Add(TFunction.CreateOper('<=','IL', etBoolean, Func_IL_LTE, 80));
Add(TFunction.CreateOper('>=','IL', etBoolean, Func_IL_GTE, 80));
Add(TFunction.CreateOper('<>','IL', etBoolean, Func_IL_NEQ, 80));
{$endif}
Add(TFunction.CreateOper('NOT', 'B', etBoolean, Func_NOT, 85));
Add(TFunction.CreateOper('AND', 'BB', etBoolean, Func_AND, 90));
Add(TFunction.CreateOper('OR', 'BB', etBoolean, Func_OR, 100));
// Functions - name, description, param types, min params, result type, Func addr
Add(TFunction.Create('STR', '', 'FII', 1, etString, FuncFloatToStr, ''));
Add(TFunction.Create('STR', '', 'III', 1, etString, FuncIntToStr, ''));
Add(TFunction.Create('DTOS', '', 'D', 1, etString, FuncDateToStr, ''));
Add(TFunction.Create('SUBSTR', 'SUBS', 'SII', 3, etString, FuncSubString, ''));
Add(TFunction.Create('UPPERCASE', 'UPPER', 'S', 1, etString, FuncUppercase, ''));
Add(TFunction.Create('LOWERCASE', 'LOWER', 'S', 1, etString, FuncLowercase, ''));
end;
with DbfWordsInsensGeneralList do
begin
Add(TFunction.CreateOper('<', 'SS', etBoolean, FuncStrI_LT , 80));
Add(TFunction.CreateOper('>', 'SS', etBoolean, FuncStrI_GT , 80));
Add(TFunction.CreateOper('<=','SS', etBoolean, FuncStrI_LTE, 80));
Add(TFunction.CreateOper('>=','SS', etBoolean, FuncStrI_GTE, 80));
Add(TFunction.CreateOper('<>','SS', etBoolean, FuncStrI_NEQ, 80));
end;
with DbfWordsInsensNoPartialList do
Add(TFunction.CreateOper('=', 'SS', etBoolean, FuncStrI_EQ , 80));
with DbfWordsInsensPartialList do
Add(TFunction.CreateOper('=', 'SS', etBoolean, FuncStrIP_EQ, 80));
with DbfWordsSensGeneralList do
begin
Add(TFunction.CreateOper('<', 'SS', etBoolean, FuncStr_LT , 80));
Add(TFunction.CreateOper('>', 'SS', etBoolean, FuncStr_GT , 80));
Add(TFunction.CreateOper('<=','SS', etBoolean, FuncStr_LTE, 80));
Add(TFunction.CreateOper('>=','SS', etBoolean, FuncStr_GTE, 80));
Add(TFunction.CreateOper('<>','SS', etBoolean, FuncStr_NEQ, 80));
end;
with DbfWordsSensNoPartialList do
Add(TFunction.CreateOper('=', 'SS', etBoolean, FuncStr_EQ , 80));
with DbfWordsSensPartialList do
Add(TFunction.CreateOper('=', 'SS', etBoolean, FuncStrP_EQ , 80));
finalization
DbfWordsGeneralList.Free;
DbfWordsInsensGeneralList.Free;
DbfWordsInsensNoPartialList.Free;
DbfWordsInsensPartialList.Free;
DbfWordsSensGeneralList.Free;
DbfWordsSensNoPartialList.Free;
DbfWordsSensPartialList.Free;
*)
end.

4
fcl/db/dbase/dbf_pgfile.pas
View File

@ -146,7 +146,7 @@ type
implementation
uses
{$ifdef WIN32}
{$ifdef WINDOWS}
Windows,
{$else}
{$ifdef KYLIX}
@ -773,7 +773,7 @@ end;
// BDE compatible lock offset found!
const
{$ifdef WIN32}
{$ifdef WINDOWS}
LockOffset = $EFFFFFFE; // BDE compatible
FileLockSize = 2;
{$else}

217
fcl/db/dbase/dbf_prscore.pas
View File

@ -4,6 +4,18 @@ unit dbf_prscore;
| TCustomExpressionParser
|
| - contains core expression parser
|
| This code is based on code from:
|
| Original author: Egbert van Nes
| With contributions of: John Bultena and Ralf Junker
| Homepage: http://www.slm.wau.nl/wkao/parseexpr.html
|
| see also: http://www.datalog.ro/delphi/parser.html
| (Renate Schaaf (schaaf at math.usu.edu), 1993
| Alin Flaider (aflaidar at datalog.ro), 1996
| Version 9-10: Stefan Hoffmeister, 1996-1997)
|
|---------------------------------------------------------------}
interface
@ -81,7 +93,6 @@ type
function DefineDateTimeVariable(AVarName: string; AValue: PDateTimeRec): TExprWord;
function DefineBooleanVariable(AVarName: string; AValue: PBoolean): TExprWord;
function DefineStringVariable(AVarName: string; AValue: PPChar): TExprWord;
function DefineStringVariableFixedLen(AVarName: string; AValue: PPChar; ALength: Integer): TExprWord;
function DefineFunction(AFunctName, AShortName, ADescription, ATypeSpec: string;
AMinFunctionArg: Integer; AResultType: TExpressionType; AFuncAddress: TExprFunc): TExprWord;
procedure Evaluate(AnExpression: string);
@ -104,8 +115,9 @@ type
//--Expression functions-----------------------------------------------------
procedure FuncFloatToStr(Param: PExpressionRec);
procedure FuncIntToStr_Gen(Param: PExpressionRec; Val: Integer);
procedure FuncIntToStr_Gen(Param: PExpressionRec; Val: {$ifdef SUPPORT_INT64}Int64{$else}Integer{$endif});
procedure FuncIntToStr(Param: PExpressionRec);
procedure FuncInt64ToStr(Param: PExpressionRec);
procedure FuncDateToStr(Param: PExpressionRec);
procedure FuncSubString(Param: PExpressionRec);
procedure FuncUppercase(Param: PExpressionRec);
@ -155,13 +167,11 @@ procedure FuncDiv_F_LF(Param: PExpressionRec);
procedure FuncDiv_F_LI(Param: PExpressionRec);
{$endif}
procedure FuncStrI_EQ(Param: PExpressionRec);
procedure FuncStrIP_EQ(Param: PExpressionRec);
procedure FuncStrI_NEQ(Param: PExpressionRec);
procedure FuncStrI_LT(Param: PExpressionRec);
procedure FuncStrI_GT(Param: PExpressionRec);
procedure FuncStrI_LTE(Param: PExpressionRec);
procedure FuncStrI_GTE(Param: PExpressionRec);
procedure FuncStrP_EQ(Param: PExpressionRec);
procedure FuncStr_EQ(Param: PExpressionRec);
procedure FuncStr_NEQ(Param: PExpressionRec);
procedure FuncStr_LT(Param: PExpressionRec);
@ -236,6 +246,40 @@ var
implementation
procedure LinkVariable(ExprRec: PExpressionRec);
begin
with ExprRec^ do
begin
if ExprWord.IsVariable then
begin
// copy pointer to variable
Args[0] := ExprWord.AsPointer;
// is this a fixed length string variable?
if ExprWord.FixedLen >= 0 then
begin
// store length as second parameter
Args[1] := PChar(ExprWord.LenAsPointer);
end;
end;
end;
end;
procedure LinkVariables(ExprRec: PExpressionRec);
var
I: integer;
begin
with ExprRec^ do
begin
I := 0;
while (I < MaxArg) and (ArgList[I] <> nil) do
begin
LinkVariables(ArgList[I]);
Inc(I);
end;
end;
LinkVariable(ExprRec);
end;
{ TCustomExpressionParser }
constructor TCustomExpressionParser.Create;
@ -288,6 +332,7 @@ begin
ExprTree := MakeTree(ExpColl, 0, ExpColl.Count - 1);
FCurrentRec := nil;
CheckArguments(ExprTree);
LinkVariables(ExprTree);
if Optimize then
RemoveConstants(ExprTree);
// all constant expressions are evaluated and replaced by variables
@ -309,15 +354,44 @@ end;
procedure TCustomExpressionParser.CheckArguments(ExprRec: PExpressionRec);
var
TempExprWord: TExprWord;
I, error: Integer;
I, error, firstFuncIndex, funcIndex: Integer;
foundAltFunc: Boolean;
begin
with ExprRec^ do
procedure FindAlternate;
begin
repeat
I := 0;
error := 0;
foundAltFunc := false;
// see if we can find another function
if funcIndex < 0 then
begin
firstFuncIndex := FWordsList.IndexOf(ExprRec^.ExprWord);
funcIndex := firstFuncIndex;
end;
// check if not last function
if (0 <= funcIndex) and (funcIndex < FWordsList.Count - 1) then
begin
inc(funcIndex);
TempExprWord := TExprWord(FWordsList.Items[funcIndex]);
if FWordsList.Compare(FWordsList.KeyOf(ExprRec^.ExprWord), FWordsList.KeyOf(TempExprWord)) = 0 then
begin
ExprRec^.ExprWord := TempExprWord;
ExprRec^.Oper := ExprRec^.ExprWord.ExprFunc;
foundAltFunc := true;
end;
end;
end;
procedure InternalCheckArguments;
begin
I := 0;
error := 0;
foundAltFunc := false;
with ExprRec^ do
begin
if WantsFunction <> (ExprWord.IsFunction and not ExprWord.IsOperator) then
begin
error := 4;
exit;
end;
while (I < ExprWord.MaxFunctionArg) and (ArgList[I] <> nil) and (error = 0) do
begin
// test subarguments first
@ -338,33 +412,38 @@ begin
// test if too many parameters passed
if (error = 0) and (I > ExprWord.MaxFunctionArg) then
error := 3;
// error occurred?
if error <> 0 then
begin
// see if we can find another function
I := FWordsList.IndexOf(ExprWord);
// check if not last function
if I < FWordsList.Count - 1 then
begin
TempExprWord := TExprWord(FWordsList.Items[I+1]);
if FWordsList.Compare(FWordsList.KeyOf(ExprWord), FWordsList.KeyOf(TempExprWord)) = 0 then
begin
ExprWord := TempExprWord;
Oper := ExprWord.ExprFunc;
foundAltFunc := true;
end;
end;
end;
until (error = 0) or not foundAltFunc;
// fatal error?
case error of
1: raise EParserException.Create('Function or operand has too few arguments');
2: raise EParserException.Create('Argument type mismatch');
3: raise EParserException.Create('Function or operand has too many arguments');
end;
end;
begin
funcIndex := -1;
repeat
InternalCheckArguments;
// error occurred?
if error <> 0 then
FindAlternate;
until (error = 0) or not foundAltFunc;
// maybe it's an undefined variable
if (error <> 0) and not ExprRec^.WantsFunction and (firstFuncIndex >= 0) then
begin
HandleUnknownVariable(ExprRec^.ExprWord.Name);
{ must not add variable as first function in this set of duplicates,
otherwise following searches will not find it }
FWordsList.Exchange(firstFuncIndex, firstFuncIndex+1);
ExprRec^.ExprWord := TExprWord(FWordsList.Items[firstFuncIndex+1]);
ExprRec^.Oper := ExprRec^.ExprWord.ExprFunc;
InternalCheckArguments;
end;
// fatal error?
case error of
1: raise EParserException.Create('Function or operand has too few arguments');
2: raise EParserException.Create('Argument type mismatch');
3: raise EParserException.Create('Function or operand has too many arguments');
4: raise EParserException.Create('No function with this name, remove brackets for variable');
end;
end;
function TCustomExpressionParser.ResultCanVary(ExprRec: PExpressionRec):
@ -377,7 +456,7 @@ begin
Result := ExprWord.CanVary;
if not Result then
for I := 0 to ExprWord.MaxFunctionArg - 1 do
if ResultCanVary(ArgList[I]) then
if (ArgList[I] <> nil) and ResultCanVary(ArgList[I]) then
begin
Result := true;
Exit;
@ -610,17 +689,6 @@ begin
begin
Result^.ExprWord := TExprWord(Expr.Items[FirstItem]);
Result^.Oper := Result^.ExprWord.ExprFunc;
if Result^.ExprWord.IsVariable then
begin
// copy pointer to variable
Result^.Args[0] := Result^.ExprWord.AsPointer;
// is this a fixed length string variable?
if Result^.ExprWord.FixedLen >= 0 then
begin
// store length as second parameter
Result^.Args[1] := PChar(Result^.ExprWord.LenAsPointer);
end;
end;
exit;
end;
@ -664,6 +732,7 @@ begin
// save function
Result^.ExprWord := TExprWord(Expr.Items[FirstItem]);
Result^.Oper := Result^.ExprWord.ExprFunc;
Result^.WantsFunction := true;
// parse function arguments
IEnd := FirstItem + 1;
IStart := IEnd;
@ -979,9 +1048,8 @@ begin
if (TExprWord(Items[I]).IsVariable) and ((I < Count - 1) and
(TExprWord(Items[I + 1]).IsVariable)) then
raise EParserException.Create('Missing operator between '''+TExprWord(Items[I]).Name+''' and '''+TExprWord(Items[I]).Name+'''');
if (TExprWord(Items[I]).ResultType = etLeftBracket) and ((I >= Count - 1) or
(TExprWord(Items[I + 1]).ResultType = etRightBracket)) then
raise EParserException.Create('Empty brackets ()');
if (TExprWord(Items[I]).ResultType = etLeftBracket) and (I >= Count - 1) then
raise EParserException.Create('Missing closing bracket');
if (TExprWord(Items[I]).ResultType = etRightBracket) and ((I < Count - 1) and
(TExprWord(Items[I + 1]).ResultType = etLeftBracket)) then
raise EParserException.Create('Missing operator between )(');
@ -1070,12 +1138,7 @@ end;
function TCustomExpressionParser.DefineStringVariable(AVarName: string; AValue: PPChar): TExprWord;
begin
Result := DefineStringVariableFixedLen(AVarName, AValue, -1);
end;
function TCustomExpressionParser.DefineStringVariableFixedLen(AVarName: string; AValue: PPChar; ALength: Integer): TExprWord;
begin
Result := TStringVariable.Create(AVarName, AValue, ALength);
Result := TStringVariable.Create(AVarName, AValue);
FWordsList.Add(Result);
end;
@ -1114,6 +1177,7 @@ begin
New(Result);
Result^.Oper := nil;
Result^.AuxData := nil;
Result^.WantsFunction := false;
for I := 0 to MaxArg - 1 do
begin
Result^.Args[I] := nil;
@ -1238,7 +1302,7 @@ begin
end;
end;
procedure FuncIntToStr_Gen(Param: PExpressionRec; Val: Integer);
procedure FuncIntToStr_Gen(Param: PExpressionRec; Val: {$ifdef SUPPORT_INT64}Int64{$else}Integer{$endif});
var
width: Integer;
begin
@ -1249,7 +1313,12 @@ begin
begin
// convert to string
width := PInteger(Args[1])^;
GetStrFromInt_Width(Val, width, Res.MemoryPos^, #32);
{$ifdef SUPPORT_INT64}
GetStrFromInt64_Width
{$else}
GetStrFromInt_Width
{$endif}
(Val, width, Res.MemoryPos^, #32);
// advance pointer
Inc(Res.MemoryPos^, width);
// need to add decimal?
@ -1267,7 +1336,13 @@ begin
end;
end else begin
// convert to string
width := GetStrFromInt(Val, Res.MemoryPos^);
width :=
{$ifdef SUPPORT_INT64}
GetStrFromInt64
{$else}
GetStrFromInt
{$endif}
(Val, Res.MemoryPos^);
// advance pointer
Inc(Param^.Res.MemoryPos^, width);
end;
@ -1281,6 +1356,15 @@ begin
FuncIntToStr_Gen(Param, PInteger(Param^.Args[0])^);
end;
{$ifdef SUPPORT_INT64}
procedure FuncInt64ToStr(Param: PExpressionRec);
begin
FuncIntToStr_Gen(Param, PInt64(Param^.Args[0])^);
end;
{$endif}
procedure FuncDateToStr(Param: PExpressionRec);
var
TempStr: string;
@ -1302,11 +1386,14 @@ begin
begin
srcLen := StrLen(Args[0]);
index := PInteger(Args[1])^ - 1;
count := PInteger(Args[2])^;
if index + count <= srcLen then
Res.Append(Args[0]+index, count)
else
Res.MemoryPos^^ := #0;
if Args[2] <> nil then
begin
count := PInteger(Args[2])^;
if index + count > srcLen then
count := srcLen - index;
end else
count := srcLen - index;
Res.Append(Args[0]+index, count)
end;
end;

47
fcl/db/dbase/dbf_prsdef.pas
View File

@ -25,6 +25,10 @@ type
EParserException = class(Exception);
PExpressionRec = ^TExpressionRec;
PDynamicType = ^TDynamicType;
PDateTimeRec = ^TDateTimeRec;
{$ifdef SUPPORT_INT64}
PLargeInt = ^Int64;
{$endif}
TExprWord = class;
@ -58,7 +62,8 @@ type
Res: TDynamicType;
ExprWord: TExprWord;
AuxData: pointer;
ResetDest: Boolean;
ResetDest: boolean;
WantsFunction: boolean;
Args: array[0..MaxArg-1] of PChar;
ArgsPos: array[0..MaxArg-1] of PChar;
ArgsSize: array[0..MaxArg-1] of Integer;
@ -107,6 +112,7 @@ type
function GetDescription: string; virtual;
function GetTypeSpec: string; virtual;
function GetShortName: string; virtual;
procedure SetFixedLen(NewLen: integer); virtual;
public
constructor Create(AName: string; AExprFunc: TExprFunc);
@ -119,7 +125,7 @@ type
property CanVary: Boolean read GetCanVary;
property IsVariable: Boolean read GetIsVariable;
property NeedsCopy: Boolean read GetNeedsCopy;
property FixedLen: Integer read GetFixedLen;
property FixedLen: Integer read GetFixedLen write SetFixedLen;
property ResultType: TExpressionType read GetResultType;
property MinFunctionArg: Integer read GetMinFunctionArg;
property MaxFunctionArg: Integer read GetMaxFunctionArg;
@ -235,8 +241,9 @@ type
FFixedLen: Integer;
protected
function GetFixedLen: Integer; override;
procedure SetFixedLen(NewLen: integer); override;
public
constructor Create(AName: string; AValue: PPChar; AFixedLen: Integer);
constructor Create(AName: string; AValue: PPChar);
function LenAsPointer: PInteger; override;
function AsPointer: PChar; override;
@ -379,15 +386,16 @@ begin
end;
procedure _StringVariable(Param: PExpressionRec);
var
length: integer;
begin
with Param^ do
Res.Append(PPChar(Args[0])^, StrLen(PPChar(Args[0])^));
end;
procedure _StringVariableFixedLen(Param: PExpressionRec);
begin
with Param^ do
Res.Append(PPChar(Args[0])^, PInteger(Args[1])^);
begin
length := PInteger(Args[1])^;
if length = -1 then
length := StrLen(PPChar(Args[0])^);
Res.Append(PPChar(Args[0])^, length);
end;
end;
procedure _DateTimeVariable(Param: PExpressionRec);
@ -454,7 +462,6 @@ begin
// fpc simply returns pointer to function, no '@' needed
Result := (@FExprFunc = @_StringVariable) or
(@FExprFunc = @_StringConstant) or
(@FExprFunc = @_StringVariableFixedLen) or
(@FExprFunc = @_FloatVariable) or
(@FExprFunc = @_IntegerVariable) or
// (FExprFunc = @_SmallIntVariable) or
@ -524,6 +531,10 @@ begin
Result := False;
end;
procedure TExprWord.SetFixedLen(NewLen: integer);
begin
end;
{ TConstant }
constructor TConstant.Create(AName: string; AVarType: TExpressionType; AExprFunc: TExprFunc);
@ -659,17 +670,14 @@ end;
{ TStringVariable }
constructor TStringVariable.Create(AName: string; AValue: PPChar; AFixedLen: Integer);
constructor TStringVariable.Create(AName: string; AValue: PPChar);
begin
// variable or fixed length?
if (AFixedLen < 0) then
inherited Create(AName, etString, _StringVariable)
else
inherited Create(AName, etString, _StringVariableFixedLen);
inherited Create(AName, etString, _StringVariable);
// store pointer to string
FValue := AValue;
FFixedLen := AFixedLen;
FFixedLen := -1;
end;
function TStringVariable.AsPointer: PChar;
@ -687,6 +695,11 @@ begin
Result := @FFixedLen;
end;
procedure TStringVariable.SetFixedLen(NewLen: integer);
begin
FFixedLen := NewLen;
end;
{ TDateTimeVariable }
constructor TDateTimeVariable.Create(AName: string; AValue: PDateTimeRec);

131
fcl/db/dbase/dbf_prssupp.pas
View File

@ -51,51 +51,15 @@ type
function GetStrFromInt(Val: Integer; const Dst: PChar): Integer;
procedure GetStrFromInt_Width(Val: Integer; const Width: Integer; const Dst: PChar; const PadChar: Char);
{$ifdef SUPPORT_INT64}
function GetStrFromInt64(Val: Int64; const Dst: PChar): Integer;
procedure GetStrFromInt64_Width(Val: Int64; const Width: Integer; const Dst: PChar; const PadChar: Char);
{$endif}
implementation
uses SysUtils;
// it seems there is no pascal function to convert an integer into a PChar???
// NOTE: in dbf_dbffile.pas there is also a convert routine, but is slightly different
function GetStrFromInt(Val: Integer; const Dst: PChar): Integer;
var
Temp: array[0..10] of Char;
I, J: Integer;
begin
Val := Abs(Val);
// we'll have to store characters backwards first
I := 0;
J := 0;
repeat
Temp[I] := Chr((Val mod 10) + Ord('0'));
Val := Val div 10;
Inc(I);
until Val = 0;
// remember number of digits
Result := I;
// copy value, remember: stored backwards
repeat
Dst[J] := Temp[I-1];
Inc(J);
Dec(I);
until I = 0;
// done!
end;
// it seems there is no pascal function to convert an integer into a PChar???
procedure GetStrFromInt_Width(Val: Integer; const Width: Integer; const Dst: PChar; const PadChar: Char);
var
Temp: array[0..10] of Char;
I, J: Integer;
NegSign: boolean;
begin
{$I getstrfromint.inc}
end;
destructor TOCollection.Destroy;
begin
FreeAll;
@ -193,7 +157,7 @@ function TSortedCollection.Search(Key: Pointer; var Index: Integer): Boolean;
var
L, H, I, C: Integer;
begin
Search := False;
Result := false;
L := 0;
H := Count - 1;
while L <= H do
@ -202,11 +166,9 @@ begin
C := Compare(KeyOf(Items[I]), Key);
if C < 0 then
L := I + 1
else
begin
else begin
H := I - 1;
if C = 0 then
Search := True;
Result := C = 0;
end;
end;
Index := L;
@ -224,5 +186,84 @@ begin
StrDispose(Item);
end;
// it seems there is no pascal function to convert an integer into a PChar???
// NOTE: in dbf_dbffile.pas there is also a convert routine, but is slightly different
function GetStrFromInt(Val: Integer; const Dst: PChar): Integer;
var
Temp: array[0..10] of Char;
I, J: Integer;
begin
Val := Abs(Val);
// we'll have to store characters backwards first
I := 0;
J := 0;
repeat
Temp[I] := Chr((Val mod 10) + Ord('0'));
Val := Val div 10;
Inc(I);
until Val = 0;
// remember number of digits
Result := I;
// copy value, remember: stored backwards
repeat
Dst[J] := Temp[I-1];
Inc(J);
Dec(I);
until I = 0;
// done!
end;
// it seems there is no pascal function to convert an integer into a PChar???
procedure GetStrFromInt_Width(Val: Integer; const Width: Integer; const Dst: PChar; const PadChar: Char);
var
Temp: array[0..10] of Char;
I, J: Integer;
NegSign: boolean;
begin
{$I getstrfromint.inc}
end;
{$ifdef SUPPORT_INT64}
procedure GetStrFromInt64_Width(Val: Int64; const Width: Integer; const Dst: PChar; const PadChar: Char);
var
Temp: array[0..19] of Char;
I, J: Integer;
NegSign: boolean;
begin
{$I getstrfromint.inc}
end;
function GetStrFromInt64(Val: Int64; const Dst: PChar): Integer;
var
Temp: array[0..19] of Char;
I, J: Integer;
begin
Val := Abs(Val);
// we'll have to store characters backwards first
I := 0;
J := 0;
repeat
Temp[I] := Chr((Val mod 10) + Ord('0'));
Val := Val div 10;
Inc(I);
until Val = 0;
// remember number of digits
Result := I;
// copy value, remember: stored backwards
repeat
Dst[J] := Temp[I-1];
inc(J);
dec(I);
until I = 0;
// done!
end;
{$endif}
end.

4
fcl/db/dbase/dbf_wtil.pas
View File

@ -4,7 +4,7 @@ unit dbf_wtil;
interface
{$ifndef WIN32}
{$ifndef WINDOWS}
uses
{$ifdef FPC}
BaseUnix,
@ -270,7 +270,7 @@ procedure SetLastError(Value: Integer);
implementation
{$ifndef WIN32}
{$ifndef WINDOWS}
{$ifdef FPC}
uses
unix;

22
fcl/db/dbase/history.txt
View File

@ -33,11 +33,31 @@ BUGS & WARNINGS
------------------------
V6.4.9
V6.9.1
- fix last memo field getting truncated (patch by dhdorrough)
- add dbf_collate unit to the packages
- fix index result too long bug
------------------------
V6.9.0
- BDE compatible index collation: MDX/NDXes have to be rebuilt!
(thx sstewart for generating collation tables)
- fix use long char fields check icw foxpro (thx rpoverdijk)
- fix TDbf.GetRecNo AV when no file open
- remove UseFloatFields, delphi 3 will use float fields, others not
- fix size/precision truncation when opening foxpro B-type fields (thx nring)
- foxbase memo is 10 character index, sizes 4 and 10 are valid (thx majky)
- add int64 to string conversion in expression parser function STR
- fix nativeformat for tdbf.getfielddata(A,B) users
- allow later defined expression variables to have same name as
already defined function
- third parameter in substr function is optional now
- expression parser distinguishes between function() and variable, =no brackets
- updated bcb 4 packages files from troy dalton
- fix write blob B-type field for non-foxpro (thx leexgone)
- fix win64 compatibility
------------------------