paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-22 11:49:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Frank Rademakers 2022-07-11 15:57:30 +00:00 committed by Michael Van Canneyt
parent 501f397277
commit 9d4cdc9383
5 changed files with 174 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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;

139
packages/fcl-db/src/dbase/dbf_dbffile.pas
View File

@ -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;

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

@ -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 :

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

@ -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

1
packages/fcl-db/src/dbase/dbf_struct.inc
View File

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