Power-Programmierung/CD1.mdf/pascal/library/dos/database/dbf/dbf.pas

Pascal/Delphi Source File | 1986-05-31 | 21.2 KB | 637 lines

  (*
  Turbo Pascal routines to access dBASE III [+] files
  By J. Troutman <JT> CompuServe PPN 74746,1567
  Revision history
   Version 1.1  - enhancements to cause the header to be updated
                  when changing the .DBF file and to ensure that the
                  End Of File marker is written and to simplify use
                  5/6/86
           1.2  - cleans up (some of) the absurdities in the code and
                  allocates the current record buffer on the heap rather than
                  in the data segment.  A few comments added and a few symbol
                  names changed. Error checking has been improved with the
                  addition of two global status variables.
                  5/27/86

                    !!!!ATTENTION!!!!
  If you have downloaded an earlier version of this file, please note that
  several of the TYPEs and VARs have been changed.  You will have to make
  some adjustments to any existing programs you have that use these routines.
  Why have they been changed?  Several have been changed to decrease the
  data segment storage demands of the code (declaring some variables as
  pointers, for example); others in order to avoid conflicts with any
  Types and Variables your program might define.

  The routines in this file present some tools for accessing dBASE III and
  dBASE III Plus files from within a Turbo Pascal program.  There is MUCH
  room for improvement: the error checking is simplistic, there are no routines
  to access memo files, no buffering of data, no support for index files,
  etc. The main routines are:

         PROCEDURE OpenDbf(VAR D : dbfRecord;) : Integer;
         PROCEDURE CloseDbf(VAR D : dbfRecord) : Integer;
         PROCEDURE GetDbfRecord(VAR D : dbfRecord; RecNum : Real);
         PROCEDURE PutDbfRecord(VAR D : dbfRecord; RecNum : Real);
         PROCEDURE AppendDbf(VAR D : dbfRecord);

  The error checking has been improved somewhat in this version with the
  addition of two global variables: dbfOK and dbfError. After calling one of
  the procedures, checking the status of the Boolean variable dbfOK will
  reveal the success or failure of the operation.  If it failed, the Integer
  variable dbfError will contain a value corresponding to the IOResult value or
  to a specially assigned value for several special conditions.  Notice in
  particular that an unsuccessful call to CloseDbf will leave the file status
  unchanged and the memory still allocated.  It is your program's
  responsibility to take appropriate action.  OpenDbf and CloseDbf have
  now become procedures.

  A skeletal program might go something like:
    VAR
      D : dbfRecord; { declare your dBASE file variable }
    BEGIN
    {...initialize and get filename of .dbf file into FileName field
       of D variable ...  }
    OpenDbf(D);        { to open the file }
    IF NOT dbfOK THEN { check dbfError and process error };
    {... the rest of your program including calls to
     GetDbfRecord, PutDbfRecord, AppendDbf as needed
     always remembering to interrogate the two global status
     variables after each procedure call   }
    CloseDbf (D);      { to close the file  }
    IF NOT dbfOK THEN { check dbfError and process error };
    END.

  Upon exit from the GetDbfRecord Procedure, the CurRecord of the
  dbfRecord variable points to the current record contents.  Each field
  can be accessed using its offset into the CurRecord^ with the variable
  Off in the Fields^ array.
  Upon entry to the PutDbfRecord Procedure, the CurRecord^ should contain
  the data that you want to write.
  AppendDbf automatically adds a record to the end of the file (the
  CurRecord^ should contain the data that you want to write).

  Notice that the OpenDbf routine does allocate a buffer on the heap for
  the current record.  You can, of course, override this by pointing
  CurRecord to any data structure that you wish.

  See the demo program for some examples.
  If you should have any problems with these routines, please leave me a
  note.
  *)

(*
dBASE III Database File Structure
The structure of a dBASE III database file is composed of a
header and data records.  The layout is given below.
dBASE III DATABASE FILE HEADER:
+---------+-------------------+---------------------------------+
|  BYTE   |     CONTENTS      |          MEANING                |
+---------+-------------------+---------------------------------+
|  0      |  1 byte           | dBASE III version number        |
|         |                   |  (03H without a .DBT file)      |
|         |                   |  (83H with a .DBT file)         |
+---------+-------------------+---------------------------------+
|  1-3    |  3 bytes          | date of last update             |
|         |                   |  (YY MM DD) in binary format    |
+---------+-------------------+---------------------------------+
|  4-7    |  32 bit number    | number of records in data file  |
+---------+-------------------+---------------------------------+
|  8-9    |  16 bit number    | length of header structure      |
+---------+-------------------+---------------------------------+
|  10-11  |  16 bit number    | length of the record            |
+---------+-------------------+---------------------------------+
|  12-31  |  20 bytes         | reserved bytes (version 1.00)   |
+---------+-------------------+---------------------------------+
|  32-n   |  32 bytes each    | field descriptor array          |
|         |                   |  (see below)                    | --+
+---------+-------------------+---------------------------------+   |
|  n+1    |  1 byte           | 0DH as the field terminator     |   |
+---------+-------------------+---------------------------------+   |
|
|
A FIELD DESCRIPTOR:      <------------------------------------------+
+---------+-------------------+---------------------------------+
|  BYTE   |     CONTENTS      |          MEANING                |
+---------+-------------------+---------------------------------+
|  0-10   |  11 bytes         | field name in ASCII zero-filled |
+---------+-------------------+---------------------------------+
|  11     |  1 byte           | field type in ASCII             |
|         |                   |  (C N L D or M)                 |
+---------+-------------------+---------------------------------+
|  12-15  |  32 bit number    | field data address              |
|         |                   |  (address is set in memory)     |
+---------+-------------------+---------------------------------+
|  16     |  1 byte           | field length in binary          |
+---------+-------------------+---------------------------------+
|  17     |  1 byte           | field decimal count in binary   |
+---------+-------------------+--------------------------------
|  18-31  |  14 bytes         | reserved bytes (version 1.00)   |
+---------+-------------------+---------------------------------+
The data records are layed out as follows:
1. Data records are preceeded by one byte that is a
space (20H) if the record is not deleted and an
asterisk (2AH) if it is deleted.
2. Data fields are packed into records with no field
separators or record terminators.
3. Data types are stored in ASCII format as follows:
DATA TYPE      DATA RECORD STORAGE
---------      --------------------------------------------
Character      (ASCII characters)
Numeric        - . 0 1 2 3 4 5 6 7 8 9
Logical        ? Y y N n T t F f  (? when not initialized)
Memo           (10 digits representing a .DBT block number)
Date           (8 digits in YYYYMMDD format, such as
19840704 for July 4, 1984)

This information came directly from the Ashton-Tate Forum.
It can also be found in the Advanced Programmer's Guide available
from Ashton-Tate.
*)

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 }

  { Special Error codes for .DBF files }
  NOT_DB_FILE = $80;  { indicates the first byte was not a $3 or $83 }
  INVALID_FIELD = $81;{ an invalid field type was found }
  REC_TOO_HIGH = $82; { tried to read a record beyond the correct range }

  (*
  Although there are some declarations for memo files, the routines to access
  them have not been implemented.
  *)

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 }
  _dRec = ^_DataRecord;
  _DataRecord = 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];
  _dbfFile = FILE;
  _FieldRecord = RECORD
                  Name : _Str10;
                  Typ : Char;
                  Len : Byte;
                  Dec : Byte;
                  Off : Integer;
                END;
  _FieldArray = ARRAY[1..MAX_FIELDS_IN_RECORD] OF _FieldRecord;
  _dFields = ^_FieldArray;
  _MemoRecord = ARRAY[1..BYTES_IN_MEMO_RECORD] OF Byte;
  _MemoFile = FILE OF _MemoRecord;
  _StatusType = (NotOpen, NotUpdated, Updated);
  dbfRecord = RECORD
                FileName : _Str64;
                dFile : _dbfFile;
                HeadProlog : _HeaderPrologType;
                dStatus : _StatusType;
                WithMemo : Boolean;
                DateOfUpdate : _Str8;
                NumRecs : Real;
                HeadLen : Integer;
                RecLen : Integer;
                NumFields : Integer;
                Fields : _dFields;
                CurRecord : _dRec;
              END;

  (*
  Notice that if you need to access more than one .DBF file simultaneously
  you could declare an ARRAY of dbfRecord.
  *)
  VAR
    dbfError : Integer; { global error indicators }
    dbfOK  : Boolean;

  FUNCTION MakeReal(VAR b) : Real;
    { takes a long 32-bit integer and converts it to a real }

  VAR
    r : ARRAY[1..4] OF Byte ABSOLUTE b;

  BEGIN
  MakeReal := (r[1]*1)+(r[2]*256)+(r[3]*65536.0)+(r[4]*16777216.0);
  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 GetDbfRecord(VAR D : dbfRecord; RecNum : Real);

  VAR
    Result : Integer;

  BEGIN
  IF RecNum > D.NumRecs THEN
    BEGIN
    dbfError := REC_TOO_HIGH;
    dbfOK := FALSE;
    Exit;
    END;
  {$I-} LongSeek(D.dFile, D.HeadLen+(RecNum-1)*D.RecLen); {$I+}
  dbfError := IOResult;
  dbfOK := (dbfError = 0);
  IF dbfOK THEN
    BEGIN
    {$I-} BlockRead(D.dFile, D.CurRecord^, D.RecLen, Result); {$I+}
    dbfError := IOResult;
    dbfOK := (dbfError = 0);
    END;
  END;                        {GetDbfRecord}

  PROCEDURE PutDbfRecord(VAR D : dbfRecord; RecNum : Real);

  VAR
    Result : Integer;

  BEGIN
  IF RecNum > D.NumRecs THEN
    BEGIN
    RecNum := D.NumRecs+1;
    D.NumRecs := RecNum;
    END;
  {$I-} LongSeek(D.dFile, D.HeadLen+(RecNum-1)*D.RecLen); {$I+}
  dbfError := IOResult;
  dbfOK := (dbfError = 0);
  IF dbfOK THEN
    BEGIN
    {$I-} BlockWrite(D.dFile, D.CurRecord^, D.RecLen, Result); {$I+}
    dbfError := IOResult;
    dbfOK := (dbfError = 0);
    END;
  IF dbfOK THEN D.dStatus := Updated;
  END;                        {PutDbfRecord}

  PROCEDURE AppendDbf(VAR D : dbfRecord);

  BEGIN
  PutDbfRecord(D, D.NumRecs+1);
  END;

  PROCEDURE CloseDbf(VAR D : dbfRecord);

    PROCEDURE UpdateHeader;

    TYPE
      RegType = RECORD CASE Byte OF
        1 : (AX, BX, CX, DX, BP, SI, DI, DS, ES, Flags : Integer);
        2 : (AL, AH, BL, BH, CL, CH, DL, DH : Byte);
                END;

    VAR
      Reg : RegType;
      r : Real;

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

  CONST
    EofMark : Byte = $1A;

  BEGIN                       { CloseDbf }
  dbfOK := TRUE;
  IF D.dStatus = Updated THEN
    BEGIN
    UpdateHeader;
    IF dbfOK THEN
      BEGIN
      {$I-} LongSeek(D.dFile, D.HeadLen+D.NumRecs*D.RecLen); {$I+}
      dbfError := IOResult;
      dbfOK := (dbfError = 0);
      END;
    IF dbfOK THEN
      BEGIN
      {$I-} BlockWrite(D.dFile, EofMark, 1); {$I+} {Put EOF marker }
      dbfError := IOResult;
      dbfOK := (dbfError = 0);
      END;
    END;   { IF Updated }
  IF dbfOK THEN
    BEGIN
    {$I-} Close(D.dFile);     {$I+}
    dbfError := IOResult;
    dbfOK := (dbfError = 0);
    END;
  IF dbfOK THEN
    BEGIN
      D.dStatus := NotOpen;
      FreeMem(D.CurRecord, D.RecLen);
      FreeMem(D.Fields, D.NumFields*SizeOf(_FieldRecord));
    END;
  END;                        { CloseDbf }

  PROCEDURE OpenDbf(VAR D : dbfRecord);

    PROCEDURE ProcessHeader(VAR Header : _HeaderType; NumBytes : Integer);

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

      VAR
        i : Integer;
        FD : _FieldDescType ABSOLUTE F;

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

    VAR
      o, i, tFieldsLen : Integer;
      tempFields : _FieldArray;

    BEGIN                     {ProcessHeader}
    CASE Header[0] OF
      DB3File : D.WithMemo := False;
      DB3WithMemo : D.WithMemo := True;
      ELSE
        BEGIN
        dbfError := NOT_DB_FILE;
        Close(D.dFile);
        Exit;
        END;
      END;                      {CASE}
    D.DateOfUpdate := MakeStr(Header[2])+'/'+MakeStr(Header[3])+'/'+MakeStr(Header[1]);
    D.NumRecs := MakeReal(Header[4]);
    D.HeadLen := MakeInt(Header[8]);
    IF NumBytes < D.HeadLen THEN
      BEGIN
      dbfError := NOT_DB_FILE;
      Close(D.dFile);
      Exit;
      END;
    D.RecLen := MakeInt(Header[10]); { Includes the Deleted Record Flag }
    GetMem(D.CurRecord, D.RecLen); { Allocate some memory for a buffer  }
    D.dStatus := NotUpdated;
    D.NumFields := 0;
    Move(Header, D.HeadProlog, SizeOf(D.HeadProlog));
    o := 1;                   {Offset within dbf record of current field }
    i := 32;                  {Index for Header }
    WHILE Header[i] <> $0D DO
      BEGIN
      D.NumFields := Succ(D.NumFields);
      GetOneFieldDesc(Header[i], tempFields[D.NumFields], o);
      IF dbfError <> 0 THEN
        BEGIN
        Close(D.dFile);
        Exit;
        END;
      i := i+32;
      END;                    { While Header[i] <> $0D }
    tFieldsLen := D.NumFields*SizeOf(_FieldRecord);
    GetMem(D.Fields, tFieldsLen);
    Move(tempFields, D.Fields^, tFieldsLen);
    IF Header[Succ(D.HeadLen)] = 0 THEN D.HeadLen := Succ(D.HeadLen);
    END;                      {ProcessHeader}

    PROCEDURE GetHeader;

    VAR
      Result : Integer;
      H : _HeaderType;

    BEGIN                     { GetHeader }
    {$I-} BlockRead(D.dFile, H, MAX_HEADER, Result); {$I+}
    dbfError := IOResult;
    IF dbfError = 0 THEN ProcessHeader(H, Result);
    END;                      { GetHeader }

  BEGIN                       { OpenDbf }
  Assign(D.dFile, D.FileName);
  {$I-} Reset(D.dFile, 1); {$I+} {the '1' parameter sets the record size}
  dbfError := IOResult;
  IF dbfError = 0 THEN GetHeader;
  dbfOK := (dbfError = 0);
  END;                        { OpenDbf }

(* !!!!!!!!! To enable the Demo program, delete the next line.  !!!!!!!!! *)
(*

  PROCEDURE ErrorHalt(errorCode : Integer);
    { a VERY crude error handler }
  VAR
    errorMsg : _Str80;

  BEGIN
  CASE errorCode OF
     00 : Exit;                { no error occurred }
    $01 : errorMsg := 'Not found';
    $02 : errorMsg := 'Not open for input';
    $03 : errorMsg := 'Not open for output';
    $04 : errorMsg := 'Just not open';
    $91 : errorMsg := 'Seek beyond EOF';
    $99 : errorMsg := 'Unexpected EOF';
    $F0 : errorMsg := 'Disk write error';
    $F1 : errorMsg := 'Directory full';
    $F3 : errorMsg := 'Too many files';
    $FF : errorMsg := 'Where did that file go?';
    NOT_DB_FILE : errorMsg := 'Not a dBASE data file';
    INVALID_FIELD : errorMsg := 'Invalid field type encountered';
    REC_TOO_HIGH  : errorMsg := 'Requested record beyond range';
    ELSE
     errorMsg := 'Undefined error';
    END;
  WriteLn;
  WriteLn(errorMsg);
  Halt(1);
  END;

TYPE
  PseudoStr = ARRAY[1..255] OF Char;

VAR
  Demo : dbfRecord;
  j, i : Integer;
  blanks : _Str255;
  SizeOfFile, r : Real;
  fn : _Str64;

  PROCEDURE Wait;
  VAR
    c : Char;

  BEGIN
  Write('Press any key to continue . . .');
  Read(Kbd, c);
  END;


  PROCEDURE List(VAR D : dbfRecord);

    PROCEDURE ShowField(VAR a; VAR F : _FieldRecord);

    VAR
      Data : PseudoStr ABSOLUTE a;

    BEGIN
    WITH F DO
      BEGIN
      CASE Typ OF
        'C', 'N', 'L' : Write(Copy(Data, 1, Len));
        'M' : Write('Memo      ');
        'D' : Write(Copy(Data, 5, 2), '/',
              Copy(Data, 7, 2), '/',
              Copy(Data, 1, 2));
      END;                    {CASE}
      IF Len <= Length(Name) THEN
        Write(Copy(blanks, 1, Length(Name)-Pred(Len)))
      ELSE
        Write(' ');
      END;                    {WITH F}
    END;                      {ShowField}

  BEGIN                       {List}
  WriteLn;
  Write('Rec Num  ');
  WITH D DO
    BEGIN
    FOR i := 1 TO NumFields DO
      WITH Fields^[i] DO
        IF Len >= Length(Name) THEN
          Write(Name, Copy(blanks, 1, Succ(Len-Length(Name))))
        ELSE
          Write(Name, ' ');
    WriteLn;
    r := 1;
    WHILE r <= NumRecs DO
      BEGIN
      GetDbfRecord(Demo, r);
      IF NOT dbfOK THEN ErrorHalt(dbfError);
      WriteLn;
      Write(r:7:0, ' ');
      Write(Chr(CurRecord^[0])); { the 'deleted' indicator }
      FOR i := 1 TO NumFields DO
        ShowField(CurRecord^[Fields^[i].Off], Fields^[i]);
      r := r+1;
      END;                    {WHILE r }
    END;                      {WITH D }
  END;                        {List}

  PROCEDURE DisplayStructure(VAR D : dbfRecord);

  VAR
    i : Integer;

  BEGIN
  WITH D DO
    BEGIN
    ClrScr;
    Write(' #  Field Name   Type  Length  Decimal');
    FOR i := 1 TO NumFields DO
      BEGIN
      WITH Fields^[i] DO
        BEGIN
        IF i MOD 20 = 0 THEN
          BEGIN
          WriteLn;
          Wait;
          ClrScr;
          Write(' #  Field Name   Type  Length  Decimal');
          END;
        GoToXY(1, Succ(WhereY));
        Write(i:2, Name:12, Typ:5, Len:9);
        IF Typ = 'N' THEN Write(Dec:5);
        END;                  {WITH Fields^}
      END;                    {FOR}
    WriteLn;
    Wait;
    END;                      {WITH D}
  END;                        { DisplayStructure }


BEGIN                         {Demonstration of DBF routines}
WITH Demo DO
  BEGIN
  FillChar(blanks, SizeOf(blanks), $20);
  blanks[0] := Chr(255);
  ClrScr;
  GoToXY(10, 10);
  Write('Name of dBASE file (.DBF assumed): ');
  Read(FileName);
  IF Pos('.', FileName) = 0 THEN FileName := FileName+'.DBF';
  OpenDbf(Demo);
  IF NOT dbfOK THEN ErrorHalt(dbfError);
  ClrScr;
  SizeOfFile := LongFileSize(dFile);
  WriteLn('File Name: ', FileName);
  WriteLn('Date Of Last Update: ', DateOfUpdate);
  WriteLn('Number of Records: ', NumRecs:10:0);
  WriteLn('Size of File: ', SizeOfFile:15:0);
  WriteLn('Length of Header: ', HeadLen:11);
  WriteLn('Length of One Record: ', RecLen:7);
  IF WithMemo THEN WriteLn('This file contains Memo fields.');
  Wait;
  ClrScr;
  DisplayStructure(Demo);
  ClrScr;
  List(Demo);
  WriteLn;
  Wait;
  CloseDbf(Demo);
  IF NOT dbfOK THEN ErrorHalt(dbfError);
  END;                        {WITH}
END.                          {of Demo program }
*)