{$R-}    {Range checking off}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N-}    {No numeric coprocessor}

Unit DBF;

{ Versie 1.1 }

Interface

Uses
  Crt, {Unit found in TURBO.TPL}
  Dos; {Unit found in TURBO.TPL}

CONST
  DB3File = 3;
  DB3WithMemo = $83;
  ValidTypes : SET OF Char = ['C', 'N', 'L', 'M', 'D'];
  MAX_HEADER = 4129;          { = maximum length of dBASE III header }
  MAX_BYTES_IN_RECORD = 4000; { dBASE III record limit }
  MAX_FIELDS_IN_RECORD = 128; { dBASE III field limit  }
  BYTES_IN_MEMO_RECORD = 512; { dBASE III memo field record size }

TYPE
  HeaderType = ARRAY[0..MAX_HEADER] OF Byte;
  HeaderPrologType = ARRAY[0..31] OF Byte; { dBASE III header prolog }
  FieldDescType = ARRAY[0..31] OF Byte; { dBASE III field definitions
}
  DbfRecord = ARRAY[0..MAX_BYTES_IN_RECORD] OF Byte; {the 0 offset
represents
                                                     the 'deleted'
flag.   }
  Str255 = STRING[255];
  Str80 = STRING[80];
  Str64 = STRING[64];
  Str10 = STRING[10];
  Str8 = STRING[8];
  Str2 = STRING[2];
  DbfFileType = FILE;
  FieldRecord = RECORD
                  Name : Str10;
                  Typ : Char;
                  Len : Byte;
                  Dec : Byte;
                  Off : Integer;
                END;
  FieldArray = ARRAY[1..MAX_FIELDS_IN_RECORD] OF FieldRecord;
  MemoRecord = ARRAY[1..BYTES_IN_MEMO_RECORD] OF Byte;
  MemoFileType = FILE OF MemoRecord;
  DbfInfoType = RECORD
                  FileName     : Str64;
                  dFile        : DbfFileType;
                  HeadProlog   : HeaderPrologType;
                  Updated      : Boolean;
                  WithMemo     : Boolean;
                  DateOfUpdate : Str8;
                  NumRecs      : LongInt;
                  HeadLen      : Integer;
                  RecLen       : Integer;
                  NumFields    : Integer;
                  Fields       : FieldArray;
                  CurRecord    : DbfRecord;
                END;

  
PROCEDURE ErrorHalt(Msg : Str80);
  
PROCEDURE Wait;

FUNCTION CloseDbf(VAR D : DbfInfoType) : Integer;

FUNCTION OpenDbf(VAR D : DbfInfoType) : Integer;

PROCEDURE GetDbfRecord(VAR D : DbfInfoType; RecNum : LongInt);

PROCEDURE PutDbfRecord(VAR D : DbfInfoType; RecNum : LongInt);

PROCEDURE AppendDBF(VAR D : DbfInfotype);

PROCEDURE CreateDbf(VAR D : dbfInfotype; fn : Str64; n : Integer;
                      flds : Fieldarray);

{===========================================================================}

Implementation


PROCEDURE ErrorHalt(Msg : Str80);

BEGIN
  WriteLn;
  WriteLn(Msg);
  Halt;
END;
  
FUNCTION Makelongint(VAR b) : Longint;
  
VAR
    r : ARRAY[1..4] OF Byte ABSOLUTE b;

  BEGIN
  MakeLongInt := (r[1]*1)+(r[2]*256)+(r[3]*65536)+(r[4]*16777216);
  END;

 
FUNCTION MakeInt(VAR b) : Integer;
  
VAR
    i : Integer ABSOLUTE b;

  BEGIN
  MakeInt := i;
  END;

  
FUNCTION MakeStr(b : Byte) : Str2;
  
VAR
    i : Integer;
    s : Str2;
  BEGIN
  i := b;
  Str(i:2, s);
  MakeStr := s;
  END;

  
PROCEDURE Wait;
  
VAR
    c : Char;

  BEGIN
  Write('Press any key to continue . . .');
  c := Readkey;
  END;


  
PROCEDURE UpdateHeader(VAR D : DbfInfoType);

VAR
    Reg :Registers;
    r : Real;

BEGIN
  WITH D DO
  BEGIN
    Reg.AX := $2A00;  { Get DOS Date }
    Intr ($21,Reg);
    HeadProlog[1] := Reg.CX - 1900; {Year}
    HeadProlog[2] := Reg.DH;        {Month}
    HeadProlog[3] := Reg.DL;        {Day}
    r := NumRecs;
    HeadProlog[7] := Trunc(r / 16777216.0);
    r := r - (HeadProlog[7] * 16777216.0);
    HeadProlog[6] := Trunc(r / 65536.0);
    r := r - (HeadProlog[6] * 65536.0);
    HeadProlog[5] := Trunc(r / 256);
    r := r - (HeadProlog[5] * 256);
    HeadProlog[4] := Trunc(r);
    Seek(dFile,0);
    {$I-} BlockWrite(dFile,HeadProlog,SizeOf(HeadProlog)); {$I+}
    IF IOResult <> 0 THEN ErrorHalt('Error Closing file.');
  END; {WITH}
END; {UpdateHeader}


  
FUNCTION CloseDbf(VAR D : DbfInfoType) : Integer;
  
VAR
    b : Byte;

BEGIN
  WITH D DO
  BEGIN
    IF Updated THEN
    BEGIN
      UpdateHeader(D);
      b := $1A;
      Seek(dFile,HeadLen+NumRecs*RecLen);
      BlockWrite(dFile,b,1); {Put EOF marker }
    END;
    {$I-} Close(dFile);             {$I+}
    CloseDbf := IOResult;
    END; {WITH}
END; {CloseDbf}

  
PROCEDURE ProcessHeader(VAR Header : HeaderType; VAR D : DbfInfoType);


  PROCEDURE GetOneFieldDesc(VAR F; VAR Field : FieldRecord; VAR Offset
: Integer);

    VAR
      i : Integer;
      FD : FieldDescType ABSOLUTE F;

  BEGIN
    WITH Field DO
    BEGIN
      i := 0;
      Name := '          ';
      REPEAT
        Name[Succ(i)] := Chr(FD[i]);
        i := Succ(i);
      UNTIL FD[i] = 0;
      Name[0] := Chr(i);
      Typ := Char(FD[11]);
      Len := FD[16];
      Dec := FD[17];
      Off := Offset;
      Offset := Offset+Len;
      IF NOT(Typ IN ValidTypes) THEN ErrorHalt('Invalid Type in Field
'+Name);
      END;   {WITH}
    END;   {GetOneFieldDesc}


  VAR
    o, i : Integer;

  BEGIN       {ProcessHeader}
  WITH D DO
    BEGIN
    CASE Header[0] OF
      DB3File : WithMemo := False;
      DB3WithMemo : WithMemo := True;
    ELSE
      ErrorHalt('Not a valid dBASE III File.');
    END;      {CASE}
    DateOfUpdate := MakeStr(Header[2])+'/'+MakeStr(Header[3])+'/'
    +MakeStr(Header[1]);
    NumRecs := MakeLongInt(Header[4]);
    HeadLen := MakeInt(Header[8]);
    RecLen := MakeInt(Header[10]); { Includes the Deleted Record Flag
}
    Updated := FALSE;
    NumFields := 0;
    FOR i := 0 TO SizeOf(HeadProlog) DO HeadProlog[i] := Header[i];
    o := 1;                   {Offset within dbf record of current
field }
    i := 32;                  {Index for Header }
    WHILE Header[i] <> $0D DO
      BEGIN
         NumFields := Succ(NumFields);
         GetOneFieldDesc(Header[i], Fields[NumFields], o);
         i := i+32;
      END;   {While}
    IF Header[Succ(HeadLen)] = 0 THEN HeadLen := Succ(HeadLen);
    END;  {With}
  END;  {ProcessHeader}

  
PROCEDURE GetHeader(VAR D : DbfInfoType);

VAR
    Result : Integer;
    H      : HeaderType;

BEGIN
  WITH D DO
  BEGIN
    {$I-} BlockRead(dFile, H, MAX_HEADER, Result); {$I+}
    IF IOResult <> 0 THEN ErrorHalt('Error reading header.');
    ProcessHeader(H, D);
    END; {WITH}
END;  {GetHeader}

  
FUNCTION OpenDbf(VAR D : DbfInfoType) : Integer;

BEGIN
  WITH D DO
  BEGIN
    Assign(dFile, FileName);
    {$I-} Reset(dFile, 1); {$I+}    {the '1' parameter sets the record
size}
    IF IOResult <> 0 THEN ErrorHalt('Error opening data file.');
    GetHeader(D);
    OpenDbf := IOResult;
  END; {WITH}
END;


PROCEDURE GetDbfRecord(VAR D : DbfInfoType; RecNum : LongInt);

VAR
    Result : Integer;

BEGIN
  WITH D DO
  BEGIN
    IF RecNum > NumRecs THEN ErrorHalt('Tried to read past EOF.');
    Seek(dFile, HeadLen+(RecNum-1)*RecLen);
    BlockRead(dFile, CurRecord, RecLen, Result);
    IF Result <> RecLen THEN ErrorHalt('Error reading DBF File');
  END;   { WITH }
END;  {GetDbfRecord}

  
PROCEDURE PutDbfRecord(VAR D : DbfInfoType; RecNum : LongInt);

VAR
    Result : Integer;

BEGIN
  WITH D DO
  BEGIN
    IF RecNum > NumRecs THEN
      BEGIN
        RecNum := NumRecs + 1;
        NumRecs := RecNum;
      END;
    Seek(dFile, HeadLen+(RecNum-1)*RecLen);
    {$I-} BlockWrite(dFile, CurRecord, RecLen, Result); {$I+}
    IF IOResult <> 0 THEN ErrorHalt('Error writing to DBF File');
    Updated := TRUE;
  END;   { WITH }
END;     {GetDbfRecord}


PROCEDURE AppendDBF(Var D : DbfInfoType);

begin
  PutDbfRecord(D, D.NumRecs+1);
end;


PROCEDURE CreateDbf(VAR D : dbfInfotype; fn : Str64; n : Integer;
                      flds : Fieldarray);
    {
    Call this procedure with the full pathname of the file that you
want
    to create (fn), the number of fields in a record (n), and a
pointer
    to an array of _FieldRecord (flds).  The procedure will initialize
all
    the data structures in the dbfRecord (D).
    }

  
VAR
    tHeader : HeaderType;
    dbferror : integer;

    PROCEDURE MakeFieldDescs;

      PROCEDURE MakeOneFieldDesc(VAR F; VAR Field : FieldRecord);

      VAR
        FD : FieldDescType ABSOLUTE F;

      BEGIN                   { MakeOneFieldDesc }
      Move(Field.Name[1],FD,Ord(Field.Name[0]));
      FD[11] := Ord(Field.Typ);
      FD[16] := Field.Len;
      IF Field.Typ <> 'N' THEN Field.Dec := 0;
      FD[17] := Field.Dec;
      Field.Off := D.RecLen;
      D.RecLen := D.RecLen+Field.Len;
      IF Field.Typ = 'M' THEN D.WithMemo := TRUE;
      END;                    { MakeOneFieldDesc }

    VAR
      i : Integer;

    BEGIN                     {MakeFieldDescs}
    D.RecLen := 1;
    FOR i := 1 TO D.NumFields DO
      BEGIN
      MakeOneFieldDesc(tHeader[i*32],flds[i]);
      END;
    END;                      {MakeFieldDescs}

    PROCEDURE MakeHeader;

    VAR
      Result : Integer;

    BEGIN                     { MakeHeader }
    FillChar(tHeader,SizeOf(tHeader),#0);
    D.WithMemo := FALSE;
    D.HeadLen := Succ(D.NumFields) * 32;
    tHeader[D.HeadLen] := $0D;
    D.HeadLen := succ(D.HeadLen);
    tHeader[8] := Lo(D.HeadLen);
    tHeader[9] := Hi(D.HeadLen);
    D.Headlen := D.Headlen - 1;
    MakeFieldDescs;
    IF D.WithMemo THEN
      tHeader[0] := DB3WithMemo
    ELSE
      tHeader[0] := DB3File;
    tHeader[10] := Lo(D.RecLen);
    tHeader[11] := Hi(D.RecLen);
    END;                      { MakeHeader }

  VAR
    i,j : Integer;

  BEGIN            { CreateDbf }
  D.NumFields := n;
  MakeHeader;
  D.FileName := fn;
  Assign(D.dFile, D.FileName);
  {$I-} Rewrite(D.dFile, 1); {$I+} {Will overwrite if file exists!}
  IF IOResult = 0 THEN
    BEGIN
    {$I-} BlockWrite(D.dFile,tHeader,Succ(D.HeadLen));{$I+}
    END;
  Close(D.dFile);
  END;                        { CreateDbf }



End. {implementation}

