Why Gemfury?
Push, build, and install
RubyGems
npm packages
Python packages
Maven artifacts
PHP packages
Go Modules
Debian packages
RPM packages
NuGet packages
Repository URL to install this package:
|
Version:
3.2.0 ▾
|
unit dbf_dbffile;
interface
{$I dbf_common.inc}
uses
Classes, SysUtils,
{$ifdef WINDOWS}
Windows,
{$else}
{$ifdef KYLIX}
Libc,
{$endif}
Types, dbf_wtil,
{$endif}
Db,
dbf_common,
dbf_cursor,
dbf_pgfile,
dbf_fields,
dbf_memo,
dbf_idxfile;
//====================================================================
//=== Dbf support (first part)
//====================================================================
// TxBaseVersion = (xUnknown,xClipper,xBaseIII,xBaseIV,xBaseV,xFoxPro,xVisualFoxPro);
// TPagedFileMode = (pfOpen,pfCreate);
// TDbfGetMode = (xFirst,xPrev,xCurrent, xNext, xLast);
// TDbfGetResult = (xOK, xBOF, xEOF, xError);
type
//====================================================================
TDbfIndexMissingEvent = procedure(var DeleteLink: Boolean) of object;
TUpdateNullField = (unfClear, unfSet);
TNullFieldFlag = (nfNullFlag, nfVarlengthFlag); //the field that the nullflags bit applies to
//====================================================================
TDbfGlobals = class;
//====================================================================
{ TDbfFile }
TDbfFile = class(TPagedFile)
protected
FBackLink: string;
FBackLinkOffset: integer; //position of VFP backlink within header
FMdxFile: TIndexFile;
FMemoFile: TMemoFile;
FMemoStream: TStream;
FFieldDefs: TDbfFieldDefs;
FIndexNames: TStringList;
FIndexFiles: TList;
FIndexStream: TStream;
FDbfVersion: TXBaseVersion;
FPrevBuffer: TRecordBuffer;
FDefaultBuffer: TRecordBuffer;
FRecordBufferSize: Integer;
FLockUserLen: DWORD;
FFileCodePage: Cardinal;
FUseCodePage: Cardinal;
FFileLangId: Byte;
FCountUse: Integer;
FCurIndex: Integer;
FForceClose: Boolean;
FLockField: TDbfFieldDef;
FNullField: TDbfFieldDef;
FAutoIncPresent: Boolean;
FCopyDateTimeAsString: Boolean;
FDateTimeHandling: TDateTimeHandling;
FOnLocaleError: TDbfLocaleErrorEvent;
FOnIndexMissing: TDbfIndexMissingEvent;
// Yes if table has blob/memo type field(s) (storage in external file)
function HasBlob: Boolean;
// File extension for memo field; uppercase if FFileName is uppercase
// (useful for *nix case-sensitive filesystems)
function GetMemoExt: string;
function GetLanguageId: Integer;
function GetLanguageStr: string;
protected
// Reads the field's properties from the field header(s)
procedure ConstructFieldDefs;
procedure InitDefaultBuffer;
// Shows if the (null or varlength) flag for AFieldDef is set.
function IsNullFlagSet(const Src: Pointer; var AFieldDef: TDbfFieldDef; WhichField: TNullFieldFlag): boolean;
// Updates _NULLFLAGS field with null or varlength flag for field
procedure UpdateNullField(Buffer: Pointer; AFieldDef: TDbfFieldDef; Action: TUpdateNullField; WhichField: TNullFieldFlag);
procedure WriteLockInfo(Buffer: TRecordBuffer);
public
constructor Create;
destructor Destroy; override;
procedure Open;
procedure Close;
procedure Zap;
// Write out field definitions to header etc.
procedure FinishCreate(AFieldDefs: TDbfFieldDefs; MemoSize: Integer);
function GetIndexByName(AIndexName: string): TIndexFile;
procedure SetRecordSize(NewSize: Integer); override;
procedure TryExclusive; override;
procedure EndExclusive; override;
procedure OpenIndex(IndexName, IndexField: string; CreateIndex: Boolean; Options: TIndexOptions);
function DeleteIndex(const AIndexName: string): Boolean;
procedure CloseIndex(AIndexName: string);
procedure RepageIndex(AIndexFile: string);
procedure CompactIndex(AIndexFile: string);
// Inserts new record
function Insert(Buffer: TRecordBuffer): integer;
// 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 FastPackTable;
procedure RestructureTable(DbfFieldDefs: TDbfFieldDefs; Pack: Boolean);
procedure Rename(DestFileName: string; NewIndexFileNames: TStrings; DeleteFiles: boolean);
function GetFieldInfo(FieldName: string): TDbfFieldDef;
// Copies record buffer to field buffer
// Returns true if not null & data succesfully copied; false if field is null
function GetFieldData(Column: Integer; DataType: TFieldType; Src,Dst: Pointer;
NativeFormat: boolean): Boolean;
// Copies record buffer to field buffer
// Returns true if not null & data succesfully copied; false if field is null
function GetFieldDataFromDef(AFieldDef: TDbfFieldDef; DataType: TFieldType;
Src, Dst: Pointer; NativeFormat: boolean): Boolean;
// Copies field buffer to record buffer for this field
procedure SetFieldData(Column: Integer; DataType: TFieldType; Src,Dst: Pointer; NativeFormat: boolean);
// Fill DestBuf with default field data
procedure InitRecord(DestBuf: TRecordBuffer);
procedure PackIndex(lIndexFile: TIndexFile; AIndexName: string);
procedure RegenerateIndexes;
procedure LockRecord(RecNo: Integer; Buffer: TRecordBuffer);
procedure UnlockRecord(RecNo: Integer; Buffer: TRecordBuffer);
procedure RecordDeleted(RecNo: Integer; Buffer: TRecordBuffer);
procedure RecordRecalled(RecNo: Integer; Buffer: TRecordBuffer);
property MemoFile: TMemoFile read FMemoFile;
// Backing stream for stream/memory-based memo "files"
property MemoStream: TStream read FMemoStream write FMemoStream;
property FieldDefs: TDbfFieldDefs read FFieldDefs;
property IndexNames: TStringList read FIndexNames;
property IndexFiles: TList read FIndexFiles;
// Backing stream for stream/memory-based index "files"
property IndexStream: TStream read FIndexStream write FIndexStream;
property MdxFile: TIndexFile read FMdxFile;
property LanguageId: Integer read GetLanguageId;
property LanguageStr: string read GetLanguageStr;
property FileCodePage: Cardinal read FFileCodePage;
property UseCodePage: Cardinal read FUseCodePage write FUseCodePage;
property FileLangId: Byte read FFileLangId write FFileLangId;
// Visual Foxpro: relative path to .dbc database file containing
// long field names and other metadata
// Empty if this is a "free table", not linked to a .dbc file
property BackLink: string read FBackLink write FBackLink;
// Dbase (clone) version that this format emulates. Related to tablelevel.
property DbfVersion: TXBaseVersion read FDbfVersion write FDbfVersion;
property PrevBuffer: TRecordBuffer read FPrevBuffer;
property ForceClose: Boolean read FForceClose;
property CopyDateTimeAsString: Boolean read FCopyDateTimeAsString write FCopyDateTimeAsString;
property DateTimeHandling: TDateTimeHandling read FDateTimeHandling write FDateTimeHandling;
property OnIndexMissing: TDbfIndexMissingEvent read FOnIndexMissing write FOnIndexMissing;
property OnLocaleError: TDbfLocaleErrorEvent read FOnLocaleError write FOnLocaleError;
end;
//====================================================================
TDbfCursor = class(TVirtualCursor)
protected
FPhysicalRecNo: Integer;
public
constructor Create(DbfFile: TDbfFile);
function Next: Boolean; override;
function Prev: Boolean; override;
procedure First; override;
procedure Last; override;
function GetPhysicalRecNo: Integer; override;
procedure SetPhysicalRecNo(RecNo: Integer); override;
function GetSequentialRecordCount: Integer; override;
function GetSequentialRecNo: Integer; override;
procedure SetSequentialRecNo(RecNo: Integer); override;
end;
//====================================================================
{ TDbfGlobals }
TDbfGlobals = class
protected
FCodePages: TList;
FCurrencyAsBCD: Boolean;
FDefaultOpenCodePage: Integer;
FDefaultCreateLangId: Byte;
FUserName: string;
FUserNameLen: DWORD;
// Translates FDefaultCreateLangId back to codepage
function GetDefaultCreateCodePage: Integer;
// Takes codepage and sets FDefaultCreateLangId
procedure SetDefaultCreateCodePage(NewCodePage: Integer);
procedure InitUserName;
public
constructor Create;
destructor Destroy; override;
function CodePageInstalled(ACodePage: Integer): Boolean;
property CurrencyAsBCD: Boolean read FCurrencyAsBCD write FCurrencyAsBCD;
property DefaultOpenCodePage: Integer read FDefaultOpenCodePage write FDefaultOpenCodePage;
property DefaultCreateCodePage: Integer read GetDefaultCreateCodePage write SetDefaultCreateCodePage;
property DefaultCreateLangId: Byte read FDefaultCreateLangId write FDefaultCreateLangId;
property UserName: string read FUserName;
property UserNameLen: DWORD read FUserNameLen;
end;
var
DbfGlobals: TDbfGlobals;
implementation
uses
{$ifndef WINDOWS}
{$IFNDEF OS2}
{$ifndef FPC}
RTLConsts,
{$else FPC}
BaseUnix,
{$endif FPC}
{$ENDIF OS2}
{$endif WINDOWS}
{$ifdef SUPPORT_MATH_UNIT}
Math,
{$endif}
dbf_str, dbf_lang, dbf_prssupp, dbf_prsdef;
const
sDBF_DEC_SEP = '.';
FIELD_DESCRIPTOR_ARRAY_TERMINATOR = $0D; // Marker at end of list of fields within header
NULLFLAGSFIELD = '_NULLFLAGS'; //Visual Foxpro system field with flags for field=null and field has varlength byte
{$I dbf_struct.inc}
//====================================================================
// International separator
// thanks to Bruno Depero from Italy
// and Andreas Wöllenstein from Denmark
//====================================================================
function DbfStrToFloat(const Src: PChar; const Size: Integer): Extended;
var
iPos: PChar;
eValue: extended;
endChar: Char;
begin
// temp null-term string
endChar := (Src + Size)^;
(Src + Size)^ := #0;
// we only have to convert if decimal separator different
if DecimalSeparator <> sDBF_DEC_SEP then
begin
// search dec sep
iPos := StrScan(Src, sDBF_DEC_SEP);
// replace
if iPos <> nil then
iPos^ := DecimalSeparator;
end else
iPos := nil;
// convert to double
if TextToFloat(Src, eValue {$ifndef VER1_0}, fvExtended{$endif}) then
Result := eValue
else
Result := 0;
// restore dec sep
if iPos <> nil then
iPos^ := sDBF_DEC_SEP;
// restore Char of null-term
(Src + Size)^ := endChar;
end;
procedure FloatToDbfStr(const Val: Extended; const Size, Precision: Integer; const Dest: PChar);
var
Buffer: array [0..24] of Char;
resLen: Integer;
iPos: PChar;
begin
// convert to temporary buffer
resLen := FloatToText(@Buffer[0], Val, {$ifndef FPC_VERSION}fvExtended,{$endif} ffFixed, Size, Precision);
// prevent overflow in destination buffer
if resLen > Size then
resLen := Size;
// null-terminate buffer
Buffer[resLen] := #0;
// we only have to convert if decimal separator different
if DecimalSeparator <> sDBF_DEC_SEP then
begin
iPos := StrScan(@Buffer[0], DecimalSeparator);
if iPos <> nil then
iPos^ := sDBF_DEC_SEP;
end;
// fill destination with spaces
FillChar(Dest^, Size, ' ');
// now copy right-aligned to destination
Move(Buffer[0], Dest[Size-resLen], resLen);
end;
function GetIntFromStrLength(Src: Pointer; Size: Integer; Default: Integer): Integer;
var
endChar: Char;
Code: Integer;
begin
// save Char at pos term. null
endChar := (PChar(Src) + Size)^;
(PChar(Src) + Size)^ := #0;
// convert
Val(PChar(Src), Result, Code);
// check success
if Code <> 0 then
Result := Default;
// restore prev. ending Char
(PChar(Src) + Size)^ := endChar;
end;
//====================================================================
// TDbfFile
//====================================================================
constructor TDbfFile.Create;
begin
// init variables first
FBackLink := '';
FBackLinkOffset := 0;
FFieldDefs := TDbfFieldDefs.Create(nil);
FIndexNames := TStringList.Create;
FIndexFiles := TList.Create;
// now initialize inherited
inherited;
end;
destructor TDbfFile.Destroy;
var
I: Integer;
begin
// close file
Close;
// free files
for I := 0 to Pred(FIndexFiles.Count) do
TPagedFile(FIndexFiles.Items[I]).Free;
// free lists
FreeAndNil(FIndexFiles);
FreeAndNil(FIndexNames);
FreeAndNil(FFieldDefs);
// call ancestor
inherited;
end;
procedure TDbfFile.Open;
var
lMemoFileName: string;
lMdxFileName: string;
MemoFileClass: TMemoFileClass;
I: Integer;
deleteLink: Boolean;
lModified: boolean;
procedure GetVersion;
var
version: byte;
begin
// OH 2000-11-15 dBase7 support. I built dBase Tables with different
// BDE dBase Level (1. without Memo, 2. with Memo)
// Header Byte ($1d hex) (29 dec) -> Language driver ID.
// $03,$83 xBaseIII Header Byte $1d=$00, Float -> N($13.$04) DateTime C($1E)
// $03,$8B xBaseIV/V Header Byte $1d=$58, Float -> N($14.$04)
// $04,$8C xBaseVII Header Byte $1d=$00 Float -> O($08) DateTime @($08)
// $03,$F5 FoxPro Level 25 Header Byte $1d=$03, Float -> N($14.$04)
// Access 97
// $03,$83 dBaseIII Header Byte $1d=$00, Float -> N($13.$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)
version := PDbfHdr(Header)^.VerDBF;
FDbfVersion := xUnknown;
// Some hardcoded versions for Visual FoxPro; see MS documentation
// (including the correction at the bottom):
// http://msdn.microsoft.com/en-US/library/st4a0s68%28v=vs.80%29.aspx
case version of
$30, $31, $32 {VFP9 with new data types}: FDbfVersion:=xVisualFoxPro;
$F5, $FB: FDbfVersion:=xFoxPro;
end;
if FDbfVersion = xUnknown then
case (version and $07) of
$03: //dbf with/without memo. Could be Foxpro, too
if not(version in [$03,$8B]) {e.g. dbase IV < v2.0 with 0 language ID} and
(LanguageID = 0) then
FDbfVersion := xBaseIII
else
FDbfVersion := xBaseIV;
$04:
FDbfVersion := xBaseVII;
$02 {FoxBase, not readable by current MS Visual FoxPro driver}, $05:
FDbfVersion := xFoxPro;
else
begin
// not a valid DBF file
raise EDbfError.Create(STRING_INVALID_DBF_FILE);
end;
end;
FFieldDefs.DbfVersion := FDbfVersion;
end;
procedure GetCodePage;
var
LangStr: PChar;
begin
// determine codepage
case FDbfVersion of
xBaseVII:
begin
// cache language str
LangStr := @PEndFixedHdrVII(PChar(Header) + SizeOf(rDbfHdr))^.LanguageDriverName;
// VdBase 7 Language strings
// 'DBWIN...' -> Charset 1252 (ansi)
// 'DB999...' -> Code page 999, 9 any digit
// 'DBHEBREW' -> Code page 1255 ??
// 'FOX..999' -> Code page 999, 9 any digit
// 'FOX..WIN' -> Charset 1252 (ansi)
if (LangStr[0] = 'D') and (LangStr[1] = 'B') then
begin
if StrLComp(LangStr+2, 'WIN', 3) = 0 then
FFileCodePage := 1252
else
if StrLComp(LangStr+2, 'HEBREW', 6) = 0 then
begin
FFileCodePage := 1255;
end else begin
FFileCodePage := GetIntFromStrLength(LangStr+2, 3, 0);
if (Ord(LangStr[5]) >= Ord('0')) and (Ord(LangStr[5]) <= Ord('9')) then
FFileCodePage := FFileCodePage * 10 + Ord(LangStr[5]) - Ord('0');
end;
end else
if StrLComp(LangStr, 'FOX', 3) = 0 then
begin
if StrLComp(LangStr+5, 'WIN', 3) = 0 then
FFileCodePage := 1252
else
FFileCodePage := GetIntFromStrLength(LangStr+5, 3, 0)
end else begin
FFileCodePage := 0;
end;
FFileLangId := GetLangId_From_LangName(LanguageStr);
end;
else
begin
// DBase II..V, FoxPro, Visual FoxPro
FFileLangId := PDbfHdr(Header)^.Language;
FFileCodePage := LangId_To_CodePage[FFileLangId];
end;
end;
// determine used codepage, if no codepage, then use default codepage
FUseCodePage := FFileCodePage;
if FUseCodePage = 0 then
FUseCodePage := DbfGlobals.DefaultOpenCodePage;
end;
procedure GetBackLink;
// Gets backlink info - only supported in Visual Foxpro
begin
FBackLink:='';
if FDBFVersion=xVisualFoxPro then //only format that supports it
begin
FBackLink:= StrPas(@PEndHdrVFP(PChar(Header) + FBackLinkOffset)^.Backlink);
end;
end;
begin
// check if not already opened
if not Active then
begin
// open requested file
OpenFile;
// check if we opened an already existing file
lModified := false;
if not FileCreated then
begin
HeaderSize := sizeof(rDbfHdr); // temporary, required for getting version
GetVersion;
RecordSize := PDbfHdr(Header)^.RecordSize;
HeaderSize := PDbfHdr(Header)^.FullHdrSize;
if (HeaderSize = 0) or (RecordSize = 0) then
begin
HeaderSize := 0;
RecordSize := 0;
RecordCount := 0;
FForceClose := true;
exit;
end;
// check if specified recordcount is right; correct if not
if PDbfHdr(Header)^.RecordCount <> RecordCount then
begin
PDbfHdr(Header)^.RecordCount := RecordCount;
lModified := true;
end;
GetCodePage;
// get list of fields
ConstructFieldDefs;
GetBackLink;
// open blob file if present
lMemoFileName := ChangeFileExt(FileName, GetMemoExt);
if HasBlob then
begin
// open blob file; if it doesn't exist yet create it
// using AutoCreate as long as we're not running read-only
// If needed, fake a memo file:
if (Mode=pfReadOnly) and (not FileExists(lMemoFileName)) then
MemoFileClass := TNullMemoFile
else if (FDbfVersion in [xFoxPro,xVisualFoxPro]) then
MemoFileClass := TFoxProMemoFile
else
MemoFileClass := TDbaseMemoFile; //fallback/default
FMemoFile := MemoFileClass.Create(Self);
FMemoFile.FileName := lMemoFileName;
if (Mode in [pfMemoryOpen,pfMemoryCreate]) then
FMemoFile.Stream:=FMemoStream;
FMemoFile.Mode := Mode;
FMemoFile.AutoCreate := true;
FMemoFile.MemoRecordSize := 0;
FMemoFile.DbfVersion := FDbfVersion;
FMemoFile.Open;
// set header blob flag corresponding to field list
if not(FDbfVersion in [xFoxPro,xVisualFoxPro]) then
begin
PDbfHdr(Header)^.VerDBF := PDbfHdr(Header)^.VerDBF or $80;
lModified := true;
end;
end else // no HasBlob
if not(FDbfVersion in [xFoxPro,xVisualFoxPro]) then
begin
PDbfHdr(Header)^.VerDBF := PDbfHdr(Header)^.VerDBF and $7F;
lModified := true;
end;
// check if mdx flagged
if not(FDbfVersion in [xFoxPro,xVisualFoxPro]) and (PDbfHdr(Header)^.MDXFlag <> 0) then
begin
// open mdx file if present
lMdxFileName := ChangeFileExt(FileName, '.mdx');
// Deal with case-sensitive filesystems:
if (FileName<>'') and (UpperCase(FileName)=FileName) then
lMdxFileName := UpperCase(lMdxFileName);
if FileExists(lMdxFileName) or ((Mode in [pfMemoryOpen,pfMemoryCreate])) then
begin
// open file
FMdxFile := TIndexFile.Create(Self);
FMdxFile.FileName := lMdxFileName;
FMdxFile.Mode := Mode;
if (Mode in [pfMemoryOpen,pfMemoryCreate]) then
begin
FMdxFile.Stream := FIndexStream;
FMdxFile.AutoCreate := true;
end
else
begin
FMdxFile.AutoCreate := false;
end;
FMdxFile.OnLocaleError := FOnLocaleError;
FMdxFile.CodePage := UseCodePage;
FMdxFile.Open;
// is index ready for use?
if not FMdxFile.ForceClose then
begin
FIndexFiles.Add(FMdxFile);
// get index tag names known
FMdxFile.GetIndexNames(FIndexNames);
end else begin
// asked to close! close file
FreeAndNil(FMdxFile);
end;
end else begin
// ask user
deleteLink := true;
if Assigned(FOnIndexMissing) then
FOnIndexMissing(deleteLink);
// correct flag
if deleteLink then
begin
PDbfHdr(Header)^.MDXFlag := 0;
lModified := true;
end else
FForceClose := true;
end;
end;
end;
// record changes
if lModified then
WriteHeader;
// open indexes
for I := 0 to FIndexFiles.Count - 1 do
TIndexFile(FIndexFiles.Items[I]).Open;
end;
end;
procedure TDbfFile.Close;
var
MdxIndex, I: Integer;
begin
if Active then
begin
// close index files first
MdxIndex := -1;
for I := 0 to FIndexFiles.Count - 1 do
begin
TIndexFile(FIndexFiles.Items[I]).Close;
if TIndexFile(FIndexFiles.Items[I]) = FMdxFile then
MdxIndex := I;
end;
// free memo file if any
FreeAndNil(FMemoFile);
// now we can close physical dbf file
CloseFile;
// free FMdxFile, remove it from the FIndexFiles and Names lists
if MdxIndex >= 0 then
FIndexFiles.Delete(MdxIndex);
I := 0;
while I < FIndexNames.Count do
begin
if FIndexNames.Objects[I] = FMdxFile then
begin
FIndexNames.Delete(I);
end else begin
Inc(I);
end;
end;
FreeAndNil(FMdxFile);
FreeMemAndNil(Pointer(FPrevBuffer));
FreeMemAndNil(Pointer(FDefaultBuffer));
// reset variables
FFileLangId := 0;
end;
end;
procedure TDbfFile.FinishCreate(AFieldDefs: TDbfFieldDefs; MemoSize: Integer);
var
lEndHdrVFP: rEndHdrVFP; //Contains Visual FoxPro backlink
lFieldDescIII: rFieldDescIII;
lFieldDescVII: rFieldDescVII;
lFieldDescPtr: Pointer;
lFieldDef: TDbfFieldDef;
lMemoFileName: string;
I, lFieldOffset, lSize, lPrec: Integer;
lHasBlob: Boolean;
lLocaleID: LCID;
lNullVarFlagCount: integer; //(VFP only) Keeps track of number null/varlength flags needed for _NULLFLAGS size calculation
begin
try
// first reset file
RecordCount := 0;
lHasBlob := false;
lNullVarFlagCount := 0;
// determine codepage & locale
if FDbfVersion in [xFoxPro, xVisualFoxPro] then
begin
// Don't use DbfGlobals default language ID as it is dbase-based
if FFileLangId = 0 then
FFileLangId := ConstructLangId(LangId_To_CodePage[FFileLangId],GetUserDefaultLCID, true);
end
else
begin
// DBase
if FFileLangId = 0 then
FFileLangId := DbfGlobals.DefaultCreateLangId;
end;
FFileCodePage := LangId_To_CodePage[FFileLangId];
lLocaleID := LangId_To_Locale[FFileLangId];
FUseCodePage := FFileCodePage;
// Prepare header size. This size may be changed later depending on number
// of fields etc - we start out with the first, fixed part of the header,
// write out the variable parts (field descriptor arrays etc) and then
// correct the header length in the header.
if FDbfVersion = xBaseVII then
begin
// version xBaseVII without memo
HeaderSize := SizeOf(rDbfHdr) + SizeOf(rEndFixedHdrVII);
RecordSize := SizeOf(rFieldDescVII);
FillChar(Header^, HeaderSize, #0);
PDbfHdr(Header)^.VerDBF := $04;
// write language string. FPC needs an explicit cast to pchar to avoid calling widestring version of StrPLCopy
StrPLCopy(
PChar(@PEndFixedHdrVII(PChar(Header)+SizeOf(rDbfHdr))^.LanguageDriverName[32]),
PChar(ConstructLangName(FFileCodePage, lLocaleID, false)),
63-32);
lFieldDescPtr := @lFieldDescVII;
end else begin
// DBase III..V, (Visual) FoxPro without memo
// rEndHdrVFP is covered at the end as it is placed after the variable
// length part of the header.
HeaderSize := SizeOf(rDbfHdr);
RecordSize := SizeOf(rFieldDescIII);
FillChar(Header^, HeaderSize, #0);
// Note: VerDBF may be changed later on depending on what features/fields are used
// (autoincrement etc)
case FDbfVersion of
xFoxPro: PDbfHdr(Header)^.VerDBF := $03; {FoxBASE+/FoxPro/dBASE III PLUS/dBASE IV, no memo
alternative $02 FoxBASE is not readable by current MS Visual FoxPro drivers.
}
xVisualFoxPro: PDbfHdr(Header)^.VerDBF := $30; {Visual FoxPro no autoincrement,no varchar}
else PDbfHdr(Header)^.VerDBF := $03; {FoxBASE+/FoxPro/dBASE III PLUS/dBASE IV, no memo}
end;
// standard language WE/Western Europe
if FDbfVersion=xBaseIII then
PDbfHdr(Header)^.Language := 0 //no language support
else
PDbfHdr(Header)^.Language := FFileLangId;
// init field ptr
lFieldDescPtr := @lFieldDescIII;
end;
// Begin variable part of the header
// Writing field definitions
FFieldDefs.Clear;
// deleted mark takes 1 byte, so skip over that
lFieldOffset := 1;
for I := 1 to AFieldDefs.Count do
begin
lFieldDef := AFieldDefs.Items[I-1];
// check if datetime conversion
if FCopyDateTimeAsString then
if lFieldDef.FieldType = ftDateTime then
begin
// convert to string
lFieldDef.FieldType := ftString;
lFieldDef.Size := 22;
end;
// update source
lFieldDef.FieldName := AnsiUpperCase(lFieldDef.FieldName);
lFieldDef.Offset := lFieldOffset;
lHasBlob := lHasBlob or lFieldDef.IsBlob;
// Check for Foxpro, too, as it can get auto-upgraded to vfp:
if (FDbfVersion in [xFoxPro,xVisualFoxPro]) then
begin
if (lFieldDef.NativeFieldType='Q') or (lFieldDef.NativeFieldType='V') then
begin
lNullVarFlagCount:=lNullVarFlagCount+1;
end;
if (lFieldDef.NullPosition>=0) then
lNullVarFlagCount:=lNullVarFlagCount+1;
end;
// apply field transformation tricks
lSize := lFieldDef.Size;
lPrec := lFieldDef.Precision;
if (lFieldDef.NativeFieldType = 'C')
{$ifndef USE_LONG_CHAR_FIELDS}
and (FDbfVersion in [xFoxPro,xVisualFoxPro])
{$endif}
then
begin
// Up to 32kb strings
// Stores high byte of size in precision, low in size
lPrec := lSize shr 8;
lSize := lSize and $FF;
end;
// update temp field properties
if FDbfVersion = xBaseVII then
begin
FillChar(lFieldDescVII, SizeOf(lFieldDescVII), #0);
StrPLCopy(lFieldDescVII.FieldName, lFieldDef.FieldName, SizeOf(lFieldDescVII.FieldName)-1);
lFieldDescVII.FieldType := lFieldDef.NativeFieldType;
lFieldDescVII.FieldSize := lSize;
lFieldDescVII.FieldPrecision := lPrec;
lFieldDescVII.NextAutoInc := SwapIntLE(lFieldDef.AutoInc);
//lFieldDescVII.MDXFlag := ???
end else begin
FillChar(lFieldDescIII, SizeOf(lFieldDescIII), #0);
StrPLCopy(lFieldDescIII.FieldName, lFieldDef.FieldName, SizeOf(lFieldDescIII.FieldName)-1);
lFieldDescIII.FieldType := lFieldDef.NativeFieldType;
lFieldDescIII.FieldSize := lSize;
lFieldDescIII.FieldPrecision := lPrec;
if (FDbfVersion in [xFoxPro,xVisualFoxPro]) then
lFieldDescIII.FieldOffset := SwapIntLE(lFieldOffset);
// Upgrade the version info if needed for supporting field types used.
// This is also what Visual FoxPro does with FoxPro tables to which you
// add new VFP features.
if (FDBFVersion in [xUnknown,xFoxPro,xVisualFoxPro]) then
begin
// VerDBF=$03 also includes dbase formats, so we perform an extra check
if (PDbfHdr(Header)^.VerDBF in [$02,$03]) and
((lFieldDef.NativeFieldType in ['0', 'Y', 'T', 'O', '+', 'Q', 'V']) or
(lNullVarFlagCount>0)) then
begin
PDbfHdr(Header)^.VerDBF := $30; {Visual FoxPro}
FDBFVersion:=xVisualFoxPro;
end;
// Upgrade if a non-empty backlink is specified - for FoxPro only
if (FBackLink<>'') and
((FDBFVersion=xFoxPro) or (PDbfHdr(Header)^.VerDBF=$02)) then
begin
PDbfHdr(Header)^.VerDBF := $30; {Visual FoxPro}
FDBFVersion:=xVisualFoxPro; //needed to write the backlink info
end;
//AutoInc only support in Visual Foxpro; another upgrade
//Note: .AutoIncrementNext is really a cardinal (see the definition)
lFieldDescIII.AutoIncrementNext:=SwapIntLE(lFieldDef.AutoInc);
lFieldDescIII.AutoIncrementStep:=lFieldDef.AutoIncStep;
// Set autoincrement flag using AutoIncStep as a marker
if (lFieldDef.AutoIncStep<>0) then
lFieldDescIII.VisualFoxProFlags:=(lFieldDescIII.VisualFoxProFlags or $0C);
if (PDbfHdr(Header)^.VerDBF = $30) and (lFieldDef.AutoIncStep<>0) then
begin
PDbfHdr(Header)^.VerDBF := $31; {Visual FoxPro, autoincrement enabled}
FDBFVersion:=xVisualFoxPro;
end;
// Only supported in Visual FoxPro but let's not upgrade format as
// IsSystemField is a minor property
if (lFieldDef.IsSystemField) then
lFieldDescIII.VisualFoxProFlags:=(lFieldDescIII.VisualFoxProFlags or $01);
end;
end;
// Update our field list
with FFieldDefs.AddFieldDef do
begin
Assign(lFieldDef);
Offset := lFieldOffset;
AutoInc := 0;
end;
// save field properties
WriteRecord(I, lFieldDescPtr);
Inc(lFieldOffset, lFieldDef.Size);
end;
// Visual Foxpro: write _NULLFLAGS field if required
if (FDBFVersion=xVisualFoxPro) and (lNullVarFlagCount>0) then
begin
FillChar(lFieldDescIII, SizeOf(lFieldDescIII), #0);
StrPLCopy(lFieldDescIII.FieldName, NULLFLAGSFIELD, 10);
lFieldDescIII.FieldType := '0'; //bytes
lFieldDescIII.FieldSize := 1+(lNullVarFlagCount-1) div 8; //Number of bytes needed for all bit flags
lFieldDescIII.FieldPrecision := 0;
lFieldDescIII.FieldOffset := SwapIntLE(lFieldOffset);
lFieldDescIII.VisualFoxProFlags:=$01+$04 ; //System column (hidden)+Column can store null values (which is a bit of a paradox)
// Save field properties
WriteRecord(AFieldDefs.Count+1, @lFieldDescIII);
Inc(lFieldOffset, lFieldDescIII.FieldSize);
end;
// End of field descriptor; usually end of header as well.
// Visual Foxpro backlink info is part of the header but comes after the
// terminator
WriteChar(FIELD_DESCRIPTOR_ARRAY_TERMINATOR);
{ For Visual FoxPro, add back-link info }
if (FDbfVersion = xVisualFoxPro) then
begin
FBackLinkOffset := Stream.Position;
// Backlink is defined as all $0 bytes if empty
lEndHdrVFP.Backlink:=FBackLink+StringOfChar(#0, SizeOf(lEndHdrVFP.BackLink));
WriteBlock(@lEndHdrVFP,SizeOf(lEndHdrVFP),Stream.Position);
end;
// Write memo bit to begin of header
if lHasBlob then
begin
case FDbfVersion of
xBaseIII: PDbfHdr(Header)^.VerDBF := PDbfHdr(Header)^.VerDBF or $80;
xFoxPro: if (PDbfHdr(Header)^.VerDBF in [$02,$03]) then {change from FoxBASE to...}
PDbfHdr(Header)^.VerDBF := $F5; {...FoxPro 2.x (or earlier) with memo}
xVisualFoxPro: //MSDN says field 28 or $02 to set memo flag
PDbfHdr(Header)^.MDXFlag := PDbfHdr(Header)^.MDXFlag or $02;
else PDbfHdr(Header)^.VerDBF := PDbfHdr(Header)^.VerDBF or $88;
end;
end;
// Update header to correct sizes
PDbfHdr(Header)^.RecordSize := lFieldOffset;
if lNullVarFlagCount>0 then
PDbfHdr(Header)^.FullHdrSize := HeaderSize + RecordSize * (AFieldDefs.Count + 1) + 1
else
PDbfHdr(Header)^.FullHdrSize := HeaderSize + RecordSize * AFieldDefs.Count + 1;
if DbfVersion=xVisualFoxPro then
PDbfHdr(Header)^.FullHdrSize := PDbfHdr(Header)^.FullHdrSize + SizeOf(rEndHdrVFP);
// write dbf header to disk
inherited WriteHeader;
finally
RecordSize := PDbfHdr(Header)^.RecordSize;
HeaderSize := PDbfHdr(Header)^.FullHdrSize;
// write full header to disk (dbf+fields)
WriteHeader;
end;
if HasBlob and (FMemoFile=nil) then
begin
lMemoFileName := ChangeFileExt(FileName, GetMemoExt);
if (FDbfVersion in [xFoxPro,xVisualFoxPro]) then
FMemoFile := TFoxProMemoFile.Create(Self)
else
FMemoFile := TDbaseMemoFile.Create(Self);
FMemoFile.FileName := lMemoFileName;
if (Mode in [pfMemoryOpen,pfMemoryCreate]) then
FMemoFile.Stream:=FMemoStream;
FMemoFile.Mode := Mode;
FMemoFile.AutoCreate := AutoCreate;
FMemoFile.MemoRecordSize := MemoSize;
FMemoFile.DbfVersion := FDbfVersion;
FMemoFile.Open;
end;
end;
function TDbfFile.HasBlob: Boolean;
var
I: Integer;
begin
Result := false;
for I := 0 to FFieldDefs.Count-1 do
if FFieldDefs.Items[I].IsBlob then
begin
Result := true;
break;
end;
end;
function TDbfFile.GetMemoExt: string;
begin
case FDbfVersion of
xFoxPro, xVisualFoxPro: Result := '.fpt'
else Result := '.dbt';
end;
if (FFileName<>'') and (FFileName=UpperCase(FFileName)) then
Result := UpperCase(Result);
end;
procedure TDbfFile.Zap;
begin
// make recordcount zero
RecordCount := 0;
// update recordcount
PDbfHdr(Header)^.RecordCount := RecordCount;
// update disk header
WriteHeader;
// update indexes
RegenerateIndexes;
end;
procedure TDbfFile.WriteHeader;
var
SystemTime: TSystemTime;
lDataHdr: PDbfHdr;
EofTerminator: Byte;
begin
if (HeaderSize=0) then
exit;
//FillHeader(0);
lDataHdr := PDbfHdr(Header);
GetLocalTime(SystemTime);
lDataHdr^.Year := SystemTime.wYear - 1900;
lDataHdr^.Month := SystemTime.wMonth;
lDataHdr^.Day := SystemTime.wDay;
// lDataHdr.RecordCount := RecordCount;
inherited WriteHeader;
// Write terminator at the end of the file, after the records:
EofTerminator := $1A;
// We're using lDataHdr to make sure we have the latest/correct version
WriteBlock(@EofTerminator, 1, CalcPageOffset(lDataHdr.RecordCount+1));
end;
procedure TDbfFile.ConstructFieldDefs;
var
// The size of the fixed part of the header
// excluding the field descriptor array
// also excluding everything that comes after the field descriptor array
// like VFP backlink records
lFakeHeaderSize: Integer;
lFieldSize: Integer;
lPropHdrOffset, lFieldOffset: Integer;
lFieldDescIII: rFieldDescIII;
lFieldDescVII: rFieldDescVII;
lFieldPropsHdr: rFieldPropsHdr;
lStdProp: rStdPropEntry;
TempFieldDef: TDbfFieldDef;
lSize,lPrec,I, lColumnCount: Integer;
lAutoInc: Cardinal;
dataPtr: PChar;
lNativeFieldType: Char;
lFieldName: string;
lCanHoldNull: boolean; //Can the field store nulls, i.e. is it nullable?
lIsVFPSystemField: boolean; //Is this a Visual FoxPro system/hidden field?
lIsVFPVarLength: boolean; //Is this a Visual FoxPro varbinary/varchar field,
// where varlength bit is maintained in _NULLFLAGS
lCurrentNullPosition: integer;
begin
FFieldDefs.Clear;
case DbfVersion of
xBaseVII:
begin
lFakeHeaderSize := SizeOf(rDbfHdr) + SizeOf(rEndFixedHdrVII);
lFieldSize := SizeOf(rFieldDescVII);
end;
else
begin
// DBase III..V, (Visual) FoxPro
if DBfVersion = xVisualFoxPro then
lFakeHeaderSize := SizeOf(rDbfHdr)
else
lFakeHeaderSize := SizeOf(rDbfHdr);
lFieldSize := SizeOf(rFieldDescIII);
end;
end;
// This is of course not true but it shrinks the perceived header to just
// before the records with field info:
HeaderSize := lFakeHeaderSize;
RecordSize := lFieldSize;
if FDbfVersion=xVisualFoxPro then
lColumnCount := (PDbfHdr(Header)^.FullHdrSize - lFakeHeaderSize - SizeOf(rEndHdrVFP)) div lFieldSize
else
lColumnCount := (PDbfHdr(Header)^.FullHdrSize - lFakeHeaderSize) div lFieldSize;
FBackLinkOffset := 0;
FLockField := nil;
FNullField := nil;
FAutoIncPresent := false;
lFieldOffset := 1;
lAutoInc := 0;
I := 1;
lCurrentNullPosition := 0; // Contains the next value for the _NULLFLAGS bit position
lCanHoldNull := false;
lIsVFPSystemField := false;
lIsVFPVarLength := false;
try
// Specs say there has to be at least one field, so use repeat:
repeat
// version field info?
if FDbfVersion = xBaseVII then
begin
ReadRecord(I, @lFieldDescVII);
lFieldName := AnsiUpperCase(PChar(@lFieldDescVII.FieldName[0]));
lSize := lFieldDescVII.FieldSize;
lPrec := lFieldDescVII.FieldPrecision;
lNativeFieldType := lFieldDescVII.FieldType;
lAutoInc := SwapIntLE(lFieldDescVII.NextAutoInc);
if lNativeFieldType = '+' then
FAutoIncPresent := true;
end else begin
// DBase III..V, FoxPro, Visual FoxPro
ReadRecord(I, @lFieldDescIII);
lFieldName := AnsiUpperCase(PChar(@lFieldDescIII.FieldName[0]));
lSize := lFieldDescIII.FieldSize;
lPrec := lFieldDescIII.FieldPrecision;
lNativeFieldType := lFieldDescIII.FieldType;
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;
end;
// Only Visual FoxPro supports null fields, if the nullable field flag is on
lCanHoldNull := (FDbfVersion in [xVisualFoxPro]) and
((lFieldDescIII.VisualFoxProFlags and $2) <> 0) and
(lFieldName <> NULLFLAGSFIELD {the field where null status is stored can never be null itself});
// System/hidden flag (VFP only):
lIsVFPSystemField := (FDbfVersion in [xVisualFoxPro]) and
((lFieldDescIII.VisualFoxProFlags and $01)=$01);
// Only Visual Foxpro supports varbinary/varchar fields where a flag indicates
// if the actual size is stored in the last data byte.
lIsVFPVarLength := (FDbfVersion in [xVisualFoxPro]) and
(lNativeFieldType in ['Q','V']) and
(lFieldName <> NULLFLAGSFIELD);
end;
// apply field transformation tricks
if (lNativeFieldType = 'C')
{$ifndef USE_LONG_CHAR_FIELDS}
and (FDbfVersion in [xFoxPro,xVisualFoxPro])
{$endif}
then
begin
// (V)FP uses the byte where precision is normally stored
// for the high byte of the field size
lSize := lSize + lPrec shl 8;
lPrec := 0;
end;
// add field
TempFieldDef := FFieldDefs.AddFieldDef;
with TempFieldDef do
begin
FieldName := lFieldName;
Offset := lFieldOffset;
Size := lSize;
Precision := lPrec;
AutoInc := lAutoInc;
NativeFieldType := lNativeFieldType;
IsSystemField := lIsVFPSystemField;
if lIsVFPVarLength then
begin
// The varlength flag uses the same _NULLFLAGS field as the null flags.
// It comes before the null bit for that field, if any.
VarLengthPosition := lCurrentNullPosition;
inc(lCurrentNullPosition);
end else
VarLengthPosition := -1;
if lCanHoldNull then
begin
NullPosition := lCurrentNullPosition;
inc(lCurrentNullPosition);
end else
NullPosition := -1;
end;
// check valid field:
// 1) non-empty field name
// 2) known field type
// {3) no changes have to be made to precision or size}
if (Length(lFieldName) = 0) or (TempFieldDef.FieldType = ftUnknown) then
raise EDbfError.Create(STRING_INVALID_DBF_FILE_FIELDERROR);
// determine if lock field present, if present, then store additional info
if lFieldName = '_DBASELOCK' then
begin
FLockField := TempFieldDef;
FLockUserLen := lSize - 8;
if FLockUserLen > DbfGlobals.UserNameLen then
FLockUserLen := DbfGlobals.UserNameLen;
end else
if (FDbfVersion=xVisualFoxPro) and (uppercase(lFieldName) = NULLFLAGSFIELD) then
FNullField := TempFieldDef;
// goto next field
Inc(lFieldOffset, lSize);
Inc(I);
// continue until header termination character found
// or end of header reached
until (I > lColumnCount) or (ReadChar = FIELD_DESCRIPTOR_ARRAY_TERMINATOR);
if FDbfVersion=xVisualFoxPro then
FBackLinkOffset:=Stream.Position+SizeOf(FIELD_DESCRIPTOR_ARRAY_TERMINATOR); //after FIELD_DESCRIPTION_ARRAY_TERMINATOR
// test if not too many fields
if FFieldDefs.Count >= 4096 then
raise EDbfError.CreateFmt(STRING_INVALID_FIELD_COUNT, [FFieldDefs.Count]);
// do not check FieldOffset = PDbfHdr(Header).RecordSize because additional
// data could be present in record
// get current position
lPropHdrOffset := Stream.Position;
// dBase 7 -> read field properties, test if enough space, maybe no header
if (FDbfVersion = xBaseVII) and (lPropHdrOffset + Sizeof(lFieldPropsHdr) <
PDbfHdr(Header)^.FullHdrSize) then
begin
// read in field properties header
ReadBlock(@lFieldPropsHdr, SizeOf(lFieldPropsHdr), lPropHdrOffset);
// read in standard properties
lFieldOffset := lPropHdrOffset + lFieldPropsHdr.StartStdProps;
for I := 0 to lFieldPropsHdr.NumStdProps - 1 do
begin
// read property data
ReadBlock(@lStdProp, SizeOf(lStdProp), lFieldOffset+I*SizeOf(lStdProp));
// is this a constraint?
if lStdProp.FieldOffset = 0 then
begin
// this is a constraint...not implemented
end else if lStdProp.FieldOffset <= FFieldDefs.Count then begin
// get fielddef for this property
TempFieldDef := FFieldDefs.Items[lStdProp.FieldOffset-1];
// allocate space to store data
TempFieldDef.AllocBuffers;
// dataPtr = nil -> no data to retrieve
dataPtr := nil;
// store data
case lStdProp.PropType of
FieldPropType_Required: TempFieldDef.Required := true;
FieldPropType_Default:
begin
dataPtr := TempFieldDef.DefaultBuf;
TempFieldDef.HasDefault := true;
end;
FieldPropType_Min:
begin
dataPtr := TempFieldDef.MinBuf;
TempFieldDef.HasMin := true;
end;
FieldPropType_Max:
begin
dataPtr := TempFieldDef.MaxBuf;
TempFieldDef.HasMax := true;
end;
end;
// get data for this property
if dataPtr <> nil then
ReadBlock(dataPtr, lStdProp.DataSize, lPropHdrOffset + lStdProp.DataOffset);
end;
end;
// todo: read dbase7 custom properties...not implemented
// todo: read dbase7 RI/referential integrity properties...not implemented
end;
finally
// Restore proper sizes so normal records after the header can be read
HeaderSize := PDbfHdr(Header)^.FullHdrSize;
RecordSize := PDbfHdr(Header)^.RecordSize;
end;
end;
function TDbfFile.GetLanguageId: Integer;
begin
Result := PDbfHdr(Header)^.Language;
end;
function TDbfFile.GetLanguageStr: string;
begin
if FDbfVersion = xBaseVII then
Result := PEndFixedHdrVII(PChar(Header) + SizeOf(rDbfHdr))^.LanguageDriverName
else
Result := ''; // Only supported in DbaseVII
end;
function TDbfFile.IsNullFlagSet(const Src: Pointer; var AFieldDef: TDbfFieldDef; WhichField: TNullFieldFlag): boolean;
var
NullFlagByte: Pointer;
begin
case WhichField of
nfNullFlag:
begin
if (AFieldDef.NullPosition<0) or (FNullField=nil) then
result:=false //field is not even nullable
else
begin
// go to _NULLFLAGS byte that has this field's null flag
// Find out the byte where the null bit for the field is stored by doing
// NullPosition shr3 (= NullPosition div 8)...
NullFlagByte := PChar(Src) + FNullField.Offset + (AFieldDef.NullPosition shr 3);
// ... get the correct bit in the byte by the equivalent of getting the bit number in that byte:
// NullPosition and $7 (=mod 8)... and going to the bit value in the byte (by shl)
// The result is true if the field is null.
Result := (PByte(NullFlagByte)^ and (1 shl (AFieldDef.NullPosition and $7))) <> 0;
end;
end;
nfVarlengthFlag:
begin
if (AFieldDef.VarLengthPosition<0) or (FNullField=nil) then
result:=false //field *never* has a varlength byte
else
begin
NullFlagByte := PChar(Src) + FNullField.Offset + (AFieldDef.VarLengthPosition shr 3);
Result := (PByte(NullFlagByte)^ and (1 shl (AFieldDef.VarLengthPosition and $7))) <> 0
end;
end;
end;
end;
{
I fill the holes with the last records.
now we can do an 'in-place' pack
}
procedure TDbfFile.FastPackTable;
var
iDel,iNormal: Integer;
pDel,pNormal: PChar;
function FindFirstDel: Boolean;
begin
while iDel<=iNormal do
begin
ReadRecord(iDel, pDel);
if (PChar(pDel)^ <> ' ') then
begin
Result := true;
exit;
end;
Inc(iDel);
end;
Result := false;
end;
function FindLastNormal: Boolean;
begin
while iNormal>=iDel do
begin
ReadRecord(iNormal, pNormal);
if (PChar(pNormal)^= ' ') then
begin
Result := true;
exit;
end;
dec(iNormal);
end;
Result := false;
end;
begin
if RecordSize < 1 then Exit;
GetMem(pNormal, RecordSize);
GetMem(pDel, RecordSize);
try
iDel := 1;
iNormal := RecordCount;
while FindFirstDel do
begin
// iDel is definitely deleted
if FindLastNormal then
begin
// but is not anymore
WriteRecord(iDel, pNormal);
PChar(pNormal)^ := '*';
WriteRecord(iNormal, pNormal);
end else begin
// Cannot find a record after iDel so iDel must be deleted
dec(iDel);
break;
end;
end;
// FindFirstDel failed means than iDel is full
RecordCount := iDel;
RegenerateIndexes;
// Pack Memofields
finally
FreeMem(pNormal);
FreeMem(pDel);
end;
end;
procedure TDbfFile.Rename(DestFileName: string; NewIndexFileNames: TStrings; DeleteFiles: boolean);
var
lIndexFileNames: TStrings;
lIndexFile: TIndexFile;
NewBaseName: string;
I: integer;
begin
// todo: verify if this works with memo files
// get memory for index file list
lIndexFileNames := TStringList.Create;
try
// save index filenames
for I := 0 to FIndexFiles.Count - 1 do
begin
lIndexFile := TIndexFile(IndexFiles[I]);
lIndexFileNames.Add(lIndexFile.FileName);
// prepare changing the dbf file name, needs changes in index files
lIndexFile.PrepareRename(NewIndexFileNames[I]);
end;
// close file
Close;
if DeleteFiles then
begin
SysUtils.DeleteFile(DestFileName);
SysUtils.DeleteFile(ChangeFileExt(DestFileName, GetMemoExt));
end else begin
I := 0;
FindNextName(DestFileName, NewBaseName, I);
SysUtils.RenameFile(DestFileName, NewBaseName);
SysUtils.RenameFile(ChangeFileExt(DestFileName, GetMemoExt),
ChangeFileExt(NewBaseName, GetMemoExt));
end;
// delete old index files
for I := 0 to NewIndexFileNames.Count - 1 do
SysUtils.DeleteFile(NewIndexFileNames.Strings[I]);
// rename the new dbf files
SysUtils.RenameFile(FileName, DestFileName);
SysUtils.RenameFile(ChangeFileExt(FileName, GetMemoExt),
ChangeFileExt(DestFileName, GetMemoExt));
// rename new index files
for I := 0 to NewIndexFileNames.Count - 1 do
SysUtils.RenameFile(lIndexFileNames.Strings[I], NewIndexFileNames.Strings[I]);
finally
lIndexFileNames.Free;
end;
end;
type
TRestructFieldInfo = record
SourceOffset: Integer;
DestOffset: Integer;
Size: Integer;
end;
{ assume nobody has more than 8192 fields, otherwise possibly range check error }
PRestructFieldInfo = ^TRestructFieldInfoArray;
TRestructFieldInfoArray = array[0..8191] of TRestructFieldInfo;
procedure TDbfFile.RestructureTable(DbfFieldDefs: TDbfFieldDefs; Pack: Boolean);
var
DestDbfFile: TDbfFile;
TempIndexDef: TDbfIndexDef;
TempIndexFile: TIndexFile;
DestFieldDefs: TDbfFieldDefs;
TempDstDef, TempSrcDef: TDbfFieldDef;
OldIndexFiles: TStrings;
IndexName, NewBaseName: string;
I, lRecNo, lFieldNo, lFieldSize, lBlobPageNo, lWRecNo, srcOffset, dstOffset: Integer;
pBuff, pDestBuff: TRecordBuffer;
RestructFieldInfo: PRestructFieldInfo;
BlobStream: TMemoryStream;
begin
// nothing to do?
if (RecordSize < 1) or ((DbfFieldDefs = nil) and not Pack) then
exit;
// if no exclusive access, terrible things can happen!
CheckExclusiveAccess;
// make up some temporary filenames
lRecNo := 0;
FindNextName(FileName, NewBaseName, lRecNo);
// select final field definition list
if DbfFieldDefs = nil then
begin
DestFieldDefs := FFieldDefs;
end else begin
DestFieldDefs := DbfFieldDefs;
// copy autoinc values
for I := 0 to DbfFieldDefs.Count - 1 do
begin
lFieldNo := DbfFieldDefs.Items[I].CopyFrom;
if (lFieldNo >= 0) and (lFieldNo < FFieldDefs.Count) then
DbfFieldDefs.Items[I].AutoInc := FFieldDefs.Items[lFieldNo].AutoInc;
end;
end;
// create temporary dbf
DestDbfFile := TDbfFile.Create;
DestDbfFile.FileName := NewBaseName;
DestDbfFile.AutoCreate := true;
DestDbfFile.Mode := pfExclusiveCreate;
DestDbfFile.OnIndexMissing := FOnIndexMissing;
DestDbfFile.OnLocaleError := FOnLocaleError;
DestDbfFile.DbfVersion := FDbfVersion;
DestDbfFile.FileLangId := FileLangId;
DestDbfFile.Open;
// create dbf header
if FMemoFile <> nil then
DestDbfFile.FinishCreate(DestFieldDefs, FMemoFile.RecordSize)
else
if (DestDbfFile.DbfVersion in [xFoxPro,xVisualFoxPro]) then
DestDbfFile.FinishCreate(DestFieldDefs, 64) {VFP default}
else
DestDbfFile.FinishCreate(DestFieldDefs, 512);
// adjust size and offsets of fields
GetMem(RestructFieldInfo, sizeof(TRestructFieldInfo)*DestFieldDefs.Count);
for lFieldNo := 0 to DestFieldDefs.Count - 1 do
begin
TempDstDef := DestFieldDefs.Items[lFieldNo];
if TempDstDef.CopyFrom >= 0 then
begin
TempSrcDef := FFieldDefs.Items[TempDstDef.CopyFrom];
if TempDstDef.NativeFieldType in ['F', 'N'] then
begin
// get minimum field length
lFieldSize := Min(TempSrcDef.Precision, TempDstDef.Precision) +
Min(TempSrcDef.Size - TempSrcDef.Precision,
TempDstDef.Size - TempDstDef.Precision);
// if one has dec separator, but other not, we lose one digit
if (TempDstDef.Precision > 0) xor
((TempSrcDef.NativeFieldType in ['F', 'N']) and (TempSrcDef.Precision > 0)) then
Dec(lFieldSize);
// should not happen, but check nevertheless (maybe corrupt data)
if lFieldSize < 0 then
lFieldSize := 0;
srcOffset := TempSrcDef.Size - TempSrcDef.Precision -
(TempDstDef.Size - TempDstDef.Precision);
if srcOffset < 0 then
begin
dstOffset := -srcOffset;
srcOffset := 0;
end else begin
dstOffset := 0;
end;
end else begin
lFieldSize := Min(TempSrcDef.Size, TempDstDef.Size);
srcOffset := 0;
dstOffset := 0;
end;
with RestructFieldInfo[lFieldNo] do
begin
Size := lFieldSize;
SourceOffset := TempSrcDef.Offset + srcOffset;
DestOffset := TempDstDef.Offset + dstOffset;
end;
end;
end;
// add indexes
TempIndexDef := TDbfIndexDef.Create(nil);
for I := 0 to FIndexNames.Count - 1 do
begin
// get length of extension -> determines MDX or NDX
IndexName := FIndexNames.Strings[I];
TempIndexFile := TIndexFile(FIndexNames.Objects[I]);
TempIndexFile.GetIndexInfo(IndexName, TempIndexDef);
if Length(ExtractFileExt(IndexName)) > 0 then
begin
// NDX index, get unique file name
lRecNo := 0;
FindNextName(IndexName, IndexName, lRecNo);
end;
// add this index
DestDbfFile.OpenIndex(IndexName, TempIndexDef.SortField, true, TempIndexDef.Options);
end;
TempIndexDef.Free;
// get memory for record buffers
GetMem(pBuff, RecordSize);
BlobStream := TMemoryStream.Create;
OldIndexFiles := TStringList.Create;
// if restructure, we need memory for dest buffer, otherwise use source
if DbfFieldDefs = nil then
pDestBuff := pBuff
else
GetMem(pDestBuff, DestDbfFile.RecordSize);
// Go through record data:
try
{$ifdef USE_CACHE}
BufferAhead := true;
DestDbfFile.BufferAhead := true;
{$endif}
lWRecNo := 1;
for lRecNo := 1 to RecordCount do
begin
// read record from original dbf
ReadRecord(lRecNo, pBuff);
// copy record unless (deleted or user wants packing)
if (ansichar(pBuff^) <> '*') or not Pack then
begin
// if restructure, initialize dest
if DbfFieldDefs <> nil then
begin
DestDbfFile.InitRecord(pDestBuff);
// copy deleted mark (the first byte)
pDestBuff^ := pBuff^;
end;
if (DbfFieldDefs <> nil) or (FMemoFile <> nil) then
begin
// copy fields
for lFieldNo := 0 to DestFieldDefs.Count-1 do
begin
TempDstDef := DestFieldDefs.Items[lFieldNo];
// handle blob fields differently
// don't try to copy new blob fields!
// DbfFieldDefs = nil -> pack only
// TempDstDef.CopyFrom >= 0 -> copy existing (blob) field
if TempDstDef.IsBlob and ((DbfFieldDefs = nil) or (TempDstDef.CopyFrom >= 0)) then
begin
// get current blob blockno
GetFieldData(lFieldNo, ftInteger, pBuff, @lBlobPageNo, false);
// valid blockno read?
if lBlobPageNo > 0 then
begin
BlobStream.Clear;
FMemoFile.ReadMemo(lBlobPageNo, BlobStream);
BlobStream.Position := 0;
// always append
DestDbfFile.FMemoFile.WriteMemo(lBlobPageNo, 0, BlobStream);
end;
// write new blockno
DestDbfFile.SetFieldData(lFieldNo, ftInteger, @lBlobPageNo, pDestBuff, false);
end else if (DbfFieldDefs <> nil) and (TempDstDef.CopyFrom >= 0) then
begin
// copy content of field
with RestructFieldInfo[lFieldNo] do
Move(pBuff[SourceOffset], pDestBuff[DestOffset], Size);
end;
end;
end;
// write record
DestDbfFile.WriteRecord(lWRecNo, pDestBuff);
// update indexes
for I := 0 to DestDbfFile.IndexFiles.Count - 1 do
TIndexFile(DestDbfFile.IndexFiles.Items[I]).Insert(lWRecNo, pDestBuff);
// go to next record
Inc(lWRecNo);
end;
end;
{$ifdef USE_CACHE}
BufferAhead := false;
DestDbfFile.BufferAhead := false;
{$endif}
// save index filenames
for I := 0 to FIndexFiles.Count - 1 do
OldIndexFiles.Add(TIndexFile(IndexFiles[I]).FileName);
// close dbf
Close;
// if restructure -> rename the old dbf files
// if pack only -> delete the old dbf files
DestDbfFile.Rename(FileName, OldIndexFiles, DbfFieldDefs = nil);
// we have to reinit fielddefs if restructured
Open;
// crop deleted records
RecordCount := lWRecNo - 1;
// update date/time stamp, recordcount
PDbfHdr(Header)^.RecordCount := RecordCount;
WriteHeader;
finally
// close temporary file
FreeAndNil(DestDbfFile);
// free mem
FreeAndNil(OldIndexFiles);
FreeMem(pBuff);
FreeAndNil(BlobStream);
FreeMem(RestructFieldInfo);
if DbfFieldDefs <> nil then
FreeMem(pDestBuff);
end;
end;
procedure TDbfFile.RegenerateIndexes;
var
lIndexNo: Integer;
begin
// recreate every index in every file
for lIndexNo := 0 to FIndexFiles.Count-1 do
begin
PackIndex(TIndexFile(FIndexFiles.Items[lIndexNo]), EmptyStr);
end;
end;
function TDbfFile.GetFieldInfo(FieldName: string): TDbfFieldDef;
var
I: Integer;
lfi: TDbfFieldDef;
begin
FieldName := AnsiUpperCase(FieldName);
for I := 0 to FFieldDefs.Count-1 do
begin
lfi := TDbfFieldDef(FFieldDefs.Items[I]);
if lfi.fieldName = FieldName then
begin
Result := lfi;
exit;
end;
end;
Result := nil;
end;
// NOTE: Dst may be nil!
function TDbfFile.GetFieldData(Column: Integer; DataType: TFieldType;
Src, Dst: Pointer; NativeFormat: boolean): Boolean;
var
TempFieldDef: TDbfFieldDef;
begin
TempFieldDef := TDbfFieldDef(FFieldDefs.Items[Column]);
Result := GetFieldDataFromDef(TempFieldDef, DataType, Src, Dst, NativeFormat);
end;
// NOTE: Dst may be nil!
function TDbfFile.GetFieldDataFromDef(AFieldDef: TDbfFieldDef; DataType: TFieldType;
Src, Dst: Pointer; NativeFormat: boolean): Boolean;
var
FieldOffset, FieldSize: Integer;
// s: string;
ldd, ldm, ldy, lth, ltm, lts: Integer;
date: TDateTime;
timeStamp: TTimeStamp;
asciiContents: boolean;
SrcRecord: Pointer;
{$ifdef SUPPORT_INT64}
function GetInt64FromStrLength(Src: Pointer; Size: Integer; Default: Int64): Int64;
var
endChar: Char;
Code: Integer;
begin
// save Char at pos term. null
endChar := (PChar(Src) + Size)^;
(PChar(Src) + Size)^ := #0;
// convert
Val(PChar(Src), Result, Code);
// check success
if Code <> 0 then Result := Default;
// restore prev. ending Char
(PChar(Src) + Size)^ := endChar;
end;
{$endif}
procedure CorrectYear(var wYear: Integer);
var wD, wM, wY, CenturyBase: Word;
{$ifndef DELPHI_5}
// Delphi 3 standard behavior, no change possible
const TwoDigitYearCenturyWindow= 0;
{$endif}
begin
if wYear >= 100 then
Exit;
DecodeDate(Date, wY, wm, wD);
// use Delphi-Date-Window
CenturyBase := wY{must be CurrentYear} - TwoDigitYearCenturyWindow;
Inc(wYear, CenturyBase div 100 * 100);
if (TwoDigitYearCenturyWindow > 0) and (wYear < CenturyBase) then
Inc(wYear, 100);
end;
procedure SaveDateToDst;
begin
if not NativeFormat then
begin
// Delphi 5 requests a TDateTime
PDateTime(Dst)^ := date;
end else begin
// Delphi 3 and 4 request a TDateTimeRec
// date is TTimeStamp.date
// datetime = msecs == BDE timestamp as we implemented it
if DataType = ftDateTime then
begin
PDateTimeRec(Dst)^.DateTime := date;
end else begin
PLongInt(Dst)^ := DateTimeToTimeStamp(date).Date;
end;
end;
end;
begin
// test if non-nil source (record buffer)
if Src = nil then
begin
Result := false;
exit;
end;
// check Dst = nil, called with dst = nil to check empty field
if (FNullField <> nil) and (Dst = nil) and (AFieldDef.NullPosition >= 0) then
begin
result:= not(IsNullFlagSet(Src, AFieldDef, nfNullFlag));
exit;
end;
FieldOffset := AFieldDef.Offset;
FieldSize := AFieldDef.Size;
SrcRecord := Src;
Src := PChar(Src) + FieldOffset;
asciiContents := false;
Result := true;
// field types that are binary and of which the fieldsize should not be truncated
case AFieldDef.NativeFieldType of
'+', 'I': //Autoincrement, integer
begin
if not(FDbfVersion in [xFoxPro,xVisualFoxPro]) then
begin
Result := Unaligned(PDWord(Src)^) <> 0;
if Result and (Dst <> nil) then
begin
PDWord(Dst)^ := SwapIntBE(Unaligned(PDWord(Src)^));
if Result then
PInteger(Dst)^ := Integer(PDWord(Dst)^ xor $80000000);
end;
end else begin
Result := true;
if Dst <> nil then
PInteger(Dst)^ := SwapIntLE(Unaligned(PInteger(Src)^));
end;
end;
'O':
begin
{$ifdef SUPPORT_INT64}
Result := Unaligned(PInt64(Src)^) <> 0;
if Result and (Dst <> nil) then
begin
SwapInt64BE(Src, Dst);
if PInt64(Dst)^ > 0 then
PInt64(Dst)^ := not PInt64(Dst)^
else
PDouble(Dst)^ := PDouble(Dst)^ * -1;
end;
{$endif}
end;
'@':
begin
Result := (Unaligned(PInteger(Src)^) <> 0) and (Unaligned(PInteger(PChar(Src)+4)^) <> 0);
if Result and (Dst <> nil) then
begin
SwapInt64BE(Src, Dst);
if FDateTimeHandling = dtBDETimeStamp then
date := BDETimeStampToDateTime(PDouble(Dst)^)
else
date := PDateTime(Dst)^;
SaveDateToDst;
end;
end;
'T':
begin
// all binary zeroes -> empty datetime
{$ifdef SUPPORT_INT64}
Result := Unaligned(PInt64(Src)^) <> 0;
{$else}
Result := (Unaligned(PInteger(Src)^) <> 0) or (Unaligned(PInteger(PChar(Src)+4)^) <> 0);
{$endif}
if Result and (Dst <> nil) then
begin
timeStamp.Date := SwapIntLE(Unaligned(PInteger(Src)^)) - JulianDateDelta;
timeStamp.Time := SwapIntLE(Unaligned(PInteger(PChar(Src)+4)^));
date := TimeStampToDateTime(timeStamp);
SaveDateToDst;
end;
end;
'Y': // currency
begin
{$ifdef SUPPORT_INT64}
Result := true;
if Dst <> nil then
begin
PInt64(Dst)^ := SwapIntLE(Unaligned(PInt64(Src)^));
if DataType = ftCurrency then
PDouble(Dst)^ := PInt64(Dst)^ / 10000.0;
end;
{$endif}
end;
'B': // Foxpro double
begin
if (FDbfVersion in [xFoxPro,xVisualFoxPro]) then
begin
{$ifdef SUPPORT_INT64}
Result := Unaligned(PInt64(Src)^) <> 0;
if Result and (Dst <> nil) then
begin
SwapInt64LE(Src, Dst);
PDouble(Dst)^ := PDouble(Dst)^;
end;
{$endif} end else
asciiContents := true;
end;
'M':
begin
if FieldSize = 4 then
begin
Result := Unaligned(PInteger(Src)^) <> 0;
if Dst <> nil then
PInteger(Dst)^ := SwapIntLE(Unaligned(PInteger(Src)^));
end else
asciiContents := true;
end;
'Q', 'V': // Visual Foxpro varbinary, varchar
//todo: check if codepage conversion/translation for varchar is needed
begin
if (FDbfVersion in [xVisualFoxPro]) then
begin
Result := true;
// The length byte is only stored if the field is not full
if (Dst <> nil) then
begin
//clear the destination, just in case
Fillchar(pbyte(Dst)^,Fieldsize,0);
if IsNullFlagSet(SrcRecord, AFieldDef, nfVarlengthFlag) then
// so we decrease the fieldsize and let the rest of the code handle it
FieldSize:=(PByte(Src)+FieldSize-1)^;
// If field is not null:
if not(IsNullFlagSet(SrcRecord, AFieldDef, nfNullFlag)) then
if Afielddef.FieldType=ftVarBytes then
begin
PWord(Dst)^:=Fieldsize; //Store size in destination
move(Src^, pbyte(Dst+sizeof(Word))^, FieldSize)
end
else
move(Src^, pbyte(Dst)^, FieldSize)
else
result:=false;
end;
end;
end;
'0': // Zero not letter 0: bytes
begin
if (Dst <> nil) then
begin
//clear the destination, just in case
Fillchar(pbyte(Dst)^,Fieldsize,0);
move(Src^, pbyte(Dst)^, FieldSize);
Result := true;
end;
end;
else
asciiContents := true;
end;
if asciiContents then
begin
// SetString(s, PChar(Src) + FieldOffset, FieldSize );
// s := {TrimStr(s)} TrimRight(s);
// truncate spaces at end by shortening fieldsize
while (FieldSize > 0) and ((PChar(Src) + FieldSize - 1)^ = ' ') do
dec(FieldSize);
// if not string field, truncate spaces at beginning too
if DataType <> ftString then
while (FieldSize > 0) and (PChar(Src)^ = ' ') do
begin
inc(PChar(Src));
dec(FieldSize);
end;
// return if field is empty
Result := FieldSize > 0;
if Result and (Dst <> nil) then // data not needed if Result= false or Dst=nil
case DataType of
ftBoolean:
begin
// in DBase- FileDescription lowercase t is allowed too
// with asking for Result= true s must be longer then 0
// else an AV occurs, maybe field is NULL
if (PChar(Src)^ = 'T') or (PChar(Src)^ = 't') then
PWord(Dst)^ := 1
else
PWord(Dst)^ := 0;
end;
ftSmallInt:
PSmallInt(Dst)^ := GetIntFromStrLength(Src, FieldSize, 0);
{$ifdef SUPPORT_INT64}
ftLargeInt:
PLargeInt(Dst)^ := GetInt64FromStrLength(Src, FieldSize, 0);
{$endif}
ftInteger:
PInteger(Dst)^ := GetIntFromStrLength(Src, FieldSize, 0);
ftFloat, ftCurrency:
PDouble(Dst)^ := DbfStrToFloat(Src, FieldSize);
ftDate, ftDateTime:
begin
// get year, month, day
ldy := GetIntFromStrLength(PChar(Src) + 0, 4, 1);
ldm := GetIntFromStrLength(PChar(Src) + 4, 2, 1);
ldd := GetIntFromStrLength(PChar(Src) + 6, 2, 1);
//if (ly<1900) or (ly>2100) then ly := 1900;
//Year from 0001 to 9999 is possible
//everyting else is an error, an empty string too
//Do DateCorrection with Delphis possibillities for one or two digits
if (ldy < 100) and (PChar(Src)[0] = #32) and (PChar(Src)[1] = #32) then
CorrectYear(ldy);
try
date := EncodeDate(ldy, ldm, ldd);
except
date := 0;
end;
// time stored too?
if (AFieldDef.FieldType = ftDateTime) and (DataType = ftDateTime) then
begin
// get hour, minute, second
lth := GetIntFromStrLength(PChar(Src) + 8, 2, 1);
ltm := GetIntFromStrLength(PChar(Src) + 10, 2, 1);
lts := GetIntFromStrLength(PChar(Src) + 12, 2, 1);
// encode
try
date := date + EncodeTime(lth, ltm, lts, 0);
except
date := 0;
end;
end;
SaveDateToDst;
end;
ftString:
StrLCopy(Dst, Src, FieldSize);
end else begin
case DataType of
ftString:
if Dst <> nil then
PChar(Dst)[0] := #0;
end;
end;
end;
end;
procedure TDbfFile.UpdateNullField(Buffer: Pointer; AFieldDef: TDbfFieldDef;
Action: TUpdateNullField; WhichField: TNullFieldFlag);
var
NullDst: pbyte;
Mask: byte;
begin
// this field has null setting capability...
// ... but no Super Cow Powers.
case WhichField of
nfNullFlag:
begin
// Find out the byte where the length bit for the field is stored by doing
// NullPosition shr3 (= NullPosition div 8)...
NullDst := PByte(PChar(Buffer) + FNullField.Offset + (AFieldDef.NullPosition shr 3));
// ... get the correct bit in the byte by the equivalent of
// getting the bit number in that byte:
// NullPosition and $7 (=mod 8)...
// and going to the bit value in the byte (shl)
Mask := 1 shl (AFieldDef.NullPosition and $7);
end;
nfVarlengthFlag:
begin
NullDst := PByte(PChar(Buffer) + FNullField.Offset + (AFieldDef.VarLengthPosition shr 3));
Mask := 1 shl (AFieldDef.VarLengthPosition and $7);
end;
end;
if Action = unfSet then
begin
// set flag
NullDst^ := NullDst^ or Mask;
end else begin //unfClear
// clear flag
NullDst^ := NullDst^ and not Mask;
end;
end;
procedure TDbfFile.SetFieldData(Column: Integer; DataType: TFieldType;
Src, Dst: Pointer; NativeFormat: boolean);
const
IsBlobFieldToPadChar: array[Boolean] of Char = (#32, '0');
SrcNilToUpdateNullField: array[boolean] of TUpdateNullField = (unfClear, unfSet);
var
DstRecord: Pointer;
FieldSize,FieldPrec: Integer;
TempFieldDef: TDbfFieldDef;
Len: Integer;
IntValue: dword;
year, month, day: Word;
hour, minute, sec, msec: Word;
date: TDateTime;
timeStamp: TTimeStamp;
asciiContents: boolean;
procedure LoadDateFromSrc;
begin
if not NativeFormat then
begin
// Delphi 5, new format, passes a TDateTime
date := PDateTime(Src)^;
end else begin
// Delphi 3 and 4, old "native" format, pass a TDateTimeRec with a time stamp
// date = integer
// datetime = msecs == BDETimeStampToDateTime as we implemented it
if DataType = ftDateTime then
begin
date := PDouble(Src)^;
end else begin
timeStamp.Time := 0;
timeStamp.Date := PLongInt(Src)^;
date := TimeStampToDateTime(timeStamp);
end;
end;
end;
begin
TempFieldDef := TDbfFieldDef(FFieldDefs.Items[Column]);
FieldSize := TempFieldDef.Size;
FieldPrec := TempFieldDef.Precision;
DstRecord:=Dst; //beginning of record
Dst := PChar(Dst) + TempFieldDef.Offset; //beginning of field
// if src = nil then write empty field
// symmetry with above loading code
// Visual Foxpro has special _nullfield for flagging fields as `null'
if (FNullField <> nil) and (TempFieldDef.NullPosition >= 0) then
UpdateNullField(DstRecord, TempFieldDef, SrcNilToUpdateNullField[Src = nil],nfNullFlag);
// copy field data to record buffer
asciiContents := false;
case TempFieldDef.NativeFieldType of
'+', 'I' {autoincrement, integer}:
begin
if not(FDbfVersion in [xFoxPro,xVisualFoxPro]) then
begin
if Src = nil then
IntValue := 0
else
IntValue := PDWord(Src)^ xor $80000000;
Unaligned(PDWord(Dst)^) := SwapIntBE(IntValue);
end else begin
if Src = nil then
Unaligned(PDWord(Dst)^) := 0
else
Unaligned(PDWord(Dst)^) := SwapIntLE(PDWord(Src)^);
end;
end;
'O':
begin
{$ifdef SUPPORT_INT64}
if Src = nil then
begin
Unaligned(PInt64(Dst)^) := 0;
end else begin
if PDouble(Src)^ < 0 then
Unaligned(PInt64(Dst)^) := not PInt64(Src)^
else
Unaligned(PDouble(Dst)^) := (PDouble(Src)^) * -1;
SwapInt64BE(Dst, Dst);
end;
{$endif}
end;
'@':
begin
if Src = nil then
begin
{$ifdef SUPPORT_INT64}
Unaligned(PInt64(Dst)^) := 0;
{$else}
Unaligned(PInteger(Dst)^) := 0;
Unaligned(PInteger(PChar(Dst)+4)^) := 0;
{$endif}
end else begin
LoadDateFromSrc;
if FDateTimeHandling = dtBDETimeStamp then
date := DateTimeToBDETimeStamp(date);
SwapInt64BE(@date, Dst);
end;
end;
'T':
begin
// all binary zeroes -> empty datetime
if Src = nil then
begin
{$ifdef SUPPORT_INT64}
Unaligned(PInt64(Dst)^) := 0;
{$else}
Unaligned(PInteger(Dst)^) := 0;
Unaligned(PInteger(PChar(Dst)+4)^) := 0;
{$endif}
end else begin
LoadDateFromSrc;
timeStamp := DateTimeToTimeStamp(date);
Unaligned(PInteger(Dst)^) := SwapIntLE(timeStamp.Date + JulianDateDelta);
Unaligned(PInteger(PChar(Dst)+4)^) := SwapIntLE(timeStamp.Time);
end;
end;
'Y':
begin
{$ifdef SUPPORT_INT64}
if Src = nil then
begin
Unaligned(PInt64(Dst)^) := 0;
end else begin
case DataType of
ftCurrency:
Unaligned(PInt64(Dst)^) := Trunc(PDouble(Src)^ * 10000);
ftBCD:
Unaligned(PCurrency(Dst)^) := PCurrency(Src)^;
end;
SwapInt64LE(Dst, Dst);
end;
{$endif}
end;
'B' {(Visual) FoxPro Double}:
begin
if DbfVersion in [xFoxPro,xVisualFoxPro] then
begin
if Src = nil then
Unaligned(PDouble(Dst)^) := 0
else
SwapInt64LE(Src, Dst);
end else
asciiContents := true;
end;
'M':
begin
if FieldSize = 4 then
begin
if Src = nil then
Unaligned(PInteger(Dst)^) := 0
else
Unaligned(PInteger(Dst)^) := SwapIntLE(PInteger(Src)^);
end else
asciiContents := true;
end;
'Q': //Visual FoxPro varbinary
begin
// copy data, and update varlength flag/varlength byte in field data
if Src = nil then
Len := 0
else
begin
Len := PWord(Src)^;
if Len > FieldSize then
Len := FieldSize;
end;
if Len < FieldSize then
begin
// Clear flag and store actual size byte in last data byte
PByte(PChar(Dst)+TempFieldDef.Size-1)^:=Len;
UpdateNullField(DstRecord, TempFieldDef, unfSet, nfVarlengthFlag);
end
else
begin
UpdateNullField(DstRecord, TempFieldDef, unfClear, nfVarlengthFlag);
end;
Move((Src+sizeof(word))^, Dst^, Len);
// fill remaining data area with spaces, keeping room for size indicator if needed
if Len=FieldSize then
FillChar((PChar(Dst)+Len)^, FieldSize - Len, ' ')
else
FillChar((PChar(Dst)+Len)^, FieldSize - Len - 1, ' ');
end;
'V': //Visual FoxPro varchar
begin
// copy data, and update varlength flag/varlength byte in field data
Len := StrLen(Src);
if Len > FieldSize then
Len := FieldSize;
if Len < FieldSize then
begin
// Clear flag and store actual size byte in last data byte
PByte(PChar(Dst)+TempFieldDef.Size-1)^:=Len;
UpdateNullField(DstRecord, TempFieldDef, unfSet, nfVarlengthFlag);
end
else
begin
UpdateNullField(DstRecord, TempFieldDef, unfClear, nfVarlengthFlag);
end;
Move(Src^, Dst^, Len);
// fill remaining data area with spaces, keeping room for size indicator if needed
if Len=FieldSize then
FillChar((PChar(Dst)+Len)^, FieldSize - Len, ' ')
else
FillChar((PChar(Dst)+Len)^, FieldSize - Len - 1, ' ');
end
else
asciiContents := true;
end;
if asciiContents then
begin
if Src = nil then
begin
FillChar(Dst^, FieldSize, ' ');
end else begin
case DataType of
ftBoolean:
begin
if PWord(Src)^ <> 0 then
PChar(Dst)^ := 'T'
else
PChar(Dst)^ := 'F';
end;
ftSmallInt:
GetStrFromInt_Width(PSmallInt(Src)^, FieldSize, PChar(Dst), #32);
{$ifdef SUPPORT_INT64}
ftLargeInt:
GetStrFromInt64_Width(PLargeInt(Src)^, FieldSize, PChar(Dst), #32);
{$endif}
ftFloat, ftCurrency:
FloatToDbfStr(PDouble(Src)^, FieldSize, FieldPrec, PChar(Dst));
ftInteger:
GetStrFromInt_Width(PInteger(Src)^, FieldSize, PChar(Dst),
IsBlobFieldToPadChar[TempFieldDef.IsBlob]);
ftDate, ftDateTime:
begin
LoadDateFromSrc;
// decode
DecodeDate(date, year, month, day);
// format is yyyymmdd
GetStrFromInt_Width(year, 4, PChar(Dst), '0');
GetStrFromInt_Width(month, 2, PChar(Dst)+4, '0');
GetStrFromInt_Width(day, 2, PChar(Dst)+6, '0');
// do time too if datetime
if DataType = ftDateTime then
begin
DecodeTime(date, hour, minute, sec, msec);
// format is hhmmss
GetStrFromInt_Width(hour, 2, PChar(Dst)+8, '0');
GetStrFromInt_Width(minute, 2, PChar(Dst)+10, '0');
GetStrFromInt_Width(sec, 2, PChar(Dst)+12, '0');
end;
end;
ftString:
begin
// copy data
Len := StrLen(Src);
if Len > FieldSize then
Len := FieldSize;
Move(Src^, Dst^, Len);
// fill remaining space with spaces
FillChar((PChar(Dst)+Len)^, FieldSize - Len, ' ');
end;
end; // case datatype
end;
end;
end;
procedure TDbfFile.InitDefaultBuffer;
var
lRecordSize: integer;
TempFieldDef: TDbfFieldDef;
I: Integer;
begin
lRecordSize := PDbfHdr(Header)^.RecordSize;
// clear buffer (assume all string, fix specific fields later)
// note: Self.RecordSize is used for reading fielddefs too
GetMem(FDefaultBuffer, lRecordSize+1);
FillChar(FDefaultBuffer^, lRecordSize, ' ');
// set nullflags field so that all fields are null (and var* fields marked as full)
if FNullField <> nil then
FillChar(PChar(FDefaultBuffer+FNullField.Offset)^, FNullField.Size, $FF);
// check binary and default fields
for I := 0 to FFieldDefs.Count-1 do
begin
TempFieldDef := FFieldDefs.Items[I];
// binary (non-text) field? (foxpro memo fields are binary, but dbase not)
if (TempFieldDef.NativeFieldType in ['I', 'O', '@', '+', '0', 'W', 'Y'])
or ((TempFieldDef.NativeFieldType = 'M') and (TempFieldDef.Size = 4) {Visual FoxPro?}) then
FillChar(PChar(FDefaultBuffer+TempFieldDef.Offset)^, TempFieldDef.Size, 0);
// copy default value?
if TempFieldDef.HasDefault then
begin
Move(TempFieldDef.DefaultBuf[0], FDefaultBuffer[TempFieldDef.Offset], TempFieldDef.Size);
// clear the null flag, this field has a value
if FNullField <> nil then
UpdateNullField(FDefaultBuffer, TempFieldDef, unfClear, nfNullFlag);
// Check for varbinary/varchar and if default matches it, then mark field as full
if (TempFieldDef.VarLengthPosition>=0) then
if (strlen(FDefaultBuffer)>=TempFieldDef.Size) then
UpdateNullField(FDefaultBuffer, TempFieldDef, unfClear, nfVarlengthFlag)
else
begin
// Set flag and store actual size byte in last data byte
UpdateNullField(FDefaultBuffer, TempFieldDef, unfSet, nfVarlengthFlag);
//todo: verify pointer use
PByte(PChar(FDefaultBuffer)+TempFieldDef.Size)^:=strlen(FDefaultBuffer);
end;
end;
end;
end;
procedure TDbfFile.InitRecord(DestBuf: TRecordBuffer);
begin
if FDefaultBuffer = nil then
InitDefaultBuffer;
Move(FDefaultBuffer^, DestBuf^, RecordSize);
end;
procedure TDbfFile.ApplyAutoIncToBuffer(DestBuf: TRecordBuffer);
var
TempFieldDef: TDbfFieldDef;
I, NextVal, lAutoIncOffset: {LongWord} Cardinal; {Delphi 3 does not know LongWord?}
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);
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
PCardinal(DestBuf+TempFieldDef.Offset)^ := SwapIntBE(NextVal or $80000000);
// increase
Inc(NextVal);
TempFieldDef.AutoInc := NextVal;
// write new value to header buffer
PCardinal(FHeader+lAutoIncOffset)^ := SwapIntLE(NextVal);
end
else //No DBaseVII
if (DbfVersion=xVisualFoxPro) 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?
// Increase with step size
NextVal:=NextVal+TempFieldDef.AutoIncStep;
// write new value back
TempFieldDef.AutoInc:=NextVal;
end;
end;
// write modified header (new autoinc values) to file
WriteHeader;
// release lock if locked
if NeedLocks then
UnlockPage(0);
end;
end;
procedure TDbfFile.TryExclusive;
var
I: Integer;
begin
inherited;
// exclusive succeeded? open index & memo exclusive too
if Mode in [pfMemoryCreate..pfExclusiveOpen] then
begin
// indexes
for I := 0 to FIndexFiles.Count - 1 do
TPagedFile(FIndexFiles[I]).TryExclusive;
// memo
if FMemoFile <> nil then
FMemoFile.TryExclusive;
end;
end;
procedure TDbfFile.EndExclusive;
var
I: Integer;
begin
// end exclusive on index & memo too
for I := 0 to FIndexFiles.Count - 1 do
TPagedFile(FIndexFiles[I]).EndExclusive;
// memo
if FMemoFile <> nil then
FMemoFile.EndExclusive;
// dbf file
inherited;
end;
procedure TDbfFile.OpenIndex(IndexName, IndexField: string; CreateIndex: Boolean; Options: TIndexOptions);
//
// assumes IndexName is not empty
//
const
// memcr, memop, excr, exopen, rwcr, rwopen, rdonly
IndexOpenMode: array[boolean, pfMemoryCreate..pfReadOnly] of TPagedFileMode =
((pfMemoryCreate, pfMemoryCreate, pfExclusiveOpen, pfExclusiveOpen, pfReadWriteOpen, pfReadWriteOpen,
pfReadOnly),
(pfMemoryCreate, pfMemoryCreate, pfExclusiveCreate, pfExclusiveCreate, pfReadWriteCreate, pfReadWriteCreate,
pfReadOnly));
var
lIndexFile: TIndexFile;
lIndexFileName: string;
createMdxFile: Boolean;
tempExclusive: boolean;
addedIndexFile: Integer;
addedIndexName: Integer;
begin
// init
addedIndexFile := -1;
addedIndexName := -1;
createMdxFile := false;
// index already opened?
lIndexFile := GetIndexByName(IndexName);
if (lIndexFile <> nil) and (lIndexFile = FMdxFile) and CreateIndex then
begin
// index already exists in MDX file
// delete it to save space, this causes a repage
FMdxFile.DeleteIndex(IndexName);
// index no longer exists
lIndexFile := nil;
end;
if (lIndexFile = nil) and (IndexName <> EmptyStr) then
begin
// check if no extension, then create MDX index
if Length(ExtractFileExt(IndexName)) = 0 then
begin
// check if mdx index already opened
if FMdxFile <> nil then
begin
lIndexFileName := EmptyStr;
lIndexFile := FMdxFile;
end else begin
lIndexFileName := ChangeFileExt(FileName, '.mdx');
createMdxFile := true;
end;
end else begin
lIndexFileName := IndexName;
end;
// do we need to open / create file?
if lIndexFileName <> EmptyStr then
begin
// try to open / create the file
lIndexFile := TIndexFile.Create(Self);
lIndexFile.FileName := lIndexFileName;
lIndexFile.Mode := IndexOpenMode[CreateIndex, Mode];
lIndexFile.AutoCreate := CreateIndex or (Length(IndexField) > 0);
if (Mode in [pfMemoryOpen,pfMemoryCreate]) then
begin
if FIndexStream = nil then
FIndexStream := TMemoryStream.Create;
lIndexFile.Stream := FIndexStream;
end;
lIndexFile.CodePage := UseCodePage;
lIndexFile.OnLocaleError := FOnLocaleError;
lIndexFile.Open;
// index file ready for use?
if not lIndexFile.ForceClose then
begin
// if we had to create the index, store that info
CreateIndex := lIndexFile.FileCreated;
// check if trying to create empty index
if CreateIndex and (IndexField = EmptyStr) then
begin
FreeAndNil(lIndexFile);
CreateIndex := false;
createMdxFile := false;
end else begin
// add new index file to list
addedIndexFile := FIndexFiles.Add(lIndexFile);
end;
// created accompanying mdx file?
if createMdxFile then
FMdxFile := lIndexFile;
end else begin
// asked to close! close file
FreeAndNil(lIndexFile);
end;
end;
// check if file succesfully opened
if lIndexFile <> nil then
begin
// add index to list
addedIndexName := FIndexNames.AddObject(IndexName, lIndexFile);
end;
end;
// create it or open it?
if lIndexFile <> nil then
begin
if not CreateIndex then
if lIndexFile = FMdxFile then
CreateIndex := lIndexFile.IndexOf(IndexName) < 0;
if CreateIndex then
begin
// try get exclusive mode
tempExclusive := IsSharedAccess;
if tempExclusive then TryExclusive;
// always uppercase index expression
IndexField := AnsiUpperCase(IndexField);
try
try
// create index if asked
lIndexFile.CreateIndex(IndexField, IndexName, Options);
// add all records
PackIndex(lIndexFile, IndexName);
// if we wanted to open index readonly, but we created it, then reopen
if Mode = pfReadOnly then
begin
lIndexFile.CloseFile;
lIndexFile.Mode := pfReadOnly;
lIndexFile.OpenFile;
end;
// if mdx file just created, write changes to dbf header
// set MDX flag to true
PDbfHdr(Header)^.MDXFlag := 1;
WriteHeader;
except
on EDbfError do
begin
// :-( need to undo 'damage'....
// remove index from list(s) if just added
if addedIndexFile >= 0 then
FIndexFiles.Delete(addedIndexFile);
if addedIndexName >= 0 then
FIndexNames.Delete(addedIndexName);
// if no file created, do not destroy!
if addedIndexFile >= 0 then
begin
lIndexFile.Close;
Sysutils.DeleteFile(lIndexFileName);
if FMdxFile = lIndexFile then
FMdxFile := nil;
lIndexFile.Free;
end;
raise;
end;
end;
finally
// return to previous mode
if tempExclusive then EndExclusive;
end;
end;
end;
end;
procedure TDbfFile.PackIndex(lIndexFile: TIndexFile; AIndexName: string);
var
prevMode: TIndexUpdateMode;
prevIndex: string;
cur, last: Integer;
{$ifdef USE_CACHE}
prevCache: Integer;
{$endif}
begin
// save current mode in case we change it
prevMode := lIndexFile.UpdateMode;
prevIndex := lIndexFile.IndexName;
// check if index specified
if Length(AIndexName) > 0 then
begin
// only pack specified index, not all
lIndexFile.IndexName := AIndexName;
lIndexFile.ClearIndex;
lIndexFile.UpdateMode := umCurrent;
end else begin
lIndexFile.IndexName := EmptyStr;
lIndexFile.Clear;
lIndexFile.UpdateMode := umAll;
end;
// prepare update
cur := 1;
last := RecordCount;
{$ifdef USE_CACHE}
BufferAhead := true;
prevCache := lIndexFile.CacheSize;
lIndexFile.CacheSize := GetFreeMemory;
if lIndexFile.CacheSize < 16384 * 1024 then
lIndexFile.CacheSize := 16384 * 1024;
{$endif}
try
try
while cur <= last do
begin
ReadRecord(cur, FPrevBuffer);
lIndexFile.Insert(cur, FPrevBuffer);
inc(cur);
end;
except
on E: EDbfError do
begin
lIndexFile.DeleteIndex(lIndexFile.IndexName);
raise;
end;
end;
finally
// restore previous mode
{$ifdef USE_CACHE}
BufferAhead := false;
lIndexFile.BufferAhead := true;
{$endif}
lIndexFile.Flush;
{$ifdef USE_CACHE}
lIndexFile.BufferAhead := false;
lIndexFile.CacheSize := prevCache;
{$endif}
lIndexFile.UpdateMode := prevMode;
lIndexFile.IndexName := prevIndex;
end;
end;
procedure TDbfFile.RepageIndex(AIndexFile: string);
var
lIndexNo: Integer;
begin
// DBF MDX index?
if Length(AIndexFile) = 0 then
begin
if FMdxFile <> nil then
begin
// repage attached mdx
FMdxFile.RepageFile;
end;
end else begin
// search index file
lIndexNo := FIndexNames.IndexOf(AIndexFile);
// index found?
if lIndexNo >= 0 then
TIndexFile(FIndexNames.Objects[lIndexNo]).RepageFile;
end;
end;
procedure TDbfFile.CompactIndex(AIndexFile: string);
var
lIndexNo: Integer;
begin
// DBF MDX index?
if Length(AIndexFile) = 0 then
begin
if FMdxFile <> nil then
begin
// repage attached mdx
FMdxFile.CompactFile;
end;
end else begin
// search index file
lIndexNo := FIndexNames.IndexOf(AIndexFile);
// index found?
if lIndexNo >= 0 then
TIndexFile(FIndexNames.Objects[lIndexNo]).CompactFile;
end;
end;
procedure TDbfFile.CloseIndex(AIndexName: string);
var
lIndexNo: Integer;
lIndex: TIndexFile;
begin
// search index file
lIndexNo := FIndexNames.IndexOf(AIndexName);
// don't close mdx file
if (lIndexNo >= 0) then
begin
// get index pointer
lIndex := TIndexFile(FIndexNames.Objects[lIndexNo]);
if (lIndex <> FMdxFile) then
begin
// close file
lIndex.Free;
// remove from lists
FIndexFiles.Remove(lIndex);
FIndexNames.Delete(lIndexNo);
// was this the current index?
if (FCurIndex = lIndexNo) then
begin
FCurIndex := -1;
//FCursor := FDbfCursor;
end;
end;
end;
end;
function TDbfFile.DeleteIndex(const AIndexName: string): Boolean;
var
lIndexNo: Integer;
lIndex: TIndexFile;
lFileName: string;
begin
// search index file
lIndexNo := FIndexNames.IndexOf(AIndexName);
Result := lIndexNo >= 0;
// found index?
if Result then
begin
// can only delete indexes from MDX files
lIndex := TIndexFile(FIndexNames.Objects[lIndexNo]);
if lIndex = FMdxFile then
begin
lIndex.DeleteIndex(AIndexName);
// remove it from the list
FIndexNames.Delete(lIndexNo);
// no more MDX indexes?
lIndexNo := FIndexNames.IndexOfObject(FMdxFile);
if lIndexNo = -1 then
begin
// no MDX indexes left
lIndexNo := FIndexFiles.IndexOf(FMdxFile);
if lIndexNo >= 0 then
FIndexFiles.Delete(lIndexNo);
lFileName := FMdxFile.FileName;
FreeAndNil(FMdxFile);
// erase file
Sysutils.DeleteFile(lFileName);
// clear mdx flag
PDbfHdr(Header)^.MDXFlag := 0;
WriteHeader;
end;
end else begin
// close index first
CloseIndex(AIndexName);
// delete file from disk
SysUtils.DeleteFile(AIndexName);
end;
end;
end;
function TDbfFile.Insert(Buffer: TRecordBuffer): integer;
type
TErrorContext = (ecNone, ecInsert, ecWriteIndex, ecWriteDbf);
var
newRecord: Integer;
lIndex: TIndexFile;
procedure RollBackIndexesAndRaise(Count: Integer; ErrorContext: TErrorContext);
var
errorMsg: string;
I: Integer;
begin
// rollback committed indexes
for I := 0 to Count-1 do
begin
lIndex := TIndexFile(FIndexFiles.Items[I]);
lIndex.Delete(newRecord, Buffer);
end;
// reset any dbf file error
ResetError;
// if part of indexes committed -> always index error msg
// if error while rolling back index -> index error msg
case ErrorContext of
ecInsert: begin TIndexFile(FIndexFiles.Items[Count]).InsertError; exit; end;
ecWriteIndex: errorMsg := STRING_WRITE_INDEX_ERROR;
ecWriteDbf: errorMsg := STRING_WRITE_ERROR;
end;
raise EDbfWriteError.Create(errorMsg);
end;
var
I: Integer;
error: TErrorContext;
begin
// get new record index
Result := 0;
newRecord := RecordCount+1;
// lock record so we can write data
while not LockPage(newRecord, false) do
Inc(newRecord);
// write autoinc value
ApplyAutoIncToBuffer(Buffer);
error := ecNone;
I := 0;
while I < FIndexFiles.Count do
begin
lIndex := TIndexFile(FIndexFiles.Items[I]);
if not lIndex.Insert(newRecord, Buffer) then
error := ecInsert;
if lIndex.WriteError then
error := ecWriteIndex;
if error <> ecNone then
begin
// if there's an index write error, I shouldn't
// try to write the dbf header and the new record,
// but raise an exception right away
UnlockPage(newRecord);
RollBackIndexesAndRaise(I, ecWriteIndex);
end;
Inc(I);
end;
// indexes ok -> continue inserting
// update header record count
LockPage(0, true);
// read current header
ReadHeader;
// increase current record count
Inc(PDbfHdr(Header)^.RecordCount);
// write header to disk
WriteHeader;
// done with header
UnlockPage(0);
if WriteError then
begin
// couldn't write header, so I shouldn't
// even try to write the record.
//
// At this point I should "roll back"
// the already written index records.
// if this fails, I'm in deep trouble!
UnlockPage(newRecord);
RollbackIndexesAndRaise(FIndexFiles.Count, ecWriteDbf);
end;
// write locking info
if FLockField <> nil then
WriteLockInfo(Buffer);
// write buffer to disk
WriteRecord(newRecord, Buffer);
// done updating, unlock
UnlockPage(newRecord);
// error occurred while writing?
if WriteError then
begin
// The record couldn't be written, so
// the written index records and the
// change to the header have to be
// rolled back
LockPage(0, true);
ReadHeader;
Dec(PDbfHdr(Header)^.RecordCount);
WriteHeader;
UnlockPage(0);
// roll back indexes, too
RollbackIndexesAndRaise(FIndexFiles.Count, ecWriteDbf);
end else
Result := newRecord;
end;
procedure TDbfFile.WriteLockInfo(Buffer: TRecordBuffer);
//
// *) assumes FHasLockField = true
//
var
year, month, day, hour, minute, sec, msec: Word;
lockoffset: integer;
begin
// increase change count
lockoffset := FLockField.Offset;
Inc(PWord(Buffer+lockoffset)^);
// set time
DecodeDate(Now(), year, month, day);
DecodeTime(Now(), hour, minute, sec, msec);
Buffer[lockoffset+2] := TRecordBufferBaseType(hour);
Buffer[lockoffset+3] := TRecordBufferBaseType(minute);
Buffer[lockoffset+4] := TRecordBufferBaseType(sec);
// set date
Buffer[lockoffset+5] := TRecordBufferBaseType(year - 1900);
Buffer[lockoffset+6] := TRecordBufferBaseType(month);
Buffer[lockoffset+7] := TRecordBufferBaseType(day);
// set name
FillChar(Buffer[lockoffset+8], FLockField.Size-8, ' ');
Move(DbfGlobals.UserName[1], Buffer[lockoffset+8], FLockUserLen);
end;
procedure TDbfFile.LockRecord(RecNo: Integer; Buffer: TRecordBuffer);
begin
if LockPage(RecNo, false) then
begin
// reread data
ReadRecord(RecNo, Buffer);
// store previous data for updating indexes
Move(Buffer^, FPrevBuffer^, RecordSize);
// lock succeeded, update lock info, if field present
if FLockField <> nil then
begin
// update buffer
WriteLockInfo(Buffer);
// write to disk
WriteRecord(RecNo, Buffer);
end;
end else
raise EDbfError.Create(STRING_RECORD_LOCKED);
end;
procedure TDbfFile.UnlockRecord(RecNo: Integer; Buffer: TRecordBuffer);
var
I: Integer;
lIndex, lErrorIndex: TIndexFile;
begin
// update indexes, possible key violation
I := 0;
while I < FIndexFiles.Count do
begin
lIndex := TIndexFile(FIndexFiles.Items[I]);
if not lIndex.Update(RecNo, FPrevBuffer, Buffer) then
begin
// error -> rollback
lErrorIndex := lIndex;
while I > 0 do
begin
Dec(I);
lIndex := TIndexFile(FIndexFiles.Items[I]);
lIndex.Update(RecNo, Buffer, FPrevBuffer);
end;
lErrorIndex.InsertError;
end;
Inc(I);
end;
// write new record buffer, all keys ok
WriteRecord(RecNo, Buffer);
// done updating, unlock
UnlockPage(RecNo);
end;
procedure TDbfFile.RecordDeleted(RecNo: Integer; Buffer: TRecordBuffer);
var
I: Integer;
lIndex: TIndexFile;
begin
// notify indexes: record deleted
for I := 0 to FIndexFiles.Count - 1 do
begin
lIndex := TIndexFile(FIndexFiles.Items[I]);
lIndex.RecordDeleted(RecNo, Buffer);
end;
end;
procedure TDbfFile.RecordRecalled(RecNo: Integer; Buffer: TRecordBuffer);
var
I: Integer;
lIndex, lErrorIndex: TIndexFile;
begin
// notify indexes: record recalled
I := 0;
while I < FIndexFiles.Count do
begin
lIndex := TIndexFile(FIndexFiles.Items[I]);
if not lIndex.RecordRecalled(RecNo, Buffer) then
begin
lErrorIndex := lIndex;
while I > 0 do
begin
Dec(I);
lIndex.RecordDeleted(RecNo, Buffer);
end;
lErrorIndex.InsertError;
end;
Inc(I);
end;
end;
procedure TDbfFile.SetRecordSize(NewSize: Integer);
begin
if NewSize <> RecordSize then
begin
if FPrevBuffer <> nil then
FreeMemAndNil(Pointer(FPrevBuffer));
if NewSize > 0 then
GetMem(FPrevBuffer, NewSize);
end;
inherited;
end;
function TDbfFile.GetIndexByName(AIndexName: string): TIndexFile;
var
I: Integer;
begin
I := FIndexNames.IndexOf(AIndexName);
if I >= 0 then
Result := TIndexFile(FIndexNames.Objects[I])
else
Result := nil;
end;
//====================================================================
// TDbfCursor
//====================================================================
constructor TDbfCursor.Create(DbfFile: TDbfFile);
begin
inherited Create(DbfFile);
end;
function TDbfCursor.Next: Boolean;
begin
if TDbfFile(PagedFile).IsRecordPresent(FPhysicalRecNo) then
begin
inc(FPhysicalRecNo);
Result := TDbfFile(PagedFile).IsRecordPresent(FPhysicalRecNo);
end else begin
FPhysicalRecNo := TDbfFile(PagedFile).CachedRecordCount + 1;
Result := false;
end;
end;
function TDbfCursor.Prev: Boolean;
begin
if FPhysicalRecNo > 0 then
dec(FPhysicalRecNo)
else
FPhysicalRecNo := 0;
Result := FPhysicalRecNo > 0;
end;
procedure TDbfCursor.First;
begin
FPhysicalRecNo := 0;
end;
procedure TDbfCursor.Last;
var
max: Integer;
begin
max := TDbfFile(PagedFile).RecordCount;
if max = 0 then
FPhysicalRecNo := 0
else
FPhysicalRecNo := max + 1;
end;
function TDbfCursor.GetPhysicalRecNo: Integer;
begin
Result := FPhysicalRecNo;
end;
procedure TDbfCursor.SetPhysicalRecNo(RecNo: Integer);
begin
FPhysicalRecNo := RecNo;
end;
function TDbfCursor.GetSequentialRecordCount: Integer;
begin
Result := TDbfFile(PagedFile).RecordCount;
end;
function TDbfCursor.GetSequentialRecNo: Integer;
begin
Result := FPhysicalRecNo;
end;
procedure TDbfCursor.SetSequentialRecNo(RecNo: Integer);
begin
FPhysicalRecNo := RecNo;
end;
// codepage enumeration procedure
var
TempCodePageList: TList;
// LPTSTR = PChar ok?
function CodePagesProc(CodePageString: PChar): Cardinal; stdcall;
begin
// add codepage to list
TempCodePageList.Add(Pointer(GetIntFromStrLength(CodePageString, StrLen(CodePageString), -1)));
// continue enumeration
Result := 1;
end;
//====================================================================
// TDbfGlobals
//====================================================================
constructor TDbfGlobals.Create;
begin
FCodePages := TList.Create;
FDefaultOpenCodePage := GetACP;
// the following sets FDefaultCreateLangId
DefaultCreateCodePage := GetACP;
FCurrencyAsBCD := true;
// determine which code pages are installed
TempCodePageList := FCodePages;
EnumSystemCodePages(@CodePagesProc, {CP_SUPPORTED} CP_INSTALLED);
TempCodePageList := nil;
InitUserName;
end;
procedure TDbfGlobals.InitUserName;
{$ifdef FPC}
{$ifndef WINDOWS}
{$IFNDEF OS2}
var
TempName: UTSName;
{$ENDIF OS2}
{$endif}
{$endif}
begin
{$ifdef WINDOWS}
{$ifdef wince}
FUserName:='cedevice';
FUserNameLen:=Length(FUserName);
{$else}
FUserNameLen := MAX_COMPUTERNAME_LENGTH+1;
SetLength(FUserName, FUserNameLen);
Windows.GetComputerName(PChar(FUserName),
{$ifdef DELPHI_3}Windows.DWORD({$endif}
FUserNameLen
{$ifdef DELPHI_3}){$endif}
);
SetLength(FUserName, FUserNameLen);
{$endif wince}
{$else}
{$ifdef FPC}
{$IFDEF OS2}
FUserName := GetEnvironmentVariable ('HOSTNAME');
{$ELSE OS2}
FpUname(TempName);
FUserName := TempName.machine;
{$ENDIF OS2}
FUserNameLen := Length(FUserName);
{$endif}
{$endif}
end;
destructor TDbfGlobals.Destroy; {override;}
begin
FCodePages.Free;
end;
function TDbfGlobals.GetDefaultCreateCodePage: Integer;
begin
Result := LangId_To_CodePage[FDefaultCreateLangId];
end;
procedure TDbfGlobals.SetDefaultCreateCodePage(NewCodePage: Integer);
begin
FDefaultCreateLangId := ConstructLangId(NewCodePage, GetUserDefaultLCID, false);
end;
function TDbfGlobals.CodePageInstalled(ACodePage: Integer): Boolean;
begin
Result := FCodePages.IndexOf(Pointer(ACodePage)) >= 0;
end;
initialization
finalization
FreeAndNil(DbfGlobals);
(*
Not implemented yet (encrypted cdx is undocumented;
unencrypted cdx could be implemented)
TFoxCDXHeader = Record
PointerRootNode : Integer;
PointerFreeList : Integer;
Reserved_8_11 : Cardinal;
KeyLength : Word;
IndexOption : Byte;
IndexSignature : Byte;
Reserved_Null : TFoxReservedNull;
SortOrder : Word;
TotalExpressionLen : Word;
ForExpressionLen : Word;
Reserved_506_507 : Word;
KeyExpressionLen : Word;
KeyForExpression : TKeyForExpression;
End;
PFoxCDXHeader = ^TFoxCDXHeader;
TFoxCDXNodeCommon = Record
NodeAttributes : Word;
NumberOfKeys : Word;
PointerLeftNode : Integer;
PointerRightNode : Integer;
End;
TFoxCDXNodeNonLeaf = Record
NodeCommon : TFoxCDXNodeCommon;
TempBlock : Array [12..511] of Byte;
End;
PFoxCDXNodeNonLeaf = ^TFoxCDXNodeNonLeaf;
TFoxCDXNodeLeaf = Packed Record
NodeCommon : TFoxCDXNodeCommon;
BlockFreeSpace : Word;
RecordNumberMask : Integer;
DuplicateCountMask : Byte;
TrailByteCountMask : Byte;
RecNoBytes : Byte;
DuplicateCountBytes : Byte;
TrailByteCountBytes : Byte;
HoldingByteCount : Byte;
DataBlock : TDataBlock;
End;
PFoxCDXNodeLeaf = ^TFoxCDXNodeLeaf;
*)
end.