Additional Visual Foxpro functionality for TDbf. AutoInc fields work and can...

packages/fcl-db/src/dbase/dbf.pas

@@ -163,7 +163,6 @@ type
 //====================================================================
   TDbf = class(TDataSet)
   private
-    FDbfFile: TDbfFile;
     FCursor: TVirtualCursor;
     FOpenMode: TDbfOpenMode;
     FStorage: TDbfStorage;
@@ -200,6 +199,7 @@ type
     FDateTimeHandling: TDateTimeHandling;
     FTranslationMode: TDbfTranslationMode;
     FIndexDefs: TDbfIndexDefs;
+    FUseAutoInc: Boolean;
     FBeforeAutoCreate: TBeforeAutoCreateEvent;
     FOnTranslate: TTranslateEvent;
     FOnLanguageWarning: TLanguageWarningEvent;
@@ -217,6 +217,7 @@ type
     function GetPhysicalRecordCount: Integer;
     function GetKeySize: Integer;
     function GetMasterFields: string;
+    function GetNextAutoInc: Cardinal;
     function FieldDefsStored: Boolean;
     procedure SetBackLink(NewBackLink: String);
 
@@ -230,6 +231,8 @@ type
     procedure SetMasterFields(const Value: string);
     procedure SetTableLevel(const NewLevel: Integer);
     procedure SetPhysicalRecNo(const NewRecNo: Integer);
+    procedure SetNextAutoInc(ThisNextAutoInc: Cardinal);
+    procedure SetUseAutoInc(ThisUseAutoInc: Boolean);
 
     procedure MasterChanged(Sender: TObject);
     procedure MasterDisabled(Sender: TObject);
@@ -246,6 +249,8 @@ type
     procedure SetRangeBuffer(LowRange: PChar; HighRange: PChar);
 
   protected
+    FDbfFile: TDbfFile;
+
     { abstract methods }
     function  AllocRecordBuffer: TRecordBuffer; override; {virtual abstract}
     procedure ClearCalcFields(Buffer: TRecordBuffer); override;
@@ -428,6 +433,8 @@ type
     // Storage for memo file - if any - when using memory storage
     property UserMemoStream: TStream read FUserMemoStream write FUserMemoStream;
     property DisableResyncOnPost: Boolean read FDisableResyncOnPost write FDisableResyncOnPost;
+    // The value stored in the file.
+    property NextAutoInc: Cardinal read GetNextAutoInc write SetNextAutoInc;
   published
     property DateTimeHandling: TDateTimeHandling
              read FDateTimeHandling write FDateTimeHandling default dtBDETimeStamp;
@@ -448,6 +455,8 @@ type
     property TableName: string read FTableName write SetTableName;
     property TableLevel: Integer read FTableLevel write SetTableLevel;
     property Version: string read GetVersion write SetVersion stored false;
+    // Turn this off to overwrite.
+    property UseAutoInc: Boolean read FUseAutoInc write SetUseAutoInc;
     property BeforeAutoCreate: TBeforeAutoCreateEvent read FBeforeAutoCreate write FBeforeAutoCreate;
     property OnCompareRecord: TNotifyEvent read FOnCompareRecord write FOnCompareRecord;
     property OnLanguageWarning: TLanguageWarningEvent read FOnLanguageWarning write FOnLanguageWarning;
@@ -682,6 +691,7 @@ begin
   FTableLevel := 4;
   FIndexName := EmptyStr;
   FilePath := EmptyStr;
+  FUseAutoInc := True;
   FTempBuffer := nil;
   FFilterBuffer := nil;
   FIndexFile := nil;
@@ -2719,6 +2729,19 @@ begin
   DoAfterScroll;
 end;
 
+procedure TDbf.SetNextAutoInc(ThisNextAutoInc: Cardinal);
+begin
+  DbfFile.NextAutoInc := ThisNextAutoInc;
+end;
+
+procedure TDbf.SetUseAutoInc(ThisUseAutoInc: Boolean);
+begin
+  if FUseAutoInc = ThisUseAutoInc then Exit;
+
+  FUseAutoInc := ThisUseAutoInc;
+  DbfFile.UseAutoInc := FUseAutoInc;
+end;
+
 function TDbf.GetDbfFieldDefs: TDbfFieldDefs;
 begin
   if FDbfFile <> nil then
@@ -3001,6 +3024,11 @@ begin
   Result := FMasterLink.FieldNames;
 end;
 
+function TDbf.GetNextAutoInc: Cardinal;
+begin
+  Result := DbfFile.NextAutoInc;
+end;
+
 procedure TDbf.SetMasterFields(const Value: string);
 begin
   FMasterLink.FieldNames := Value;

packages/fcl-db/src/dbase/dbf_dbffile.pas

@@ -104,6 +104,8 @@ type
     // Updates _NULLFLAGS field with null or varlength flag for field
     procedure UpdateNullField(Buffer: Pointer; AFieldDef: TDbfFieldDef; Action: TUpdateNullField; WhichField: TNullFieldFlag);
     procedure WriteLockInfo(Buffer: TRecordBuffer);
+    function GetNextAutoInc: Cardinal;
+    procedure SetNextAutoInc(ThisNextAutoInc: Cardinal);
 
   public
     constructor Create;
@@ -131,7 +133,7 @@ type
     // Write dbf header as well as EOF marker at end of file if necessary
     procedure WriteHeader; override;
     // Writes autoinc value to record buffer and updates autoinc value in field header
-    procedure ApplyAutoIncToBuffer(DestBuf: TRecordBuffer);
+    procedure ApplyAutoIncToBuffer(DestBuf: TRecordBuffer); virtual;
     procedure FastPackTable;
     procedure RestructureTable(DbfFieldDefs: TDbfFieldDefs; Pack: Boolean);
     procedure Rename(DestFileName: string; NewIndexFileNames: TStrings; DeleteFiles: boolean);
@@ -180,6 +182,8 @@ type
     property CopyDateTimeAsString: Boolean read FCopyDateTimeAsString write FCopyDateTimeAsString;
     property DateTimeHandling: TDateTimeHandling read FDateTimeHandling write FDateTimeHandling;
 
+    property NextAutoInc: Cardinal read GetNextAutoInc write SetNextAutoInc;
+
     property OnIndexMissing: TDbfIndexMissingEvent read FOnIndexMissing write FOnIndexMissing;
     property OnLocaleError: TDbfLocaleErrorEvent read FOnLocaleError write FOnLocaleError;
   end;
@@ -842,7 +846,7 @@ begin
 
           //AutoInc only support in Visual Foxpro; another upgrade
           //Note: .AutoIncrementNext is really a cardinal (see the definition)
-          lFieldDescIII.AutoIncrementNext:=SwapIntLE(lFieldDef.AutoInc);
+          PCardinal(@lFieldDescIII.AutoIncrementNext)^:=SwapIntLE(lFieldDef.AutoInc);
           lFieldDescIII.AutoIncrementStep:=lFieldDef.AutoIncStep;
           // Set autoincrement flag using AutoIncStep as a marker
           if (lFieldDef.AutoIncStep<>0) then
@@ -952,6 +956,111 @@ begin
   end;
 end;
 
+function TDbfFile.GetNextAutoInc: Cardinal;
+var
+  TempFieldDef: TDbfFieldDef;
+  I, NextVal, lAutoIncOffset: Cardinal;
+begin
+  Result := 0;
+
+  if FAutoIncPresent then
+  begin
+    // if shared, reread header to find new autoinc values
+    if NeedLocks then
+    begin
+      // lock header so nobody else can use this value
+      LockPage(0, true);
+    end;
+
+    // find autoinc fields
+    for I := 0 to FFieldDefs.Count-1 do
+    begin
+      TempFieldDef := FFieldDefs.Items[I];
+      if (DbfVersion=xBaseVII) and
+        (TempFieldDef.NativeFieldType = '+') then
+      begin
+        // read current auto inc, from header or field, depending on sharing
+        lAutoIncOffset := sizeof(rDbfHdr) + sizeof(rEndFixedHdrVII) +
+          FieldDescVII_AutoIncOffset + I * sizeof(rFieldDescVII);
+        if NeedLocks then
+        begin
+          ReadBlock(@NextVal, 4, lAutoIncOffset);
+          NextVal := SwapIntLE(NextVal);
+        end else
+          NextVal := TempFieldDef.AutoInc;
+        // store to buffer, positive = high bit on, so flip it
+        Result := NextVal;
+      end
+      else //No DBaseVII
+      if (DbfVersion=xVisualFoxPro) and (TempFieldDef.NativeFieldType = 'I') and
+        (TempFieldDef.AutoIncStep<>0) then
+      begin
+        // read current auto inc from field header
+        lAutoIncOffset := SizeOf(rDbfHdr) + FieldDescIII_AutoIncOffset +
+          SizeOf(rFieldDescIII) * I;
+        if NeedLocks then
+        begin
+          ReadBlock(@NextVal, 4, lAutoIncOffset);
+          NextVal := SwapIntLE(NextVal);
+        end else
+          NextVal := TempFieldDef.AutoInc;
+        Result := NextVal;
+      end;
+    end;
+
+    // release lock if locked
+    if NeedLocks then
+      UnlockPage(0);
+  end;
+end;
+
+procedure TDbfFile.SetNextAutoInc(ThisNextAutoInc: Cardinal);
+var
+  TempFieldDef: TDbfFieldDef;
+  I, NextVal, lAutoIncOffset: Cardinal;
+begin
+  if FAutoIncPresent then
+  begin
+    // if shared, reread header to find new autoinc values
+    if NeedLocks then
+    begin
+      // lock header so nobody else can use this value
+      LockPage(0, true);
+    end;
+
+    // find autoinc fields
+    for I := 0 to FFieldDefs.Count-1 do
+    begin
+      TempFieldDef := FFieldDefs.Items[I];
+      if (DbfVersion=xBaseVII) and
+        (TempFieldDef.NativeFieldType = '+') then
+      begin
+        // read current auto inc, from header or field, depending on sharing
+        lAutoIncOffset := sizeof(rDbfHdr) + sizeof(rEndFixedHdrVII) +
+          FieldDescVII_AutoIncOffset + I * sizeof(rFieldDescVII);
+        // write new value to header buffer
+        PCardinal(FHeader+lAutoIncOffset)^ := SwapIntLE(ThisNextAutoInc);
+      end
+      else //No DBaseVII
+      if (DbfVersion=xVisualFoxPro) and (TempFieldDef.NativeFieldType = 'I') and
+        (TempFieldDef.AutoIncStep<>0) then
+      begin
+        // read current auto inc from field header
+        lAutoIncOffset := SizeOf(rDbfHdr) + FieldDescIII_AutoIncOffset +
+          SizeOf(rFieldDescIII) * I;
+        PCardinal(FHeader+lAutoIncOffset)^ := SwapIntLE(ThisNextAutoInc);
+      end;
+    end;
+
+    // write modified header (new autoinc values) to file
+    WriteHeader;
+
+    // release lock if locked
+    if NeedLocks then
+      UnlockPage(0);
+  end;
+end;
+
 function TDbfFile.HasBlob: Boolean;
 var
   I: Integer;
@@ -1027,6 +1136,7 @@ var
   TempFieldDef: TDbfFieldDef;
   lSize,lPrec,I, lColumnCount: Integer;
   lAutoInc: Cardinal;
+  lAutoIncStep: Byte;
   dataPtr: PChar;
   lNativeFieldType: Char;
   lFieldName: string;
@@ -1077,6 +1187,9 @@ begin
   try
     // Specs say there has to be at least one field, so use repeat:
     repeat
+      // clear autoinc params
+      lAutoInc := 0;
+      lAutoIncStep := 0;
       // version field info?
       if FDbfVersion = xBaseVII then
       begin
@@ -1098,8 +1211,9 @@ begin
         if (FDBFVersion=xVisualFoxPro) and ((lFieldDescIII.VisualFoxProFlags and $0C)<>0) then
         begin
           // We do not test for an I field - we could implement our own N autoincrement this way...
-          lAutoInc:=lFieldDescIII.AutoIncrementNext;
-          FAutoIncPresent:=true;
+          lAutoInc := PCardinal(@lFieldDescIII.AutoIncrementNext)^;
+          lAutoIncStep := lFieldDescIII.AutoIncrementStep;
+          FAutoIncPresent := True;
         end;
 
         // Only Visual FoxPro supports null fields, if the nullable field flag is on
@@ -1138,6 +1252,7 @@ begin
         Size := lSize;
         Precision := lPrec;
         AutoInc := lAutoInc;
+        AutoIncStep := lAutoIncStep;
         NativeFieldType := lNativeFieldType;
         IsSystemField := lIsVFPSystemField;
         if lIsVFPVarLength then
@@ -2392,7 +2507,7 @@ var
   TempFieldDef: TDbfFieldDef;
   I, NextVal, lAutoIncOffset: {LongWord} Cardinal;    {Delphi 3 does not know LongWord?}
 begin
-  if FAutoIncPresent then
+  if FAutoIncPresent and FUseAutoInc then
   begin
     // if shared, reread header to find new autoinc values
     if NeedLocks then
@@ -2426,16 +2541,24 @@ begin
         PCardinal(FHeader+lAutoIncOffset)^ := SwapIntLE(NextVal);
       end
       else //No DBaseVII
-      if (DbfVersion=xVisualFoxPro) and
+      if (DbfVersion=xVisualFoxPro) and (TempFieldDef.NativeFieldType = 'I') and
         (TempFieldDef.AutoIncStep<>0) then
       begin
         // read current auto inc from field header
-        NextVal:=TempFieldDef.AutoInc; //todo: is this correct
-        PCardinal(DestBuf+TempFieldDef.Offset)^ := SwapIntBE(NextVal); //todo: is swapintbe correct?
+        lAutoIncOffset := SizeOf(rDbfHdr) + FieldDescIII_AutoIncOffset +
+          SizeOf(rFieldDescIII) * I;
+        if NeedLocks then
+        begin
+          ReadBlock(@NextVal, 4, lAutoIncOffset);
+          NextVal := SwapIntLE(NextVal);
+        end else
+          NextVal := TempFieldDef.AutoInc;
+        PCardinal(DestBuf+TempFieldDef.Offset)^ := SwapIntLE(NextVal);
         // Increase with step size
         NextVal:=NextVal+TempFieldDef.AutoIncStep;
         // write new value back
         TempFieldDef.AutoInc:=NextVal;
+        PCardinal(FHeader+lAutoIncOffset)^ := SwapIntLE(NextVal);
       end;
     end;
 

packages/fcl-db/src/dbase/dbf_fields.pas

@@ -467,7 +467,17 @@ begin
   case FFieldType of
     ftAutoInc  :
       if DbfVersion=xVisualFoxPro then
-        FNativeFieldType  := 'I'
+      begin
+        FNativeFieldType  := 'I';
+        // set some default autoinc start value and step
+        // without it field will be considered a simple integer field
+        // (not sure if this is the right place for that)
+        if (FAutoInc = 0) and (FAllocSize = 0) then
+        begin
+          FAutoInc := 1;
+          FAutoIncStep := 1;
+        end;
+      end
       else
         FNativeFieldType  := '+'; //Apparently xbaseV/7+ only; not (Visual) Foxpro
     ftDateTime :

packages/fcl-db/src/dbase/dbf_pgfile.pas

@@ -79,6 +79,7 @@ type
     FBufferMaxSize: Integer;
     FBufferModified: Boolean;
     FWriteError: Boolean;
+    FUseAutoInc: Boolean;
   protected
     procedure SetHeaderOffset(NewValue: Integer); virtual;
     procedure SetRecordSize(NewValue: Integer); virtual;
@@ -160,6 +161,7 @@ type
     property Stream: TStream read FStream write SetStream;
     property BufferAhead: Boolean read FBufferAhead write SetBufferAhead;
     property WriteError: Boolean read FWriteError;
+    property UseAutoInc: Boolean read FUseAutoInc write FUseAutoInc;
   end;
 
 implementation

packages/fcl-db/src/dbase/dbf_struct.inc

@@ -22,6 +22,7 @@ const
   FieldPropType_Default     = $04;
   FieldPropType_Constraint  = $06;
 
+  FieldDescIII_AutoIncOffset = 19;
   FieldDescVII_AutoIncOffset = 42;
 
 //====================================================================