Browse Source

Updated to version 6.4.0

michael 21 years ago
parent
commit
24720c0056

+ 7 - 30
fcl/db/dbase/Makefile

@@ -1,8 +1,8 @@
 #
 #
-# Don't edit, this file is generated by FPCMake Version 1.1 [2004/09/04]
+# Don't edit, this file is generated by FPCMake Version 1.1 [2004/08/31]
 #
 #
 default: all
 default: all
-MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom morphos netwlibc
+MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom morphos
 BSDs = freebsd netbsd openbsd darwin
 BSDs = freebsd netbsd openbsd darwin
 UNIXs = linux $(BSDs) sunos qnx
 UNIXs = linux $(BSDs) sunos qnx
 FORCE:
 FORCE:
@@ -216,19 +216,19 @@ PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/ext
 override PACKAGE_NAME=fcl
 override PACKAGE_NAME=fcl
 ifeq ($(CPU_TARGET),i386)
 ifeq ($(CPU_TARGET),i386)
 ifneq ($(OS_TARGET),win32)
 ifneq ($(OS_TARGET),win32)
-INSTALL_UNITS+=Dbf_Wtil
-CLEAN_UNITS+=Dbf_Wtil
+INSTALL_UNITS+=dbf_Wtil
+CLEAN_UNITS+=dbf_Wtil
 endif
 endif
 endif
 endif
 ifeq ($(CPU_TARGET),i386)
 ifeq ($(CPU_TARGET),i386)
-override TARGET_UNITS+=Dbf
+override TARGET_UNITS+=dbf
 endif
 endif
 ifeq ($(CPU_TARGET),i386)
 ifeq ($(CPU_TARGET),i386)
 override TARGET_EXAMPLES+=testdbf
 override TARGET_EXAMPLES+=testdbf
 endif
 endif
-override CLEAN_UNITS+=Dbf_Common Dbf_Cursor Dbf_DbfFile Dbf_Fields Dbf_IdxCur Dbf_IdxFile Dbf_Lang Dbf_Memo Dbf_Parser Dbf_PgFile Dbf_PrsCore Dbf_PrsDef Dbf_PrsSupp Dbf_Str
+override CLEAN_UNITS+=dbf_common dbf_cursor dbf_dbffile dbf_fields dbf_idxcur dbf_idxfile dbf_lang dbf_memo dbf_parser dbf_pgfile dbf_prscore dbf_prsdef dbf_prssupp dbf_str
 ifeq ($(CPU_TARGET),i386)
 ifeq ($(CPU_TARGET),i386)
-override INSTALL_UNITS+=Dbf_Common Dbf_Cursor Dbf_DbfFile Dbf_Fields Dbf_IdxCur Dbf_IdxFile Dbf_Lang Dbf_Memo Dbf_Parser Dbf_PgFile Dbf_PrsCore Dbf_PrsDef Dbf_PrsSupp Dbf_Str
+override INSTALL_UNITS+=dbf_common dbf_cursor dbf_dbffile dbf_fields dbf_idxcur dbf_idxfile dbf_lang dbf_memo dbf_parser dbf_pgfile dbf_prscore dbf_prsdef dbf_prssupp dbf_str
 endif
 endif
 override INSTALL_FPCPACKAGE=y
 override INSTALL_FPCPACKAGE=y
 override COMPILER_OPTIONS+=-S2 -Sh
 override COMPILER_OPTIONS+=-S2 -Sh
@@ -541,12 +541,6 @@ STATICLIBPREFIX=
 FPCMADE=fpcmade.nw
 FPCMADE=fpcmade.nw
 ZIPSUFFIX=nw
 ZIPSUFFIX=nw
 endif
 endif
-ifeq ($(OS_TARGET),netwlibc)
-EXEEXT=.nlm
-STATICLIBPREFIX=
-FPCMADE=fpcmade.nwl
-ZIPSUFFIX=nwl
-endif
 ifeq ($(OS_TARGET),macos)
 ifeq ($(OS_TARGET),macos)
 BATCHEXT=
 BATCHEXT=
 EXEEXT=
 EXEEXT=
@@ -699,18 +693,6 @@ FPCMADE=fpcmade.nw
 ZIPSUFFIX=nw
 ZIPSUFFIX=nw
 EXEEXT=.nlm
 EXEEXT=.nlm
 endif
 endif
-ifeq ($(OS_TARGET),netwlibc)
-STATICLIBPREFIX=
-PPUEXT=.ppu
-OEXT=.o
-ASMEXT=.s
-SMARTEXT=.sl
-STATICLIBEXT=.a
-SHAREDLIBEXT=.nlm
-FPCMADE=fpcmade.nwl
-ZIPSUFFIX=nwl
-EXEEXT=.nlm
-endif
 ifeq ($(OS_TARGET),macos)
 ifeq ($(OS_TARGET),macos)
 BATCHEXT=
 BATCHEXT=
 PPUEXT=.ppu
 PPUEXT=.ppu
@@ -1113,11 +1095,6 @@ ifeq ($(CPU_TARGET),powerpc)
 REQUIRE_PACKAGES_RTL=1
 REQUIRE_PACKAGES_RTL=1
 endif
 endif
 endif
 endif
-ifeq ($(OS_TARGET),netwlibc)
-ifeq ($(CPU_TARGET),i386)
-REQUIRE_PACKAGES_RTL=1
-endif
-endif
 ifdef REQUIRE_PACKAGES_RTL
 ifdef REQUIRE_PACKAGES_RTL
 PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/$(OS_TARGET)/Makefile.fpc,$(PACKAGESDIR))))))
 PACKAGEDIR_RTL:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /rtl/$(OS_TARGET)/Makefile.fpc,$(PACKAGESDIR))))))
 ifneq ($(PACKAGEDIR_RTL),)
 ifneq ($(PACKAGEDIR_RTL),)

+ 10 - 10
fcl/db/dbase/Makefile.fpc

@@ -6,7 +6,7 @@
 main=fcl
 main=fcl
 
 
 [target]
 [target]
-units_i386=Dbf
+units_i386=dbf
 examples_i386=testdbf
 examples_i386=testdbf
 
 
 [compiler]
 [compiler]
@@ -18,21 +18,21 @@ fpcdir=../../..
 
 
 [install]
 [install]
 fpcpackage=y
 fpcpackage=y
-units_i386=Dbf_Common Dbf_Cursor Dbf_DbfFile Dbf_Fields Dbf_IdxCur \
-      Dbf_IdxFile Dbf_Lang Dbf_Memo Dbf_Parser Dbf_PgFile \
-      Dbf_PrsCore Dbf_PrsDef Dbf_PrsSupp Dbf_Str
+units_i386=dbf_common dbf_cursor dbf_dbffile dbf_fields dbf_idxcur \
+      dbf_idxfile dbf_lang dbf_memo dbf_parser dbf_pgfile \
+      dbf_prscore dbf_prsdef dbf_prssupp dbf_str
 
 
 [clean]
 [clean]
-units=Dbf_Common Dbf_Cursor Dbf_DbfFile Dbf_Fields Dbf_IdxCur \
-      Dbf_IdxFile Dbf_Lang Dbf_Memo Dbf_Parser Dbf_PgFile \
-      Dbf_PrsCore Dbf_PrsDef Dbf_PrsSupp Dbf_Str
+units=dbf_common dbf_cursor dbf_dbffile dbf_fields dbf_idxcur \
+      dbf_idxfile dbf_lang dbf_memo dbf_parser dbf_pgfile \
+      dbf_prscore dbf_prsdef dbf_prssupp dbf_str
 
 
 [prerules]
 [prerules]
-# Dbf_Wtil is needed on all targets except win32
+# dbf_Wtil is needed on all targets except win32
 ifeq ($(CPU_TARGET),i386)
 ifeq ($(CPU_TARGET),i386)
 ifneq ($(OS_TARGET),win32)
 ifneq ($(OS_TARGET),win32)
-INSTALL_UNITS+=Dbf_Wtil
-CLEAN_UNITS+=Dbf_Wtil
+INSTALL_UNITS+=dbf_Wtil
+CLEAN_UNITS+=dbf_Wtil
 endif
 endif
 endif
 endif
 
 

+ 145 - 127
fcl/db/dbase/Dbf.pas → fcl/db/dbase/dbf.pas

@@ -1,4 +1,4 @@
-unit Dbf;
+unit dbf;
 
 
 { design info in dbf_reg.pas }
 { design info in dbf_reg.pas }
 
 
@@ -8,10 +8,11 @@ interface
 
 
 uses
 uses
   Classes,
   Classes,
-  DB,
+  Db,
   Dbf_Common,
   Dbf_Common,
   Dbf_DbfFile,
   Dbf_DbfFile,
   Dbf_Parser,
   Dbf_Parser,
+  Dbf_PrsDef,
   Dbf_Cursor,
   Dbf_Cursor,
   Dbf_Fields,
   Dbf_Fields,
   Dbf_PgFile,
   Dbf_PgFile,
@@ -23,10 +24,16 @@ uses
 type
 type
 
 
 //====================================================================
 //====================================================================
-  pDbfRecord = ^rDbfRecordHeader;
-  rDbfRecordHeader = record
-    BookmarkData: rBookmarkData;
+  pBookmarkData = ^TBookmarkData;
+  TBookmarkData = record
+    PhysicalRecNo: Integer;
+  end;
+
+  pDbfRecord = ^TDbfRecordHeader;
+  TDbfRecordHeader = record
+    BookmarkData: TBookmarkData;
     BookmarkFlag: TBookmarkFlag;
     BookmarkFlag: TBookmarkFlag;
+    SequentialRecNo: Integer;
     DeletedFlag: Char;
     DeletedFlag: Char;
   end;
   end;
 //====================================================================
 //====================================================================
@@ -208,6 +215,7 @@ type
     procedure GetFieldDefsFromDbfFieldDefs;
     procedure GetFieldDefsFromDbfFieldDefs;
     procedure InitDbfFile(FileOpenMode: TPagedFileMode);
     procedure InitDbfFile(FileOpenMode: TPagedFileMode);
     function  ParseIndexName(const AIndexName: string): string;
     function  ParseIndexName(const AIndexName: string): string;
+    procedure ParseFilter(const AFilter: string);
     function  GetDbfFieldDefs: TDbfFieldDefs;
     function  GetDbfFieldDefs: TDbfFieldDefs;
     function  SearchKeyBuffer(Buffer: PChar; SearchType: TSearchKeyType): Boolean;
     function  SearchKeyBuffer(Buffer: PChar; SearchType: TSearchKeyType): Boolean;
     procedure SetRangeBuffer(LowRange: PChar; HighRange: PChar);
     procedure SetRangeBuffer(LowRange: PChar; HighRange: PChar);
@@ -306,6 +314,7 @@ type
     function  SearchKey(Key: Variant; SearchType: TSearchKeyType): Boolean;
     function  SearchKey(Key: Variant; SearchType: TSearchKeyType): Boolean;
     procedure SetRange(LowRange: Variant; HighRange: Variant);
     procedure SetRange(LowRange: Variant; HighRange: Variant);
 {$endif}
 {$endif}
+    function  PrepareKey(Buffer: Pointer; BufferType: TExpressionType): PChar;
     function  SearchKeyPChar(Key: PChar; SearchType: TSearchKeyType): Boolean;
     function  SearchKeyPChar(Key: PChar; SearchType: TSearchKeyType): Boolean;
     procedure SetRangePChar(LowRange: PChar; HighRange: PChar);
     procedure SetRangePChar(LowRange: PChar; HighRange: PChar);
     function  GetCurrentBuffer: PChar;
     function  GetCurrentBuffer: PChar;
@@ -458,6 +467,17 @@ const
   SCircularDataLink = 'Circular datalinks are not allowed';
   SCircularDataLink = 'Circular datalinks are not allowed';
 {$endif}
 {$endif}
 
 
+function TableLevelToDbfVersion(TableLevel: integer): TXBaseVersion;
+begin
+  case TableLevel of
+    3:                      Result := xBaseIII;
+    7:                      Result := xBaseVII;
+    TDBF_TABLELEVEL_FOXPRO: Result := xFoxPro;
+  else
+    {4:} Result := xBaseIV;
+  end;
+end;
+
 //==========================================================
 //==========================================================
 //============ TDbfBlobStream
 //============ TDbfBlobStream
 //==========================================================
 //==========================================================
@@ -579,7 +599,7 @@ begin
   if DbfGlobals = nil then
   if DbfGlobals = nil then
     DbfGlobals := TDbfGlobals.Create;
     DbfGlobals := TDbfGlobals.Create;
 
 
-  BookmarkSize := sizeof(rBookmarkData);
+  BookmarkSize := sizeof(TBookmarkData);
   FIndexDefs := TDbfIndexDefs.Create(Self);
   FIndexDefs := TDbfIndexDefs.Create(Self);
   FMasterLink := TDbfMasterLink.Create(Self);
   FMasterLink := TDbfMasterLink.Create(Self);
   FMasterLink.OnMasterChange := MasterChanged;
   FMasterLink.OnMasterChange := MasterChanged;
@@ -625,7 +645,7 @@ end;
 
 
 function TDbf.AllocRecordBuffer: PChar; {override virtual abstract from TDataset}
 function TDbf.AllocRecordBuffer: PChar; {override virtual abstract from TDataset}
 begin
 begin
-  GetMem(Result, SizeOf(rDbfRecordHeader)+FDbfFile.RecordSize+CalcFieldsSize+1);
+  GetMem(Result, SizeOf(TDbfRecordHeader)+FDbfFile.RecordSize+CalcFieldsSize+1);
 end;
 end;
 
 
 procedure TDbf.FreeRecordBuffer(var Buffer: PChar); {override virtual abstract from TDataset}
 procedure TDbf.FreeRecordBuffer(var Buffer: PChar); {override virtual abstract from TDataset}
@@ -634,19 +654,13 @@ begin
 end;
 end;
 
 
 procedure TDbf.GetBookmarkData(Buffer: PChar; Data: Pointer); {override virtual abstract from TDataset}
 procedure TDbf.GetBookmarkData(Buffer: PChar; Data: Pointer); {override virtual abstract from TDataset}
-var
-  pRecord: pDbfRecord;
 begin
 begin
-  pRecord := pDbfRecord(Buffer);
-  pBookMarkData(Data)^ := pRecord.BookMarkData;
+  pBookmarkData(Data)^ := pDbfRecord(Buffer)^.BookmarkData;
 end;
 end;
 
 
 function TDbf.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; {override virtual abstract from TDataset}
 function TDbf.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; {override virtual abstract from TDataset}
-var
-  pRecord: pDbfRecord;
 begin
 begin
-  pRecord := pDbfRecord(Buffer);
-  Result := pRecord.BookMarkFlag;
+  Result := pDbfRecord(Buffer)^.BookmarkFlag;
 end;
 end;
 
 
 function TDbf.GetCurrentBuffer: PChar;
 function TDbf.GetCurrentBuffer: PChar;
@@ -761,12 +775,6 @@ begin
   repeat
   repeat
     Result := grOK;
     Result := grOK;
     case GetMode of
     case GetMode of
-      gmCurrent :
-        begin
-          //if pRecord.BookmarkData.RecNo=FPhysicalRecNo then begin
-          //  exit;    // try to fasten a bit...
-          //end;
-        end;
       gmNext :
       gmNext :
         begin
         begin
           Acceptable := FCursor.Next;
           Acceptable := FCursor.Next;
@@ -790,7 +798,7 @@ begin
     if (Result = grOK) then
     if (Result = grOK) then
     begin
     begin
       lPhysicalRecNo := FCursor.PhysicalRecNo;
       lPhysicalRecNo := FCursor.PhysicalRecNo;
-      if not FDbfFile.IsRecordPresent(lPhysicalRecNo) then
+      if (lPhysicalRecNo = 0) or not FDbfFile.IsRecordPresent(lPhysicalRecNo) then
       begin
       begin
         Result := grError;
         Result := grError;
       end else begin
       end else begin
@@ -816,17 +824,12 @@ begin
 
 
   if (Result = grOK) and not FFindRecordFilter then
   if (Result = grOK) and not FFindRecordFilter then
   begin
   begin
-    ClearCalcFields(Buffer); //run automatically
-    try
-      GetCalcFields(Buffer);
-    finally
-       pRecord.BookmarkData := FCursor.GetBookMark;
-       pRecord.BookmarkFlag := bfCurrent;
-    end;
-    if (pRecord.BookMarkData <= 0) then
-       pRecord.BookmarkData := FCursor.GetBookMark;
+    pRecord.BookmarkData.PhysicalRecNo := FCursor.PhysicalRecNo;
+    pRecord.BookmarkFlag := bfCurrent;
+    pRecord.SequentialRecNo := FCursor.SequentialRecNo;
+    GetCalcFields(Buffer);
   end else begin
   end else begin
-    pRecord.BookmarkData := -1;
+    pRecord.BookmarkData.PhysicalRecNo := -1;
   end;
   end;
 end;
 end;
 
 
@@ -941,11 +944,19 @@ begin
 end;
 end;
 
 
 procedure TDbf.InternalGotoBookmark(Bookmark: Pointer); {override virtual abstract from TDataset}
 procedure TDbf.InternalGotoBookmark(Bookmark: Pointer); {override virtual abstract from TDataset}
-var
-  RecInfo: rBookmarkData;
 begin
 begin
-  RecInfo := rBookmarkData(Bookmark^);
-  FCursor.GotoBookmark(RecInfo);
+  with PBookmarkData(Bookmark)^ do
+  begin
+    if (PhysicalRecNo = 0) then begin
+      First;
+    end else
+    if (PhysicalRecNo = MaxInt) then begin
+      Last;
+    end else begin
+      if FCursor.PhysicalRecNo <> PhysicalRecNo then
+        FCursor.PhysicalRecNo := PhysicalRecNo;
+    end;
+  end;
 end;
 end;
 
 
 procedure TDbf.InternalHandleException; {override virtual abstract from TDataset}
 procedure TDbf.InternalHandleException; {override virtual abstract from TDataset}
@@ -1009,12 +1020,16 @@ begin
 end;
 end;
 
 
 procedure TDbf.InitDbfFile(FileOpenMode: TPagedFileMode);
 procedure TDbf.InitDbfFile(FileOpenMode: TPagedFileMode);
+const
+  FileModeToMemMode: array[TPagedFileMode] of TPagedFileMode =
+    (pfNone, pfMemoryCreate, pfMemoryOpen, pfMemoryCreate, pfMemoryOpen,
+     pfMemoryCreate, pfMemoryOpen, pfMemoryOpen);
 begin
 begin
   FDbfFile := TDbfFile.Create;
   FDbfFile := TDbfFile.Create;
   if FStorage = stoMemory then
   if FStorage = stoMemory then
   begin
   begin
     FDbfFile.Stream := FUserStream;
     FDbfFile.Stream := FUserStream;
-    FDbfFile.Mode := pfMemoryOpen;
+    FDbfFile.Mode := FileModeToMemMode[FileOpenMode];
   end else begin
   end else begin
     FDbfFile.FileName := FAbsolutePath + FTableName;
     FDbfFile.FileName := FAbsolutePath + FTableName;
     FDbfFile.Mode := FileOpenMode;
     FDbfFile.Mode := FileOpenMode;
@@ -1051,8 +1066,9 @@ var
   pRecord: pDbfRecord;
   pRecord: pDbfRecord;
 begin
 begin
   pRecord := pDbfRecord(Buffer);
   pRecord := pDbfRecord(Buffer);
-  pRecord.BookmarkData{.IndexBookmark} := 0;
+  pRecord.BookmarkData.PhysicalRecNo := 0;
   pRecord.BookmarkFlag := bfCurrent;
   pRecord.BookmarkFlag := bfCurrent;
+  pRecord.SequentialRecNo := 0;
 // Init Record with zero and set autoinc field with next value
 // Init Record with zero and set autoinc field with next value
   FDbfFile.InitRecord(@pRecord.DeletedFlag);
   FDbfFile.InitRecord(@pRecord.DeletedFlag);
 end;
 end;
@@ -1201,18 +1217,12 @@ begin
     FDbfFile.OpenIndex(lIndexName, lIndex.SortField, false, lIndex.Options);
     FDbfFile.OpenIndex(lIndexName, lIndex.SortField, false, lIndex.Options);
   end;
   end;
 
 
-  // parse filter
-  if Length(Filter) > 0 then
-  begin
-    // create parser
-    FParser := TDbfParser.Create(FDbfFile);
-    // parse expression
-    try
-      FParser.ParseExpression(Filter);
-    except
-      // oops, a problem with parsing, clear filter for now
-      on E: EDbfError do Filter := EmptyStr;
-    end;
+  // parse filter expression
+  try
+    ParseFilter(Filter);
+  except
+    // oops, a problem with parsing, clear filter for now
+    on E: EDbfError do Filter := EmptyStr;
   end;
   end;
 
 
   SetIndexName(FIndexName);
   SetIndexName(FIndexName);
@@ -1242,11 +1252,13 @@ end;
 
 
 function TDbf.LockTable(const Wait: Boolean): Boolean;
 function TDbf.LockTable(const Wait: Boolean): Boolean;
 begin
 begin
+  CheckActive;
   Result := FDbfFile.LockAllPages(Wait);
   Result := FDbfFile.LockAllPages(Wait);
 end;
 end;
 
 
 procedure TDbf.UnlockTable;
 procedure TDbf.UnlockTable;
 begin
 begin
+  CheckActive;
   FDbfFile.UnlockAllPages;
   FDbfFile.UnlockAllPages;
 end;
 end;
 
 
@@ -1370,6 +1382,8 @@ begin
       if tempFieldDefs then
       if tempFieldDefs then
       begin
       begin
         DbfFieldDefs := TDbfFieldDefs.Create(Self);
         DbfFieldDefs := TDbfFieldDefs.Create(Self);
+        DbfFieldDefs.DbfVersion := TableLevelToDbfVersion(FTableLevel);
+        DbfFieldDefs.UseFloatFields := FUseFloatFields;
 
 
         // get fields -> fielddefs if no fielddefs
         // get fields -> fielddefs if no fielddefs
 {$ifndef FPC_VERSION}
 {$ifndef FPC_VERSION}
@@ -1397,17 +1411,15 @@ begin
 
 
       InitDbfFile(pfExclusiveCreate);
       InitDbfFile(pfExclusiveCreate);
       FDbfFile.CopyDateTimeAsString := FInCopyFrom and FCopyDateTimeAsString;
       FDbfFile.CopyDateTimeAsString := FInCopyFrom and FCopyDateTimeAsString;
-      case FTableLevel of
-        3:                      FDbfFile.DbfVersion := xBaseIII;
-        7:                      FDbfFile.DbfVersion := xBaseVII;
-        TDBF_TABLELEVEL_FOXPRO: FDbfFile.DbfVersion := xFoxPro;
-      else
-        {4:} FDbfFile.DbfVersion := xBaseIV;
-      end;
+      FDbfFile.DbfVersion := TableLevelToDbfVersion(FTableLevel);
       FDbfFile.FileLangID := FLanguageID;
       FDbfFile.FileLangID := FLanguageID;
       FDbfFile.Open;
       FDbfFile.Open;
       FDbfFile.FinishCreate(DbfFieldDefs, 512);
       FDbfFile.FinishCreate(DbfFieldDefs, 512);
 
 
+      // if creating memory table, copy stream pointer
+      if FStorage = stoMemory then
+        FUserStream := FDbfFile.Stream;
+
       // create all indexes
       // create all indexes
       for I := 0 to FIndexDefs.Count-1 do
       for I := 0 to FIndexDefs.Count-1 do
       begin
       begin
@@ -1417,7 +1429,7 @@ begin
       end;
       end;
     except
     except
       // dbf file created?
       // dbf file created?
-      if FDbfFile <> nil then
+      if (FDbfFile <> nil) and (FStorage = stoFile) then
       begin
       begin
         FreeAndNil(FDbfFile);
         FreeAndNil(FDbfFile);
         SysUtils.DeleteFile(FAbsolutePath+FTableName);
         SysUtils.DeleteFile(FAbsolutePath+FTableName);
@@ -1549,6 +1561,7 @@ begin
     FFindRecordFilter := false;
     FFindRecordFilter := false;
     if not Result then
     if not Result then
       RecNo := oldRecNo;
       RecNo := oldRecNo;
+    CursorPosChanged;
     Resync([]);
     Resync([]);
   end;
   end;
 end;
 end;
@@ -1783,7 +1796,11 @@ begin
   // check if in editing mode if user wants to write
   // check if in editing mode if user wants to write
   if (Mode = bmWrite) or (Mode = bmReadWrite) then
   if (Mode = bmWrite) or (Mode = bmReadWrite) then
     if not (State in [dsEdit, dsInsert]) then
     if not (State in [dsEdit, dsInsert]) then
+{$ifdef DELPHI_3}    
+      DatabaseError(SNotEditing);
+{$else}    
       DatabaseError(SNotEditing, Self);
       DatabaseError(SNotEditing, Self);
+{$endif}      
   // already created a `placeholder' blob for this field?
   // already created a `placeholder' blob for this field?
   MemoFieldNo := Field.FieldNo - 1;
   MemoFieldNo := Field.FieldNo - 1;
   if FBlobStreams[MemoFieldNo] = nil then
   if FBlobStreams[MemoFieldNo] = nil then
@@ -1896,11 +1913,11 @@ begin
   if Buffer <> nil then
   if Buffer <> nil then
   begin
   begin
     pRecord := pDbfRecord(Buffer);
     pRecord := pDbfRecord(Buffer);
-    if pRecord.BookMarkFlag = bfInserted then
+    if pRecord.BookmarkFlag = bfInserted then
     begin
     begin
       // do what ???
       // do what ???
     end else begin
     end else begin
-      FCursor.GotoBookmark(pRecord.BookmarkData);
+      FCursor.SequentialRecNo := pRecord.SequentialRecNo;
     end;
     end;
   end;
   end;
 end;
 end;
@@ -1916,19 +1933,13 @@ begin
 end;
 end;
 
 
 procedure TDbf.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); {override virtual abstract from TDataset}
 procedure TDbf.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); {override virtual abstract from TDataset}
-var
-  pRecord: pDbfRecord;
 begin
 begin
-  pRecord := pDbfRecord(Buffer);
-  pRecord.BookMarkFlag := Value;
+  pDbfRecord(Buffer)^.BookmarkFlag := Value;
 end;
 end;
 
 
 procedure TDbf.SetBookmarkData(Buffer: PChar; Data: Pointer); {override virtual abstract from TDataset}
 procedure TDbf.SetBookmarkData(Buffer: PChar; Data: Pointer); {override virtual abstract from TDataset}
-var
-  pRecord: pDbfRecord;
 begin
 begin
-  pRecord := pDbfRecord(Buffer);
-  pRecord.BookMarkData := pBookMarkData(Data)^;
+  pDbfRecord(Buffer)^.BookmarkData := pBookmarkData(Data)^;
 end;
 end;
 
 
 procedure TDbf.SetFieldData(Field: TField; Buffer: Pointer); {override virtual abstract from TDataset}
 procedure TDbf.SetFieldData(Field: TField; Buffer: Pointer); {override virtual abstract from TDataset}
@@ -2008,15 +2019,27 @@ end;
 // this function is just for the grid scrollbars
 // this function is just for the grid scrollbars
 // it doesn't have to be perfectly accurate, but fast.
 // it doesn't have to be perfectly accurate, but fast.
 function TDbf.GetRecNo: Integer; {override virtual}
 function TDbf.GetRecNo: Integer; {override virtual}
+var
+  pBuffer: pointer;
 begin
 begin
-  UpdateCursorPos;
-  Result := FCursor.SequentialRecNo;
+  if State = dsCalcFields then
+    pBuffer := CalcBuffer
+  else
+    pBuffer := ActiveBuffer;
+  Result := pDbfRecord(pBuffer)^.SequentialRecNo;
 end;
 end;
 
 
-procedure TDbf.SetRecNo(Value: Integer); {override virual}
+procedure TDbf.SetRecNo(Value: Integer); {override virtual}
 begin
 begin
+  CheckBrowseMode;
+  if Value = RecNo then
+    exit;
+
+  DoBeforeScroll;
   FCursor.SequentialRecNo := Value;
   FCursor.SequentialRecNo := Value;
+  CursorPosChanged;
   Resync([]);
   Resync([]);
+  DoAfterScroll;
 end;
 end;
 
 
 function TDbf.GetCanModify: Boolean; {override;}
 function TDbf.GetCanModify: Boolean; {override;}
@@ -2036,10 +2059,10 @@ end;
 
 
 {$endif}
 {$endif}
 
 
-procedure TDbf.SetFilterText(const Value: String);
+procedure TDbf.ParseFilter(const AFilter: string);
 begin
 begin
   // parser created?
   // parser created?
-  if Length(Value) > 0 then
+  if Length(AFilter) > 0 then
   begin
   begin
     if (FParser = nil) and (FDbfFile <> nil) then
     if (FParser = nil) and (FDbfFile <> nil) then
     begin
     begin
@@ -2051,11 +2074,21 @@ begin
     if FParser <> nil then
     if FParser <> nil then
     begin
     begin
       // set options
       // set options
+      FParser.PartialMatch := not (foNoPartialCompare in FilterOptions);
       FParser.CaseInsensitive := foCaseInsensitive in FilterOptions;
       FParser.CaseInsensitive := foCaseInsensitive in FilterOptions;
       // parse expression
       // parse expression
-      FParser.ParseExpression(Value);
+      FParser.ParseExpression(AFilter);
     end;
     end;
   end;
   end;
+end;
+
+procedure TDbf.SetFilterText(const Value: String);
+begin
+  if Value = Filter then
+    exit;
+
+  // parse
+  ParseFilter(Value);
 
 
   // call dataset method
   // call dataset method
   inherited;
   inherited;
@@ -2066,6 +2099,9 @@ end;
 
 
 procedure TDbf.SetFiltered(Value: Boolean); {override;}
 procedure TDbf.SetFiltered(Value: Boolean); {override;}
 begin
 begin
+  if Value = Filtered then
+    exit;
+
   // pass on to ancestor
   // pass on to ancestor
   inherited;
   inherited;
 
 
@@ -2270,7 +2306,6 @@ begin
   lIndexFileName := ParseIndexName(AIndexName);
   lIndexFileName := ParseIndexName(AIndexName);
   // try to delete index
   // try to delete index
   FDbfFile.DeleteIndex(lIndexFileName);
   FDbfFile.DeleteIndex(lIndexFileName);
-//    raise EDbfError.CreateFmt(STRING_INDEX_NOT_EXIST, [AIndexName]);
 
 
   // refresh index defs
   // refresh index defs
   InternalInitFieldDefs;
   InternalInitFieldDefs;
@@ -2377,28 +2412,30 @@ begin
 end;
 end;
 
 
 function TDbf.GetPhysicalRecNo: Integer;
 function TDbf.GetPhysicalRecNo: Integer;
+var
+  pBuffer: pointer;
 begin
 begin
   // check if active, test state: if inserting, then -1
   // check if active, test state: if inserting, then -1
   if (FCursor <> nil) and (State <> dsInsert) then
   if (FCursor <> nil) and (State <> dsInsert) then
   begin
   begin
-    UpdateCursorPos;
-    Result := FCursor.PhysicalRecNo;
+    if State = dsCalcFields then
+      pBuffer := CalcBuffer
+    else
+      pBuffer := ActiveBuffer;
+    Result := pDbfRecord(pBuffer)^.BookmarkData.PhysicalRecNo;
   end else
   end else
     Result := -1;
     Result := -1;
 end;
 end;
 
 
 procedure TDbf.SetPhysicalRecNo(const NewRecNo: Integer);
 procedure TDbf.SetPhysicalRecNo(const NewRecNo: Integer);
 begin
 begin
-  // active?
-  if FCursor <> nil then
-  begin
-    // editing?
-    CheckBrowseMode;
-    // set recno
-    FCursor.PhysicalRecNo := NewRecNo;
-    // refresh data controls
-    Resync([]);
-  end;
+  // editing?
+  CheckBrowseMode;
+  DoBeforeScroll;
+  FCursor.PhysicalRecNo := NewRecNo;
+  CursorPosChanged;
+  Resync([]);
+  DoAfterScroll;
 end;
 end;
 
 
 function TDbf.GetDbfFieldDefs: TDbfFieldDefs;
 function TDbf.GetDbfFieldDefs: TDbfFieldDefs;
@@ -2454,48 +2491,17 @@ begin
     exit;
     exit;
 
 
   // disable current range if any
   // disable current range if any
-  TIndexCursor(FCursor).CancelRange;
-  // refresh
-  Refresh;
+  FIndexFile.CancelRange;
+  // reretrieve previous and next records
+  Resync([]);
 end;
 end;
 
 
 procedure TDbf.SetRangeBuffer(LowRange: PChar; HighRange: PChar);
 procedure TDbf.SetRangeBuffer(LowRange: PChar; HighRange: PChar);
-var
-  Result: Boolean;
 begin
 begin
   if FIndexFile = nil then
   if FIndexFile = nil then
     exit;
     exit;
 
 
-  // disable current range if any
-  TIndexCursor(FCursor).CancelRange;
-  // search lower bound
-  Result := TIndexCursor(FCursor).SearchKey(LowRange, stGreaterEqual);
-  if not Result then
-  begin
-    // not found? -> make empty range
-    FCursor.Last;
-  end;
-  // set lower bound
-  TIndexCursor(FCursor).SetBracketLow;
-  // search upper bound
-  Result := TIndexCursor(FCursor).SearchKey(HighRange, stGreater);
-  // if result true, then need to get previous item <=>
-  //    last of equal/lower than key
-  if Result then
-  begin
-    Result := FCursor.Prev;
-    if not Result then
-    begin
-      // cannot go prev -> empty range
-      FCursor.First;
-    end;
-  end else begin
-    // not found -> EOF found, go EOF, then to last record
-    FCursor.Last;
-    FCursor.Prev;
-  end;
-  // set upper bound
-  TIndexCursor(FCursor).SetBracketHigh;
+  FIndexFile.SetRange(LowRange, HighRange);
   // go to first in this range
   // go to first in this range
   if Active then
   if Active then
     inherited First;
     inherited First;
@@ -2534,8 +2540,8 @@ end;
 
 
 procedure TDbf.ExtractKey(KeyBuffer: PChar);
 procedure TDbf.ExtractKey(KeyBuffer: PChar);
 begin
 begin
-  if FCursor is TIndexCursor then
-    StrCopy(TIndexCursor(FCursor).IndexFile.ExtractKeyFromBuffer(GetCurrentBuffer), KeyBuffer)
+  if FIndexFile <> nil then
+    StrCopy(FIndexFile.ExtractKeyFromBuffer(GetCurrentBuffer), KeyBuffer)
   else
   else
     KeyBuffer[0] := #0;
     KeyBuffer[0] := #0;
 end;
 end;
@@ -2567,6 +2573,17 @@ end;
 
 
 {$endif}
 {$endif}
 
 
+function  TDbf.PrepareKey(Buffer: Pointer; BufferType: TExpressionType): PChar;
+begin
+  if FIndexFile = nil then
+  begin
+    Result := nil;
+    exit;
+  end;
+  
+  Result := TIndexCursor(FCursor).IndexFile.PrepareKey(Buffer, BufferType);
+end;
+
 function TDbf.SearchKeyPChar(Key: PChar; SearchType: TSearchKeyType): Boolean;
 function TDbf.SearchKeyPChar(Key: PChar; SearchType: TSearchKeyType): Boolean;
 var
 var
   StringBuf: array [0..100] of Char;
   StringBuf: array [0..100] of Char;
@@ -2591,14 +2608,15 @@ begin
   end;
   end;
 
 
   CheckBrowseMode;
   CheckBrowseMode;
-  Result := TIndexCursor(FCursor).SearchKey(Buffer, SearchType);
+  Result := FIndexFile.SearchKey(Buffer, SearchType);
   { if found, then retrieve new current record }
   { if found, then retrieve new current record }
   if Result then
   if Result then
   begin
   begin
+    CursorPosChanged;
     Resync([]);
     Resync([]);
     UpdateCursorPos;
     UpdateCursorPos;
     { recno could have been changed due to deleted record, check if still matches }
     { recno could have been changed due to deleted record, check if still matches }
-    matchRes := TIndexCursor(FCursor).IndexFile.MatchKey;
+    matchRes := TIndexCursor(FCursor).IndexFile.MatchKey(Buffer);
     case SearchType of
     case SearchType of
       stEqual:        Result := matchRes =  0;
       stEqual:        Result := matchRes =  0;
       stGreater:      Result := (not Eof) and (matchRes <  0);
       stGreater:      Result := (not Eof) and (matchRes <  0);
@@ -2639,7 +2657,7 @@ begin
   fieldsVal := TIndexCursor(FCursor).IndexFile.PrepareKey(fieldsVal, FMasterLink.Parser.ResultType);
   fieldsVal := TIndexCursor(FCursor).IndexFile.PrepareKey(fieldsVal, FMasterLink.Parser.ResultType);
   SetRangeBuffer(fieldsVal, fieldsVal);
   SetRangeBuffer(fieldsVal, fieldsVal);
 end;
 end;
-
+    
 procedure TDbf.MasterChanged(Sender: TObject);
 procedure TDbf.MasterChanged(Sender: TObject);
 begin
 begin
   CheckBrowseMode;
   CheckBrowseMode;

+ 423 - 425
fcl/db/dbase/Dbf_Avl.pas → fcl/db/dbase/dbf_avl.pas

@@ -1,425 +1,423 @@
-unit Dbf_Avl;
-
-{fix CR/LF}
-
-interface
-
-type
-  TBal = -1..1;
-
-  TAvlTree = class;
-
-  TKeyType = Cardinal;
-  TExtraData = Pointer;
-
-  PData = ^TData;
-  TData = record
-    ID: TKeyType;
-    ExtraData: TExtraData;
-  end;
-
-  PNode = ^TNode;
-  TNode = record
-    Data: TData;
-    Left: PNode;
-    Right: PNode;
-    Bal: TBal;    // balance factor: h(Right) - h(Left)
-  end;
-
-  TAvlTreeEvent = procedure(Sender: TAvlTree; Data: PData) of object;
-
-  TAvlTree = class(TObject)
-  private
-    FRoot: PNode;
-    FCount: Cardinal;
-    FOnDelete: TAvlTreeEvent;
-    FHeightChange: Boolean;
-
-    procedure InternalInsert(X: PNode; var P: PNode);
-    procedure InternalDelete(X: TKeyType; var P: PNode);
-
-    procedure DeleteNode(X: PNode);
-    procedure TreeDispose(X: PNode);
-  public
-    constructor Create;
-    destructor Destroy; override;
-
-    procedure Clear;
-    function  Find(Key: TKeyType): TExtraData;
-    procedure Insert(Key: TKeyType; Extra: TExtraData);
-    procedure Delete(Key: TKeyType);
-
-    function  Lowest: PData;
-
-    property Count: Cardinal read FCount;
-    property OnDelete: TAvlTreeEvent read FOnDelete write FOnDelete;
-  end;
-
-
-implementation
-
-uses
-    Math;
-
-procedure RotL(var P: PNode);
-var
-  P1: PNode;
-begin
-  P1 := P^.Right;
-  P^.Right := P1^.Left;
-  P1^.Left := P;
-  P := P1;
-end;
-
-procedure RotR(var P: PNode);
-var
-  P1: PNode;
-begin
-  P1 := P^.Left;
-  P^.Left := P1^.Right;
-  P1^.Right := P;
-  P := P1;
-end;
-
-function  Height(X: PNode): Integer;
-begin
-  if X = nil then
-    Result := 0
-  else
-    Result := 1+Max(Height(X^.Left), Height(X^.Right));
-end;
-
-function  CheckTree_T(X: PNode; var H: Integer): Boolean;
-var
-  HR: Integer;
-begin
-  if X = nil then
-  begin
-    Result := true;
-    H := 0;
-  end else begin
-    Result := CheckTree_T(X^.Left, H) and CheckTree_T(X^.Right, HR) and
-        ((X^.Left = nil) or (X^.Left^.Data.ID < X^.Data.ID)) and
-        ((X^.Right = nil) or (X^.Right^.Data.ID > X^.Data.ID)) and
-//      ((Height(X^.Right) - Height(X^.Left)) = X^.Bal);
-        (HR - H = X^.Bal);
-    H := 1 + Max(H, HR);
-  end;
-end;
-
-function  CheckTree(X: PNode): Boolean;
-var
-  H: Integer;
-begin
-  Result := CheckTree_T(X, H);
-end;
-
-procedure BalanceLeft(var P: PNode; var HeightChange: Boolean);
-var
-  B1, B2: TBal;
-{HeightChange = true, left branch has become less high}
-begin
-  case P^.Bal of
-   -1: begin P^.Bal := 0 end;
-    0: begin P^.Bal := 1; HeightChange := false end;
-    1: begin {Rebalance}
-         B1 := P^.Right^.Bal;
-         if B1 >= 0
-         then {single L rotation}
-           begin
-             RotL(P);
-             //adjust balance factors:
-             if B1 = 0
-             then
-               begin P^.Bal :=-1; P^.Left^.Bal := 1; HeightChange := false end
-             else
-               begin P^.Bal := 0; P^.Left^.Bal := 0 end;
-           end
-         else {double RL rotation}
-           begin
-             B2 := P^.Right^.Left^.Bal;
-             RotR(P^.Right);
-             RotL(P);
-             //adjust balance factors:
-             if B2=+1 then P^.Left^.Bal := -1 else P^.Left^.Bal := 0;
-             if B2=-1 then P^.Right^.Bal := 1 else P^.Right^.Bal := 0;
-             P^.Bal := 0;
-           end;
-       end;{1}
-  end{case}
-end;{BalanceLeft}
-
-procedure BalanceRight(var P: PNode; var HeightChange: Boolean);
-var
-  B1, B2: TBal;
-{HeightChange = true, right branch has become less high}
-begin
-  case P^.Bal of
-    1: begin P^.Bal := 0 end;
-    0: begin P^.Bal := -1; HeightChange := false end;
-   -1: begin {Rebalance}
-         B1 := P^.Left^.Bal;
-         if B1 <= 0
-         then {single R rotation}
-           begin
-             RotR(P);
-             //adjust balance factors}
-             if B1 = 0
-             then
-               begin P^.Bal :=1; P^.Right^.Bal :=-1; HeightChange:= false end
-             else
-               begin P^.Bal := 0; P^.Right^.Bal := 0 end;
-           end
-         else {double LR rotation}
-           begin
-             B2 := P^.Left^.Right^.Bal;
-             RotL(P^.Left);
-             RotR(P);
-             //adjust balance factors
-             if B2=-1 then P^.Right^.Bal := 1 else P^.Right^.Bal := 0;
-             if B2= 1 then P^.Left^.Bal := -1 else P^.Left^.Bal := 0;
-             P^.Bal := 0;
-           end;
-       end;{-1}
-  end{case}
-end;{BalanceRight}
-
-procedure DelRM(var R: PNode; var S: PNode; var HeightChange: Boolean);
-// Make S refer to rightmost element of tree with root R;
-// Remove that element from the tree
-begin
-  if R^.Right = nil then
-    begin S := R; R := R^.Left; HeightChange := true end
-  else
-    begin
-      DelRM(R^.Right, S, HeightChange);
-      if HeightChange then BalanceRight(R, HeightChange)
-    end
-end;
-
-//---------------------------------------
-//---****--- Class TAvlTree ---*****-----
-//---------------------------------------
-
-constructor TAvlTree.Create;
-begin
-  inherited;
-
-  FRoot := nil;
-end;
-
-destructor TAvlTree.Destroy;
-begin
-  Clear;
-
-  inherited;
-end;
-
-procedure TAvlTree.Clear;
-begin
-  TreeDispose(FRoot);
-  FRoot := nil;
-end;
-
-procedure TAvlTree.DeleteNode(X: PNode);
-begin
-  // delete handler installed?
-  if Assigned(FOnDelete) then
-    FOnDelete(Self, @X^.Data);
-
-  // dispose of memory
-  Dispose(X);
-  Dec(FCount);
-end;
-
-procedure TAvlTree.TreeDispose(X: PNode);
-var
-  P: PNode;
-begin
-  // nothing to dispose of?
-  if X = nil then
-    exit;
-
-  // use in-order visiting, maybe someone likes sequential ordering
-  TreeDispose(X^.Left);
-  P := X^.Right;
-
-  // free mem
-  DeleteNode(X);
-
-  // free right child
-  TreeDispose(P);
-end;
-
-function TAvlTree.Find(Key: TKeyType): TExtraData;
-var
-  H: PNode;
-begin
-  H := FRoot;
-  while (H <> nil) and (H^.Data.ID <> Key) do // use conditional and
-    if Key < H^.Data.ID then
-      H := H^.Left
-    else
-      H := H^.Right;
-
-  if H <> nil then
-    Result := H^.Data.ExtraData
-  else
-    Result := nil;
-end;
-
-procedure TAvlTree.Insert(Key: TKeyType; Extra: TExtraData);
-var
-  H: PNode;
-begin
-  // make new node
-  New(H);
-  with H^ do
-  begin
-    Data.ID := Key;
-    Data.ExtraData := Extra;
-    Left := nil;
-    Right := nil;
-    Bal := 0;
-  end;
-  // insert new node
-  InternalInsert(H, FRoot);
-  // check tree
-//  assert(CheckTree(FRoot));
-end;
-
-procedure TAvlTree.Delete(Key: TKeyType);
-begin
-  InternalDelete(Key, FRoot);
-//  assert(CheckTree(FRoot));
-end;
-
-procedure TAvlTree.InternalInsert(X: PNode; var P: PNode);
-begin
-  if P = nil
-  then begin P := X; Inc(FCount); FHeightChange := true end
-  else
-    if X^.Data.ID < P^.Data.ID then
-    begin
-      { less }
-      InternalInsert(X, P^.Left);
-      if FHeightChange then {Left branch has grown higher}
-        case P^.Bal of
-          1: begin P^.Bal := 0; FHeightChange := false end;
-          0: begin P^.Bal := -1 end;
-         -1: begin {Rebalance}
-               if P^.Left^.Bal = -1
-               then {single R rotation}
-                 begin
-                   RotR(P);
-                   //adjust balance factor:
-                   P^.Right^.Bal := 0;
-                 end
-               else {double LR rotation}
-                 begin
-                   RotL(P^.Left);
-                   RotR(P);
-                   //adjust balance factor:
-                   case P^.Bal of
-                     -1: begin P^.Left^.Bal :=  0; P^.Right^.Bal := 1 end;
-                      0: begin P^.Left^.Bal :=  0; P^.Right^.Bal := 0 end;
-                      1: begin P^.Left^.Bal := -1; P^.Right^.Bal := 0 end;
-                   end;
-                 end;
-               P^.Bal := 0;
-               FHeightChange := false;
-//               assert(CheckTree(P));
-             end{-1}
-        end{case}
-    end else
-    if X^.Data.ID > P^.Data.ID then
-    begin
-      { greater }
-      InternalInsert(X, P^.Right);
-      if FHeightChange then {Right branch has grown higher}
-        case P^.Bal of
-          -1: begin P^.Bal := 0; FHeightChange := false end;
-           0: begin P^.Bal := 1 end;
-           1: begin {Rebalance}
-                if P^.Right^.Bal = 1
-                then {single L rotation}
-                  begin
-                    RotL(P);
-                    //adjust balance factor:
-                    P^.Left.Bal := 0;
-                  end
-                else {double RL rotation}
-                  begin
-                    RotR(P^.Right);
-                    RotL(P);
-                    //adjust balance factor
-                    case P^.Bal of
-                       1: begin P^.Right^.Bal := 0; P^.Left^.Bal := -1 end;
-                       0: begin P^.Right^.Bal := 0; P^.Left^.Bal :=  0 end;
-                      -1: begin P^.Right^.Bal := 1; P^.Left^.Bal :=  0 end;
-                    end;
-                  end;
-                P^.Bal := 0;
-                FHeightChange := false;
-//                assert(CheckTree(P));
-              end{1}
-         end{case}
-    end {greater} else begin
-      {X already present; do not insert again}
-      FHeightChange := false;
-    end;
-
-//  assert(CheckTree(P));
-end;{InternalInsert}
-
-procedure TAvlTree.InternalDelete(X: TKeyType; var P: PNode);
-var
-  Q: PNode;
-  H: TData;
-begin
-  if P = nil then
-    FHeightChange := false
-  else
-    if X < P^.Data.ID then
-    begin
-      InternalDelete(X, P^.Left);
-      if FHeightChange then BalanceLeft(P, FHeightChange)
-    end else
-    if X > P^.Data.ID then
-    begin
-      InternalDelete(X, P^.Right);
-      if FHeightChange then BalanceRight(P, FHeightChange)
-    end else begin
-      if P^.Right = nil then
-      begin Q := P; P := P^.Left; FHeightChange := true end
-      else if P^.Left = nil then
-      begin Q := P; P := P^.Right; FHeightChange := true end
-      else
-        begin
-          DelRM(P^.Left, Q, FHeightChange);
-          H := P^.Data;
-          P^.Data := Q^.Data;
-          Q^.Data := H;
-          if FHeightChange then BalanceLeft(P, FHeightChange)
-        end;
-      DeleteNode(Q)
-    end;{eq}
-end;{InternalDelete}
-
-function TAvlTree.Lowest: PData;
-var
-  H: PNode;
-begin
-  H := FRoot;
-  if H = nil then
-  begin
-    Result := nil;
-    exit;
-  end;
-
-  while H^.Left <> nil do
-    H := H^.Left;
-  Result := @H^.Data;
-end;
-
-end.
+unit dbf_avl;
+
+interface
+
+type
+  TBal = -1..1;
+
+  TAvlTree = class;
+
+  TKeyType = Cardinal;
+  TExtraData = Pointer;
+
+  PData = ^TData;
+  TData = record
+    ID: TKeyType;
+    ExtraData: TExtraData;
+  end;
+
+  PNode = ^TNode;
+  TNode = record
+    Data: TData;
+    Left: PNode;
+    Right: PNode;
+    Bal: TBal;    // balance factor: h(Right) - h(Left)
+  end;
+
+  TAvlTreeEvent = procedure(Sender: TAvlTree; Data: PData) of object;
+
+  TAvlTree = class(TObject)
+  private
+    FRoot: PNode;
+    FCount: Cardinal;
+    FOnDelete: TAvlTreeEvent;
+    FHeightChange: Boolean;
+
+    procedure InternalInsert(X: PNode; var P: PNode);
+    procedure InternalDelete(X: TKeyType; var P: PNode);
+
+    procedure DeleteNode(X: PNode);
+    procedure TreeDispose(X: PNode);
+  public
+    constructor Create;
+    destructor Destroy; override;
+
+    procedure Clear;
+    function  Find(Key: TKeyType): TExtraData;
+    procedure Insert(Key: TKeyType; Extra: TExtraData);
+    procedure Delete(Key: TKeyType);
+
+    function  Lowest: PData;
+
+    property Count: Cardinal read FCount;
+    property OnDelete: TAvlTreeEvent read FOnDelete write FOnDelete;
+  end;
+
+
+implementation
+
+uses
+    Math;
+
+procedure RotL(var P: PNode);
+var
+  P1: PNode;
+begin
+  P1 := P^.Right;
+  P^.Right := P1^.Left;
+  P1^.Left := P;
+  P := P1;
+end;
+
+procedure RotR(var P: PNode);
+var
+  P1: PNode;
+begin
+  P1 := P^.Left;
+  P^.Left := P1^.Right;
+  P1^.Right := P;
+  P := P1;
+end;
+
+function  Height(X: PNode): Integer;
+begin
+  if X = nil then
+    Result := 0
+  else
+    Result := 1+Max(Height(X^.Left), Height(X^.Right));
+end;
+
+function  CheckTree_T(X: PNode; var H: Integer): Boolean;
+var
+  HR: Integer;
+begin
+  if X = nil then
+  begin
+    Result := true;
+    H := 0;
+  end else begin
+    Result := CheckTree_T(X^.Left, H) and CheckTree_T(X^.Right, HR) and
+        ((X^.Left = nil) or (X^.Left^.Data.ID < X^.Data.ID)) and
+        ((X^.Right = nil) or (X^.Right^.Data.ID > X^.Data.ID)) and
+//      ((Height(X^.Right) - Height(X^.Left)) = X^.Bal);
+        (HR - H = X^.Bal);
+    H := 1 + Max(H, HR);
+  end;
+end;
+
+function  CheckTree(X: PNode): Boolean;
+var
+  H: Integer;
+begin
+  Result := CheckTree_T(X, H);
+end;
+
+procedure BalanceLeft(var P: PNode; var HeightChange: Boolean);
+var
+  B1, B2: TBal;
+{HeightChange = true, left branch has become less high}
+begin
+  case P^.Bal of
+   -1: begin P^.Bal := 0 end;
+    0: begin P^.Bal := 1; HeightChange := false end;
+    1: begin {Rebalance}
+         B1 := P^.Right^.Bal;
+         if B1 >= 0
+         then {single L rotation}
+           begin
+             RotL(P);
+             //adjust balance factors:
+             if B1 = 0
+             then
+               begin P^.Bal :=-1; P^.Left^.Bal := 1; HeightChange := false end
+             else
+               begin P^.Bal := 0; P^.Left^.Bal := 0 end;
+           end
+         else {double RL rotation}
+           begin
+             B2 := P^.Right^.Left^.Bal;
+             RotR(P^.Right);
+             RotL(P);
+             //adjust balance factors:
+             if B2=+1 then P^.Left^.Bal := -1 else P^.Left^.Bal := 0;
+             if B2=-1 then P^.Right^.Bal := 1 else P^.Right^.Bal := 0;
+             P^.Bal := 0;
+           end;
+       end;{1}
+  end{case}
+end;{BalanceLeft}
+
+procedure BalanceRight(var P: PNode; var HeightChange: Boolean);
+var
+  B1, B2: TBal;
+{HeightChange = true, right branch has become less high}
+begin
+  case P^.Bal of
+    1: begin P^.Bal := 0 end;
+    0: begin P^.Bal := -1; HeightChange := false end;
+   -1: begin {Rebalance}
+         B1 := P^.Left^.Bal;
+         if B1 <= 0
+         then {single R rotation}
+           begin
+             RotR(P);
+             //adjust balance factors}
+             if B1 = 0
+             then
+               begin P^.Bal :=1; P^.Right^.Bal :=-1; HeightChange:= false end
+             else
+               begin P^.Bal := 0; P^.Right^.Bal := 0 end;
+           end
+         else {double LR rotation}
+           begin
+             B2 := P^.Left^.Right^.Bal;
+             RotL(P^.Left);
+             RotR(P);
+             //adjust balance factors
+             if B2=-1 then P^.Right^.Bal := 1 else P^.Right^.Bal := 0;
+             if B2= 1 then P^.Left^.Bal := -1 else P^.Left^.Bal := 0;
+             P^.Bal := 0;
+           end;
+       end;{-1}
+  end{case}
+end;{BalanceRight}
+
+procedure DelRM(var R: PNode; var S: PNode; var HeightChange: Boolean);
+// Make S refer to rightmost element of tree with root R;
+// Remove that element from the tree
+begin
+  if R^.Right = nil then
+    begin S := R; R := R^.Left; HeightChange := true end
+  else
+    begin
+      DelRM(R^.Right, S, HeightChange);
+      if HeightChange then BalanceRight(R, HeightChange)
+    end
+end;
+
+//---------------------------------------
+//---****--- Class TAvlTree ---*****-----
+//---------------------------------------
+
+constructor TAvlTree.Create;
+begin
+  inherited;
+
+  FRoot := nil;
+end;
+
+destructor TAvlTree.Destroy;
+begin
+  Clear;
+
+  inherited;
+end;
+
+procedure TAvlTree.Clear;
+begin
+  TreeDispose(FRoot);
+  FRoot := nil;
+end;
+
+procedure TAvlTree.DeleteNode(X: PNode);
+begin
+  // delete handler installed?
+  if Assigned(FOnDelete) then
+    FOnDelete(Self, @X^.Data);
+
+  // dispose of memory
+  Dispose(X);
+  Dec(FCount);
+end;
+
+procedure TAvlTree.TreeDispose(X: PNode);
+var
+  P: PNode;
+begin
+  // nothing to dispose of?
+  if X = nil then
+    exit;
+
+  // use in-order visiting, maybe someone likes sequential ordering
+  TreeDispose(X^.Left);
+  P := X^.Right;
+
+  // free mem
+  DeleteNode(X);
+
+  // free right child
+  TreeDispose(P);
+end;
+
+function TAvlTree.Find(Key: TKeyType): TExtraData;
+var
+  H: PNode;
+begin
+  H := FRoot;
+  while (H <> nil) and (H^.Data.ID <> Key) do // use conditional and
+    if Key < H^.Data.ID then
+      H := H^.Left
+    else
+      H := H^.Right;
+
+  if H <> nil then
+    Result := H^.Data.ExtraData
+  else
+    Result := nil;
+end;
+
+procedure TAvlTree.Insert(Key: TKeyType; Extra: TExtraData);
+var
+  H: PNode;
+begin
+  // make new node
+  New(H);
+  with H^ do
+  begin
+    Data.ID := Key;
+    Data.ExtraData := Extra;
+    Left := nil;
+    Right := nil;
+    Bal := 0;
+  end;
+  // insert new node
+  InternalInsert(H, FRoot);
+  // check tree
+//  assert(CheckTree(FRoot));
+end;
+
+procedure TAvlTree.Delete(Key: TKeyType);
+begin
+  InternalDelete(Key, FRoot);
+//  assert(CheckTree(FRoot));
+end;
+
+procedure TAvlTree.InternalInsert(X: PNode; var P: PNode);
+begin
+  if P = nil
+  then begin P := X; Inc(FCount); FHeightChange := true end
+  else
+    if X^.Data.ID < P^.Data.ID then
+    begin
+      { less }
+      InternalInsert(X, P^.Left);
+      if FHeightChange then {Left branch has grown higher}
+        case P^.Bal of
+          1: begin P^.Bal := 0; FHeightChange := false end;
+          0: begin P^.Bal := -1 end;
+         -1: begin {Rebalance}
+               if P^.Left^.Bal = -1
+               then {single R rotation}
+                 begin
+                   RotR(P);
+                   //adjust balance factor:
+                   P^.Right^.Bal := 0;
+                 end
+               else {double LR rotation}
+                 begin
+                   RotL(P^.Left);
+                   RotR(P);
+                   //adjust balance factor:
+                   case P^.Bal of
+                     -1: begin P^.Left^.Bal :=  0; P^.Right^.Bal := 1 end;
+                      0: begin P^.Left^.Bal :=  0; P^.Right^.Bal := 0 end;
+                      1: begin P^.Left^.Bal := -1; P^.Right^.Bal := 0 end;
+                   end;
+                 end;
+               P^.Bal := 0;
+               FHeightChange := false;
+//               assert(CheckTree(P));
+             end{-1}
+        end{case}
+    end else
+    if X^.Data.ID > P^.Data.ID then
+    begin
+      { greater }
+      InternalInsert(X, P^.Right);
+      if FHeightChange then {Right branch has grown higher}
+        case P^.Bal of
+          -1: begin P^.Bal := 0; FHeightChange := false end;
+           0: begin P^.Bal := 1 end;
+           1: begin {Rebalance}
+                if P^.Right^.Bal = 1
+                then {single L rotation}
+                  begin
+                    RotL(P);
+                    //adjust balance factor:
+                    P^.Left.Bal := 0;
+                  end
+                else {double RL rotation}
+                  begin
+                    RotR(P^.Right);
+                    RotL(P);
+                    //adjust balance factor
+                    case P^.Bal of
+                       1: begin P^.Right^.Bal := 0; P^.Left^.Bal := -1 end;
+                       0: begin P^.Right^.Bal := 0; P^.Left^.Bal :=  0 end;
+                      -1: begin P^.Right^.Bal := 1; P^.Left^.Bal :=  0 end;
+                    end;
+                  end;
+                P^.Bal := 0;
+                FHeightChange := false;
+//                assert(CheckTree(P));
+              end{1}
+         end{case}
+    end {greater} else begin
+      {X already present; do not insert again}
+      FHeightChange := false;
+    end;
+
+//  assert(CheckTree(P));
+end;{InternalInsert}
+
+procedure TAvlTree.InternalDelete(X: TKeyType; var P: PNode);
+var
+  Q: PNode;
+  H: TData;
+begin
+  if P = nil then
+    FHeightChange := false
+  else
+    if X < P^.Data.ID then
+    begin
+      InternalDelete(X, P^.Left);
+      if FHeightChange then BalanceLeft(P, FHeightChange)
+    end else
+    if X > P^.Data.ID then
+    begin
+      InternalDelete(X, P^.Right);
+      if FHeightChange then BalanceRight(P, FHeightChange)
+    end else begin
+      if P^.Right = nil then
+      begin Q := P; P := P^.Left; FHeightChange := true end
+      else if P^.Left = nil then
+      begin Q := P; P := P^.Right; FHeightChange := true end
+      else
+        begin
+          DelRM(P^.Left, Q, FHeightChange);
+          H := P^.Data;
+          P^.Data := Q^.Data;
+          Q^.Data := H;
+          if FHeightChange then BalanceLeft(P, FHeightChange)
+        end;
+      DeleteNode(Q)
+    end;{eq}
+end;{InternalDelete}
+
+function TAvlTree.Lowest: PData;
+var
+  H: PNode;
+begin
+  H := FRoot;
+  if H = nil then
+  begin
+    Result := nil;
+    exit;
+  end;
+
+  while H^.Left <> nil do
+    H := H^.Left;
+  Result := @H^.Data;
+end;
+
+end.

+ 6 - 1
fcl/db/dbase/Dbf_Common.inc → fcl/db/dbase/dbf_common.inc

@@ -159,6 +159,10 @@
   {$undef USE_ASSEMBLER_486_UP}
   {$undef USE_ASSEMBLER_486_UP}
 {$endif}
 {$endif}
 
 
+{$ifndef FPC_LITTLE_ENDIAN}
+  {$message error TDbf is not compatible with non little-endian CPUs. Please contact the author.}
+{$endif}
+
 {$ifdef USE_ASSEMBLER_486_UP}
 {$ifdef USE_ASSEMBLER_486_UP}
   {$asmmode intel}
   {$asmmode intel}
 {$endif}
 {$endif}
@@ -170,6 +174,7 @@
   {$define SUPPORT_FIELDDEF_TPERSISTENT}
   {$define SUPPORT_FIELDDEF_TPERSISTENT}
   {$define SUPPORT_FIELDTYPES_V4}
   {$define SUPPORT_FIELDTYPES_V4}
   {$define SUPPORT_UINT32_CARDINAL}
   {$define SUPPORT_UINT32_CARDINAL}
+  {$define SUPPORT_REINTRODUCE}
 
 
   // FPC 1.0.x exceptions: no 0/0 support
   // FPC 1.0.x exceptions: no 0/0 support
   {$ifdef VER1_0}
   {$ifdef VER1_0}
@@ -177,7 +182,7 @@
     {$undef SUPPORT_DEFAULT_PARAMS}
     {$undef SUPPORT_DEFAULT_PARAMS}
     {$undef SUPPORT_NEW_TRANSLATE}
     {$undef SUPPORT_NEW_TRANSLATE}
 
 
-    #ERROR TDbf needs fpc 1.9 minimum.
+    {$message error TDbf needs fpc 1.9 minimum.}
 
 
   {$endif}
   {$endif}
 
 

+ 18 - 18
fcl/db/dbase/Dbf_Common.pas → fcl/db/dbase/dbf_common.pas

@@ -1,4 +1,4 @@
-unit Dbf_Common;
+unit dbf_common;
 
 
 interface
 interface
 
 
@@ -17,7 +17,7 @@ uses
 
 
 const
 const
   TDBF_MAJOR_VERSION      = 6;
   TDBF_MAJOR_VERSION      = 6;
-  TDBF_MINOR_VERSION      = 37;
+  TDBF_MINOR_VERSION      = 40;
   TDBF_SUB_MINOR_VERSION  = 0;
   TDBF_SUB_MINOR_VERSION  = 0;
 
 
   TDBF_TABLELEVEL_FOXPRO = 25;
   TDBF_TABLELEVEL_FOXPRO = 25;
@@ -27,18 +27,16 @@ type
   EDbfWriteError = class (EDbfError);
   EDbfWriteError = class (EDbfError);
 
 
   TDbfFieldType = char;
   TDbfFieldType = char;
-  PBookMarkData = ^rBookMarkData;
-  rBookmarkData = Integer;
 
 
-  xBaseVersion   = (xUnknown, xClipper, xBaseIII, xBaseIV, xBaseV, xFoxPro, xBaseVII);
+  TXBaseVersion   = (xUnknown, xClipper, xBaseIII, xBaseIV, xBaseV, xFoxPro, xBaseVII);
   TSearchKeyType = (stEqual, stGreaterEqual, stGreater);
   TSearchKeyType = (stEqual, stGreaterEqual, stGreater);
 
 
   TDateTimeHandling       = (dtDateTime, dtBDETimeStamp);
   TDateTimeHandling       = (dtDateTime, dtBDETimeStamp);
 
 
 //-------------------------------------
 //-------------------------------------
 
 
-{$ifdef FPC_VERSION}
   PDateTime = ^TDateTime;
   PDateTime = ^TDateTime;
+{$ifdef FPC_VERSION}
   TDateTimeAlias = type TDateTime;
   TDateTimeAlias = type TDateTime;
   TDateTimeRec = record
   TDateTimeRec = record
     case TFieldType of
     case TFieldType of
@@ -86,10 +84,8 @@ function IncludeTrailingPathDelimiter(const Path: string): string;
 function GetCompletePath(const Base, Path: string): string;
 function GetCompletePath(const Base, Path: string): string;
 function GetCompleteFileName(const Base, FileName: string): string;
 function GetCompleteFileName(const Base, FileName: string): string;
 function IsFullFilePath(const Path: string): Boolean; // full means not relative
 function IsFullFilePath(const Path: string): Boolean; // full means not relative
-{$ifndef SUPPORT_NEW_FIELDDATA}
 function DateTimeToBDETimeStamp(aDT: TDateTime): double;
 function DateTimeToBDETimeStamp(aDT: TDateTime): double;
 function BDETimeStampToDateTime(aBT: double): TDateTime;
 function BDETimeStampToDateTime(aBT: double): TDateTime;
-{$endif}
 function  GetStrFromInt(Val: Integer; const Dst: PChar): Integer;
 function  GetStrFromInt(Val: Integer; const Dst: PChar): Integer;
 procedure GetStrFromInt_Width(Val: Integer; const Width: Integer; const Dst: PChar; const PadChar: Char);
 procedure GetStrFromInt_Width(Val: Integer; const Width: Integer; const Dst: PChar; const PadChar: Char);
 {$ifdef SUPPORT_INT64}
 {$ifdef SUPPORT_INT64}
@@ -170,9 +166,13 @@ end;
 procedure GetStrFromInt_Width(Val: Integer; const Width: Integer; const Dst: PChar; const PadChar: Char);
 procedure GetStrFromInt_Width(Val: Integer; const Width: Integer; const Dst: PChar; const PadChar: Char);
 var
 var
   Temp: array[0..10] of Char;
   Temp: array[0..10] of Char;
-  I, J, K, Sign: Integer;
+  I, J, K: Integer;
+  NegSign: boolean;
 begin
 begin
-  Sign := Val;
+  if Width <= 0 then
+    exit;
+
+  NegSign := Val < 0;
   Val := Abs(Val);
   Val := Abs(Val);
   // we'll have to store characters backwards first
   // we'll have to store characters backwards first
   I := 0;
   I := 0;
@@ -183,7 +183,7 @@ begin
     Inc(I);
     Inc(I);
   until Val = 0;
   until Val = 0;
   // add sign
   // add sign
-  if Sign < 0 then
+  if NegSign then
   begin
   begin
     Dst[J] := '-';
     Dst[J] := '-';
     Inc(J);
     Inc(J);
@@ -212,9 +212,12 @@ procedure GetStrFromInt64_Width(Val: Int64; const Width: Integer; const Dst: PCh
 var
 var
   Temp: array[0..19] of Char;
   Temp: array[0..19] of Char;
   I, J, K: Integer;
   I, J, K: Integer;
-  Sign: Int64;
+  NegSign: boolean;
 begin
 begin
-  Sign := Val;
+  if Width <= 0 then
+    exit;
+
+  NegSign := Val < 0;
   Val := Abs(Val);
   Val := Abs(Val);
   // we'll have to store characters backwards first
   // we'll have to store characters backwards first
   I := 0;
   I := 0;
@@ -225,7 +228,7 @@ begin
     inc(I);
     inc(I);
   until Val = 0;
   until Val = 0;
   // add sign
   // add sign
-  if Sign < 0 then
+  if NegSign then
   begin
   begin
     Dst[J] := '-';
     Dst[J] := '-';
     inc(J);
     inc(J);
@@ -247,6 +250,7 @@ begin
   until I = 0;
   until I = 0;
   // done!
   // done!
 end;
 end;
+
 {$endif}
 {$endif}
 
 
 // it seems there is no pascal function to convert an integer into a PChar???
 // it seems there is no pascal function to convert an integer into a PChar???
@@ -308,8 +312,6 @@ end;
 
 
 {$endif}
 {$endif}
 
 
-{$ifndef SUPPORT_NEW_FIELDDATA}
-
 function DateTimeToBDETimeStamp(aDT: TDateTime): double;
 function DateTimeToBDETimeStamp(aDT: TDateTime): double;
 var
 var
   aTS: TTimeStamp;
   aTS: TTimeStamp;
@@ -326,8 +328,6 @@ begin
   Result := TimeStampToDateTime(aTS);
   Result := TimeStampToDateTime(aTS);
 end;
 end;
 
 
-{$endif}
-
 //====================================================================
 //====================================================================
 
 
 {$ifndef SUPPORT_FREEANDNIL}
 {$ifndef SUPPORT_FREEANDNIL}

+ 64 - 70
fcl/db/dbase/Dbf_Cursor.pas → fcl/db/dbase/dbf_cursor.pas

@@ -1,70 +1,64 @@
-unit Dbf_Cursor;
-
-interface
-
-{$I Dbf_Common.inc}
-
-uses
-  SysUtils,
-  Classes,
-  Dbf_PgFile,
-  Dbf_Common;
-
-type
-
-//====================================================================
-  TVirtualCursor = class(TObject)
-  private
-    FFile: TPagedFile;
-
-  protected
-    function GetPhysicalRecno: Integer; virtual; abstract;
-    function GetSequentialRecno: Integer; virtual; abstract;
-    function GetSequentialRecordCount: Integer; virtual; abstract;
-    procedure SetPhysicalRecno(Recno: Integer); virtual; abstract;
-    procedure SetSequentialRecno(Recno: Integer); virtual; abstract;
-
-  public
-    constructor Create(pFile: TPagedFile);
-    destructor Destroy; override;
-
-    function  RecordSize: Integer;
-
-    function  Next: Boolean; virtual; abstract;
-    function  Prev: Boolean; virtual; abstract;
-    procedure First; virtual; abstract;
-    procedure Last; virtual; abstract;
-
-    function  GetBookMark: rBookmarkData; virtual; abstract;
-    procedure GotoBookmark(Bookmark: rBookmarkData); virtual; abstract;
-
-    procedure Insert(Recno: Integer; Buffer: PChar); virtual; abstract;
-    procedure Update(Recno: Integer; PrevBuffer,NewBuffer: PChar); virtual; abstract;
-
-    property PagedFile: TPagedFile read FFile;
-    property PhysicalRecNo: Integer read GetPhysicalRecNo write SetPhysicalRecNo;
-    property SequentialRecNo: Integer read GetSequentialRecNo write SetSequentialRecNo;
-    property SequentialRecordCount: Integer read GetSequentialRecordCount;
-  end;
-
-implementation
-
-constructor TVirtualCursor.Create(pFile: TPagedFile);
-begin
-  FFile := pFile;
-end;
-
-destructor TVirtualCursor.Destroy; {override;}
-begin
-end;
-
-function TVirtualCursor.RecordSize : Integer;
-begin
-  if FFile = nil then
-    Result := 0
-  else
-    Result := FFile.RecordSize;
-end;
-
-end.
-
+unit dbf_cursor;
+
+interface
+
+{$I Dbf_Common.inc}
+
+uses
+  SysUtils,
+  Classes,
+  Dbf_PgFile,
+  Dbf_Common;
+
+type
+
+//====================================================================
+  TVirtualCursor = class(TObject)
+  private
+    FFile: TPagedFile;
+
+  protected
+    function GetPhysicalRecno: Integer; virtual; abstract;
+    function GetSequentialRecno: Integer; virtual; abstract;
+    function GetSequentialRecordCount: Integer; virtual; abstract;
+    procedure SetPhysicalRecno(Recno: Integer); virtual; abstract;
+    procedure SetSequentialRecno(Recno: Integer); virtual; abstract;
+
+  public
+    constructor Create(pFile: TPagedFile);
+    destructor Destroy; override;
+
+    function  RecordSize: Integer;
+
+    function  Next: Boolean; virtual; abstract;
+    function  Prev: Boolean; virtual; abstract;
+    procedure First; virtual; abstract;
+    procedure Last; virtual; abstract;
+
+    property PagedFile: TPagedFile read FFile;
+    property PhysicalRecNo: Integer read GetPhysicalRecNo write SetPhysicalRecNo;
+    property SequentialRecNo: Integer read GetSequentialRecNo write SetSequentialRecNo;
+    property SequentialRecordCount: Integer read GetSequentialRecordCount;
+  end;
+
+implementation
+
+constructor TVirtualCursor.Create(pFile: TPagedFile);
+begin
+  FFile := pFile;
+end;
+
+destructor TVirtualCursor.Destroy; {override;}
+begin
+end;
+
+function TVirtualCursor.RecordSize : Integer;
+begin
+  if FFile = nil then
+    Result := 0
+  else
+    Result := FFile.RecordSize;
+end;
+
+end.
+

+ 87 - 70
fcl/db/dbase/Dbf_DbfFile.pas → fcl/db/dbase/dbf_dbffile.pas

@@ -1,4 +1,4 @@
-unit Dbf_DbfFile;
+unit dbf_dbffile;
 
 
 interface
 interface
 
 
@@ -46,7 +46,7 @@ type
     FFieldDefs: TDbfFieldDefs;
     FFieldDefs: TDbfFieldDefs;
     FIndexNames: TStringList;
     FIndexNames: TStringList;
     FIndexFiles: TList;
     FIndexFiles: TList;
-    FDbfVersion: xBaseVersion;
+    FDbfVersion: TXBaseVersion;
     FPrevBuffer: PChar;
     FPrevBuffer: PChar;
     FRecordBufferSize: Integer;
     FRecordBufferSize: Integer;
     FLockFieldOffset: Integer;
     FLockFieldOffset: Integer;
@@ -120,7 +120,7 @@ type
     property FileCodePage: Cardinal read FFileCodePage;
     property FileCodePage: Cardinal read FFileCodePage;
     property UseCodePage: Cardinal read FUseCodePage write FUseCodePage;
     property UseCodePage: Cardinal read FUseCodePage write FUseCodePage;
     property FileLangId: Byte read FFileLangId write FFileLangId;
     property FileLangId: Byte read FFileLangId write FFileLangId;
-    property DbfVersion: xBaseVersion read FDbfVersion write FDbfVersion;
+    property DbfVersion: TXBaseVersion read FDbfVersion write FDbfVersion;
     property PrevBuffer: PChar read FPrevBuffer;
     property PrevBuffer: PChar read FPrevBuffer;
     property ForceClose: Boolean read FForceClose;
     property ForceClose: Boolean read FForceClose;
     property HasLockField: Boolean read FHasLockField;
     property HasLockField: Boolean read FHasLockField;
@@ -149,11 +149,6 @@ type
     function GetSequentialRecordCount: Integer; override;
     function GetSequentialRecordCount: Integer; override;
     function GetSequentialRecNo: Integer; override;
     function GetSequentialRecNo: Integer; override;
     procedure SetSequentialRecNo(RecNo: Integer); override;
     procedure SetSequentialRecNo(RecNo: Integer); override;
-
-    procedure GotoBookmark(Bookmark: rBookmarkData); override;
-    procedure Insert(RecNo: Integer; Buffer: PChar); override;
-    procedure Update(RecNo: Integer; PrevBuffer,NewBuffer: PChar); override;
-    function GetBookMark: rBookmarkData; override;
   end;
   end;
 
 
 //====================================================================
 //====================================================================
@@ -336,6 +331,7 @@ var
   I: Integer;
   I: Integer;
   deleteLink: Boolean;
   deleteLink: Boolean;
   LangStr: PChar;
   LangStr: PChar;
+  version: byte;
 begin
 begin
   // check if not already opened
   // check if not already opened
   if not Active then
   if not Active then
@@ -359,7 +355,8 @@ begin
       //  $03,$8B dBaseIV/V       Header Byte $1d=$00, Float -> N($14.$05) DateTime D($08)
       //  $03,$8B dBaseIV/V       Header Byte $1d=$00, Float -> N($14.$05) DateTime D($08)
       //  $03,$F5 FoxPro Level 25 Header Byte $1d=$09, Float -> N($14.$05) DateTime D($08)
       //  $03,$F5 FoxPro Level 25 Header Byte $1d=$09, Float -> N($14.$05) DateTime D($08)
 
 
-      case (PDbfHdr(Header).VerDBF and $07) of
+      version := PDbfHdr(Header).VerDBF;
+      case (version and $07) of
         $03:
         $03:
           if LanguageID = 0 then
           if LanguageID = 0 then
             FDbfVersion := xBaseIII
             FDbfVersion := xBaseIII
@@ -371,7 +368,7 @@ begin
           FDbfVersion := xFoxPro;
           FDbfVersion := xFoxPro;
       else
       else
         // check visual foxpro
         // check visual foxpro
-        if (PDbfHdr(Header).VerDBF and $70) = $30 then
+        if ((version and $FE) = $30) or (version = $F5) or (version = $FB) then
         begin
         begin
           FDbfVersion := xFoxPro;
           FDbfVersion := xFoxPro;
         end else begin
         end else begin
@@ -458,7 +455,7 @@ begin
           MemoFileClass := TFoxProMemoFile
           MemoFileClass := TFoxProMemoFile
         else
         else
           MemoFileClass := TDbaseMemoFile;
           MemoFileClass := TDbaseMemoFile;
-        FMemoFile := MemoFileClass.Create;
+        FMemoFile := MemoFileClass.Create(Self);
         FMemoFile.FileName := lMemoFileName;
         FMemoFile.FileName := lMemoFileName;
         FMemoFile.Mode := Mode;
         FMemoFile.Mode := Mode;
         FMemoFile.AutoCreate := false;
         FMemoFile.AutoCreate := false;
@@ -598,8 +595,9 @@ begin
       RecordSize := SizeOf(rFieldDescIII);
       RecordSize := SizeOf(rFieldDescIII);
       FillChar(Header^, HeaderSize, #0);
       FillChar(Header^, HeaderSize, #0);
       if FDbfVersion = xFoxPro then
       if FDbfVersion = xFoxPro then
-        PDbfHdr(Header).VerDBF := $05
-      else
+      begin
+        PDbfHdr(Header).VerDBF := $02
+      end else
         PDbfHdr(Header).VerDBF := $03;
         PDbfHdr(Header).VerDBF := $03;
       // standard language WE, dBase III no language support
       // standard language WE, dBase III no language support
       if FDbfVersion = xBaseIII then
       if FDbfVersion = xBaseIII then
@@ -634,10 +632,10 @@ begin
       // apply field transformation tricks
       // apply field transformation tricks
       lSize := lFieldDef.Size;
       lSize := lFieldDef.Size;
       lPrec := lFieldDef.Precision;
       lPrec := lFieldDef.Precision;
-      if lFieldDef.NativeFieldType = 'C' then
+      if (FDbfVersion = xFoxPro) and (lFieldDef.NativeFieldType = 'C') then
       begin
       begin
-        lPrec := lSize div 256;
-        lSize := lSize mod 256;
+        lPrec := lSize shr 8;
+        lSize := lSize and $FF;
       end;
       end;
 
 
       // update temp field props
       // update temp field props
@@ -657,6 +655,13 @@ begin
         lFieldDescIII.FieldType := lFieldDef.NativeFieldType;
         lFieldDescIII.FieldType := lFieldDef.NativeFieldType;
         lFieldDescIII.FieldSize := lSize;
         lFieldDescIII.FieldSize := lSize;
         lFieldDescIII.FieldPrecision := lPrec;
         lFieldDescIII.FieldPrecision := lPrec;
+        // TODO: bug-endianness
+        if FDbfVersion = xFoxPro then
+          lFieldDescIII.FieldOffset := lFieldOffset;
+        if (PDbfHdr(Header).VerDBF = $02) and (lFieldDef.NativeFieldType in ['0', 'Y', 'T', 'O', '+']) then
+          PDbfHdr(Header).VerDBF := $30;
+        if (PDbfHdr(Header).VerDBF = $30) and (lFieldDef.NativeFieldType = '+') then
+          PDbfHdr(Header).VerDBF := $31;
       end;
       end;
 
 
       // update our field list
       // update our field list
@@ -676,17 +681,28 @@ begin
 
 
     // write memo bit
     // write memo bit
     if lHasBlob then
     if lHasBlob then
+    begin
       if FDbfVersion = xBaseIII then
       if FDbfVersion = xBaseIII then
         PDbfHdr(Header).VerDBF := PDbfHdr(Header).VerDBF or $80
         PDbfHdr(Header).VerDBF := PDbfHdr(Header).VerDBF or $80
       else
       else
       if FDbfVersion = xFoxPro then
       if FDbfVersion = xFoxPro then
-        PDbfHdr(Header).VerDBF := PDbfHdr(Header).VerDBF or $F0
-      else
+      begin
+        if PDbfHdr(Header).VerDBF = $02 then
+          PDbfHdr(Header).VerDBF := $F5;
+      end else
         PDbfHdr(Header).VerDBF := PDbfHdr(Header).VerDBF or $88;
         PDbfHdr(Header).VerDBF := PDbfHdr(Header).VerDBF or $88;
+    end;
 
 
     // update header
     // update header
     PDbfHdr(Header).RecordSize := lFieldOffset;
     PDbfHdr(Header).RecordSize := lFieldOffset;
     PDbfHdr(Header).FullHdrSize := HeaderSize + RecordSize * FieldDefs.Count + 1;
     PDbfHdr(Header).FullHdrSize := HeaderSize + RecordSize * FieldDefs.Count + 1;
+    // add empty "back-link" info, whatever it is: 
+    { A 263-byte range that contains the backlink, which is the relative path of 
+      an associated database (.dbc) file, information. If the first byte is 0x00, 
+      the file is not associated with a database. Therefore, database files always 
+      contain 0x00. }
+    if FDbfVersion = xFoxPro then
+      Inc(PDbfHdr(Header).FullHdrSize, 263);
 
 
     // write dbf header to disk
     // write dbf header to disk
     inherited WriteHeader;
     inherited WriteHeader;
@@ -702,9 +718,9 @@ begin
   begin
   begin
     lMemoFileName := ChangeFileExt(FileName, GetMemoExt);
     lMemoFileName := ChangeFileExt(FileName, GetMemoExt);
     if FDbfVersion = xFoxPro then
     if FDbfVersion = xFoxPro then
-      FMemoFile := TFoxProMemoFile.Create
+      FMemoFile := TFoxProMemoFile.Create(Self)
     else
     else
-      FMemoFile := TDbaseMemoFile.Create;
+      FMemoFile := TDbaseMemoFile.Create(Self);
     FMemoFile.FileName := lMemoFileName;
     FMemoFile.FileName := lMemoFileName;
     FMemoFile.Mode := Mode;
     FMemoFile.Mode := Mode;
     FMemoFile.AutoCreate := AutoCreate;
     FMemoFile.AutoCreate := AutoCreate;
@@ -826,7 +842,7 @@ begin
       end;
       end;
 
 
       // apply field transformation tricks
       // apply field transformation tricks
-      if lNativeFieldType = 'C' then
+      if (lNativeFieldType = 'C') and (FDbfVersion = xFoxPro) then
       begin
       begin
         lSize := lSize + lPrec shl 8;
         lSize := lSize + lPrec shl 8;
         lPrec := 0;
         lPrec := 0;
@@ -1343,7 +1359,7 @@ var
     //  datetime = msecs == BDE timestamp as we implemented it
     //  datetime = msecs == BDE timestamp as we implemented it
     if DataType = ftDateTime then
     if DataType = ftDateTime then
     begin
     begin
-      PDateTimeRec(Dst).DateTime := DateTimeToBDETimeStamp(date);
+      PDateTimeRec(Dst)^.DateTime := date;
     end else begin
     end else begin
       PLongInt(Dst)^ := DateTimeToTimeStamp(date).Date;
       PLongInt(Dst)^ := DateTimeToTimeStamp(date).Date;
     end;
     end;
@@ -1365,7 +1381,7 @@ begin
           if FDbfVersion <> xFoxPro then
           if FDbfVersion <> xFoxPro then
           begin
           begin
             Result := PDWord(Src)^ <> 0;
             Result := PDWord(Src)^ <> 0;
-            if Result then
+            if Result and (Dst <> nil) then
             begin
             begin
               PInteger(Dst)^ := SwapInt(PInteger(Src)^);
               PInteger(Dst)^ := SwapInt(PInteger(Src)^);
               if Result then
               if Result then
@@ -1373,14 +1389,15 @@ begin
             end;
             end;
           end else begin
           end else begin
             Result := true;
             Result := true;
-            PInteger(Dst)^ := PInteger(Src)^;
+            if Dst <> nil then
+              PInteger(Dst)^ := PInteger(Src)^;
           end;
           end;
         end;
         end;
       'O':
       'O':
         begin
         begin
 {$ifdef SUPPORT_INT64}
 {$ifdef SUPPORT_INT64}
           Result := (PInt64(Src)^ <> 0);
           Result := (PInt64(Src)^ <> 0);
-          if Result then
+          if Result and (Dst <> nil) then
           begin
           begin
             SwapInt64(Src, Dst);
             SwapInt64(Src, Dst);
             if PInt64(Dst)^ > 0 then
             if PInt64(Dst)^ > 0 then
@@ -1392,17 +1409,22 @@ begin
         end;
         end;
       '@':
       '@':
         begin
         begin
-{$ifdef SUPPORT_INT64}
-          Result := (PInt64(Src)^ <> 0);
-          if Result then
+          Result := (PInteger(Src)^ <> 0) and (PInteger(PChar(Src)+4)^ <> 0);
+          if Result and (Dst <> nil) then
+          begin
             SwapInt64(Src, Dst);
             SwapInt64(Src, Dst);
-{$endif}
+            if FDateTimeHandling = dtBDETimeStamp then
+              date := BDETimeStampToDateTime(PDouble(Dst)^)
+            else
+              date := PDateTime(Dst)^;
+            SaveDateToDst;
+          end;
         end;
         end;
       'T':
       'T':
         begin
         begin
           // all binary zeroes -> empty datetime
           // all binary zeroes -> empty datetime
           Result := (PInteger(Src)^ <> 0) or (PInteger(PChar(Src)+4)^ <> 0);
           Result := (PInteger(Src)^ <> 0) or (PInteger(PChar(Src)+4)^ <> 0);
-          if Result then
+          if Result and (Dst <> nil) then
           begin
           begin
             timeStamp.Date := PInteger(Src)^ - 1721425;
             timeStamp.Date := PInteger(Src)^ - 1721425;
             timeStamp.Time := PInteger(PChar(Src)+4)^;
             timeStamp.Time := PInteger(PChar(Src)+4)^;
@@ -1414,15 +1436,18 @@ begin
         begin
         begin
 {$ifdef SUPPORT_INT64}
 {$ifdef SUPPORT_INT64}
           Result := true;
           Result := true;
-          SwapInt64(Src, Dst);
-          case DataType of
-            ftCurrency:
-            begin
-              PDouble(Dst)^ := PInt64(Src)^ / 10000.0;
-            end;
-            ftBCD:
-            begin
-              PCurrency(Dst)^ := PCurrency(Src)^;
+          if Dst <> nil then
+          begin
+            SwapInt64(Src, Dst);
+            case DataType of
+              ftCurrency:
+              begin
+                PDouble(Dst)^ := PInt64(Src)^ / 10000.0;
+              end;
+              ftBCD:
+              begin
+                PCurrency(Dst)^ := PCurrency(Src)^;
+              end;
             end;
             end;
           end;
           end;
 {$endif}
 {$endif}
@@ -1537,7 +1562,7 @@ var
     //  datetime = msecs == BDETimeStampToDateTime as we implemented it
     //  datetime = msecs == BDETimeStampToDateTime as we implemented it
     if DataType = ftDateTime then
     if DataType = ftDateTime then
     begin
     begin
-      date := BDETimeStampToDateTime(PDouble(Src)^);
+      date := PDouble(Src)^;
     end else begin
     end else begin
       timeStamp.Time := 0;
       timeStamp.Time := 0;
       timeStamp.Date := PLongInt(Src)^;
       timeStamp.Date := PLongInt(Src)^;
@@ -1557,11 +1582,19 @@ begin
   case TempFieldDef.NativeFieldType of
   case TempFieldDef.NativeFieldType of
     '+', 'I':
     '+', 'I':
       begin
       begin
-        if Src = nil then
-          IntValue := 0
-        else
-          IntValue := Integer(PDWord(Src)^ + $80000000);
-        PInteger(Dst)^ := SwapInt(IntValue);
+        if FDbfVersion <> xFoxPro then
+        begin
+          if Src = nil then
+            IntValue := 0
+          else
+            IntValue := Integer(PDWord(Src)^ + $80000000);
+          PInteger(Dst)^ := SwapInt(IntValue);
+        end else begin
+          if Src = nil then
+            PInteger(Dst)^ := 0
+          else
+            PInteger(Dst)^ := PInteger(Src)^;
+        end;
       end;
       end;
     'O':
     'O':
       begin
       begin
@@ -1580,12 +1613,16 @@ begin
       end;
       end;
     '@':
     '@':
       begin
       begin
-{$ifdef SUPPORT_INT64}
         if Src = nil then
         if Src = nil then
-          PInteger(Dst)^ := 0
-        else
-          SwapInt64(Src, Dst);
-{$endif}
+        begin
+          PInteger(Dst)^ := 0;
+          PInteger(PChar(Dst)+4)^ := 0;
+        end else begin
+          LoadDateFromSrc;
+          if FDateTimeHandling = dtBDETimeStamp then
+            date := DateTimeToBDETimeStamp(date);
+          SwapInt64(@date, Dst);
+        end;
       end;
       end;
     'T':
     'T':
       begin
       begin
@@ -2391,20 +2428,6 @@ begin
   FPhysicalRecNo := RecNo;
   FPhysicalRecNo := RecNo;
 end;
 end;
 
 
-procedure TDbfCursor.GotoBookmark(Bookmark: rBookmarkData);
-begin
-  FPhysicalRecNo := Bookmark{.RecNo};
-end;
-
-procedure TDbfCursor.Insert(RecNo: Integer; Buffer: PChar); {override;}
-begin
-  FPhysicalRecNo := TDbfFile(PagedFile).RecordCount;
-end;
-
-procedure TDbfCursor.Update(RecNo: Integer; PrevBuffer,NewBuffer: PChar); {override;}
-begin
-end;
-
 // codepage enumeration procedure
 // codepage enumeration procedure
 var
 var
   TempCodePageList: TList;
   TempCodePageList: TList;
@@ -2420,12 +2443,6 @@ begin
   Result := 1;
   Result := 1;
 end;
 end;
 
 
-function TDbfCursor.GetBookMark: rBookmarkData; {override;}
-begin
-//  Result.IndexBookmark := -1;
-  Result{.RecNo} := FPhysicalRecNo;
-end;
-
 //====================================================================
 //====================================================================
 // TDbfGlobals
 // TDbfGlobals
 //====================================================================
 //====================================================================

+ 22 - 20
fcl/db/dbase/Dbf_Fields.pas → fcl/db/dbase/dbf_fields.pas

@@ -1,6 +1,4 @@
-unit Dbf_Fields;
-
-{force CR/LF fix}
+unit dbf_fields;
 
 
 interface
 interface
 
 
@@ -36,7 +34,7 @@ type
     FRequired: Boolean;
     FRequired: Boolean;
     FIsLockField: Boolean;
     FIsLockField: Boolean;
 
 
-    function  GetDbfVersion: xBaseVersion;
+    function  GetDbfVersion: TXBaseVersion;
     procedure SetNativeFieldType(lFieldType: TDbfFieldType);
     procedure SetNativeFieldType(lFieldType: TDbfFieldType);
     procedure SetFieldType(lFieldType: TFieldType);
     procedure SetFieldType(lFieldType: TFieldType);
     procedure SetSize(lSize: Integer);
     procedure SetSize(lSize: Integer);
@@ -48,7 +46,7 @@ type
     function  GetDisplayName: string; override;
     function  GetDisplayName: string; override;
     procedure AssignTo(Dest: TPersistent); override;
     procedure AssignTo(Dest: TPersistent); override;
 
 
-    property DbfVersion: xBaseVersion read GetDbfVersion;
+    property DbfVersion: TXBaseVersion read GetDbfVersion;
   public
   public
     constructor Create(Collection: TCollection); override;
     constructor Create(Collection: TCollection); override;
     destructor Destroy; override;
     destructor Destroy; override;
@@ -83,7 +81,7 @@ type
   TDbfFieldDefs = class(TCollection)
   TDbfFieldDefs = class(TCollection)
   private
   private
     FOwner: TPersistent;
     FOwner: TPersistent;
-    FDbfVersion: xBaseVersion;
+    FDbfVersion: TXBaseVersion;
     FUseFloatFields: Boolean;
     FUseFloatFields: Boolean;
 
 
     function GetItem(Idx: Integer): TDbfFieldDef;
     function GetItem(Idx: Integer): TDbfFieldDef;
@@ -100,7 +98,7 @@ type
     function AddFieldDef: TDbfFieldDef;
     function AddFieldDef: TDbfFieldDef;
 
 
     property Items[Idx: Integer]: TDbfFieldDef read GetItem;
     property Items[Idx: Integer]: TDbfFieldDef read GetItem;
-    property DbfVersion: xBaseVersion read FDbfVersion write FDbfVersion;
+    property DbfVersion: TXBaseVersion read FDbfVersion write FDbfVersion;
     property UseFloatFields: Boolean read FUseFloatFields write FUseFloatFields;
     property UseFloatFields: Boolean read FUseFloatFields write FUseFloatFields;
   end;
   end;
 
 
@@ -289,7 +287,7 @@ begin
     inherited AssignTo(Dest);
     inherited AssignTo(Dest);
 end;
 end;
 
 
-function TDbfFieldDef.GetDbfVersion: xBaseVersion;
+function TDbfFieldDef.GetDbfVersion: TXBaseVersion;
 begin
 begin
   Result := TDbfFieldDefs(Collection).DbfVersion;
   Result := TDbfFieldDefs(Collection).DbfVersion;
 end;
 end;
@@ -298,7 +296,7 @@ procedure TDbfFieldDef.SetFieldType(lFieldType: tFieldType);
 begin
 begin
   FFieldType := lFieldType;
   FFieldType := lFieldType;
   VCLToNative;
   VCLToNative;
-  CheckSizePrecision;
+  SetDefaultSize;
 end;
 end;
 
 
 procedure TDbfFieldDef.SetNativeFieldType(lFieldType: tDbfFieldType);
 procedure TDbfFieldDef.SetNativeFieldType(lFieldType: tDbfFieldType);
@@ -381,11 +379,10 @@ begin
   case FFieldType of
   case FFieldType of
     ftAutoInc  : FNativeFieldType  := '+';
     ftAutoInc  : FNativeFieldType  := '+';
     ftDateTime :
     ftDateTime :
-{$ifdef SUPPORT_INT64}
       if DbfVersion = xBaseVII then
       if DbfVersion = xBaseVII then
         FNativeFieldType := '@'
         FNativeFieldType := '@'
       else
       else
-{$endif}
+      if DbfVersion = xFoxPro then
         FNativeFieldType := 'T';
         FNativeFieldType := 'T';
 {$ifdef SUPPORT_FIELDTYPES_V4}
 {$ifdef SUPPORT_FIELDTYPES_V4}
     ftFixedChar,
     ftFixedChar,
@@ -417,6 +414,7 @@ end;
 
 
 procedure TDbfFieldDef.SetDefaultSize;
 procedure TDbfFieldDef.SetDefaultSize;
 begin
 begin
+  // choose default values for variable size fields
   case FFieldType of
   case FFieldType of
     ftFloat:
     ftFloat:
       begin
       begin
@@ -433,7 +431,7 @@ begin
         FSize := DIGITS_SMALLINT;
         FSize := DIGITS_SMALLINT;
         FPrecision := 0;
         FPrecision := 0;
       end;
       end;
-    ftInteger:
+    ftInteger, ftAutoInc:
       begin
       begin
         if DbfVersion = xBaseVII then
         if DbfVersion = xBaseVII then
           FSize := 4
           FSize := 4
@@ -448,15 +446,15 @@ begin
         FPrecision := 0;
         FPrecision := 0;
       end;
       end;
 {$endif}
 {$endif}
-    ftDate, ftDateTime:
+    ftString {$ifdef SUPPORT_FIELDTYPES_V4}, ftFixedChar, ftWideString{$endif}:
       begin
       begin
-        if FNativeFieldType = 'T' then
-          FSize := 14
-        else
-          FSize := 8;
+        FSize := 30;
         FPrecision := 0;
         FPrecision := 0;
       end;
       end;
   end; // case fieldtype
   end; // case fieldtype
+
+  // set sizes for fields that are restricted to single size/precision
+  CheckSizePrecision;
 end;
 end;
 
 
 procedure TDbfFieldDef.CheckSizePrecision;
 procedure TDbfFieldDef.CheckSizePrecision;
@@ -475,8 +473,9 @@ begin
       end;
       end;
     'N','F':
     'N','F':
       begin
       begin
-        if FSize < 1       then FSize := 0;
-        if FSize >= 20     then FSize := 20;
+        // floating point
+        if FSize < 2   then FSize := 2;
+        if FSize >= 20 then FSize := 20;
         if FPrecision > FSize-2 then FPrecision := FSize-2;
         if FPrecision > FSize-2 then FPrecision := FSize-2;
         if FPrecision < 0       then FPrecision := 0;
         if FPrecision < 0       then FPrecision := 0;
       end;
       end;
@@ -502,7 +501,10 @@ begin
       end;
       end;
     'T':
     'T':
       begin
       begin
-        FSize := 14;
+        if DbfVersion = xFoxPro then
+          FSize := 8
+        else
+          FSize := 14;
         FPrecision := 0;
         FPrecision := 0;
       end;
       end;
     'Y':
     'Y':

+ 5 - 74
fcl/db/dbase/Dbf_IdxCur.pas → fcl/db/dbase/dbf_idxcur.pas

@@ -1,6 +1,4 @@
-unit Dbf_IdxCur;
-
-{force CR/LF fix}
+unit dbf_idxcur;
 
 
 interface
 interface
 
 
@@ -38,20 +36,13 @@ type
     procedure First; override;
     procedure First; override;
     procedure Last; override;
     procedure Last; override;
 
 
-    procedure GotoBookmark(Bookmark: rBookmarkData); override;
-    function  GetBookMark: rBookmarkData; override;
-
-    procedure Insert(RecNo: Integer; Buffer: PChar); override;
-    procedure Update(RecNo: Integer; PrevBuffer, NewBuffer: PChar); override;
+    procedure Insert(RecNo: Integer; Buffer: PChar);
+    procedure Update(RecNo: Integer; PrevBuffer, NewBuffer: PChar);
 
 
 {$ifdef SUPPORT_VARIANTS}
 {$ifdef SUPPORT_VARIANTS}
-    procedure VariantToBuffer(Key: Variant; ABuffer: PChar); { override; }
+    procedure VariantToBuffer(Key: Variant; ABuffer: PChar);
 {$endif}
 {$endif}
-    function  CheckUserKey(Key: PChar; StringBuf: PChar): PChar; { override; }
-    function  SearchKey(Key: PChar; SearchType: TSearchKeyType): Boolean; { override; }
-    procedure CancelRange; { override; }
-    procedure SetBracketLow; { override;}
-    procedure SetBracketHigh; { override; }
+    function  CheckUserKey(Key: PChar; StringBuf: PChar): PChar;
 
 
     property IndexFile: TIndexFile read FIndexFile;
     property IndexFile: TIndexFile read FIndexFile;
   end;
   end;
@@ -135,31 +126,6 @@ begin
   TIndexFile(PagedFile).SequentialRecNo := RecNo;
   TIndexFile(PagedFile).SequentialRecNo := RecNo;
 end;
 end;
 
 
-procedure TIndexCursor.GotoBookmark(Bookmark: rBookmarkData);
-begin
-  TIndexFile(PagedFile).GotoBookMark(Bookmark);
-end;
-
-function TIndexCursor.GetBookMark: rBookmarkData;
-begin
-  Result := TIndexFile(PagedFile).GetBookmark;
-end;
-
-procedure TIndexCursor.SetBracketLow;
-begin
-  TIndexFile(PagedFile).SetBracketLow;
-end;
-
-procedure TIndexCursor.SetBracketHigh;
-begin
-  TIndexFile(PagedFile).SetBracketHigh;
-end;
-
-procedure TIndexCursor.CancelRange;
-begin
-  TIndexFile(PagedFile).CancelRange;
-end;
-
 {$ifdef SUPPORT_VARIANTS}
 {$ifdef SUPPORT_VARIANTS}
 
 
 procedure TIndexCursor.VariantToBuffer(Key: Variant; ABuffer: PChar);
 procedure TIndexCursor.VariantToBuffer(Key: Variant; ABuffer: PChar);
@@ -211,40 +177,5 @@ begin
   end;
   end;
 end;
 end;
 
 
-function TIndexCursor.SearchKey(Key: PChar; SearchType: TSearchKeyType): Boolean;
-var
-  findres, currRecNo: Integer;
-begin
-  // save current position
-  currRecNo := TIndexFile(PagedFile).SequentialRecNo;
-  // search, these are always from the root: no need for first
-  findres := TIndexFile(PagedFile).Find(-2, Key);
-  // test result
-  case SearchType of
-    stEqual:
-      Result := findres = 0;
-    stGreaterEqual:
-      Result := findres <= 0;
-    stGreater:
-      begin
-        if findres = 0 then
-        begin
-          // find next record that is greater
-          // NOTE: MatchKey assumes key to search for is already specified
-          //   in FUserKey, it is because we have called Find
-          repeat
-            Result := TIndexFile(PagedFile).Next;
-          until not Result or (TIndexFile(PagedFile).MatchKey <> 0);
-        end else
-          Result := findres < 0;
-      end;
-    else
-      Result := false;
-  end;
-  // search failed -> restore previous position
-  if not Result then
-    TIndexFile(PagedFile).SequentialRecNo := currRecNo;
-end;
-
 end.
 end.
 
 

+ 264 - 148
fcl/db/dbase/Dbf_IdxFile.pas → fcl/db/dbase/dbf_idxfile.pas

@@ -1,4 +1,4 @@
-unit Dbf_IdxFile;
+unit dbf_idxfile;
 
 
 interface
 interface
 
 
@@ -156,7 +156,6 @@ type
     procedure RecalcWeight;
     procedure RecalcWeight;
     procedure UpdateWeight;
     procedure UpdateWeight;
     procedure Flush;
     procedure Flush;
-    procedure DisableRange;
 
 
     property Key: PChar read GetKeyData;
     property Key: PChar read GetKeyData;
     property Entry: Pointer read FEntry;
     property Entry: Pointer read FEntry;
@@ -221,7 +220,7 @@ type
     FIndexHeaders: array[0..MaxIndexes-1] of Pointer;
     FIndexHeaders: array[0..MaxIndexes-1] of Pointer;
     FHeaderModified: array[0..MaxIndexes-1] of Boolean;
     FHeaderModified: array[0..MaxIndexes-1] of Boolean;
     FIndexHeader: Pointer;
     FIndexHeader: Pointer;
-    FIndexVersion: xBaseVersion;
+    FIndexVersion: TXBaseVersion;
     FRoots: array[0..MaxIndexes-1] of TIndexPage;
     FRoots: array[0..MaxIndexes-1] of TIndexPage;
     FLeaves: array[0..MaxIndexes-1] of TIndexPage;
     FLeaves: array[0..MaxIndexes-1] of TIndexPage;
     FCurrentParser: TDbfParser;
     FCurrentParser: TDbfParser;
@@ -240,11 +239,14 @@ type
     FModifyMode: TIndexModifyMode;
     FModifyMode: TIndexModifyMode;
     FHeaderLocked: Integer;   // used to remember which header page we have locked
     FHeaderLocked: Integer;   // used to remember which header page we have locked
     FKeyBuffer: array[0..100] of Char;
     FKeyBuffer: array[0..100] of Char;
+    FLowBuffer: array[0..100] of Char;
+    FHighBuffer: array[0..100] of Char;
     FEntryBof: Pointer;
     FEntryBof: Pointer;
     FEntryEof: Pointer;
     FEntryEof: Pointer;
     FDbfFile: Pointer;
     FDbfFile: Pointer;
     FCanEdit: Boolean;
     FCanEdit: Boolean;
     FOpened: Boolean;
     FOpened: Boolean;
+    FRangeActive: Boolean;
     FUpdateMode: TIndexUpdateMode;
     FUpdateMode: TIndexUpdateMode;
     FUserKey: PChar;        // find / insert key
     FUserKey: PChar;        // find / insert key
     FUserRecNo: Integer;    // find / insert recno
     FUserRecNo: Integer;    // find / insert recno
@@ -269,16 +271,26 @@ type
     procedure ClearRoots;
     procedure ClearRoots;
     function  CalcTagOffset(AIndex: Integer): Pointer;
     function  CalcTagOffset(AIndex: Integer): Pointer;
 
 
-    function  FindKey(const Insert: Boolean): Integer;
+    function  FindKey(Insert: boolean): Integer;
     procedure InsertKey(Buffer: PChar);
     procedure InsertKey(Buffer: PChar);
     procedure DeleteKey(Buffer: PChar);
     procedure DeleteKey(Buffer: PChar);
     procedure InsertCurrent;
     procedure InsertCurrent;
     procedure DeleteCurrent;
     procedure DeleteCurrent;
     procedure UpdateCurrent(PrevBuffer, NewBuffer: PChar);
     procedure UpdateCurrent(PrevBuffer, NewBuffer: PChar);
     procedure ReadIndexes;
     procedure ReadIndexes;
+    procedure Resync(Relative: boolean);
     procedure ResyncRoot;
     procedure ResyncRoot;
     procedure ResyncTree;
     procedure ResyncTree;
+    procedure ResyncRange(KeepPosition: boolean);
+    procedure ResetRange;
+    procedure SetBracketLow;
+    procedure SetBracketHigh;
 
 
+    procedure WalkFirst;
+    procedure WalkLast;
+    function  WalkPrev: boolean;
+    function  WalkNext: boolean;
+    
     procedure TranslateToANSI(Src, Dest: PChar);
     procedure TranslateToANSI(Src, Dest: PChar);
     function  CompareKeyNumericNDX(Key: PChar): Integer;
     function  CompareKeyNumericNDX(Key: PChar): Integer;
     function  CompareKeyNumericMDX(Key: PChar): Integer;
     function  CompareKeyNumericMDX(Key: PChar): Integer;
@@ -330,6 +342,7 @@ type
 
 
     procedure CreateIndex(FieldDesc, TagName: string; Options: TIndexOptions);
     procedure CreateIndex(FieldDesc, TagName: string; Options: TIndexOptions);
     function  ExtractKeyFromBuffer(Buffer: PChar): PChar;
     function  ExtractKeyFromBuffer(Buffer: PChar): PChar;
+    function  SearchKey(Key: PChar; SearchType: TSearchKeyType): Boolean;
     function  Find(RecNo: Integer; Buffer: PChar): Integer;
     function  Find(RecNo: Integer; Buffer: PChar): Integer;
     function  IndexOf(const AIndexName: string): Integer;
     function  IndexOf(const AIndexName: string): Integer;
 
 
@@ -343,19 +356,15 @@ type
     function  Next: Boolean;
     function  Next: Boolean;
     function  Prev: Boolean;
     function  Prev: Boolean;
 
 
-    function  GetBookMark: rBookmarkData;
-    function  GotoBookmark(IndexBookmark: rBookmarkData): Boolean;
-
-    procedure SetBracketLow;
-    procedure SetBracketHigh;
+    procedure SetRange(LowRange, HighRange: PChar);
     procedure CancelRange;
     procedure CancelRange;
-    function  MatchKey: Integer;
+    function  MatchKey(UserKey: PChar): Integer;
     function  CompareKey(Key: PChar): Integer;
     function  CompareKey(Key: PChar): Integer;
     function  CompareKeys(Key1, Key2: PChar): Integer;
     function  CompareKeys(Key1, Key2: PChar): Integer;
     function  PrepareKey(Buffer: PChar; ResultType: TExpressionType): PChar;
     function  PrepareKey(Buffer: PChar; ResultType: TExpressionType): PChar;
 
 
     property KeyLen: Integer read GetKeyLen;
     property KeyLen: Integer read GetKeyLen;
-    property IndexVersion: xBaseVersion read FIndexVersion;
+    property IndexVersion: TXBaseVersion read FIndexVersion;
     property EntryHeaderSize: Integer read FEntryHeaderSize;
     property EntryHeaderSize: Integer read FEntryHeaderSize;
     property KeyType: Char read GetKeyType;
     property KeyType: Char read GetKeyType;
 
 
@@ -828,7 +837,7 @@ function TIndexPage.FindNearest(ARecNo: Integer): Integer;
   //  Result = 0  -> key,recno found, FEntryNo = found key entryno
   //  Result = 0  -> key,recno found, FEntryNo = found key entryno
   //  Result > 0  -> key,recno larger than current entry
   //  Result > 0  -> key,recno larger than current entry
 var
 var
-  recNo, low, high: Integer;
+  low, high, current: Integer;
 begin
 begin
   // implement binary search, keys are sorted
   // implement binary search, keys are sorted
   low := FLowIndex;
   low := FLowIndex;
@@ -845,8 +854,8 @@ begin
   // vf: high + 1 - low
   // vf: high + 1 - low
   while low < high do
   while low < high do
   begin
   begin
-    FEntryNo := (low + high) div 2;
-    FEntry := GetEntry(FEntryNo);
+    current := (low + high) div 2;
+    FEntry := GetEntry(current);
     // calc diff
     // calc diff
     Result := MatchKey;
     Result := MatchKey;
     // test if we need to go lower or higher
     // test if we need to go lower or higher
@@ -854,68 +863,56 @@ begin
     // result = 0 implies key equal to tested entry
     // result = 0 implies key equal to tested entry
     // result > 0 implies key greater than tested entry
     // result > 0 implies key greater than tested entry
     if (Result < 0) or ((ARecNo<>-3) and (Result=0)) then
     if (Result < 0) or ((ARecNo<>-3) and (Result=0)) then
-      high := FEntryNo
+      high := current
     else
     else
-      low := FEntryNo+1;
+      low := current+1;
   end;
   end;
   // high will contain first greater-or-equal key
   // high will contain first greater-or-equal key
   // ARecNo <> -3 -> Entry(high).Key will contain first key that matches    -> go to high
   // ARecNo <> -3 -> Entry(high).Key will contain first key that matches    -> go to high
   // ARecNo =  -3 -> Entry(high).Key will contain first key that is greater -> go to high
   // ARecNo =  -3 -> Entry(high).Key will contain first key that is greater -> go to high
-  recNo := high;
-  if FEntryNo <> recNo then
-  begin
-    FEntryNo := recNo;
-    FEntry := GetEntry(recNo);
-  end;
+  FEntryNo := -1;
+  EntryNo := high;
   // calc end result: can't inspect high if lowerpage <> nil
   // calc end result: can't inspect high if lowerpage <> nil
   // if this is a leaf, we need to find specific recno
   // if this is a leaf, we need to find specific recno
   if (LowerPage = nil) then
   if (LowerPage = nil) then
   begin
   begin
-    // FLowerPage = nil -> can inspect high
-    Result := MatchKey;
-    // test if we need to find a specific recno
-    // result < 0 -> current key greater -> nothing found -> don't search
-    if (ARecNo > 0) then
+    if high > FHighIndex then
     begin
     begin
-      // BLS to RecNo
-      high := FHighIndex + 1;
-      low := FEntryNo;
-      // inv: FLowIndex <= FEntryNo <= high <= FHighIndex + 1 /\
-      // (Ai: FLowIndex <= i < FEntryNo: Entry(i).RecNo <> ARecNo)
-      while FEntryNo <> high do
+      Result := 1;
+    end else begin
+      Result := MatchKey;
+      // test if we need to find a specific recno
+      // result < 0 -> current key greater -> nothing found -> don't search
+      if (ARecNo > 0) then
       begin
       begin
-        // FEntryNo < high, get new entry
-        if low <> FEntryNo then
+        // BLS to RecNo
+        high := FHighIndex + 1;
+        low := FEntryNo;
+        // inv: FLowIndex <= FEntryNo <= high <= FHighIndex + 1 /\
+        // (Ai: FLowIndex <= i < FEntryNo: Entry(i).RecNo <> ARecNo)
+        while FEntryNo <> high do
         begin
         begin
-          FEntry := GetEntry(FEntryNo);
-          // check if entry key still ok
-          Result := MatchKey;
-        end;
-        // get recno of current item
-        recNo := GetRecNo;
-        // test if out of range or found
-        if (Result <> 0) or (recNo = ARecNo) then
-          high := FEntryNo
-        else begin
-          // default to EOF
-          inc(FEntryNo);
-          Result := 1;
+          // FEntryNo < high, get new entry
+          if low <> FEntryNo then
+          begin
+            FEntry := GetEntry(FEntryNo);
+            // check if entry key still ok
+            Result := MatchKey;
+          end;
+          // test if out of range or found recno
+          if (Result <> 0) or (GetRecNo = ARecNo) then
+            high := FEntryNo
+          else begin
+            // default to EOF
+            inc(FEntryNo);
+            Result := 1;
+          end;
         end;
         end;
       end;
       end;
-      // if not found, get EOF entry
-      if (Result <> 0) then
-      begin
-        // Entry(FEntryNo) <> Entry
-        // bypass SetEntryNo check
-        FEntryNo := -1;
-        EntryNo := high;
-      end;
     end;
     end;
   end else begin
   end else begin
     // FLowerPage <> nil -> high contains entry, can not have empty range
     // FLowerPage <> nil -> high contains entry, can not have empty range
     Result := 0;
     Result := 0;
-    // sync lower page
-    SyncLowerPage;
   end;
   end;
 end;
 end;
 
 
@@ -1222,15 +1219,6 @@ begin
   end;
   end;
 end;
 end;
 
 
-procedure TIndexPage.DisableRange;
-begin
-  // update low / high index range
-  FLowIndex := 0;
-  FHighIndex := GetNumEntries;
-  if FLowerPage = nil then
-    dec(FHighIndex);
-end;
-
 function TMdxPage.GetIsInnerNode: Boolean;
 function TMdxPage.GetIsInnerNode: Boolean;
 begin
 begin
   Result := PMdxPage(FPageBuffer).NumEntries < PIndexHdr(FIndexFile.IndexHeader).NumKeys;
   Result := PMdxPage(FPageBuffer).NumEntries < PIndexHdr(FIndexFile.IndexHeader).NumKeys;
@@ -1704,6 +1692,7 @@ begin
 
 
   // clear variables
   // clear variables
   FOpened := false;
   FOpened := false;
+  FRangeActive := false;
   FUpdateMode := umCurrent;
   FUpdateMode := umCurrent;
   FModifyMode := mmNormal;
   FModifyMode := mmNormal;
   FTempMode := TDbfFile(ADbfFile).TempMode;
   FTempMode := TDbfFile(ADbfFile).TempMode;
@@ -2746,6 +2735,9 @@ begin
   end else begin
   end else begin
     InsertKey(Buffer);
     InsertKey(Buffer);
   end;
   end;
+
+  // check range, disabled by insert
+  ResyncRange(true);
 end;
 end;
 
 
 function TIndexFile.CheckKeyViolation(Buffer: PChar): Boolean;
 function TIndexFile.CheckKeyViolation(Buffer: PChar): Boolean;
@@ -2818,14 +2810,20 @@ begin
           begin
           begin
             IntSrc := PInteger(Result)^;
             IntSrc := PInteger(Result)^;
             // handle zero differently: no decimals
             // handle zero differently: no decimals
-            NumDecimals := GetStrFromInt(IntSrc, @FloatRec.Digits[0]);
+            if IntSrc <> 0 then
+              NumDecimals := GetStrFromInt(IntSrc, @FloatRec.Digits[0])
+            else
+              NumDecimals := 0;
             FloatRec.Negative := IntSrc < 0;
             FloatRec.Negative := IntSrc < 0;
           end;
           end;
 {$ifdef SUPPORT_INT64}
 {$ifdef SUPPORT_INT64}
         etLargeInt:
         etLargeInt:
           begin
           begin
             Int64Src := PLargeInt(Result)^;
             Int64Src := PLargeInt(Result)^;
-            NumDecimals := GetStrFromInt64(Int64Src, @FloatRec.Digits[0]);
+            if Int64Src <> 0 then
+              NumDecimals := GetStrFromInt64(Int64Src, @FloatRec.Digits[0])
+            else
+              NumDecimals := 0;
             FloatRec.Negative := Int64Src < 0;
             FloatRec.Negative := Int64Src < 0;
           end;
           end;
 {$endif}
 {$endif}
@@ -2833,7 +2831,10 @@ begin
           begin
           begin
             ExtValue := PDouble(Result)^;
             ExtValue := PDouble(Result)^;
             FloatToDecimal(FloatRec, ExtValue, {$ifndef FPC_VERSION}fvExtended,{$endif} 9999, 15);
             FloatToDecimal(FloatRec, ExtValue, {$ifndef FPC_VERSION}fvExtended,{$endif} 9999, 15);
-            NumDecimals := StrLen(@FloatRec.Digits[0]);
+            if ExtValue <> 0.0 then
+              NumDecimals := StrLen(@FloatRec.Digits[0])
+            else
+              NumDecimals := 0;
             // maximum number of decimals possible to encode in BCD is 16
             // maximum number of decimals possible to encode in BCD is 16
             if NumDecimals > 16 then
             if NumDecimals > 16 then
               NumDecimals := 16;
               NumDecimals := 16;
@@ -2905,7 +2906,6 @@ procedure TIndexFile.InsertCurrent;
   // insert in current index
   // insert in current index
   // assumes: FUserKey is an OEM key
   // assumes: FUserKey is an OEM key
 var
 var
-  TempPage: TIndexPage;
   SearchKey: array[0..100] of Char;
   SearchKey: array[0..100] of Char;
   OemKey: PChar;
   OemKey: PChar;
 begin
 begin
@@ -2920,6 +2920,8 @@ begin
       FUserKey := @SearchKey[0];
       FUserKey := @SearchKey[0];
       TranslateToANSI(OemKey, FUserKey);
       TranslateToANSI(OemKey, FUserKey);
     end;
     end;
+    // temporarily remove range to find correct location of key
+    ResetRange;
     // find this record as closely as possible
     // find this record as closely as possible
     // if result = 0 then key already exists
     // if result = 0 then key already exists
     // if unique index, then don't insert key if already present
     // if unique index, then don't insert key if already present
@@ -2940,13 +2942,6 @@ begin
         InsertError;
         InsertError;
       end;
       end;
     end;
     end;
-
-    // check range, disabled by insert
-    TempPage := FRoot;
-    repeat
-      TempPage.UpdateBounds(TempPage.LowerPage <> nil);
-      TempPage := TempPage.LowerPage;
-    until TempPage = nil;
   end;
   end;
 end;
 end;
 
 
@@ -2980,6 +2975,8 @@ begin
   end else begin
   end else begin
     DeleteKey(Buffer);
     DeleteKey(Buffer);
   end;
   end;
+  // range may be changed
+  ResyncRange(true);
 end;
 end;
 
 
 procedure TIndexFile.DeleteKey(Buffer: PChar);
 procedure TIndexFile.DeleteKey(Buffer: PChar);
@@ -3003,6 +3000,8 @@ begin
   // modify = mmDeleteRecall /\ unique = distinct -> key needs to be deleted from index
   // modify = mmDeleteRecall /\ unique = distinct -> key needs to be deleted from index
   if (FModifyMode <> mmDeleteRecall) or (FUniqueMode = iuDistinct) then
   if (FModifyMode <> mmDeleteRecall) or (FUniqueMode = iuDistinct) then
   begin
   begin
+    // prevent "confined" view of index while deleting
+    ResetRange;
     // search correct entry to delete
     // search correct entry to delete
     if FLeaf.PhysicalRecNo <> FUserRecNo then
     if FLeaf.PhysicalRecNo <> FUserRecNo then
     begin
     begin
@@ -3063,6 +3062,8 @@ begin
       // now set userkey to key to insert
       // now set userkey to key to insert
       FUserKey := @TempBuffer[0];
       FUserKey := @TempBuffer[0];
       InsertCurrent;
       InsertCurrent;
+      // check range, disabled by delete/insert
+      ResyncRange(true);
     end;
     end;
   end;
   end;
 end;
 end;
@@ -3130,6 +3131,41 @@ begin
   FRoot.PageNo := PIndexHdr(FIndexHeader).RootPage;
   FRoot.PageNo := PIndexHdr(FIndexHeader).RootPage;
 end;
 end;
 
 
+function TIndexFile.SearchKey(Key: PChar; SearchType: TSearchKeyType): Boolean;
+var
+  findres, currRecNo: Integer;
+begin
+  // save current position
+  currRecNo := SequentialRecNo;
+  // search, these are always from the root: no need for first
+  findres := Find(-2, Key);
+  // test result
+  case SearchType of
+    stEqual:
+      Result := findres = 0;
+    stGreaterEqual:
+      Result := findres <= 0;
+    stGreater:
+      begin
+        if findres = 0 then
+        begin
+          // find next record that is greater
+          // NOTE: MatchKey assumes key to search for is already specified
+          //   in FUserKey, it is because we have called Find
+          repeat
+            Result := WalkNext;
+          until not Result or (MatchKey(Key) <> 0);
+        end else
+          Result := findres < 0;
+      end;
+    else
+      Result := false;
+  end;
+  // search failed -> restore previous position
+  if not Result then
+    SequentialRecNo := currRecNo;
+end;
+
 function TIndexFile.Find(RecNo: Integer; Buffer: PChar): Integer;
 function TIndexFile.Find(RecNo: Integer; Buffer: PChar): Integer;
 begin
 begin
   // execute find
   // execute find
@@ -3138,7 +3174,7 @@ begin
   Result := FindKey(false);
   Result := FindKey(false);
 end;
 end;
 
 
-function TIndexFile.FindKey(const Insert: Boolean): Integer;
+function TIndexFile.FindKey(Insert: boolean): Integer;
 //
 //
 // if you set Insert = true, you need to re-enable range after insert!!
 // if you set Insert = true, you need to re-enable range after insert!!
 //
 //
@@ -3162,16 +3198,6 @@ begin
   end else begin
   end else begin
     searchRecNo := -2;
     searchRecNo := -2;
   end;
   end;
-  // disable range to prepare for insert
-  if Insert then
-  begin
-    // start from root
-    TempPage := FRoot;
-    repeat
-      TempPage.DisableRange;
-      TempPage := TempPage.LowerPage;
-    until TempPage = nil;
-  end;
   // start from root
   // start from root
   TempPage := FRoot;
   TempPage := FRoot;
   repeat
   repeat
@@ -3236,7 +3262,7 @@ begin
   until done = 0;
   until done = 0;
 end;
 end;
 
 
-function TIndexFile.MatchKey: Integer;
+function TIndexFile.MatchKey(UserKey: PChar): Integer;
 begin
 begin
   // BOF and EOF always false
   // BOF and EOF always false
   if FLeaf.Entry = FEntryBof then
   if FLeaf.Entry = FEntryBof then
@@ -3244,8 +3270,18 @@ begin
   else
   else
   if FLeaf.Entry = FEntryEof then
   if FLeaf.Entry = FEntryEof then
     Result := -1
     Result := -1
-  else
+  else begin
+    FUserKey := UserKey;
     Result := FLeaf.MatchKey;
     Result := FLeaf.MatchKey;
+  end;
+end;
+
+procedure TIndexFile.SetRange(LowRange, HighRange: PChar);
+begin
+  Move(LowRange^, FLowBuffer[0], KeyLen);
+  Move(HighRange^, FHighBuffer[0], KeyLen);
+  FRangeActive := true;
+  ResyncRange(true);
 end;
 end;
 
 
 procedure TIndexFile.RecordDeleted(RecNo: Integer; Buffer: PChar);
 procedure TIndexFile.RecordDeleted(RecNo: Integer; Buffer: PChar);
@@ -3264,20 +3300,6 @@ begin
   FModifyMode := mmNormal;
   FModifyMode := mmNormal;
 end;
 end;
 
 
-function TIndexFile.GotoBookmark(IndexBookmark: rBookmarkData): Boolean;
-begin
-  if (IndexBookmark{.RecNo} = 0) then begin
-    First;
-  end else if (IndexBookmark{.RecNo} = MAXINT) then begin
-    Last;
-  end else begin
-    if (FLeaf.GetRecNo <> IndexBookmark{.RecNo}) then
-      PhysicalRecNo := IndexBookmark{.RecNo};
-  end;
-
-  Result := true;
-end;
-
 procedure TIndexFile.SetLocaleID(const NewID: LCID);
 procedure TIndexFile.SetLocaleID(const NewID: LCID);
 {$ifdef WIN32}
 {$ifdef WIN32}
 var
 var
@@ -3302,16 +3324,20 @@ end;
 
 
 procedure TIndexFile.SetPhysicalRecNo(RecNo: Integer);
 procedure TIndexFile.SetPhysicalRecNo(RecNo: Integer);
 begin
 begin
-  // read buffer of this RecNo
-  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);
+  // check record actually exists
+  if TDbfFile(FDbfFile).IsRecordPresent(RecNo) then
+  begin
+    // read buffer of this RecNo
+    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);
+  end;
 end;
 end;
 
 
 procedure TIndexFile.SetUpdateMode(NewMode: TIndexUpdateMode);
 procedure TIndexFile.SetUpdateMode(NewMode: TIndexUpdateMode);
@@ -3323,28 +3349,16 @@ begin
     FUpdateMode := NewMode;
     FUpdateMode := NewMode;
 end;
 end;
 
 
-function TIndexFile.GetBookMark: rBookmarkData;
+procedure TIndexFile.WalkFirst;
 begin
 begin
-  // get physical recno
-  Result := FLeaf.GetRecNo;
-end;
-
-procedure TIndexFile.First;
-begin
-  // resync tree
-  if NeedLocks then
-    ResyncRoot;
   // search first node
   // search first node
   FRoot.RecurFirst;
   FRoot.RecurFirst;
   // out of index - BOF
   // out of index - BOF
   FLeaf.EntryNo := FLeaf.EntryNo - 1;
   FLeaf.EntryNo := FLeaf.EntryNo - 1;
 end;
 end;
 
 
-procedure TIndexFile.Last;
+procedure TIndexFile.WalkLast;
 begin
 begin
-  // resync tree
-  if NeedLocks then
-    ResyncRoot;
   // search last node
   // search last node
   FRoot.RecurLast;
   FRoot.RecurLast;
   // out of index - EOF
   // out of index - EOF
@@ -3352,40 +3366,125 @@ begin
   FLeaf.EntryNo := FLeaf.EntryNo + 2;
   FLeaf.EntryNo := FLeaf.EntryNo + 2;
 end;
 end;
 
 
+procedure TIndexFile.First;
+begin
+  // resync tree
+  Resync(false);
+  WalkFirst;
+end;
+
+procedure TIndexFile.Last;
+begin
+  // resync tree
+  Resync(false);
+  WalkLast;
+end;
+
+procedure TIndexFile.ResyncRange(KeepPosition: boolean);
+var
+  Result: Boolean;
+  currRecNo: integer;
+begin
+  if not FRangeActive then
+    exit;
+
+  // disable current range if any
+  if KeepPosition then
+    currRecNo := SequentialRecNo;
+  ResetRange;
+  // search lower bound
+  Result := SearchKey(FLowBuffer, stGreaterEqual);
+  if not Result then
+  begin
+    // not found? -> make empty range
+    WalkLast;
+  end;
+  // set lower bound
+  SetBracketLow;
+  // search upper bound
+  Result := SearchKey(FHighBuffer, stGreater);
+  // if result true, then need to get previous item <=>
+  //    last of equal/lower than key
+  if Result then
+  begin
+    Result := WalkPrev;
+    if not Result then
+    begin
+      // cannot go prev -> empty range
+      WalkFirst;
+    end;
+  end else begin
+    // not found -> EOF found, go EOF, then to last record
+    WalkLast;
+    WalkPrev;
+  end;
+  // set upper bound
+  SetBracketHigh;
+  if KeepPosition then
+    SequentialRecNo := currRecNo;
+end;
+
+procedure TIndexFile.Resync(Relative: boolean);
+begin
+  if NeedLocks then
+  begin
+    if not Relative then
+    begin
+      ResyncRoot;
+      ResyncRange(false);
+    end else begin
+      // resyncing tree implies resyncing range
+      ResyncTree;
+    end;
+  end;
+end;
+
 procedure TIndexFile.ResyncTree;
 procedure TIndexFile.ResyncTree;
+var
+  action, recno: integer;
 begin
 begin
   // if at BOF or EOF, then we need to resync by first or last
   // if at BOF or EOF, then we need to resync by first or last
+  // remember where the cursor was
   if FLeaf.Entry = FEntryBof then
   if FLeaf.Entry = FEntryBof then
   begin
   begin
-    First;
+    action := 0;
   end else if FLeaf.Entry = FEntryEof then begin
   end else if FLeaf.Entry = FEntryEof then begin
-    Last;
+    action := 1;
   end else begin
   end else begin
     // read current key into buffer
     // read current key into buffer
     Move(FLeaf.Key^, FKeyBuffer, PIndexHdr(FIndexHeader).KeyLen);
     Move(FLeaf.Key^, FKeyBuffer, PIndexHdr(FIndexHeader).KeyLen);
-    // search current in-mem key on disk
-    FUserKey := FKeyBuffer;
-    FUserRecNo := FLeaf.PhysicalRecNo;
     // translate to searchable key
     // translate to searchable key
     if KeyType = 'C' then
     if KeyType = 'C' then
-      TranslateToANSI(FUserKey, FUserKey);
-    if (FindKey(false) <> 0) then
+      TranslateToANSI(FKeyBuffer, FKeyBuffer);
+    recno := FLeaf.PhysicalRecNo;
+    action := 2;
+  end;
+
+  // we now know cursor position, resync possible range
+  ResyncRange(false);
+  
+  // go to cursor position
+  case action of
+    0: WalkFirst;
+    1: WalkLast;
+    2:
     begin
     begin
-      // houston, we've got a problem!
-      // our `current' record has gone. we need to find it
-      // find it by using physical recno
-      PhysicalRecNo := FUserRecNo;
+      // search current in-mem key on disk
+      if (Find(recno, FKeyBuffer) <> 0) then
+      begin
+        // houston, we've got a problem!
+        // our `current' record has gone. we need to find it
+        // find it by using physical recno
+        PhysicalRecNo := recno;
+      end;
     end;
     end;
   end;
   end;
 end;
 end;
 
 
-function TIndexFile.Prev: Boolean;
+function TIndexFile.WalkPrev: boolean;
 var
 var
   curRecNo: Integer;
   curRecNo: Integer;
 begin
 begin
-  // resync in-mem tree with tree on disk
-  if NeedLocks then
-    ResyncTree;
   // save current recno, find different next!
   // save current recno, find different next!
   curRecNo := FLeaf.PhysicalRecNo;
   curRecNo := FLeaf.PhysicalRecNo;
   repeat
   repeat
@@ -3394,13 +3493,10 @@ begin
   until not Result or (curRecNo <> FLeaf.PhysicalRecNo);
   until not Result or (curRecNo <> FLeaf.PhysicalRecNo);
 end;
 end;
 
 
-function TIndexFile.Next: Boolean;
+function TIndexFile.WalkNext: boolean;
 var
 var
   curRecNo: Integer;
   curRecNo: Integer;
 begin
 begin
-  // resync in-mem tree with tree on disk
-  if NeedLocks then
-    ResyncTree;
   // save current recno, find different prev!
   // save current recno, find different prev!
   curRecNo := FLeaf.PhysicalRecNo;
   curRecNo := FLeaf.PhysicalRecNo;
   repeat
   repeat
@@ -3409,6 +3505,20 @@ begin
   until not Result or (curRecNo <> FLeaf.PhysicalRecNo);
   until not Result or (curRecNo <> FLeaf.PhysicalRecNo);
 end;
 end;
 
 
+function TIndexFile.Prev: Boolean;
+begin
+  // resync in-mem tree with tree on disk
+  Resync(true);
+  Result := WalkPrev;
+end;
+
+function TIndexFile.Next: Boolean;
+begin
+  // resync in-mem tree with tree on disk
+  Resync(true);
+  Result := WalkNext;
+end;
+
 function TIndexFile.GetKeyLen: Integer;
 function TIndexFile.GetKeyLen: Integer;
 begin
 begin
   Result := PIndexHdr(FIndexHeader).KeyLen;
   Result := PIndexHdr(FIndexHeader).KeyLen;
@@ -3514,6 +3624,12 @@ begin
 end;
 end;
 
 
 procedure TIndexFile.CancelRange;
 procedure TIndexFile.CancelRange;
+begin
+  FRangeActive := false;
+  ResetRange;
+end;
+
+procedure TIndexFile.ResetRange;
 var
 var
   TempPage: TIndexPage;
   TempPage: TIndexPage;
 begin
 begin

+ 1 - 3
fcl/db/dbase/Dbf_Lang.pas → fcl/db/dbase/dbf_lang.pas

@@ -1,6 +1,4 @@
-unit Dbf_Lang;
-
-{force CR/LF fix}
+unit dbf_lang;
 
 
 {$i Dbf_Common.inc}
 {$i Dbf_Common.inc}
 
 

+ 13 - 9
fcl/db/dbase/Dbf_Memo.pas → fcl/db/dbase/dbf_memo.pas

@@ -1,4 +1,4 @@
-unit Dbf_Memo;
+unit dbf_memo;
 
 
 interface
 interface
 
 
@@ -14,7 +14,8 @@ type
 //====================================================================
 //====================================================================
   TMemoFile = class(TPagedFile)
   TMemoFile = class(TPagedFile)
   protected
   protected
-    FDbfVersion: xBaseVersion;
+    FDbfFile: pointer;
+    FDbfVersion: TXBaseVersion;
     FMemoRecordSize: Integer;
     FMemoRecordSize: Integer;
     FOpened: Boolean;
     FOpened: Boolean;
     FBuffer: PChar;
     FBuffer: PChar;
@@ -25,7 +26,7 @@ type
     procedure SetNextFreeBlock(BlockNo: Integer); virtual; abstract;
     procedure SetNextFreeBlock(BlockNo: Integer); virtual; abstract;
     procedure SetBlockLen(BlockLen: Integer); virtual; abstract;
     procedure SetBlockLen(BlockLen: Integer); virtual; abstract;
   public
   public
-    constructor Create;
+    constructor Create(ADbfFile: pointer);
     destructor Destroy; override;
     destructor Destroy; override;
 
 
     procedure Open;
     procedure Open;
@@ -34,7 +35,7 @@ type
     procedure ReadMemo(BlockNo: Integer; DestStream: TStream);
     procedure ReadMemo(BlockNo: Integer; DestStream: TStream);
     procedure WriteMemo(var BlockNo: Integer; ReadSize: Integer; Src: TStream);
     procedure WriteMemo(var BlockNo: Integer; ReadSize: Integer; Src: TStream);
 
 
-    property DbfVersion: xBaseVersion read FDbfVersion write FDbfVersion;
+    property DbfVersion: TXBaseVersion read FDbfVersion write FDbfVersion;
     property MemoRecordSize: Integer read FMemoRecordSize write FMemoRecordSize;
     property MemoRecordSize: Integer read FMemoRecordSize write FMemoRecordSize;
   end;
   end;
 
 
@@ -79,7 +80,7 @@ type
     procedure SetBlockLen(BlockLen: Integer); override;
     procedure SetBlockLen(BlockLen: Integer); override;
 
 
   public
   public
-    constructor Create;
+    constructor Create(ADbfFile: pointer);
 
 
     procedure CloseFile; override;
     procedure CloseFile; override;
     procedure OpenFile; override;
     procedure OpenFile; override;
@@ -94,7 +95,7 @@ type
 implementation
 implementation
 
 
 uses
 uses
-  SysUtils;
+  SysUtils, Dbf_DbfFile;
 
 
 //====================================================================
 //====================================================================
 //=== Memo and binary fields support
 //=== Memo and binary fields support
@@ -130,14 +131,17 @@ type
 //==========================================================
 //==========================================================
 //============ Dbtfile
 //============ Dbtfile
 //==========================================================
 //==========================================================
-constructor TMemoFile.Create;
+constructor TMemoFile.Create(ADbfFile: pointer);
 begin
 begin
   // init vars
   // init vars
   FBuffer := nil;
   FBuffer := nil;
   FOpened := false;
   FOpened := false;
 
 
   // call inherited
   // call inherited
-  inherited;
+  inherited Create;
+
+  FDbfFile := ADbfFile;
+  FTempMode := TDbfFile(ADbfFile).TempMode;
 end;
 end;
 
 
 destructor TMemoFile.Destroy;
 destructor TMemoFile.Destroy;
@@ -478,7 +482,7 @@ end;
 // NULL file (no file) specific helper routines
 // NULL file (no file) specific helper routines
 // ------------------------------------------------------------------
 // ------------------------------------------------------------------
 
 
-constructor TNullMemoFile.Create;
+constructor TNullMemoFile.Create(ADbfFile: pointer);
 begin
 begin
   inherited;
   inherited;
 end;
 end;

+ 380 - 20
fcl/db/dbase/Dbf_Parser.pas → fcl/db/dbase/dbf_parser.pas

@@ -1,4 +1,4 @@
-unit Dbf_Parser;
+unit dbf_parser;
 
 
 interface
 interface
 
 
@@ -31,6 +31,7 @@ type
     FFieldType: TExpressionType;
     FFieldType: TExpressionType;
     FCaseInsensitive: Boolean;
     FCaseInsensitive: Boolean;
     FRawStringFields: Boolean;
     FRawStringFields: Boolean;
+    FPartialMatch: boolean;
 
 
   protected
   protected
     FCurrentExpression: string;
     FCurrentExpression: string;
@@ -43,6 +44,7 @@ type
 
 
     procedure SetCaseInsensitive(NewInsensitive: Boolean);
     procedure SetCaseInsensitive(NewInsensitive: Boolean);
     procedure SetRawStringFields(NewRawFields: Boolean);
     procedure SetRawStringFields(NewRawFields: Boolean);
+    procedure SetPartialMatch(NewPartialMatch: boolean);
   public
   public
     constructor Create(ADbfFile: Pointer);
     constructor Create(ADbfFile: Pointer);
     destructor Destroy; override;
     destructor Destroy; override;
@@ -58,6 +60,7 @@ type
 
 
     property CaseInsensitive: Boolean read FCaseInsensitive write SetCaseInsensitive;
     property CaseInsensitive: Boolean read FCaseInsensitive write SetCaseInsensitive;
     property RawStringFields: Boolean read FRawStringFields write SetRawStringFields;
     property RawStringFields: Boolean read FRawStringFields write SetRawStringFields;
+    property PartialMatch: boolean read FPartialMatch write SetPartialMatch;
   end;
   end;
 
 
 //--Expression functions-----------------------------------------------------
 //--Expression functions-----------------------------------------------------
@@ -80,6 +83,39 @@ procedure FuncAdd_F_LL(Param: PExpressionRec);
 procedure FuncAdd_F_LF(Param: PExpressionRec);
 procedure FuncAdd_F_LF(Param: PExpressionRec);
 procedure FuncAdd_F_LI(Param: PExpressionRec);
 procedure FuncAdd_F_LI(Param: PExpressionRec);
 {$endif}
 {$endif}
+procedure FuncSub_F_FF(Param: PExpressionRec);
+procedure FuncSub_F_FI(Param: PExpressionRec);
+procedure FuncSub_F_II(Param: PExpressionRec);
+procedure FuncSub_F_IF(Param: PExpressionRec);
+{$ifdef SUPPORT_INT64}
+procedure FuncSub_F_FL(Param: PExpressionRec);
+procedure FuncSub_F_IL(Param: PExpressionRec);
+procedure FuncSub_F_LL(Param: PExpressionRec);
+procedure FuncSub_F_LF(Param: PExpressionRec);
+procedure FuncSub_F_LI(Param: PExpressionRec);
+{$endif}
+procedure FuncMul_F_FF(Param: PExpressionRec);
+procedure FuncMul_F_FI(Param: PExpressionRec);
+procedure FuncMul_F_II(Param: PExpressionRec);
+procedure FuncMul_F_IF(Param: PExpressionRec);
+{$ifdef SUPPORT_INT64}
+procedure FuncMul_F_FL(Param: PExpressionRec);
+procedure FuncMul_F_IL(Param: PExpressionRec);
+procedure FuncMul_F_LL(Param: PExpressionRec);
+procedure FuncMul_F_LF(Param: PExpressionRec);
+procedure FuncMul_F_LI(Param: PExpressionRec);
+{$endif}
+procedure FuncDiv_F_FF(Param: PExpressionRec);
+procedure FuncDiv_F_FI(Param: PExpressionRec);
+procedure FuncDiv_F_II(Param: PExpressionRec);
+procedure FuncDiv_F_IF(Param: PExpressionRec);
+{$ifdef SUPPORT_INT64}
+procedure FuncDiv_F_FL(Param: PExpressionRec);
+procedure FuncDiv_F_IL(Param: PExpressionRec);
+procedure FuncDiv_F_LL(Param: PExpressionRec);
+procedure FuncDiv_F_LF(Param: PExpressionRec);
+procedure FuncDiv_F_LI(Param: PExpressionRec);
+{$endif}
 procedure FuncStrI_EQ(Param: PExpressionRec);
 procedure FuncStrI_EQ(Param: PExpressionRec);
 procedure FuncStrI_NEQ(Param: PExpressionRec);
 procedure FuncStrI_NEQ(Param: PExpressionRec);
 procedure FuncStrI_LT(Param: PExpressionRec);
 procedure FuncStrI_LT(Param: PExpressionRec);
@@ -548,7 +584,7 @@ begin
     dest := (Res.MemoryPos)^;
     dest := (Res.MemoryPos)^;
     Res.Append(Args[0], StrLen(Args[0]));
     Res.Append(Args[0], StrLen(Args[0]));
     // make uppercase
     // make uppercase
-    StrUpper(dest);
+    AnsiStrUpper(dest);
   end;
   end;
 end;
 end;
 
 
@@ -562,7 +598,7 @@ begin
     dest := (Res.MemoryPos)^;
     dest := (Res.MemoryPos)^;
     Res.Append(Args[0], StrLen(Args[0]));
     Res.Append(Args[0], StrLen(Args[0]));
     // make lowercase
     // make lowercase
-    StrLower(dest);
+    AnsiStrLower(dest);
   end;
   end;
 end;
 end;
 
 
@@ -624,12 +660,224 @@ end;
 
 
 {$endif}
 {$endif}
 
 
+procedure FuncSub_F_FF(Param: PExpressionRec);
+begin
+  with Param^ do
+    PDouble(Res.MemoryPos^)^ := PDouble(Args[0])^ - PDouble(Args[1])^;
+end;
+
+procedure FuncSub_F_FI(Param: PExpressionRec);
+begin
+  with Param^ do
+    PDouble(Res.MemoryPos^)^ := PDouble(Args[0])^ - PInteger(Args[1])^;
+end;
+
+procedure FuncSub_F_II(Param: PExpressionRec);
+begin
+  with Param^ do
+    PInteger(Res.MemoryPos^)^ := PInteger(Args[0])^ - PInteger(Args[1])^;
+end;
+
+procedure FuncSub_F_IF(Param: PExpressionRec);
+begin
+  with Param^ do
+    PDouble(Res.MemoryPos^)^ := PInteger(Args[0])^ - PDouble(Args[1])^;
+end;
+
+{$ifdef SUPPORT_INT64}
+
+procedure FuncSub_F_FL(Param: PExpressionRec);
+begin
+  with Param^ do
+    PDouble(Res.MemoryPos^)^ := PDouble(Args[0])^ - PInt64(Args[1])^;
+end;
+
+procedure FuncSub_F_IL(Param: PExpressionRec);
+begin
+  with Param^ do
+    PInt64(Res.MemoryPos^)^ := PInteger(Args[0])^ - PInt64(Args[1])^;
+end;
+
+procedure FuncSub_F_LL(Param: PExpressionRec);
+begin
+  with Param^ do
+    PInt64(Res.MemoryPos^)^ := PInt64(Args[0])^ - PInt64(Args[1])^;
+end;
+
+procedure FuncSub_F_LF(Param: PExpressionRec);
+begin
+  with Param^ do
+    PDouble(Res.MemoryPos^)^ := PInt64(Args[0])^ - PDouble(Args[1])^;
+end;
+
+procedure FuncSub_F_LI(Param: PExpressionRec);
+begin
+  with Param^ do
+    PInt64(Res.MemoryPos^)^ := PInt64(Args[0])^ - PInteger(Args[1])^;
+end;
+
+{$endif}
+
+procedure FuncMul_F_FF(Param: PExpressionRec);
+begin
+  with Param^ do
+    PDouble(Res.MemoryPos^)^ := PDouble(Args[0])^ * PDouble(Args[1])^;
+end;
+
+procedure FuncMul_F_FI(Param: PExpressionRec);
+begin
+  with Param^ do
+    PDouble(Res.MemoryPos^)^ := PDouble(Args[0])^ * PInteger(Args[1])^;
+end;
+
+procedure FuncMul_F_II(Param: PExpressionRec);
+begin
+  with Param^ do
+    PInteger(Res.MemoryPos^)^ := PInteger(Args[0])^ * PInteger(Args[1])^;
+end;
+
+procedure FuncMul_F_IF(Param: PExpressionRec);
+begin
+  with Param^ do
+    PDouble(Res.MemoryPos^)^ := PInteger(Args[0])^ * PDouble(Args[1])^;
+end;
+
+{$ifdef SUPPORT_INT64}
+
+procedure FuncMul_F_FL(Param: PExpressionRec);
+begin
+  with Param^ do
+    PDouble(Res.MemoryPos^)^ := PDouble(Args[0])^ * PInt64(Args[1])^;
+end;
+
+procedure FuncMul_F_IL(Param: PExpressionRec);
+begin
+  with Param^ do
+    PInt64(Res.MemoryPos^)^ := PInteger(Args[0])^ * PInt64(Args[1])^;
+end;
+
+procedure FuncMul_F_LL(Param: PExpressionRec);
+begin
+  with Param^ do
+    PInt64(Res.MemoryPos^)^ := PInt64(Args[0])^ * PInt64(Args[1])^;
+end;
+
+procedure FuncMul_F_LF(Param: PExpressionRec);
+begin
+  with Param^ do
+    PDouble(Res.MemoryPos^)^ := PInt64(Args[0])^ * PDouble(Args[1])^;
+end;
+
+procedure FuncMul_F_LI(Param: PExpressionRec);
+begin
+  with Param^ do
+    PInt64(Res.MemoryPos^)^ := PInt64(Args[0])^ * PInteger(Args[1])^;
+end;
+
+{$endif}
+
+procedure FuncDiv_F_FF(Param: PExpressionRec);
+begin
+  with Param^ do
+    PDouble(Res.MemoryPos^)^ := PDouble(Args[0])^ / PDouble(Args[1])^;
+end;
+
+procedure FuncDiv_F_FI(Param: PExpressionRec);
+begin
+  with Param^ do
+    PDouble(Res.MemoryPos^)^ := PDouble(Args[0])^ / PInteger(Args[1])^;
+end;
+
+procedure FuncDiv_F_II(Param: PExpressionRec);
+begin
+  with Param^ do
+    PInteger(Res.MemoryPos^)^ := PInteger(Args[0])^ div PInteger(Args[1])^;
+end;
+
+procedure FuncDiv_F_IF(Param: PExpressionRec);
+begin
+  with Param^ do
+    PDouble(Res.MemoryPos^)^ := PInteger(Args[0])^ / PDouble(Args[1])^;
+end;
+
+{$ifdef SUPPORT_INT64}
+
+procedure FuncDiv_F_FL(Param: PExpressionRec);
+begin
+  with Param^ do
+    PDouble(Res.MemoryPos^)^ := PDouble(Args[0])^ / PInt64(Args[1])^;
+end;
+
+procedure FuncDiv_F_IL(Param: PExpressionRec);
+begin
+  with Param^ do
+    PInt64(Res.MemoryPos^)^ := PInteger(Args[0])^ div PInt64(Args[1])^;
+end;
+
+procedure FuncDiv_F_LL(Param: PExpressionRec);
+begin
+  with Param^ do
+    PInt64(Res.MemoryPos^)^ := PInt64(Args[0])^ div PInt64(Args[1])^;
+end;
+
+procedure FuncDiv_F_LF(Param: PExpressionRec);
+begin
+  with Param^ do
+    PDouble(Res.MemoryPos^)^ := PInt64(Args[0])^ / PDouble(Args[1])^;
+end;
+
+procedure FuncDiv_F_LI(Param: PExpressionRec);
+begin
+  with Param^ do
+    PInt64(Res.MemoryPos^)^ := PInt64(Args[0])^ div PInteger(Args[1])^;
+end;
+
+{$endif}
+
 procedure FuncStrI_EQ(Param: PExpressionRec);
 procedure FuncStrI_EQ(Param: PExpressionRec);
 begin
 begin
   with Param^ do
   with Param^ do
     Res.MemoryPos^^ := Char(AnsiStrIComp(Args[0], Args[1]) = 0);
     Res.MemoryPos^^ := Char(AnsiStrIComp(Args[0], Args[1]) = 0);
 end;
 end;
 
 
+procedure FuncStrIP_EQ(Param: PExpressionRec);
+var
+  arg0len, arg1len: integer;
+  match: boolean;
+  str0, str1: string;
+begin
+  with Param^ do
+  begin
+    arg1len := StrLen(Args[1]);
+    if Args[1][0] = '*' then
+    begin
+      if Args[1][arg1len-1] = '*' then
+      begin
+        str0 := AnsiStrUpper(Args[0]);
+        str1 := AnsiStrUpper(Args[1]+1);
+        setlength(str1, arg1len-2);
+        match := AnsiPos(str0, str1) = 0;
+      end else begin
+        arg0len := StrLen(Args[0]);
+        // at least length without asterisk
+        match := arg0len >= arg1len - 1;
+        if match then
+          match := AnsiStrLIComp(Args[0]+(arg0len-arg1len+1), Args[1]+1, arg1len-1) = 0;
+      end;
+    end else
+    if Args[1][arg1len-1] = '*' then
+    begin
+      arg0len := StrLen(Args[0]);
+      match := arg1len >= arg0len - 1;
+      if match then
+        match := AnsiStrLIComp(Args[0], Args[1], arg1len-1) = 0;
+    end else begin
+      match := AnsiStrIComp(Args[0], Args[1]) = 0;
+    end;
+    Res.MemoryPos^^ := Char(match);
+  end;
+end;
+
 procedure FuncStrI_NEQ(Param: PExpressionRec);
 procedure FuncStrI_NEQ(Param: PExpressionRec);
 begin
 begin
   with Param^ do
   with Param^ do
@@ -660,6 +908,42 @@ begin
     Res.MemoryPos^^ := Char(AnsiStrIComp(Args[0], Args[1]) >= 0);
     Res.MemoryPos^^ := Char(AnsiStrIComp(Args[0], Args[1]) >= 0);
 end;
 end;
 
 
+procedure FuncStrP_EQ(Param: PExpressionRec);
+var
+  arg0len, arg1len: integer;
+  match: boolean;
+begin
+  with Param^ do
+  begin
+    arg1len := StrLen(Args[1]);
+    if Args[1][0] = '*' then
+    begin
+      if Args[1][arg1len-1] = '*' then
+      begin
+        Args[1][arg1len-1] := #0;
+        match := AnsiStrPos(Args[0], Args[1]+1) <> nil;
+        Args[1][arg1len-1] := '*';
+      end else begin
+        arg0len := StrLen(Args[0]);
+        // at least length without asterisk
+        match := arg0len >= arg1len - 1;
+        if match then
+          match := AnsiStrLComp(Args[0]+(arg0len-arg1len+1), Args[1]+1, arg1len-1) = 0;
+      end;
+    end else
+    if Args[1][arg1len-1] = '*' then
+    begin
+      arg0len := StrLen(Args[0]);
+      match := arg1len >= arg0len - 1;
+      if match then
+        match := AnsiStrLComp(Args[0], Args[1], arg1len-1) = 0;
+    end else begin
+      match := AnsiStrComp(Args[0], Args[1]) = 0;
+    end;
+    Res.MemoryPos^^ := Char(match);
+  end;
+end;
+
 procedure FuncStr_EQ(Param: PExpressionRec);
 procedure FuncStr_EQ(Param: PExpressionRec);
 begin
 begin
   with Param^ do
   with Param^ do
@@ -1045,8 +1329,10 @@ end;
 //--TDbfParser---------------------------------------------------------------
 //--TDbfParser---------------------------------------------------------------
 
 
 var
 var
-  DbfWordsSensList, DbfWordsInsensList: TExpressList;
-  DbfWordsAllList: TExpressList;
+  DbfWordsSensGeneralList, DbfWordsInsensGeneralList: TExpressList;
+  DbfWordsSensPartialList, DbfWordsInsensPartialList: TExpressList;
+  DbfWordsSensNoPartialList, DbfWordsInsensNoPartialList: TExpressList;
+  DbfWordsGeneralList: TExpressList;
 
 
 constructor TDbfParser.Create(ADbfFile: Pointer);
 constructor TDbfParser.Create(ADbfFile: Pointer);
 begin
 begin
@@ -1085,6 +1371,18 @@ begin
   end;
   end;
 end;
 end;
 
 
+procedure TDbfParser.SetPartialMatch(NewPartialMatch: boolean);
+begin
+  if FPartialMatch <> NewPartialMatch then
+  begin
+    // refill function list
+    FPartialMatch := NewPartialMatch;
+    FillExpressList;
+    if Length(Expression) > 0 then
+      ParseExpression(Expression);
+  end;
+end;
+
 procedure TDbfParser.SetRawStringFields(NewRawFields: Boolean);
 procedure TDbfParser.SetRawStringFields(NewRawFields: Boolean);
 begin
 begin
   if FRawStringFields <> NewRawFields then
   if FRawStringFields <> NewRawFields then
@@ -1099,11 +1397,24 @@ end;
 procedure TDbfParser.FillExpressList;
 procedure TDbfParser.FillExpressList;
 begin
 begin
   FWordsList.FreeAll;
   FWordsList.FreeAll;
+  FWordsList.AddList(DbfWordsGeneralList, 0, DbfWordsGeneralList.Count - 1);
   if FCaseInsensitive then
   if FCaseInsensitive then
   begin
   begin
-    FWordsList.AddList(DbfWordsInsensList, 0, DbfWordsInsensList.Count - 1);
+    FWordsList.AddList(DbfWordsInsensGeneralList, 0, DbfWordsInsensGeneralList.Count - 1);
+    if FPartialMatch then
+    begin
+      FWordsList.AddList(DbfWordsInsensPartialList, 0, DbfWordsInsensPartialList.Count - 1);
+    end else begin
+      FWordsList.AddList(DbfWordsInsensNoPartialList, 0, DbfWordsInsensNoPartialList.Count - 1);
+    end;
   end else begin
   end else begin
-    FWordsList.AddList(DbfWordsSensList, 0, DbfWordsSensList.Count - 1);
+    FWordsList.AddList(DbfWordsSensGeneralList, 0, DbfWordsSensGeneralList.Count - 1);
+    if FPartialMatch then
+    begin
+      FWordsList.AddList(DbfWordsSensPartialList, 0, DbfWordsSensPartialList.Count - 1);
+    end else begin
+      FWordsList.AddList(DbfWordsSensNoPartialList, 0, DbfWordsSensNoPartialList.Count - 1);
+    end;
   end;
   end;
 end;
 end;
 
 
@@ -1273,11 +1584,15 @@ end;
 
 
 initialization
 initialization
 
 
-  DbfWordsSensList := TExpressList.Create;
-  DbfWordsInsensList := TExpressList.Create;
-  DbfWordsAllList := TExpressList.Create;
+  DbfWordsGeneralList := TExpressList.Create;
+  DbfWordsInsensGeneralList := TExpressList.Create;
+  DbfWordsInsensNoPartialList := TExpressList.Create;
+  DbfWordsInsensPartialList := TExpressList.Create;
+  DbfWordsSensGeneralList := TExpressList.Create;
+  DbfWordsSensNoPartialList := TExpressList.Create;
+  DbfWordsSensPartialList := TExpressList.Create;
 
 
-  with DbfWordsAllList do
+  with DbfWordsGeneralList do
   begin
   begin
     // basic function functionality
     // basic function functionality
     Add(TLeftBracket.Create('(', nil));
     Add(TLeftBracket.Create('(', nil));
@@ -1297,6 +1612,39 @@ initialization
     Add(TFunction.CreateOper('+', 'LL', etLargeInt, FuncAdd_F_LI, 40));
     Add(TFunction.CreateOper('+', 'LL', etLargeInt, FuncAdd_F_LI, 40));
     Add(TFunction.CreateOper('+', 'LI', etLargeInt, FuncAdd_F_LL, 40));
     Add(TFunction.CreateOper('+', 'LI', etLargeInt, FuncAdd_F_LL, 40));
 {$endif}
 {$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_EQ , 80));
     Add(TFunction.CreateOper('<', 'FF', etBoolean, Func_FF_LT , 80));
     Add(TFunction.CreateOper('<', 'FF', etBoolean, Func_FF_LT , 80));
@@ -1368,10 +1716,8 @@ initialization
     Add(TFunction.Create('LOWERCASE', 'LOWER', 'S',   1, etString, FuncLowercase, ''));
     Add(TFunction.Create('LOWERCASE', 'LOWER', 'S',   1, etString, FuncLowercase, ''));
   end;
   end;
 
 
-  with DbfWordsInsensList do
+  with DbfWordsInsensGeneralList do
   begin
   begin
-    AddList(DbfWordsAllList, 0, DbfWordsAllList.Count - 1);
-    Add(TFunction.CreateOper('=', 'SS', etBoolean, FuncStrI_EQ , 80));
     Add(TFunction.CreateOper('<', 'SS', etBoolean, FuncStrI_LT , 80));
     Add(TFunction.CreateOper('<', 'SS', etBoolean, FuncStrI_LT , 80));
     Add(TFunction.CreateOper('>', 'SS', etBoolean, FuncStrI_GT , 80));
     Add(TFunction.CreateOper('>', 'SS', etBoolean, FuncStrI_GT , 80));
     Add(TFunction.CreateOper('<=','SS', etBoolean, FuncStrI_LTE, 80));
     Add(TFunction.CreateOper('<=','SS', etBoolean, FuncStrI_LTE, 80));
@@ -1379,22 +1725,36 @@ initialization
     Add(TFunction.CreateOper('<>','SS', etBoolean, FuncStrI_NEQ, 80));
     Add(TFunction.CreateOper('<>','SS', etBoolean, FuncStrI_NEQ, 80));
   end;
   end;
 
 
-  with DbfWordsSensList do
+  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
   begin
-    AddList(DbfWordsAllList, 0, DbfWordsAllList.Count - 1);
-    Add(TFunction.CreateOper('=', 'SS', etBoolean, FuncStr_EQ , 80));
     Add(TFunction.CreateOper('<', 'SS', etBoolean, FuncStr_LT , 80));
     Add(TFunction.CreateOper('<', 'SS', etBoolean, FuncStr_LT , 80));
     Add(TFunction.CreateOper('>', 'SS', etBoolean, FuncStr_GT , 80));
     Add(TFunction.CreateOper('>', 'SS', etBoolean, FuncStr_GT , 80));
     Add(TFunction.CreateOper('<=','SS', etBoolean, FuncStr_LTE, 80));
     Add(TFunction.CreateOper('<=','SS', etBoolean, FuncStr_LTE, 80));
     Add(TFunction.CreateOper('>=','SS', etBoolean, FuncStr_GTE, 80));
     Add(TFunction.CreateOper('>=','SS', etBoolean, FuncStr_GTE, 80));
     Add(TFunction.CreateOper('<>','SS', etBoolean, FuncStr_NEQ, 80));
     Add(TFunction.CreateOper('<>','SS', etBoolean, FuncStr_NEQ, 80));
   end;
   end;
+    
+  with DbfWordsSensNoPartialList do
+    Add(TFunction.CreateOper('=', 'SS', etBoolean, FuncStr_EQ , 80));
+
+  with DbfWordsSensPartialList do
+    Add(TFunction.CreateOper('=', 'SS', etBoolean, FuncStrP_EQ , 80));
 
 
 finalization
 finalization
 
 
-  DbfWordsAllList.Free;
-  DbfWordsInsensList.Free;
-  DbfWordsSensList.Free;
+  DbfWordsGeneralList.Free;
+  DbfWordsInsensGeneralList.Free;
+  DbfWordsInsensNoPartialList.Free;
+  DbfWordsInsensPartialList.Free;
+  DbfWordsSensGeneralList.Free;
+  DbfWordsSensNoPartialList.Free;
+  DbfWordsSensPartialList.Free;
 
 
 end.
 end.
 
 

+ 232 - 234
fcl/db/dbase/Dbf_PgcFile.pas → fcl/db/dbase/dbf_pgcfile.pas

@@ -1,234 +1,232 @@
-unit Dbf_PgcFile;
-
-{force CR/LF fix}
-
-// paged, cached file
-
-interface
-
-{$I Dbf_Common.inc}
-
-{$ifdef USE_CACHE}
-
-uses
-  Classes,
-  SysUtils,
-  Dbf_Common,
-  Dbf_Avl,
-  Dbf_PgFile;
-
-type
-
-  PPageInfo = ^TPageInfo;
-  TPageInfo = record
-    TimeStamp: Cardinal;
-    Modified: Boolean;
-    Data: Char;
-  end;
-
-  TCachedFile = class(TPagedFile)
-  private
-    FPageTree: TAvlTree;
-    FUseTree: TAvlTree;
-    FTimeStamp: Cardinal;
-    FPageInfoSize: Integer;
-    FCacheSize: Integer;
-    FMaxPages: Cardinal;
-
-    function  GetTimeStamp: Cardinal;
-    procedure UpdateTimeStamp(RecNo: Integer; Data: PPageInfo);
-    procedure PageDeleted(Sender: TAvlTree; Data: PData);
-    procedure UpdateMaxPages;
-    function  AddToCache(RecNo: Integer; Buffer: Pointer): PPageInfo;
-  protected
-    procedure SetRecordSize(NewValue: Integer); override;
-    procedure SetCacheSize(NewSize: Integer);
-  public
-    constructor Create(AFileName: string);
-    destructor Destroy; override;
-
-    procedure CloseFile; override;
-    procedure Flush; override;
-
-    function  ReadRecord(RecNo: Integer; Buffer: Pointer): Integer; override;
-    procedure WriteRecord(RecNo: Integer; Buffer: Pointer); override;
-
-    property CacheSize: Integer read FCacheSize write SetCacheSize;
-  end;
-
-{$endif}
-
-implementation
-
-{$ifdef USE_CACHE}
-
-constructor TCachedFile.Create(AFileName: string);
-begin
-  inherited;
-
-  FPageTree := TAvlTree.Create;
-  FPageTree.OnDelete := PageDeleted;
-  FUseTree := TAvlTree.Create;
-  FPageInfoSize := 0;
-  FTimeStamp := 0;
-  FCacheSize := 256 * 1024;
-end;
-
-destructor TCachedFile.Destroy;
-begin
-  Flush;
-
-  FPageTree.Free;
-  FUseTree.Free;
-  FPageTree := nil;
-  FUseTree := nil;
-
-  inherited;
-end;
-
-procedure TCachedFile.Flush;
-begin
-  if FPageTree <> nil then
-  begin
-    FPageTree.Clear;
-    FUseTree.Clear;
-  end;
-  FTimeStamp := 0;
-end;
-
-procedure TCachedFile.CloseFile;
-begin
-  // flush modified pages to disk
-  Flush;
-
-  // now we can safely close
-  inherited;
-end;
-
-procedure TCachedFile.SetRecordSize(NewValue: Integer);
-begin
-  inherited;
-
-  // first flush all pages, restart caching with new parameters
-  Flush;
-
-  // calculate size of extra data of pagetree
-  FPageInfoSize := SizeOf(TPageInfo) - SizeOf(Char) + RecordSize;
-  UpdateMaxPages;
-end;
-
-procedure TCachedFile.SetCacheSize(NewSize: Integer);
-begin
-  if FCacheSize <> NewSize then
-  begin
-    FCacheSize := NewSize;
-    UpdateMaxPages;
-  end;
-end;
-
-procedure TCachedFile.UpdateMaxPages;
-begin
-  if RecordSize = 0 then
-    FMaxPages := 0
-  else
-    FMaxPages := FCacheSize div RecordSize;
-end;
-
-function TCachedFile.GetTimeStamp: Cardinal;
-begin
-  Result := FTimeStamp;
-  Inc(FTimeStamp);
-end;
-
-procedure TCachedFile.PageDeleted(Sender: TAvlTree; Data: PData);
-begin
-  // data modified? write to disk
-  if PPageInfo(Data^.ExtraData)^.Modified then
-    inherited WriteRecord(Data^.ID, @PPageInfo(Data^.ExtraData)^.Data);
-
-  // free cached page mem
-  FreeMem(Data^.ExtraData);
-end;
-
-function TCachedFile.AddToCache(RecNo: Integer; Buffer: Pointer): PPageInfo;
-var
-  oldData: PData;
-begin
-  // make sure there is a free page in the cache
-  while FPageTree.Count >= FMaxPages do
-  begin
-    // no free space, find oldest page
-    oldData := FUseTree.Lowest;
-    // remove from cache
-    FPageTree.Delete(Integer(oldData^.ExtraData));
-    FUseTree.Delete(oldData^.ID);
-  end;
-  // add to cache
-  GetMem(Result, FPageInfoSize);
-  Result^.TimeStamp := GetTimeStamp;
-  Result^.Modified := false;
-  Move(Buffer^, Result^.Data, RecordSize);
-  FPageTree.Insert(RecNo, Result);
-  FUseTree.Insert(Result^.TimeStamp, Pointer(RecNo));
-end;
-
-procedure TCachedFile.UpdateTimeStamp(RecNo: Integer; Data: PPageInfo);
-begin
-  // update time used
-  FUseTree.Delete(Data^.TimeStamp);
-  Data^.TimeStamp := GetTimeStamp;
-  FUseTree.Insert(Data^.TimeStamp, Pointer(RecNo));
-end;
-
-function TCachedFile.ReadRecord(RecNo: Integer; Buffer: Pointer): Integer;
-var
-  Data: PPageInfo;
-begin
-  // only cache when we do not need locking
-  if NeedLocks then
-  begin Result := inherited ReadRecord(RecNo, Buffer) end else begin
-    // do we have this page in cache?
-    Data := PPageInfo(FPageTree.Find(RecNo));
-    if Data <> nil then
-    begin
-      // copy from cache
-      Move(Data^.Data, Buffer^, RecordSize);
-      UpdateTimeStamp(RecNo, Data);
-      Result := RecordSize;
-    end else begin
-      // not yet in cache
-      Result := inherited ReadRecord(RecNo, Buffer);
-      // add
-      if Result > 0 then
-        AddToCache(RecNo, Buffer);
-    end;
-  end;
-end;
-
-procedure TCachedFile.WriteRecord(RecNo: Integer; Buffer: Pointer);
-var
-  Data: PPageInfo;
-begin
-  // only cache when we do not need locking
-  if NeedLocks then
-  begin inherited end else begin
-    // do we have this page in cache?
-    Data := PPageInfo(FPageTree.Find(RecNo));
-    if Data <> nil then
-    begin
-      // copy to cache
-      Move(Buffer^, Data^.Data, RecordSize);
-      UpdateTimeStamp(RecNo, Data);
-    end else begin
-      // add
-      Data := AddToCache(RecNo, Buffer);
-      // notify we've added a page
-      UpdateCachedSize(CalcPageOffset(RecNo+PagesPerRecord));
-    end;
-    Data^.Modified := true;
-  end;
-end;
-
-{$endif}  // USE_CACHE
-
-end.
+unit dbf_pgcfile;
+
+// paged, cached file
+
+interface
+
+{$I Dbf_Common.inc}
+
+{$ifdef USE_CACHE}
+
+uses
+  Classes,
+  SysUtils,
+  Dbf_Common,
+  Dbf_Avl,
+  Dbf_PgFile;
+
+type
+
+  PPageInfo = ^TPageInfo;
+  TPageInfo = record
+    TimeStamp: Cardinal;
+    Modified: Boolean;
+    Data: Char;
+  end;
+
+  TCachedFile = class(TPagedFile)
+  private
+    FPageTree: TAvlTree;
+    FUseTree: TAvlTree;
+    FTimeStamp: Cardinal;
+    FPageInfoSize: Integer;
+    FCacheSize: Integer;
+    FMaxPages: Cardinal;
+
+    function  GetTimeStamp: Cardinal;
+    procedure UpdateTimeStamp(RecNo: Integer; Data: PPageInfo);
+    procedure PageDeleted(Sender: TAvlTree; Data: PData);
+    procedure UpdateMaxPages;
+    function  AddToCache(RecNo: Integer; Buffer: Pointer): PPageInfo;
+  protected
+    procedure SetRecordSize(NewValue: Integer); override;
+    procedure SetCacheSize(NewSize: Integer);
+  public
+    constructor Create(AFileName: string);
+    destructor Destroy; override;
+
+    procedure CloseFile; override;
+    procedure Flush; override;
+
+    function  ReadRecord(RecNo: Integer; Buffer: Pointer): Integer; override;
+    procedure WriteRecord(RecNo: Integer; Buffer: Pointer); override;
+
+    property CacheSize: Integer read FCacheSize write SetCacheSize;
+  end;
+
+{$endif}
+
+implementation
+
+{$ifdef USE_CACHE}
+
+constructor TCachedFile.Create(AFileName: string);
+begin
+  inherited;
+
+  FPageTree := TAvlTree.Create;
+  FPageTree.OnDelete := PageDeleted;
+  FUseTree := TAvlTree.Create;
+  FPageInfoSize := 0;
+  FTimeStamp := 0;
+  FCacheSize := 256 * 1024;
+end;
+
+destructor TCachedFile.Destroy;
+begin
+  Flush;
+
+  FPageTree.Free;
+  FUseTree.Free;
+  FPageTree := nil;
+  FUseTree := nil;
+
+  inherited;
+end;
+
+procedure TCachedFile.Flush;
+begin
+  if FPageTree <> nil then
+  begin
+    FPageTree.Clear;
+    FUseTree.Clear;
+  end;
+  FTimeStamp := 0;
+end;
+
+procedure TCachedFile.CloseFile;
+begin
+  // flush modified pages to disk
+  Flush;
+
+  // now we can safely close
+  inherited;
+end;
+
+procedure TCachedFile.SetRecordSize(NewValue: Integer);
+begin
+  inherited;
+
+  // first flush all pages, restart caching with new parameters
+  Flush;
+
+  // calculate size of extra data of pagetree
+  FPageInfoSize := SizeOf(TPageInfo) - SizeOf(Char) + RecordSize;
+  UpdateMaxPages;
+end;
+
+procedure TCachedFile.SetCacheSize(NewSize: Integer);
+begin
+  if FCacheSize <> NewSize then
+  begin
+    FCacheSize := NewSize;
+    UpdateMaxPages;
+  end;
+end;
+
+procedure TCachedFile.UpdateMaxPages;
+begin
+  if RecordSize = 0 then
+    FMaxPages := 0
+  else
+    FMaxPages := FCacheSize div RecordSize;
+end;
+
+function TCachedFile.GetTimeStamp: Cardinal;
+begin
+  Result := FTimeStamp;
+  Inc(FTimeStamp);
+end;
+
+procedure TCachedFile.PageDeleted(Sender: TAvlTree; Data: PData);
+begin
+  // data modified? write to disk
+  if PPageInfo(Data^.ExtraData)^.Modified then
+    inherited WriteRecord(Data^.ID, @PPageInfo(Data^.ExtraData)^.Data);
+
+  // free cached page mem
+  FreeMem(Data^.ExtraData);
+end;
+
+function TCachedFile.AddToCache(RecNo: Integer; Buffer: Pointer): PPageInfo;
+var
+  oldData: PData;
+begin
+  // make sure there is a free page in the cache
+  while FPageTree.Count >= FMaxPages do
+  begin
+    // no free space, find oldest page
+    oldData := FUseTree.Lowest;
+    // remove from cache
+    FPageTree.Delete(Integer(oldData^.ExtraData));
+    FUseTree.Delete(oldData^.ID);
+  end;
+  // add to cache
+  GetMem(Result, FPageInfoSize);
+  Result^.TimeStamp := GetTimeStamp;
+  Result^.Modified := false;
+  Move(Buffer^, Result^.Data, RecordSize);
+  FPageTree.Insert(RecNo, Result);
+  FUseTree.Insert(Result^.TimeStamp, Pointer(RecNo));
+end;
+
+procedure TCachedFile.UpdateTimeStamp(RecNo: Integer; Data: PPageInfo);
+begin
+  // update time used
+  FUseTree.Delete(Data^.TimeStamp);
+  Data^.TimeStamp := GetTimeStamp;
+  FUseTree.Insert(Data^.TimeStamp, Pointer(RecNo));
+end;
+
+function TCachedFile.ReadRecord(RecNo: Integer; Buffer: Pointer): Integer;
+var
+  Data: PPageInfo;
+begin
+  // only cache when we do not need locking
+  if NeedLocks then
+  begin Result := inherited ReadRecord(RecNo, Buffer) end else begin
+    // do we have this page in cache?
+    Data := PPageInfo(FPageTree.Find(RecNo));
+    if Data <> nil then
+    begin
+      // copy from cache
+      Move(Data^.Data, Buffer^, RecordSize);
+      UpdateTimeStamp(RecNo, Data);
+      Result := RecordSize;
+    end else begin
+      // not yet in cache
+      Result := inherited ReadRecord(RecNo, Buffer);
+      // add
+      if Result > 0 then
+        AddToCache(RecNo, Buffer);
+    end;
+  end;
+end;
+
+procedure TCachedFile.WriteRecord(RecNo: Integer; Buffer: Pointer);
+var
+  Data: PPageInfo;
+begin
+  // only cache when we do not need locking
+  if NeedLocks then
+  begin inherited end else begin
+    // do we have this page in cache?
+    Data := PPageInfo(FPageTree.Find(RecNo));
+    if Data <> nil then
+    begin
+      // copy to cache
+      Move(Buffer^, Data^.Data, RecordSize);
+      UpdateTimeStamp(RecNo, Data);
+    end else begin
+      // add
+      Data := AddToCache(RecNo, Buffer);
+      // notify we've added a page
+      UpdateCachedSize(CalcPageOffset(RecNo+PagesPerRecord));
+    end;
+    Data^.Modified := true;
+  end;
+end;
+
+{$endif}  // USE_CACHE
+
+end.

+ 3 - 5
fcl/db/dbase/Dbf_PgFile.pas → fcl/db/dbase/dbf_pgfile.pas

@@ -1,4 +1,4 @@
-unit Dbf_PgFile;
+unit dbf_pgfile;
 
 
 interface
 interface
 
 
@@ -248,8 +248,6 @@ begin
     begin
     begin
       FMode := pfMemoryCreate;
       FMode := pfMemoryCreate;
       FStream := TMemoryStream.Create;
       FStream := TMemoryStream.Create;
-    end else begin
-      FMode := pfMemoryOpen;
     end;
     end;
   end;
   end;
   // init size var
   // init size var
@@ -269,10 +267,10 @@ begin
   begin
   begin
     FlushHeader;
     FlushHeader;
     // don't free the user's stream
     // don't free the user's stream
-    if FMode <> pfMemoryOpen then
+    if not (FMode in [pfMemoryOpen, pfMemoryCreate]) then
       FreeAndNil(FStream);
       FreeAndNil(FStream);
 
 
-    // mode possibly overriden in case of auto-created file
+    // mode possibly overridden in case of auto-created file
     FMode := FUserMode;
     FMode := FUserMode;
     FActive := false;
     FActive := false;
     FCachedRecordCount := 0;
     FCachedRecordCount := 0;

+ 36 - 13
fcl/db/dbase/Dbf_PrsCore.pas → fcl/db/dbase/dbf_prscore.pas

@@ -1,6 +1,4 @@
-unit Dbf_PrsCore;
-
-{force CR/LF fix}
+unit dbf_prscore;
 
 
 {--------------------------------------------------------------
 {--------------------------------------------------------------
 | TCustomExpressionParser
 | TCustomExpressionParser
@@ -427,20 +425,45 @@ function TCustomExpressionParser.MakeTree(Expr: TExprCollection;
 
 
 var
 var
   I, IArg, IStart, IEnd, lPrec, brCount: Integer;
   I, IArg, IStart, IEnd, lPrec, brCount: Integer;
-  redundantBrackets: boolean;
   ExprWord: TExprWord;
   ExprWord: TExprWord;
 begin
 begin
   // remove redundant brackets
   // remove redundant brackets
-  repeat
-    redundantBrackets := false;
-    if (TExprWord(Expr.Items[FirstItem]).ResultType = etLeftBracket) and
-        (TExprWord(Expr.Items[LastItem]).ResultType = etRightBracket) then
-    begin
-      Inc(FirstItem);
-      Dec(LastItem);
-      redundantBrackets := true;
+  brCount := 0;
+  while (FirstItem+brCount < LastItem) and (TExprWord(
+      Expr.Items[FirstItem+brCount]).ResultType = etLeftBracket) do
+    Inc(brCount);
+  I := LastItem;
+  while (I > FirstItem) and (TExprWord(
+      Expr.Items[I]).ResultType = etRightBracket) do
+    Dec(I);
+  // test max of start and ending brackets
+  if brCount > (LastItem-I) then
+    brCount := LastItem-I;
+  // count number of bracket pairs completely open from start to end
+  // IArg is min.brCount
+  I := FirstItem + brCount;
+  IArg := brCount;
+  while (I <= LastItem - brCount) and (brCount > 0) do
+  begin
+    case TExprWord(Expr.Items[I]).ResultType of
+      etLeftBracket: Inc(brCount);
+      etRightBracket: 
+        begin
+          Dec(brCount);
+          if brCount < IArg then
+            IArg := brCount;
+        end;
     end;
     end;
-  until not redundantBrackets;
+    Inc(I);
+  end;
+  // useful pair bracket count, is in minimum, is IArg
+  brCount := IArg;
+  // check if subexpression closed within (bracket level will be zero)
+  if brCount > 0 then
+  begin
+    Inc(FirstItem, brCount);
+    Dec(LastItem, brCount);
+  end;
 
 
   // check for empty range
   // check for empty range
   if LastItem < FirstItem then
   if LastItem < FirstItem then

+ 1 - 3
fcl/db/dbase/Dbf_PrsDef.pas → fcl/db/dbase/dbf_prsdef.pas

@@ -1,6 +1,4 @@
-unit Dbf_PrsDef;
-
-{force CR/LF fix}
+unit dbf_prsdef;
 
 
 interface
 interface
 
 

+ 1 - 3
fcl/db/dbase/Dbf_PrsSupp.pas → fcl/db/dbase/dbf_prssupp.pas

@@ -1,6 +1,4 @@
-unit Dbf_PrsSupp;
-
-{force CR/LF fix}
+unit dbf_prssupp;
 
 
 // parse support
 // parse support
 
 

+ 366 - 368
fcl/db/dbase/Dbf_Reg.pas → fcl/db/dbase/dbf_reg.pas

@@ -1,368 +1,366 @@
-unit Dbf_Reg;
-
-{tab fix}
-
-{===============================================================================
-||         TDbf Component         ||         http://tdbf.sf.net               ||
-===============================================================================}
-(*
-  tDBF is supplied "AS IS". The author disclaims all warranties,
-  expressed or implied, including, without limitation, the warranties of
-  merchantability and or fitness for any purpose. The author assumes no
-  liability for damages, direct or consequential, which may result from the
-  use of TDBF.
-
-  TDbf is licensed under the LGPL (lesser general public license).
-
-  You are allowed to use this component in any project free of charge.
-  You are
-  - NOT allowed to claim that you have created this component.  You are
-  - NOT allowed to copy this component's code into your own component and
-      claim that the code is your idea.
-
-*)
-
-interface
-
-{$I Dbf_Common.inc}
-
-procedure Register;
-
-implementation
-
-{$ifndef FPC}
-{$R Dbf.dcr}
-{$endif}
-
-uses
-  SysUtils,
-  Classes,
-{$ifdef KYLIX}
-  QGraphics,
-  QControls,
-  QForms,
-  QDialogs,
-{$else}
-  Controls,
-  Forms,
-  Dialogs,
-{$endif}
-  Dbf,
-  Dbf_DbfFile,
-  Dbf_IdxFile,
-  Dbf_Fields,
-  Dbf_Common,
-  Dbf_Str
-{$ifndef FPC}
-  ,ExptIntf
-{$endif}
-{$ifdef DELPHI_6}
-  ,DesignIntf,DesignEditors
-{$else}
-{$ifndef FPC}
-  ,DsgnIntf
-{$else}
-  ,PropEdits
-  ,LazarusPackageIntf
-  ,LResources
-  {,ComponentEditors}
-{$endif}
-{$endif}
-  ;
-
-//==========================================================
-//============ DESIGNONLY ==================================
-//==========================================================
-(*
-//==========================================================
-//============ TFilePathProperty
-//==========================================================
-type
-  TFilePathProperty = class(TStringProperty)
-  public
-    function GetValue: string; override;
-  end;
-
-function TFilePathProperty.GetValue: string;
-begin
-  Result := inherited GetValue;
-  if Result = EmptyStr then
-  begin
-    SetValue(ExtractFilePath(ToolServices.GetProjectName));
-    Result := inherited GetValue;
-  end;
-end;
-*)
-
-//==========================================================
-//============ TTableNameProperty
-//==========================================================
-type
-  TTableNameProperty = class(TStringProperty)
-  public
-    procedure Edit; override;
-    function GetAttributes: TPropertyAttributes; override;
-  end;
-
-procedure TTableNameProperty.Edit; {override;}
-var
-  FileOpen: TOpenDialog;
-  Dbf: TDbf;
-begin
-  FileOpen := TOpenDialog.Create(Application);
-  try
-    with fileopen do begin
-      Dbf := GetComponent(0) as TDbf;
-{$ifndef FPC}
-      if Dbf.FilePath = EmptyStr then
-        FileOpen.InitialDir := ExtractFilePath(ToolServices.GetProjectName)
-      else
-{$endif}
-        FileOpen.InitialDir := Dbf.AbsolutePath;
-      Filename := GetValue;
-      Filter := 'Dbf table|*.dbf';
-      if Execute then begin
-        SetValue(Filename);
-      end;
-    end;
-  finally
-    Fileopen.free;
-  end;
-end;
-
-function TTableNameProperty.GetAttributes: TPropertyAttributes; {override;}
-begin
-  Result := [paDialog, paRevertable];
-end;
-
-//==========================================================
-//============ TIndexFileNameProperty
-//==========================================================
-
-type
-  TIndexFileNameProperty = class(TStringProperty)
-  public
-    procedure Edit; override;
-    function GetAttributes: TPropertyAttributes; override;
-  end;
-
-procedure TIndexFileNameProperty.Edit; {override;}
-var
-  FileOpen: TOpenDialog;
-  IndexDef: TDbfIndexDef;
-  Indexes: TDbfIndexDefs;
-  Dbf: TDbf;
-begin
-  FileOpen := TOpenDialog.Create(Application);
-  try
-    with fileopen do begin
-      IndexDef := GetComponent(0) as TDbfIndexDef;
-      Indexes := TDbfIndexDefs(IndexDef.Collection);
-      Dbf := TDbf(Indexes.FOwner);
-      FileOpen.InitialDir := Dbf.AbsolutePath;
-      Filename := GetValue;
-      Filter := 'Simple index (ndx)|*.ndx'{|Multiple index (mdx)|*.mdx'};
-      if Execute then begin
-        SetValue(ExtractFileName(Filename));
-      end;
-    end;
-  finally
-    Fileopen.free;
-  end;
-end;
-
-function TIndexFileNameProperty.GetAttributes: TPropertyAttributes; {override;}
-begin
-  Result := [paDialog, paRevertable];
-end;
-
-//==========================================================
-//============ TSortFieldProperty
-//==========================================================
-
-type
-  TSortFieldProperty = class(TStringProperty)
-  public
-    function GetAttributes: TPropertyAttributes; override;
-    procedure GetValues(Proc: TGetStrProc); override;
-  end;
-
-
-function TSortFieldProperty.GetAttributes: TPropertyAttributes; {override;}
-begin
-  Result := [paValueList, paSortList, paRevertable];
-end;
-
-procedure TSortFieldProperty.GetValues(Proc: TGetStrProc);
-var
-  IndexDef: TDbfIndexDef;
-  Indexes: TDbfIndexDefs;
-  Dbf: TDbf;
-  I: integer;
-begin
-  IndexDef := GetComponent(0) as TDbfIndexDef;
-  Indexes := TDbfIndexDefs(IndexDef.Collection);
-  Dbf :=  TDbf(Indexes.FOwner);
-  for I := 0 to Dbf.FieldCount-1 do
-  begin
-    Proc(Dbf.Fields[i].FieldName);
-  end;
-end;
-
-//==========================================================
-//============ TIndexNameProperty
-//==========================================================
-
-type
-  TIndexNameProperty = class(TStringProperty)
-  public
-    function GetAttributes: TPropertyAttributes; override;
-    procedure GetValues(Proc: TGetStrProc); override;
-    procedure SetValue(const Value: string); override;
-    function GetValue: string; override;
-  end;
-
-function TIndexNameProperty.GetAttributes: TPropertyAttributes; {override;}
-begin
-  Result := [paValueList, paRevertable];
-end;
-
-procedure TIndexNameProperty.GetValues(Proc: TGetStrProc);
-var
-  Dbf: TDbf;
-  I: Integer;
-begin
-  Dbf := GetComponent(0) as TDbf;
-  Dbf.UpdateIndexDefs;
-  for I := 0 to Dbf.Indexes.Count - 1 do
-    Proc(Dbf.Indexes[I].IndexFile);
-end;
-
-procedure TIndexNameProperty.SetValue(const Value: string); {override}
-var
-  Dbf: TDbf;
-begin
-  Dbf := GetComponent(0) as TDbf;
-  Dbf.IndexName := Value;
-end;
-
-function TIndexNameProperty.GetValue: string; {override;}
-var
-  Dbf: TDbf;
-begin
-  Dbf := GetComponent(0) as TDbf;
-  Result := Dbf.IndexName;
-end;
-
-//==========================================================
-//============ TVersionProperty
-//==========================================================
-type
-  TVersionProperty = class(TStringProperty)
-  public
-    procedure Edit; override;
-    function GetAttributes: TPropertyAttributes; override;
-  end;
-
-procedure TVersionProperty.Edit; {override;}
-begin
-  ShowMessage(
-    Format(STRING_VERSION,[TDBF_MAJOR_VERSION, TDBF_MINOR_VERSION]) +
-      ' : a dBase component'+#13+
-      'for Delphi and c++ builder with no BDE.'+#13+
-      #13 +
-      'To get the latest version, please visit'+#13+
-      'the website: http://www.tdbf.net'+#13+
-      'or SourceForge: http://tdbf.sf.net');
-end;
-
-function TVersionProperty.GetAttributes: TPropertyAttributes; {override;}
-begin
-  Result := [paDialog, paReadOnly, paRevertable];
-end;
-
-//==========================================================
-//============ TNativeFieldTypeProperty
-//==========================================================
-type
-  TNativeFieldTypeProperty = class(TCharProperty)
-  public
-    function GetAttributes: TPropertyAttributes; override;
-    procedure GetValues(Proc: TGetStrProc); override;
-    procedure SetValue(const Value: string); override;
-  end;
-
-procedure TNativeFieldTypeProperty.SetValue(const Value: string);
-var
-  L: Longint;
-begin
-  if Length(Value) = 0 then L := 0 else
-  if Value[1] = '#' then L := StrToInt(Copy(Value, 2, Maxint))
-  else L := Ord(Value[1]);
-  SetOrdValue(L);
-end;
-
-function TNativeFieldTypeProperty.GetAttributes: TPropertyAttributes; {override;}
-begin
-  result := [paRevertable,paValueList];
-end;
-
-procedure TNativeFieldTypeProperty.GetValues(Proc: TGetStrProc);
-begin
-  Proc('C Character');
-  Proc('N Numeric');
-  Proc('D Date');
-  Proc('L Logical');
-  Proc('M Memo');
-  Proc('B Blob');
-  Proc('F Float');
-  Proc('O Double');
-  Proc('I Integer');
-  Proc('G Graphic');
-  Proc('+ AutoIncrement');
-  Proc('@ DateTime');
-end;
-
-//==========================================================
-//============ initialization
-//==========================================================
-function IDE_DbfDefaultPath:string;
-begin
-{$ifndef FPC}
-  if ToolServices<>nil then
-    Result := ExtractFilePath(ToolServices.GetProjectName)
-  else
-{$endif}
-    Result := GetCurrentDir
-end;
-
-{$ifdef FPC}
-procedure RegisterUnitDbf;
-{$else}
-procedure Register;
-{$endif}
-begin
-  Dbf.DbfBasePath := IDE_DbfDefaultPath;
-  RegisterComponents('Data Access', [TDbf]);
-//  RegisterPropertyEditor(TypeInfo(string), TDbf, 'FilePath', TFilePathProperty);
-  RegisterPropertyEditor(TypeInfo(string), TDbf, 'TableName', TTableNameProperty);
-  RegisterPropertyEditor(TypeInfo(string), TDbf, 'Version', TVersionProperty);
-  RegisterPropertyEditor(TypeInfo(string), TDbf, 'IndexName', TIndexNameProperty);
-  RegisterPropertyEditor(TypeInfo(string), TDbfIndexDef, 'IndexFile', TIndexFileNameProperty);
-  RegisterPropertyEditor(TypeInfo(string), TDbfIndexDef, 'SortField', TSortFieldProperty);
-  RegisterPropertyEditor(TypeInfo(char), TDbfFieldDef, 'NativeFieldType', TNativeFieldTypeProperty);
-end;
-
-{$ifdef FPC}
-procedure Register;
-begin
-  RegisterUnit('Dbf', @RegisterUnitDbf);
-end;
-{$endif}
-
-{$ifdef FPC}
-initialization
-  {$i tdbf.lrs}
-{$endif}
-
-end.
+unit dbf_reg;
+
+{===============================================================================
+||         TDbf Component         ||         http://tdbf.sf.net               ||
+===============================================================================}
+(*
+  tDBF is supplied "AS IS". The author disclaims all warranties,
+  expressed or implied, including, without limitation, the warranties of
+  merchantability and or fitness for any purpose. The author assumes no
+  liability for damages, direct or consequential, which may result from the
+  use of TDBF.
+
+  TDbf is licensed under the LGPL (lesser general public license).
+
+  You are allowed to use this component in any project free of charge.
+  You are
+  - NOT allowed to claim that you have created this component.  You are
+  - NOT allowed to copy this component's code into your own component and
+      claim that the code is your idea.
+
+*)
+
+interface
+
+{$I Dbf_Common.inc}
+
+procedure Register;
+
+implementation
+
+{$ifndef FPC}
+{$R Dbf.dcr}
+{$endif}
+
+uses
+  SysUtils,
+  Classes,
+{$ifdef KYLIX}
+  QGraphics,
+  QControls,
+  QForms,
+  QDialogs,
+{$else}
+  Controls,
+  Forms,
+  Dialogs,
+{$endif}
+  Dbf,
+  Dbf_DbfFile,
+  Dbf_IdxFile,
+  Dbf_Fields,
+  Dbf_Common,
+  Dbf_Str
+{$ifndef FPC}
+  ,ExptIntf
+{$endif}
+{$ifdef DELPHI_6}
+  ,DesignIntf,DesignEditors
+{$else}
+{$ifndef FPC}
+  ,DsgnIntf
+{$else}
+  ,PropEdits
+  ,LazarusPackageIntf
+  ,LResources
+  {,ComponentEditors}
+{$endif}
+{$endif}
+  ;
+
+//==========================================================
+//============ DESIGNONLY ==================================
+//==========================================================
+(*
+//==========================================================
+//============ TFilePathProperty
+//==========================================================
+type
+  TFilePathProperty = class(TStringProperty)
+  public
+    function GetValue: string; override;
+  end;
+
+function TFilePathProperty.GetValue: string;
+begin
+  Result := inherited GetValue;
+  if Result = EmptyStr then
+  begin
+    SetValue(ExtractFilePath(ToolServices.GetProjectName));
+    Result := inherited GetValue;
+  end;
+end;
+*)
+
+//==========================================================
+//============ TTableNameProperty
+//==========================================================
+type
+  TTableNameProperty = class(TStringProperty)
+  public
+    procedure Edit; override;
+    function GetAttributes: TPropertyAttributes; override;
+  end;
+
+procedure TTableNameProperty.Edit; {override;}
+var
+  FileOpen: TOpenDialog;
+  Dbf: TDbf;
+begin
+  FileOpen := TOpenDialog.Create(Application);
+  try
+    with fileopen do begin
+      Dbf := GetComponent(0) as TDbf;
+{$ifndef FPC}
+      if Dbf.FilePath = EmptyStr then
+        FileOpen.InitialDir := ExtractFilePath(ToolServices.GetProjectName)
+      else
+{$endif}
+        FileOpen.InitialDir := Dbf.AbsolutePath;
+      Filename := GetValue;
+      Filter := 'Dbf table|*.dbf';
+      if Execute then begin
+        SetValue(Filename);
+      end;
+    end;
+  finally
+    Fileopen.free;
+  end;
+end;
+
+function TTableNameProperty.GetAttributes: TPropertyAttributes; {override;}
+begin
+  Result := [paDialog, paRevertable];
+end;
+
+//==========================================================
+//============ TIndexFileNameProperty
+//==========================================================
+
+type
+  TIndexFileNameProperty = class(TStringProperty)
+  public
+    procedure Edit; override;
+    function GetAttributes: TPropertyAttributes; override;
+  end;
+
+procedure TIndexFileNameProperty.Edit; {override;}
+var
+  FileOpen: TOpenDialog;
+  IndexDef: TDbfIndexDef;
+  Indexes: TDbfIndexDefs;
+  Dbf: TDbf;
+begin
+  FileOpen := TOpenDialog.Create(Application);
+  try
+    with fileopen do begin
+      IndexDef := GetComponent(0) as TDbfIndexDef;
+      Indexes := TDbfIndexDefs(IndexDef.Collection);
+      Dbf := TDbf(Indexes.FOwner);
+      FileOpen.InitialDir := Dbf.AbsolutePath;
+      Filename := GetValue;
+      Filter := 'Simple index (ndx)|*.ndx'{|Multiple index (mdx)|*.mdx'};
+      if Execute then begin
+        SetValue(ExtractFileName(Filename));
+      end;
+    end;
+  finally
+    Fileopen.free;
+  end;
+end;
+
+function TIndexFileNameProperty.GetAttributes: TPropertyAttributes; {override;}
+begin
+  Result := [paDialog, paRevertable];
+end;
+
+//==========================================================
+//============ TSortFieldProperty
+//==========================================================
+
+type
+  TSortFieldProperty = class(TStringProperty)
+  public
+    function GetAttributes: TPropertyAttributes; override;
+    procedure GetValues(Proc: TGetStrProc); override;
+  end;
+
+
+function TSortFieldProperty.GetAttributes: TPropertyAttributes; {override;}
+begin
+  Result := [paValueList, paSortList, paRevertable];
+end;
+
+procedure TSortFieldProperty.GetValues(Proc: TGetStrProc);
+var
+  IndexDef: TDbfIndexDef;
+  Indexes: TDbfIndexDefs;
+  Dbf: TDbf;
+  I: integer;
+begin
+  IndexDef := GetComponent(0) as TDbfIndexDef;
+  Indexes := TDbfIndexDefs(IndexDef.Collection);
+  Dbf :=  TDbf(Indexes.FOwner);
+  for I := 0 to Dbf.FieldCount-1 do
+  begin
+    Proc(Dbf.Fields[i].FieldName);
+  end;
+end;
+
+//==========================================================
+//============ TIndexNameProperty
+//==========================================================
+
+type
+  TIndexNameProperty = class(TStringProperty)
+  public
+    function GetAttributes: TPropertyAttributes; override;
+    procedure GetValues(Proc: TGetStrProc); override;
+    procedure SetValue(const Value: string); override;
+    function GetValue: string; override;
+  end;
+
+function TIndexNameProperty.GetAttributes: TPropertyAttributes; {override;}
+begin
+  Result := [paValueList, paRevertable];
+end;
+
+procedure TIndexNameProperty.GetValues(Proc: TGetStrProc);
+var
+  Dbf: TDbf;
+  I: Integer;
+begin
+  Dbf := GetComponent(0) as TDbf;
+  Dbf.UpdateIndexDefs;
+  for I := 0 to Dbf.Indexes.Count - 1 do
+    Proc(Dbf.Indexes[I].IndexFile);
+end;
+
+procedure TIndexNameProperty.SetValue(const Value: string); {override}
+var
+  Dbf: TDbf;
+begin
+  Dbf := GetComponent(0) as TDbf;
+  Dbf.IndexName := Value;
+end;
+
+function TIndexNameProperty.GetValue: string; {override;}
+var
+  Dbf: TDbf;
+begin
+  Dbf := GetComponent(0) as TDbf;
+  Result := Dbf.IndexName;
+end;
+
+//==========================================================
+//============ TVersionProperty
+//==========================================================
+type
+  TVersionProperty = class(TStringProperty)
+  public
+    procedure Edit; override;
+    function GetAttributes: TPropertyAttributes; override;
+  end;
+
+procedure TVersionProperty.Edit; {override;}
+begin
+  ShowMessage(
+    Format(STRING_VERSION,[TDBF_MAJOR_VERSION, TDBF_MINOR_VERSION]) +
+      ' : a dBase component'+#13+
+      'for Delphi and c++ builder with no BDE.'+#13+
+      #13 +
+      'To get the latest version, please visit'+#13+
+      'the website: http://www.tdbf.net'+#13+
+      'or SourceForge: http://tdbf.sf.net');
+end;
+
+function TVersionProperty.GetAttributes: TPropertyAttributes; {override;}
+begin
+  Result := [paDialog, paReadOnly, paRevertable];
+end;
+
+//==========================================================
+//============ TNativeFieldTypeProperty
+//==========================================================
+type
+  TNativeFieldTypeProperty = class(TCharProperty)
+  public
+    function GetAttributes: TPropertyAttributes; override;
+    procedure GetValues(Proc: TGetStrProc); override;
+    procedure SetValue(const Value: string); override;
+  end;
+
+procedure TNativeFieldTypeProperty.SetValue(const Value: string);
+var
+  L: Longint;
+begin
+  if Length(Value) = 0 then L := 0 else
+  if Value[1] = '#' then L := StrToInt(Copy(Value, 2, Maxint))
+  else L := Ord(Value[1]);
+  SetOrdValue(L);
+end;
+
+function TNativeFieldTypeProperty.GetAttributes: TPropertyAttributes; {override;}
+begin
+  result := [paRevertable,paValueList];
+end;
+
+procedure TNativeFieldTypeProperty.GetValues(Proc: TGetStrProc);
+begin
+  Proc('C Character');
+  Proc('N Numeric');
+  Proc('D Date');
+  Proc('L Logical');
+  Proc('M Memo');
+  Proc('B Blob');
+  Proc('F Float');
+  Proc('O Double');
+  Proc('I Integer');
+  Proc('G Graphic');
+  Proc('+ AutoIncrement');
+  Proc('@ DateTime');
+end;
+
+//==========================================================
+//============ initialization
+//==========================================================
+function IDE_DbfDefaultPath:string;
+begin
+{$ifndef FPC}
+  if ToolServices<>nil then
+    Result := ExtractFilePath(ToolServices.GetProjectName)
+  else
+{$endif}
+    Result := GetCurrentDir
+end;
+
+{$ifdef FPC}
+procedure RegisterUnitDbf;
+{$else}
+procedure Register;
+{$endif}
+begin
+  Dbf.DbfBasePath := IDE_DbfDefaultPath;
+  RegisterComponents('Data Access', [TDbf]);
+//  RegisterPropertyEditor(TypeInfo(string), TDbf, 'FilePath', TFilePathProperty);
+  RegisterPropertyEditor(TypeInfo(string), TDbf, 'TableName', TTableNameProperty);
+  RegisterPropertyEditor(TypeInfo(string), TDbf, 'Version', TVersionProperty);
+  RegisterPropertyEditor(TypeInfo(string), TDbf, 'IndexName', TIndexNameProperty);
+  RegisterPropertyEditor(TypeInfo(string), TDbfIndexDef, 'IndexFile', TIndexFileNameProperty);
+  RegisterPropertyEditor(TypeInfo(string), TDbfIndexDef, 'SortField', TSortFieldProperty);
+  RegisterPropertyEditor(TypeInfo(char), TDbfFieldDef, 'NativeFieldType', TNativeFieldTypeProperty);
+end;
+
+{$ifdef FPC}
+procedure Register;
+begin
+  RegisterUnit('Dbf', @RegisterUnitDbf);
+end;
+{$endif}
+
+{$ifdef FPC}
+initialization
+  {$i tdbf.lrs}
+{$endif}
+
+end.

+ 0 - 0
fcl/db/dbase/Dbf_Str.inc → fcl/db/dbase/dbf_str.inc


+ 36 - 38
fcl/db/dbase/Dbf_Str.pas → fcl/db/dbase/dbf_str.pas

@@ -1,38 +1,36 @@
-unit Dbf_Str;
-
-{fix CR/LF}
-
-interface
-
-{$I Dbf_Common.inc}
-{$I Dbf_Str.inc}
-
-implementation
-
-initialization
-
-  STRING_FILE_NOT_FOUND               := 'Open: file not found: "%s".';
-  STRING_VERSION                      := 'TDbf V%d.%d';
-
-  STRING_RECORD_LOCKED                := 'Record locked.';
-  STRING_WRITE_ERROR                  := 'Error while writing occurred. (Disk full?)';
-  STRING_WRITE_INDEX_ERROR            := 'Error while writing occurred; indexes probably corrupted. (Disk full?)';
-  STRING_KEY_VIOLATION                := 'Key violation. (Key already present in file).'+#13+#10+
-                                         'Index: %s'+#13+#10+'Record=%d Key=''%s''.';
-
-  STRING_INVALID_DBF_FILE             := 'Invalid DBF file.';
-  STRING_FIELD_TOO_LONG               := 'Value is too long: %d characters (it can''t be more than %d).';
-  STRING_INVALID_FIELD_COUNT          := 'Invalid field count: %d (must be between 1 and 4095).';
-  STRING_INVALID_FIELD_TYPE           := 'Invalid field type ''%s'' for field ''%s''.';
-  STRING_INVALID_VCL_FIELD_TYPE       := 'Cannot create field "%s", VCL field type %x not supported by DBF.';
-
-  STRING_INDEX_BASED_ON_UNKNOWN_FIELD := 'Index based on unknown field "%s".';
-  STRING_INDEX_BASED_ON_INVALID_FIELD := 'Field "%s" is an invalid field type to base index on.';
-  STRING_INDEX_EXPRESSION_TOO_LONG    := 'Index result for "%s" too long, >100 characters (%d).';
-  STRING_INVALID_INDEX_TYPE           := 'Invalid index type: can only be string or float.';
-  STRING_CANNOT_OPEN_INDEX            := 'Cannot open index: "%s".';
-  STRING_TOO_MANY_INDEXES             := 'Can not create index: too many indexes in file.';
-  STRING_INDEX_NOT_EXIST              := 'Index "%s" does not exist.';
-  STRING_NEED_EXCLUSIVE_ACCESS        := 'Exclusive access is required for this operation.';
-end.
-
+unit dbf_str;
+
+interface
+
+{$I Dbf_Common.inc}
+{$I Dbf_Str.inc}
+
+implementation
+
+initialization
+
+  STRING_FILE_NOT_FOUND               := 'Open: file not found: "%s".';
+  STRING_VERSION                      := 'TDbf V%d.%d';
+
+  STRING_RECORD_LOCKED                := 'Record locked.';
+  STRING_WRITE_ERROR                  := 'Error while writing occurred. (Disk full?)';
+  STRING_WRITE_INDEX_ERROR            := 'Error while writing occurred; indexes probably corrupted. (Disk full?)';
+  STRING_KEY_VIOLATION                := 'Key violation. (Key already present in file).'+#13+#10+
+                                         'Index: %s'+#13+#10+'Record=%d Key=''%s''.';
+
+  STRING_INVALID_DBF_FILE             := 'Invalid DBF file.';
+  STRING_FIELD_TOO_LONG               := 'Value is too long: %d characters (it can''t be more than %d).';
+  STRING_INVALID_FIELD_COUNT          := 'Invalid field count: %d (must be between 1 and 4095).';
+  STRING_INVALID_FIELD_TYPE           := 'Invalid field type ''%s'' for field ''%s''.';
+  STRING_INVALID_VCL_FIELD_TYPE       := 'Cannot create field "%s", VCL field type %x not supported by DBF.';
+
+  STRING_INDEX_BASED_ON_UNKNOWN_FIELD := 'Index based on unknown field "%s".';
+  STRING_INDEX_BASED_ON_INVALID_FIELD := 'Field "%s" is an invalid field type to base index on.';
+  STRING_INDEX_EXPRESSION_TOO_LONG    := 'Index result for "%s" too long, >100 characters (%d).';
+  STRING_INVALID_INDEX_TYPE           := 'Invalid index type: can only be string or float.';
+  STRING_CANNOT_OPEN_INDEX            := 'Cannot open index: "%s".';
+  STRING_TOO_MANY_INDEXES             := 'Can not create index: too many indexes in file.';
+  STRING_INDEX_NOT_EXIST              := 'Index "%s" does not exist.';
+  STRING_NEED_EXCLUSIVE_ACCESS        := 'Exclusive access is required for this operation.';
+end.
+

+ 36 - 0
fcl/db/dbase/dbf_str_es.pas

@@ -0,0 +1,36 @@
+unit dbf_str;
+
+interface
+
+{$I Dbf_Common.inc}
+{$I Dbf_Str.inc}
+
+implementation
+
+initialization
+
+  STRING_FILE_NOT_FOUND               := 'Apertura: archivo no encontrado: "%s".';
+  STRING_VERSION                      := 'TDbf V%d.%d';
+
+  STRING_RECORD_LOCKED                := 'Registro bloqueado.';
+  STRING_WRITE_ERROR                  := 'Error de escritura. (Disco lleno?)';
+  STRING_WRITE_INDEX_ERROR            := 'Error de escritura; índices probablemente corruptos. (Disco lleno?)';
+  STRING_KEY_VIOLATION                := 'Violación de clave. (Clave ya presente en archivo).'+#13+#10+
+                                         'Indice: %s'+#13+#10+'Registro=%d Clave=''%s''.';
+
+  STRING_INVALID_DBF_FILE             := 'Archivo DBF inválido.';
+  STRING_FIELD_TOO_LONG               := 'Valor demasiado largo: %d caracteres (no puede ser mayor de %d).';
+  STRING_INVALID_FIELD_COUNT          := 'Cantidad de campos inválida: %d (debe estar entre 1 y 4095).';
+  STRING_INVALID_FIELD_TYPE           := 'Tipo de campo inválido ''%s'' para el campo ''%s''.';
+  STRING_INVALID_VCL_FIELD_TYPE       := 'No se puede crear el campo "%s", campo VCL tipo %x no soportado por DBF.';
+
+  STRING_INDEX_BASED_ON_UNKNOWN_FIELD := 'Indice basado en campo desconocido "%s".';
+  STRING_INDEX_BASED_ON_INVALID_FIELD := 'Campo "%s" inválido para crear un índice.';
+  STRING_INDEX_EXPRESSION_TOO_LONG    := 'Resultado de índice para "%s" demasiado largo, >100 caracteres (%d).';
+  STRING_INVALID_INDEX_TYPE           := 'Tipo de índice invalido: solo puede ser string o float.';
+  STRING_CANNOT_OPEN_INDEX            := 'No se puede abrir el índice: "%s".';
+  STRING_TOO_MANY_INDEXES             := 'No se puede crear el índice: demasiados indices en el archivo.';
+  STRING_INDEX_NOT_EXIST              := 'Indice "%s" no existe.';
+  STRING_NEED_EXCLUSIVE_ACCESS        := 'Acceso Exclusivo requirido para esta operación.';
+end.
+

+ 54 - 56
fcl/db/dbase/Dbf_Str_FR.pas → fcl/db/dbase/dbf_str_fr.pas

@@ -1,56 +1,54 @@
-unit Dbf_Str;
-
-{fix CR/LF}
-
-interface
-
-{$I Dbf_Common.inc}
-
-var
-  STRING_FILE_NOT_FOUND: string;
-  STRING_VERSION: string;
-
-  STRING_RECORD_LOCKED: string;
-  STRING_KEY_VIOLATION: string;
-
-  STRING_INVALID_DBF_FILE: string;
-  STRING_FIELD_TOO_LONG: string;
-  STRING_INVALID_FIELD_COUNT: string;
-  STRING_INVALID_FIELD_TYPE: string;
-
-  STRING_INDEX_BASED_ON_UNKNOWN_FIELD: string;
-  STRING_INDEX_BASED_ON_INVALID_FIELD: string;
-  STRING_INDEX_EXPRESSION_TOO_LONG: string;
-  STRING_INVALID_INDEX_TYPE: string;
-  STRING_CANNOT_OPEN_INDEX: string;
-  STRING_TOO_MANY_INDEXES: string;
-  STRING_INDEX_NOT_EXIST: string;
-  STRING_NEED_EXCLUSIVE_ACCESS: string;
-
-implementation
-
-initialization
-
-  STRING_FILE_NOT_FOUND               := 'Ouverture: fichier non trouvé: "%s"';
-  STRING_VERSION                      := 'TDbf V%d.%d';
-
-  STRING_RECORD_LOCKED                := 'Enregistrement verrouillé.';
-  STRING_KEY_VIOLATION                := 'Violation de clé. (doublon dans un index).'+#13+#10+
-                                         'Index: %s'+#13+#10+'Enregistrement=%d Cle=''%s''';
-
-  STRING_INVALID_DBF_FILE             := 'Fichier DBF invalide.';
-  STRING_FIELD_TOO_LONG               := 'Valeur trop longue: %d caractères (ne peut dépasser %d).';
-  STRING_INVALID_FIELD_COUNT          := 'Nombre de champs non valide: %d (doit être entre 1 et 4095).';
-  STRING_INVALID_FIELD_TYPE           := 'Type de champ ''%s'' invalide pour le champ %s.';
-  STRING_INVALID_VCL_FIELD_TYPE       := 'Impossible de créer le champ "%s", champ type %x VCL non supporté par DBF';
-
-  STRING_INDEX_BASED_ON_UNKNOWN_FIELD := 'Index basé sur un champ inconnu %s';
-  STRING_INDEX_BASED_ON_INVALID_FIELD := 'Impossible de contruire un index sur ce type de champ "%s"';
-  STRING_INDEX_EXPRESSION_TOO_LONG    := 'Résultat d''Index trop long pour "%s", >100 caractères (%d).';
-  STRING_INVALID_INDEX_TYPE           := 'Type d''index non valide: doit être string ou float';
-  STRING_CANNOT_OPEN_INDEX            := 'Impossible d''ouvrir l''index: "%s"';
-  STRING_TOO_MANY_INDEXES             := 'Impossible de créer l''index: trop d''index dans le fichier.';
-  STRING_INDEX_NOT_EXIST              := 'L''index "%s" n''existe pas.';
-  STRING_NEED_EXCLUSIVE_ACCESS        := 'Access exclusif requis pour cette opération.';
-end.
-
+unit dbf_str;
+
+interface
+
+{$I Dbf_Common.inc}
+
+var
+  STRING_FILE_NOT_FOUND: string;
+  STRING_VERSION: string;
+
+  STRING_RECORD_LOCKED: string;
+  STRING_KEY_VIOLATION: string;
+
+  STRING_INVALID_DBF_FILE: string;
+  STRING_FIELD_TOO_LONG: string;
+  STRING_INVALID_FIELD_COUNT: string;
+  STRING_INVALID_FIELD_TYPE: string;
+
+  STRING_INDEX_BASED_ON_UNKNOWN_FIELD: string;
+  STRING_INDEX_BASED_ON_INVALID_FIELD: string;
+  STRING_INDEX_EXPRESSION_TOO_LONG: string;
+  STRING_INVALID_INDEX_TYPE: string;
+  STRING_CANNOT_OPEN_INDEX: string;
+  STRING_TOO_MANY_INDEXES: string;
+  STRING_INDEX_NOT_EXIST: string;
+  STRING_NEED_EXCLUSIVE_ACCESS: string;
+
+implementation
+
+initialization
+
+  STRING_FILE_NOT_FOUND               := 'Ouverture: fichier non trouvé: "%s"';
+  STRING_VERSION                      := 'TDbf V%d.%d';
+
+  STRING_RECORD_LOCKED                := 'Enregistrement verrouillé.';
+  STRING_KEY_VIOLATION                := 'Violation de clé. (doublon dans un index).'+#13+#10+
+                                         'Index: %s'+#13+#10+'Enregistrement=%d Cle=''%s''';
+
+  STRING_INVALID_DBF_FILE             := 'Fichier DBF invalide.';
+  STRING_FIELD_TOO_LONG               := 'Valeur trop longue: %d caractères (ne peut dépasser %d).';
+  STRING_INVALID_FIELD_COUNT          := 'Nombre de champs non valide: %d (doit être entre 1 et 4095).';
+  STRING_INVALID_FIELD_TYPE           := 'Type de champ ''%s'' invalide pour le champ %s.';
+  STRING_INVALID_VCL_FIELD_TYPE       := 'Impossible de créer le champ "%s", champ type %x VCL non supporté par DBF';
+
+  STRING_INDEX_BASED_ON_UNKNOWN_FIELD := 'Index basé sur un champ inconnu %s';
+  STRING_INDEX_BASED_ON_INVALID_FIELD := 'Impossible de contruire un index sur ce type de champ "%s"';
+  STRING_INDEX_EXPRESSION_TOO_LONG    := 'Résultat d''Index trop long pour "%s", >100 caractères (%d).';
+  STRING_INVALID_INDEX_TYPE           := 'Type d''index non valide: doit être string ou float';
+  STRING_CANNOT_OPEN_INDEX            := 'Impossible d''ouvrir l''index: "%s"';
+  STRING_TOO_MANY_INDEXES             := 'Impossible de créer l''index: trop d''index dans le fichier.';
+  STRING_INDEX_NOT_EXIST              := 'L''index "%s" n''existe pas.';
+  STRING_NEED_EXCLUSIVE_ACCESS        := 'Access exclusif requis pour cette opération.';
+end.
+

+ 45 - 47
fcl/db/dbase/Dbf_Str_ITA.pas → fcl/db/dbase/dbf_str_ita.pas

@@ -1,47 +1,45 @@
-unit Dbf_Str;
-
-{fix CR/LF}
-
-interface
-
-{$I Dbf_Common.inc}
-
-var
-  STRING_FILE_NOT_FOUND: string;
-  STRING_VERSION: string;
-
-  STRING_RECORD_LOCKED: string;
-
-  STRING_INVALID_DBF_FILE: string;
-  STRING_FIELD_TOO_LONG: string;
-  STRING_INVALID_FIELD_COUNT: string;
-
-  STRING_INDEX_BASED_ON_UNKNOWN_FIELD: string;
-  STRING_INDEX_BASED_ON_INVALID_FIELD: string;
-  STRING_INVALID_INDEX_TYPE: string;
-  STRING_CANNOT_OPEN_INDEX: string;
-  STRING_TOO_MANY_INDEXES: string;
-  STRING_INDEX_NOT_EXIST: string;
-  STRING_NEED_EXCLUSIVE_ACCESS: string;
-
-implementation
-
-initialization
-
-  STRING_FILE_NOT_FOUND               := 'Apertura: file non trovato: "%s"';
-  STRING_VERSION                      := 'TDbf V%d.%d';
-
-  STRING_RECORD_LOCKED                := 'Record già in uso.';
-
-  STRING_INVALID_DBF_FILE             := 'File DBF non valido.';
-  STRING_FIELD_TOO_LONG               := 'Valore troppo elevato: %d caratteri (esso non può essere più di %d).';
-  STRING_INVALID_FIELD_COUNT          := 'Campo non valido (count): %d (deve essere tra 1 e 4095).';
-
-  STRING_INDEX_BASED_ON_UNKNOWN_FIELD := 'Indice basato su un campo sconosciuto "%s"';
-  STRING_INDEX_BASED_ON_INVALID_FIELD := 'Campo "%s" è di tipo non valido per un indice';
-  STRING_INVALID_INDEX_TYPE           := 'Tipo indice non valido: Può essere solo string o float';
-  STRING_CANNOT_OPEN_INDEX            := 'Non è possibile aprire indice : "%s"';
-  STRING_TOO_MANY_INDEXES             := 'Non è possibile creare indice: Troppi indici aperti.';
-  STRING_INDEX_NOT_EXIST              := 'Indice "%s" non esiste.';
-  STRING_NEED_EXCLUSIVE_ACCESS        := 'L''Accesso in esclusiva è richiesto per questa operazione.';
-end.
+unit dbf_str;
+
+interface
+
+{$I Dbf_Common.inc}
+
+var
+  STRING_FILE_NOT_FOUND: string;
+  STRING_VERSION: string;
+
+  STRING_RECORD_LOCKED: string;
+
+  STRING_INVALID_DBF_FILE: string;
+  STRING_FIELD_TOO_LONG: string;
+  STRING_INVALID_FIELD_COUNT: string;
+
+  STRING_INDEX_BASED_ON_UNKNOWN_FIELD: string;
+  STRING_INDEX_BASED_ON_INVALID_FIELD: string;
+  STRING_INVALID_INDEX_TYPE: string;
+  STRING_CANNOT_OPEN_INDEX: string;
+  STRING_TOO_MANY_INDEXES: string;
+  STRING_INDEX_NOT_EXIST: string;
+  STRING_NEED_EXCLUSIVE_ACCESS: string;
+
+implementation
+
+initialization
+
+  STRING_FILE_NOT_FOUND               := 'Apertura: file non trovato: "%s"';
+  STRING_VERSION                      := 'TDbf V%d.%d';
+
+  STRING_RECORD_LOCKED                := 'Record già in uso.';
+
+  STRING_INVALID_DBF_FILE             := 'File DBF non valido.';
+  STRING_FIELD_TOO_LONG               := 'Valore troppo elevato: %d caratteri (esso non può essere più di %d).';
+  STRING_INVALID_FIELD_COUNT          := 'Campo non valido (count): %d (deve essere tra 1 e 4095).';
+
+  STRING_INDEX_BASED_ON_UNKNOWN_FIELD := 'Indice basato su un campo sconosciuto "%s"';
+  STRING_INDEX_BASED_ON_INVALID_FIELD := 'Campo "%s" è di tipo non valido per un indice';
+  STRING_INVALID_INDEX_TYPE           := 'Tipo indice non valido: Può essere solo string o float';
+  STRING_CANNOT_OPEN_INDEX            := 'Non è possibile aprire indice : "%s"';
+  STRING_TOO_MANY_INDEXES             := 'Non è possibile creare indice: Troppi indici aperti.';
+  STRING_INDEX_NOT_EXIST              := 'Indice "%s" non esiste.';
+  STRING_NEED_EXCLUSIVE_ACCESS        := 'L''Accesso in esclusiva è richiesto per questa operazione.';
+end.

+ 55 - 57
fcl/db/dbase/Dbf_Str_NL.pas → fcl/db/dbase/dbf_str_nl.pas

@@ -1,57 +1,55 @@
-unit Dbf_Str;
-
-{fix CR/LF}
-
-interface
-
-{$I Dbf_Common.inc}
-
-var
-  STRING_FILE_NOT_FOUND: string;
-  STRING_VERSION: string;
-
-  STRING_RECORD_LOCKED: string;
-  STRING_KEY_VIOLATION: string;
-
-  STRING_INVALID_DBF_FILE: string;
-  STRING_FIELD_TOO_LONG: string;
-  STRING_INVALID_FIELD_COUNT: string;
-  STRING_INVALID_FIELD_TYPE: string;
-
-  STRING_INDEX_BASED_ON_UNKNOWN_FIELD: string;
-  STRING_INDEX_BASED_ON_INVALID_FIELD: string;
-  STRING_INDEX_EXPRESSION_TOO_LONG: string;
-  STRING_INVALID_INDEX_TYPE: string;
-  STRING_CANNOT_OPEN_INDEX: string;
-  STRING_TOO_MANY_INDEXES: string;
-  STRING_INDEX_NOT_EXIST: string;
-  STRING_NEED_EXCLUSIVE_ACCESS: string;
-
-implementation
-
-initialization
-
-  STRING_FILE_NOT_FOUND               := 'Openen: bestand niet gevonden: "%s"';
-  STRING_VERSION                      := 'TDbf V%d.%d';
-
-  STRING_RECORD_LOCKED                := 'Record in gebruik.';
-  STRING_WRITE_ERROR                  := 'Error tijdens schrijven. (Disk vol?)';
-  STRING_KEY_VIOLATION                := 'Indexsleutel bestond al in bestand.'+#13+#10+
-                                         'Index: %s'+#13+#10+'Record=%d Sleutel=''%s''';
-
-  STRING_INVALID_DBF_FILE             := 'Ongeldig DBF bestand.';
-  STRING_FIELD_TOO_LONG               := 'Waarde is te lang: %d karakters (maximum is %d).';
-  STRING_INVALID_FIELD_COUNT          := 'Ongeldig aantal velden: %d (moet tussen 1 en 4095).';
-  STRING_INVALID_FIELD_TYPE           := 'Veldtype ''%s'' is ongeldig voor veld ''%s''.';
-  STRING_INVALID_VCL_FIELD_TYPE       := 'Veld "%s": VCL veldtype %x wordt niet ondersteund door DBF.';
-
-  STRING_INDEX_BASED_ON_UNKNOWN_FIELD := 'Index gebaseerd op onbekend veld "%s".';
-  STRING_INDEX_BASED_ON_INVALID_FIELD := 'Veld "%s" heeft een ongeldig veldtype om index op te baseren.';
-  STRING_INDEX_EXPRESSION_TOO_LONG    := 'Index expressie resultaat "%s" is te lang, >100 karakters (%d).';
-  STRING_INVALID_INDEX_TYPE           := 'Ongeldig index type: kan alleen karakter of numeriek.';
-  STRING_CANNOT_OPEN_INDEX            := 'Openen index gefaald: "%s".';
-  STRING_TOO_MANY_INDEXES             := 'Toevoegen index onmogenlijk: te veel indexen in bestand.';
-  STRING_INDEX_NOT_EXIST              := 'Index "%s" bestaat niet.';
-  STRING_NEED_EXCLUSIVE_ACCESS        := 'Exclusieve toegang is vereist voor deze actie.';
-end.
-
+unit dbf_str;
+
+interface
+
+{$I Dbf_Common.inc}
+
+var
+  STRING_FILE_NOT_FOUND: string;
+  STRING_VERSION: string;
+
+  STRING_RECORD_LOCKED: string;
+  STRING_KEY_VIOLATION: string;
+
+  STRING_INVALID_DBF_FILE: string;
+  STRING_FIELD_TOO_LONG: string;
+  STRING_INVALID_FIELD_COUNT: string;
+  STRING_INVALID_FIELD_TYPE: string;
+
+  STRING_INDEX_BASED_ON_UNKNOWN_FIELD: string;
+  STRING_INDEX_BASED_ON_INVALID_FIELD: string;
+  STRING_INDEX_EXPRESSION_TOO_LONG: string;
+  STRING_INVALID_INDEX_TYPE: string;
+  STRING_CANNOT_OPEN_INDEX: string;
+  STRING_TOO_MANY_INDEXES: string;
+  STRING_INDEX_NOT_EXIST: string;
+  STRING_NEED_EXCLUSIVE_ACCESS: string;
+
+implementation
+
+initialization
+
+  STRING_FILE_NOT_FOUND               := 'Openen: bestand niet gevonden: "%s"';
+  STRING_VERSION                      := 'TDbf V%d.%d';
+
+  STRING_RECORD_LOCKED                := 'Record in gebruik.';
+  STRING_WRITE_ERROR                  := 'Error tijdens schrijven. (Disk vol?)';
+  STRING_KEY_VIOLATION                := 'Indexsleutel bestond al in bestand.'+#13+#10+
+                                         'Index: %s'+#13+#10+'Record=%d Sleutel=''%s''';
+
+  STRING_INVALID_DBF_FILE             := 'Ongeldig DBF bestand.';
+  STRING_FIELD_TOO_LONG               := 'Waarde is te lang: %d karakters (maximum is %d).';
+  STRING_INVALID_FIELD_COUNT          := 'Ongeldig aantal velden: %d (moet tussen 1 en 4095).';
+  STRING_INVALID_FIELD_TYPE           := 'Veldtype ''%s'' is ongeldig voor veld ''%s''.';
+  STRING_INVALID_VCL_FIELD_TYPE       := 'Veld "%s": VCL veldtype %x wordt niet ondersteund door DBF.';
+
+  STRING_INDEX_BASED_ON_UNKNOWN_FIELD := 'Index gebaseerd op onbekend veld "%s".';
+  STRING_INDEX_BASED_ON_INVALID_FIELD := 'Veld "%s" heeft een ongeldig veldtype om index op te baseren.';
+  STRING_INDEX_EXPRESSION_TOO_LONG    := 'Index expressie resultaat "%s" is te lang, >100 karakters (%d).';
+  STRING_INVALID_INDEX_TYPE           := 'Ongeldig index type: kan alleen karakter of numeriek.';
+  STRING_CANNOT_OPEN_INDEX            := 'Openen index gefaald: "%s".';
+  STRING_TOO_MANY_INDEXES             := 'Toevoegen index onmogenlijk: te veel indexen in bestand.';
+  STRING_INDEX_NOT_EXIST              := 'Index "%s" bestaat niet.';
+  STRING_NEED_EXCLUSIVE_ACCESS        := 'Exclusieve toegang is vereist voor deze actie.';
+end.
+

+ 36 - 36
fcl/db/dbase/Dbf_Str_PL.pas → fcl/db/dbase/dbf_str_pl.pas

@@ -1,36 +1,36 @@
-unit Dbf_Str;
-
-interface
-
-{$I Dbf_Common.inc}
-{$I Dbf_Str.inc}
-
-implementation
-
-initialization
-
-  STRING_FILE_NOT_FOUND               := 'Open: brak pliku: "%s"';
-  STRING_VERSION                      := 'TDbf V%d.%d';
-
-  STRING_RECORD_LOCKED                := 'Rekord zablokowany.';
-  STRING_WRITE_ERROR                  := 'Niezapisano(Brak miejsca na dysku?)';
-  STRING_KEY_VIOLATION                := 'Konflikt klucza. (Klucz obecny w pliku).'+#13+#10+
-                                         'Indeks: %s'+#13+#10+'Rekord=%d Klucz=''%s''';
-
-  STRING_INVALID_DBF_FILE             := 'Uszkodzony plik bazy.';
-  STRING_FIELD_TOO_LONG               := 'Dana za d³uga : %d znaków (dopuszczalne do %d).';
-  STRING_INVALID_FIELD_COUNT          := 'Z³a liczba pól: %d (dozwolone 1 do 4095).';
-  STRING_INVALID_FIELD_TYPE           := 'B³êdny typ pola ''%c'' dla pola ''%s''.';
-  STRING_INVALID_VCL_FIELD_TYPE       := 'Nie mogê tworzyæ pola "%s", typ pola VCL %x nie wspierany przez DBF.';
-
-
-  STRING_INDEX_BASED_ON_UNKNOWN_FIELD := 'Kluczowe pole indeksu "%s" nie istnieje';
-  STRING_INDEX_BASED_ON_INVALID_FIELD := 'Typ pola "%s" niedozwolony dla indeksów';
-  STRING_INDEX_EXPRESSION_TOO_LONG    := 'Zbyt d³ugi wynik "%s", >100 znaków (%d).';
-  STRING_INVALID_INDEX_TYPE           := 'Z³y typ indeksu: tylko string lub float';
-  STRING_CANNOT_OPEN_INDEX            := 'Nie mogê otworzyæ indeksu: "%s"';
-  STRING_TOO_MANY_INDEXES             := 'Nie mogê stworzyæ indeksu: za du¿o w pliku.';
-  STRING_INDEX_NOT_EXIST              := 'Brak indeksu "%s".';
-  STRING_NEED_EXCLUSIVE_ACCESS        := 'Operacja wymaga dostêpu w trybie Exclusive.';
-end.
-
+unit dbf_str;
+
+interface
+
+{$I Dbf_Common.inc}
+{$I Dbf_Str.inc}
+
+implementation
+
+initialization
+
+  STRING_FILE_NOT_FOUND               := 'Open: brak pliku: "%s"';
+  STRING_VERSION                      := 'TDbf V%d.%d';
+
+  STRING_RECORD_LOCKED                := 'Rekord zablokowany.';
+  STRING_WRITE_ERROR                  := 'Niezapisano(Brak miejsca na dysku?)';
+  STRING_KEY_VIOLATION                := 'Konflikt klucza. (Klucz obecny w pliku).'+#13+#10+
+                                         'Indeks: %s'+#13+#10+'Rekord=%d Klucz=''%s''';
+
+  STRING_INVALID_DBF_FILE             := 'Uszkodzony plik bazy.';
+  STRING_FIELD_TOO_LONG               := 'Dana za d³uga : %d znaków (dopuszczalne do %d).';
+  STRING_INVALID_FIELD_COUNT          := 'Z³a liczba pól: %d (dozwolone 1 do 4095).';
+  STRING_INVALID_FIELD_TYPE           := 'B³êdny typ pola ''%c'' dla pola ''%s''.';
+  STRING_INVALID_VCL_FIELD_TYPE       := 'Nie mogê tworzyæ pola "%s", typ pola VCL %x nie wspierany przez DBF.';
+
+
+  STRING_INDEX_BASED_ON_UNKNOWN_FIELD := 'Kluczowe pole indeksu "%s" nie istnieje';
+  STRING_INDEX_BASED_ON_INVALID_FIELD := 'Typ pola "%s" niedozwolony dla indeksów';
+  STRING_INDEX_EXPRESSION_TOO_LONG    := 'Zbyt d³ugi wynik "%s", >100 znaków (%d).';
+  STRING_INVALID_INDEX_TYPE           := 'Z³y typ indeksu: tylko string lub float';
+  STRING_CANNOT_OPEN_INDEX            := 'Nie mogê otworzyæ indeksu: "%s"';
+  STRING_TOO_MANY_INDEXES             := 'Nie mogê stworzyæ indeksu: za du¿o w pliku.';
+  STRING_INDEX_NOT_EXIST              := 'Brak indeksu "%s".';
+  STRING_NEED_EXCLUSIVE_ACCESS        := 'Operacja wymaga dostêpu w trybie Exclusive.';
+end.
+

+ 37 - 0
fcl/db/dbase/dbf_str_pt.pas

@@ -0,0 +1,37 @@
+unit dbf_str;
+
+{ note this is Brazilian Portuguese }
+
+interface
+
+{$I Dbf_Common.inc}
+{$I Dbf_Str.inc}
+
+implementation
+
+initialization
+
+  STRING_FILE_NOT_FOUND               := 'Abertura: arquivo não encontrado: "%s".';
+  STRING_VERSION                      := 'TDbf V%d.%d';
+
+  STRING_RECORD_LOCKED                := 'Registro bloqueado.';
+  STRING_WRITE_ERROR                  := 'Erro de escrita. (Disco cheio?)';
+  STRING_WRITE_INDEX_ERROR            := 'Erro de escrita; índices provavelmente corrompidos. (Disco cheio?)';
+  STRING_KEY_VIOLATION                := 'Violação de chave. (Chave já presente no archivo).'+#13+#10+
+                                         'Índice: %s'+#13+#10+'Registro=%d Chave=''%s''.';
+
+  STRING_INVALID_DBF_FILE             := 'Arquivo DBF inválido.';
+  STRING_FIELD_TOO_LONG               := 'Valor muito grande: %d caracteres (não pode ser maior que %d).';
+  STRING_INVALID_FIELD_COUNT          := 'Quantidade de campos inválida: %d (deve estar entre 1 e 4095).';
+  STRING_INVALID_FIELD_TYPE           := 'Tipo de campo inválido ''%s'' para o campo ''%s''.';
+  STRING_INVALID_VCL_FIELD_TYPE       := 'Não se pode criar o campo "%s", campo VCL tipo %x não suportado por DBF.';
+
+  STRING_INDEX_BASED_ON_UNKNOWN_FIELD := 'Índice baseado em campo desconhecido "%s".';
+  STRING_INDEX_BASED_ON_INVALID_FIELD := 'Campo "%s" inválido para criar um índice.';
+  STRING_INDEX_EXPRESSION_TOO_LONG    := 'Resultado de índice para "%s" demasiado grande, >100 caracteres (%d).';
+  STRING_INVALID_INDEX_TYPE           := 'Tipo de índice inválido: só pode ser string ou float.';
+  STRING_CANNOT_OPEN_INDEX            := 'Não se pode abrir o índice: "%s".';
+  STRING_TOO_MANY_INDEXES             := 'Não se pode criar o índice: demasiados índices no archivo.';
+  STRING_INDEX_NOT_EXIST              := 'Ìndice "%s" não existe.';
+  STRING_NEED_EXCLUSIVE_ACCESS        := 'Acesso Exclusivo requerido para esta operação.';
+end.

+ 40 - 42
fcl/db/dbase/Dbf_Str_RU.pas → fcl/db/dbase/dbf_str_ru.pas

@@ -1,42 +1,40 @@
-unit Dbf_Str_RU;
-
-{fix CR/LF}
-
-// file is encoded in Windows-1251 encoding
-// for using with Linux/Kylix must be re-coded to KOI8-R
-// for use with DOS & OS/2 (if it will be possible with FreePascal or VirtualPascal)
-//    file should be recoded to cp866
-
-interface
-
-{$I Dbf_Common.inc}
-{$I Dbf_Str.inc}
-
-implementation
-
-initialization
-
-  STRING_FILE_NOT_FOUND               := 'Ôàéë "%s" íå ñóùåñòâóåò. Îòêðûòü íåâîçìîæíî.';
-  STRING_VERSION                      := 'TDbf V%d.%d';
-
-  STRING_RECORD_LOCKED                := 'Çàïèñü (ñòðîêà òàáëèöû) çàáëîêèðîâàíà.';
-  STRING_WRITE_ERROR                  := 'Îøèáêà çàïèñè íà äèñê (Äèñê çàïîëíåí?)';
-  STRING_KEY_VIOLATION                := 'Êëþ÷åâîå çíà÷åíèå íå äîëæíî ïîâòîðÿòüñÿ!.'+#13+#10+
-                                         'Èíäåêñ: %s'+#13+#10+'Çàïèñü (ñòðîêà)=%d  Êëþ÷="%s".';
-
-  STRING_INVALID_DBF_FILE             := 'Ôàéë DBF ïîâðåæäåí èëè åãî ñòðóêòóðà íå DBF.';
-  STRING_FIELD_TOO_LONG               := 'Äëèíà çíà÷åíèÿ - %d ñèìâîëîâ, ýòî áîëüøå ìàêñèìóìà - %d.';
-  STRING_INVALID_FIELD_COUNT          := 'Êîëè÷åñòâî ïîëåé â òàáëèöå (%d) íåâîçìîæíî. Äîïóñòèìî îò 1 äî 4095.';
-  STRING_INVALID_FIELD_TYPE           := 'Òèï çíà÷åíèÿ "%s", çàòðåáîâàííûé ïîëåì "%s" íåâîçìîæåí.';
-  STRING_INVALID_VCL_FIELD_TYPE       := 'Íåâîçìîæíî ñîçäàòü ïîëå "%s", Òèï äàííûõ VCL[%x] íå ìîæåò áûòü çàïèñàí â DBF.';
-
-  STRING_INDEX_BASED_ON_UNKNOWN_FIELD := 'Èíäåêñ ññûëàåòñÿ íà íåñóùåñòâóþùåå ïîëå "%s".';
-  STRING_INDEX_BASED_ON_INVALID_FIELD := 'Ïîëå "%s" íå ìîæåò áûòü èíäåêñèðîâàííî. Èíäåêñû íå ïîääåðæèâàþò òàêîé òèï ïîëÿ.';
-  STRING_INDEX_EXPRESSION_TOO_LONG    := '%s: Ñëèøêîì äëèííîå çíà÷åíèå äëÿ èíäåêñà (%d). Äîëæíî áûòü íå áîëüøå 100 ñèìâîëîâ.';
-  STRING_INVALID_INDEX_TYPE           := 'Íåâîçìîæíûé òèï èíäåêñà: èíäåêñàöèÿ âîçìîæíî òîëüêî ïî ÷èñëó èëè ñòðîêå';
-  STRING_CANNOT_OPEN_INDEX            := 'Íåâîçìîæíî îòêðûòü èíäåêñ "%s".';
-  STRING_TOO_MANY_INDEXES             := 'Íåâîçìîæíî ñîçäàòü åùå îäèí èíäåêñ. Ôàéë ïîëîí.';
-  STRING_INDEX_NOT_EXIST              := 'Èíäåêñ "%s" íå ñóùåñòâóåò.';
-  STRING_NEED_EXCLUSIVE_ACCESS        := 'Íåâîçìîæíî âûïîëíèòü - ñíà÷àëà íóæíî ïîëó÷èòü ìîíîïîëüíûé äîñòóï.';
-end.
-
+unit dbf_str_ru;
+
+// file is encoded in Windows-1251 encoding
+// for using with Linux/Kylix must be re-coded to KOI8-R
+// for use with DOS & OS/2 (if it will be possible with FreePascal or VirtualPascal)
+//    file should be recoded to cp866
+
+interface
+
+{$I Dbf_Common.inc}
+{$I Dbf_Str.inc}
+
+implementation
+
+initialization
+
+  STRING_FILE_NOT_FOUND               := 'Ôàéë "%s" íå ñóùåñòâóåò. Îòêðûòü íåâîçìîæíî.';
+  STRING_VERSION                      := 'TDbf V%d.%d';
+
+  STRING_RECORD_LOCKED                := 'Çàïèñü (ñòðîêà òàáëèöû) çàáëîêèðîâàíà.';
+  STRING_WRITE_ERROR                  := 'Îøèáêà çàïèñè íà äèñê (Äèñê çàïîëíåí?)';
+  STRING_KEY_VIOLATION                := 'Êëþ÷åâîå çíà÷åíèå íå äîëæíî ïîâòîðÿòüñÿ!.'+#13+#10+
+                                         'Èíäåêñ: %s'+#13+#10+'Çàïèñü (ñòðîêà)=%d  Êëþ÷="%s".';
+
+  STRING_INVALID_DBF_FILE             := 'Ôàéë DBF ïîâðåæäåí èëè åãî ñòðóêòóðà íå DBF.';
+  STRING_FIELD_TOO_LONG               := 'Äëèíà çíà÷åíèÿ - %d ñèìâîëîâ, ýòî áîëüøå ìàêñèìóìà - %d.';
+  STRING_INVALID_FIELD_COUNT          := 'Êîëè÷åñòâî ïîëåé â òàáëèöå (%d) íåâîçìîæíî. Äîïóñòèìî îò 1 äî 4095.';
+  STRING_INVALID_FIELD_TYPE           := 'Òèï çíà÷åíèÿ "%s", çàòðåáîâàííûé ïîëåì "%s" íåâîçìîæåí.';
+  STRING_INVALID_VCL_FIELD_TYPE       := 'Íåâîçìîæíî ñîçäàòü ïîëå "%s", Òèï äàííûõ VCL[%x] íå ìîæåò áûòü çàïèñàí â DBF.';
+
+  STRING_INDEX_BASED_ON_UNKNOWN_FIELD := 'Èíäåêñ ññûëàåòñÿ íà íåñóùåñòâóþùåå ïîëå "%s".';
+  STRING_INDEX_BASED_ON_INVALID_FIELD := 'Ïîëå "%s" íå ìîæåò áûòü èíäåêñèðîâàííî. Èíäåêñû íå ïîääåðæèâàþò òàêîé òèï ïîëÿ.';
+  STRING_INDEX_EXPRESSION_TOO_LONG    := '%s: Ñëèøêîì äëèííîå çíà÷åíèå äëÿ èíäåêñà (%d). Äîëæíî áûòü íå áîëüøå 100 ñèìâîëîâ.';
+  STRING_INVALID_INDEX_TYPE           := 'Íåâîçìîæíûé òèï èíäåêñà: èíäåêñàöèÿ âîçìîæíî òîëüêî ïî ÷èñëó èëè ñòðîêå';
+  STRING_CANNOT_OPEN_INDEX            := 'Íåâîçìîæíî îòêðûòü èíäåêñ "%s".';
+  STRING_TOO_MANY_INDEXES             := 'Íåâîçìîæíî ñîçäàòü åùå îäèí èíäåêñ. Ôàéë ïîëîí.';
+  STRING_INDEX_NOT_EXIST              := 'Èíäåêñ "%s" íå ñóùåñòâóåò.';
+  STRING_NEED_EXCLUSIVE_ACCESS        := 'Íåâîçìîæíî âûïîëíèòü - ñíà÷àëà íóæíî ïîëó÷èòü ìîíîïîëüíûé äîñòóï.';
+end.
+

+ 0 - 0
fcl/db/dbase/Dbf_Struct.inc → fcl/db/dbase/dbf_struct.inc


+ 5 - 4
fcl/db/dbase/Dbf_Wtil.pas → fcl/db/dbase/dbf_wtil.pas

@@ -1,4 +1,4 @@
-unit Dbf_Wtil;
+unit dbf_wtil;
 
 
 {$i Dbf_Common.inc}
 {$i Dbf_Common.inc}
 
 
@@ -6,11 +6,10 @@ interface
 
 
 {$ifndef WIN32}
 {$ifndef WIN32}
 uses
 uses
-{$ifdef KYLIX}
-  Libc, 
-{$endif}
 {$ifdef FPC}
 {$ifdef FPC}
   BaseUnix,
   BaseUnix,
+{$else}
+  Libc, 
 {$endif}
 {$endif}
   Types, SysUtils, Classes;
   Types, SysUtils, Classes;
 
 
@@ -550,6 +549,8 @@ end;
 function CompareString(Locale: LCID; dwCmpFlags: DWORD; lpString1: PChar; cchCount1: Integer; lpString2: PChar; cchCount2: Integer): Integer;
 function CompareString(Locale: LCID; dwCmpFlags: DWORD; lpString1: PChar; cchCount1: Integer; lpString2: PChar; cchCount2: Integer): Integer;
 begin
 begin
   Result := StrLComp(lpString1, lpString2, cchCount1) + 2;
   Result := StrLComp(lpString1, lpString2, cchCount1) + 2;
+  if Result > 2 then Result := 3;
+  if Result < 2 then Result := 1;
 end;
 end;
 
 
 function EnumSystemCodePages(lpCodePageEnumProc: TFNCodepageEnumProc; dwFlags: DWORD): BOOL;
 function EnumSystemCodePages(lpCodePageEnumProc: TFNCodepageEnumProc; dwFlags: DWORD): BOOL;

+ 22 - 0
fcl/db/dbase/tdbf_l.pas

@@ -0,0 +1,22 @@
+{  This file was automatically created by Lazarus. Do not edit!
+  This source is only used to compile and install
+  the package tdbf_l 0.0.
+}
+
+unit tdbf_l; 
+
+interface
+
+uses
+  Dbf, Dbf_Reg, LazarusPackageIntf; 
+
+implementation
+
+procedure Register; 
+begin
+  RegisterUnit('Dbf', @Dbf_Reg.Register); 
+end; 
+
+initialization
+  RegisterPackage('tdbf_l', @Register)
+end.