Contributor: BILL HIMMELSTOSS
{
{ If this code is used commercially, please send a few bucks to }
{ Bill Himmelstoss, PO BOX 23246, Jacksonville, FL 32241-3246, }
{ Otherwise, it's freely distributable. }
unit DBF;
interface
uses
Objects,
OString;
type
TYMDDate = record
Year,
Month,
Day: Byte;
end;
PDatabase = ^TDatabase;
TDatabase = object(TObject)
DatabaseType: Byte;
LastUpdate: TYMDDate;
NumRecords: Longint;
FirstRecordPos: Word;
RecordLength: Word;
S: TDosStream;
Pathname: TOString;
Modified: Boolean;
Fields: TCollection;
constructor Init(APathname: TOString);
constructor InitCreate(APathname: TOString; AFields: PCollection);
destructor Done; virtual;
procedure RefreshHeader;
procedure UpdateHeader;
function GetRecord(RecordNum: Longint): Pointer;
procedure PutRecord(RecordNum: Longint; Rec: Pointer);
procedure Append(Rec: Pointer);
procedure Zap;
procedure RefreshFields;
end;
PFieldDef = ^TFieldDef;
TFieldDef = object(TObject)
Name: TOString;
DataType: Char;
Displacement: Longint;
Length: Byte;
Decimal: Byte;
constructor Init(
AName: String;
ADataType: Char;
ALength,
ADecimal: Byte);
destructor Done; virtual;
constructor Load(var S: TStream);
procedure Store(var S: TStream);
end;
implementation
uses
WinDos;
constructor TDatabase.Init(APathname: TOString); begin
inherited Init;
Pathname.InitText(APathname);
S.Init(Pathname.CString, stOpen);
if S.Status stOk then Fail;
Fields.Init(5, 5);
RefreshHeader;
end;
constructor TDatabase.InitCreate(APathname: TOString; AFields: PCollection);
const
Terminator: Byte = 0ドルD;
var
Year, Month, Day, Dummy: Word;
procedure CopyField(Item: PFieldDef); far;
begin
Fields.Insert(Item);
end;
procedure WriteFieldSubrecord(Item: PFieldDef); far;
begin
Item^.Store(S);
Inc(RecordLength, Item^.Length);
end;
begin
inherited Init;
DatabaseType := 03ドル;
GetDate(Year, Month, Day, Dummy);
LastUpdate.Year := Year - 1900;
LastUpdate.Month := Month;
LastUpdate.Day := Day;
NumRecords := 0;
RecordLength := 0;
Pathname.InitText(APathname);
S.Init(Pathname.CString, stCreate);
if S.Status stOk then Fail;
UpdateHeader;
S.Seek(32); { beginning of field subrecords }
Fields.Init(AFields^.Count, 5);
AFields^.ForEach(@CopyField);
Fields.ForEach(@WriteFieldSubrecord);
S.Write(Terminator, SizeOf(Terminator));
Modified := true;
FirstRecordPos := S.GetPos;
UpdateHeader;
end;
destructor TDatabase.Done;
begin
if Modified then UpdateHeader;
Pathname.Done;
S.Done;
Fields.Done;
inherited Done;
end;
procedure TDatabase.RefreshHeader;
var
OldPos: Longint;
begin
OldPos := S.GetPos;
S.Seek(0);
S.Read(DatabaseType, SizeOf(DatabaseType));
S.Read(LastUpdate, SizeOf(LastUpdate));
S.Read(NumRecords, SizeOf(NumRecords));
S.Read(FirstRecordPos, SizeOf(FirstRecordPos));
S.Read(RecordLength, SizeOf(RecordLength));
S.Seek(OldPos);
RefreshFields;
end;
procedure TDatabase.UpdateHeader;
var
OldPos: Longint;
Reserved: array[12..31] of Char;
begin
OldPos := S.GetPos;
S.Seek(0);
S.Write(DatabaseType, SizeOf(DatabaseType));
S.Write(LastUpdate, SizeOf(LastUpdate));
S.Write(NumRecords, SizeOf(NumRecords));
S.Write(FirstRecordPos, SizeOf(FirstRecordPos));
S.Write(RecordLength, SizeOf(RecordLength));
FillChar(Reserved, SizeOf(Reserved), #0);
S.Write(Reserved, SizeOf(Reserved));
S.Seek(OldPos);
end;
function TDatabase.GetRecord(RecordNum: Longint): Pointer; var
Temp: Pointer;
Pos: Longint;
begin
Temp := NIL;
GetMem(Temp, RecordLength);
if Temp NIL then
begin
Pos := FirstRecordPos + ((RecordNum - 1) * RecordLength);
if S.GetPos Pos then
S.Seek(Pos);
S.Read(Temp^, RecordLength);
end;
GetRecord := Temp;
end;
procedure TDatabase.Append(Rec: Pointer); begin
if Assigned(Rec) then
begin
Modified := true;
Inc(NumRecords);
PutRecord(NumRecords, Rec);
end;
end;
procedure TDatabase.PutRecord(RecordNum: Longint; Rec: Pointer); var
Pos: Longint;
begin
if Assigned(Rec) and (RecordNum <= NumRecords) then begin Pos := FirstRecordPos + ((RecordNum - 1) * RecordLength); if S.GetPos Pos then
S.Seek(Pos);
S.Write(Rec^, RecordLength);
end;
end;
procedure TDatabase.Zap;
var
T: TDosStream;
Temp, D, N, E: TOString;
F: File;
begin
D.Init(fsDirectory);
N.Init(fsFilename);
E.Init(fsExtension);
FileSplit(Pathname.CString, D.CString, N.CString, E.CString);
D.RecalcLength;
N.RecalcLength;
E.RecalcLength;
Temp.InitText(D);
Temp.Append(N);
Temp.AppendP('.TMP');
D.Done;
N.Done;
E.Done;
T.Init(Temp.CString, stCreate);
S.Seek(0);
T.CopyFrom(S, FirstRecordPos - 1);
T.Done;
S.Done;
Assign(F, Pathname.CString);
Erase(F);
Assign(F, Temp.CString);
Rename(F, Pathname.CString);
S.Init(Pathname.CString, stOpen);
NumRecords := 0;
Modified := false;
UpdateHeader;
end;
procedure TDatabase.RefreshFields;
var
Terminator: Byte;
HoldPos: Longint;
FieldDef: PFieldDef;
begin
S.Seek(32); { beginning of Field subrecords }
repeat
HoldPos := S.GetPos;
S.Read(Terminator, SizeOf(Terminator));
if Terminator 0ドルD then
begin
S.Seek(HoldPos);
FieldDef := New(PFieldDef, Load(S));
Fields.Insert(FieldDef);
end;
until Terminator = 0ドルD;
end;
constructor TFieldDef.Init(
AName: String;
ADataType: Char;
ALength,
ADecimal: Byte);
begin
inherited Init;
Name.InitTextP(AName);
DataType := ADataType;
Length := ALength;
Decimal := ADecimal;
Displacement := 0;
end;
destructor TFieldDef.Done;
begin
Name.Done;
inherited Done;
end;
constructor TFieldDef.Load(var S: TStream); var
AName: array[1..11] of Char;
Reserved: array[18..31] of Char;
begin
S.Read(AName, SizeOf(AName));
Name.Init(SizeOf(AName));
Name.SetText_(@AName[1], 11);
S.Read(DataType, SizeOf(DataType));
S.Read(Displacement, Sizeof(Displacement));
S.Read(Length, SizeOf(Length));
S.Read(Decimal, SizeOf(Decimal));
S.Read(Reserved, SizeOf(Reserved));
end;
procedure TFieldDef.Store(var S: TStream); var
Reserved: array[18..31] of Char;
begin
S.Write(Name.CString^, 11);
S.Write(DataType, SizeOf(DataType));
S.Write(Displacement, Sizeof(Displacement));
S.Write(Length, SizeOf(Length));
S.Write(Decimal, SizeOf(Decimal));
FillChar(Reserved, SizeOf(Reserved), #0);
S.Write(Reserved, SizeOf(Reserved));
end;
end.
program DbfTest;
uses
dbf, wincrt, ostring, objects, strings;
type
PDbfTest = ^TDbfTest;
TDbfTest = record
Deleted: Char; { ' '=no, '*'=yes }
AcctNo: array[1..16] of Char;
Chunk: array[1..8] of Char;
Baskard: array[1..5] of Char;
Extra: array[1..8] of Char;
Sandwich: array[1..25] of Char;
end;
var
rec: PDbfTest;
database: tdatabase;
pathname: tostring;
temp: string;
fields: tcollection;
procedure DoShow;
procedure show(item: pfielddef); far;
begin
writeln(
item^.name.cstring:15, ' ',
item^.datatype, ' ',
item^.length:10, ' ',
item^.decimal:10, ' ');
end;
begin
database.fields.foreach(@show);
end;
begin
InitWinCrt;
fields.init(5, 0);
fields.insert(new(pfielddef, init('ACCTNO', 'C', 16, 0)));
fields.insert(new(pfielddef, init('CHUNK', 'N', 8, 2)));
fields.insert(new(pfielddef, init('BASKARD', 'C', 5, 0)));
fields.insert(new(pfielddef, init('EXTRA', 'D', 8, 0)));
fields.insert(new(pfielddef, init('SANDWICH', 'C', 25, 0)));
pathname.inittextp('c:\dbftest.dbf');
database.initcreate(pathname, @fields);
pathname.done;
DoShow;
New(Rec);
with Rec^ do
begin
Acctno := '1313558000001005'; { <-will self-check, but not valid }
Chunk := ' 10.00';
Baskard := 'ABCDE';
Extra := '19931125';
Sandwich := 'Turkey Leftovers ';
end;
database.append(rec);
dispose(rec);
rec := database.getrecord(1);
writeln(rec^.acctno, ' ', rec^.Sandwich);
dispose(rec);
database.done;
end.