[Back to MISC SWAG index] [Back to Main SWAG index] [Original]

    {
    { 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 = $0D;
    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 <> $0D then
        begin
          S.Seek(HoldPos);
          FieldDef := New(PFieldDef, Load(S));
          Fields.Insert(FieldDef);
        end;
      until Terminator = $0D;
    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.

[Back to MISC SWAG index] [Back to Main SWAG index] [Original]