home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / modula2 / library / dbf_file / dbf.mod < prev    next >
Text File  |  1991-04-24  |  59KB  |  997 lines
  1. IMPLEMENTATION MODULE DBF;    (* version 1.3 *)
  2.  
  3. (**********************************************************************)
  4. (* Copyright 1988,1989,1990,1991 by David Albert                      *)
  5. (**********************************************************************)
  6. (* This module exports procedures and data to allow Modula-2 users to *)
  7. (* easily access dBase III, III+, and IV data files.  Procedures      *)
  8. (* include: OpenDBF, CloseDBF, GetRec, PutRec, GetField, PutField,    *)
  9. (*          RecCount, RecSize, etc.                                   *)
  10. (* The DBF Module is most effective when used in combination with the *)
  11. (* independent NDX module which provides access to dBase index files. *)
  12. (* Complete documentation for this module can be found in DBF.DOC     *)
  13. (**********************************************************************)
  14. (* Modification History                                               *)
  15. (*     9/2/88 by DAA reduced imported code added RightTrim            *)
  16. (*    10/7/88 by DAA fixed NumRecs locking for AddRec                 *)
  17. (*   12/14/88 by DAA Added null to str retrned by GetField            *)
  18. (*    2/27/89 by DAA modified to run under TopSpeed M2                *)
  19. (*    4/17/89 by DAA removed much unnecessary locking                 *)
  20. (*     5/1/89 by DAA added DBase IV compatibility                     *)
  21. (*     6/1/90 by DAA fixed bug in Field array allocation.             *)
  22. (*    7/11/90 by DAA added ErrRecNo check for Get & PutRec            *)
  23. (*    3/26/91 by DAA removed dependencies on non-standard libraries   *)
  24. (*    3/29/91 by DAA centralized and improved error handling.         *)
  25. (**********************************************************************)
  26.  
  27. IMPORT FIO;
  28. FROM Storage    IMPORT ALLOCATE, DEALLOCATE, Available;
  29. FROM Str        IMPORT Append, Caps, Compare, Concat, Copy, Pos, Length;
  30. FROM Lib        IMPORT HashString, Move, Dos;
  31. FROM SYSTEM     IMPORT Registers;
  32. FROM IO         IMPORT RdKey, WrStr, WrCard, WrLn;
  33. FROM Window     IMPORT WinDef, WinType, Open, Close, Color, DoubleFrame;
  34.  
  35. TYPE
  36.   DBFile    = POINTER TO DBFRec;                 (* Exported DBF File Type  *)
  37.   RecPtr    = POINTER TO RecType;                (* Pointer to rec buffer   *)
  38.   RecType   = ARRAY[1..MaxRecLen] OF CHAR;       (* Record buffer type      *)
  39.   FieldType = RECORD                             (* Field definition record *)
  40.      Name       : ARRAY[0..10] OF CHAR;          (*    Field name           *)
  41.      Type       : CHAR;                          (*    Field type (CNLD)    *)
  42.      Reserved1  : ARRAY[0..3] OF CHAR;           (*    Not used             *)
  43.      Len        : SHORTCARD;                     (*    Field length         *)
  44.      Dec        : SHORTCARD;                     (*    Decimal places       *)
  45.      Ofs        : CARDINAL;                      (*    Not used/Rec offset  *)
  46.      WorkAreaID : SHORTCARD;                     (*    Work area ID         *)
  47.      Reserved3  : ARRAY[0..10] OF CHAR;          (*    Not used             *)
  48.   END; (* FieldType *)
  49.   Fields   = ARRAY[1..MaxFields] OF FieldType;   (* Array of all field defs *)
  50.   HashPtr  = POINTER TO HashType;                (* Field names are stored  *)
  51.   HashType = RECORD                              (*    in a hash table for  *)
  52.      Name       : ARRAY[0..10] OF CHAR;          (*    rapid access to data *)
  53.      Field      : CARDINAL;                      (*    by field name.       *)
  54.      Next       : HashPtr;                       (*    (instead of by field *)
  55.   END; (* HashType *)                            (*     number)             *)
  56.   HashTable= ARRAY[0..MaxFields] OF HashPtr;     (* Hashtable of field names*)
  57.   DBFRec   = RECORD                              (* For each DBF opened,    *)
  58.      Name       : ARRAY [0..63] OF CHAR;         (* a record is kept of     *)
  59.      Handle     : FIO.File;                      (*    the file name, handle*)
  60.      Shared     : BOOLEAN;                       (*    and sharing mode     *)
  61.      (* DBF File header *)                       (*    The DBF file header  *)
  62.      HasMemo    : SHORTCARD;                     (*    - Memo file flag     *)
  63.      LastUpdate : ARRAY[0..2] OF CHAR;           (*    - Last update date   *)
  64.      NumRecs    : LONGCARD;                      (*    - Total recs in DBF  *)
  65.      HeadLen    : CARDINAL;                      (*    - File header len    *)
  66.      RecLen     : CARDINAL;                      (*    - Data record length *)
  67.      Reserved1  : ARRAY[0..1] OF CHAR;           (*    - Not used           *)
  68.      Incomplete : SHORTCARD;                     (*    - Incomplete transctn*)
  69.      Encrypted  : SHORTCARD;                     (*    - Encrypted file flag*)
  70.      Reserved2  : ARRAY[0..11] OF CHAR;          (*    - Resrvd for Network *)
  71.      HasMDX     : SHORTCARD;                     (*    - Associated MDX flag*)
  72.      Reserved3  : ARRAY[0..2] OF CHAR;           (*    - Reserved for future*)
  73.      (* End of DBF Header *)                     (*    Data/Record buffers  *)
  74.      CurRec     : LONGCARD;                      (*    - Cur Rec # (0 = EOF)*)
  75.      OldBuf     : RecPtr;                        (*    - Un-modified record *)
  76.      Buf        : RecPtr;                        (*    - Modified record    *)
  77.      NumFields  : CARDINAL;                      (*    - # of fields per rec*)
  78.      FIELDS     : POINTER TO Fields;             (*    - Field data array   *)
  79.      HashTable  : HashTable;                     (*    - Hash of field names*)
  80.   END; (* DBFRec *)
  81.  
  82. (****************************************************************************)
  83. (* DBF Procedures (Forward declarations)                                    *)
  84. (****************************************************************************)
  85. PROCEDURE AddRec    (D : DBFile);                           FORWARD;
  86. PROCEDURE CloseDBF  (VAR D : DBFile);                       FORWARD;
  87. PROCEDURE Deleted   (D : DBFile) : BOOLEAN;                 FORWARD;
  88. PROCEDURE DelRec    (D : DBFile);                           FORWARD;
  89. PROCEDURE Encrypted (D : DBFile) : BOOLEAN;                 FORWARD;
  90. PROCEDURE FieldData (D : DBFile; FieldName : ARRAY OF CHAR;
  91.                      VAR Type     : CHAR;
  92.                      VAR Len, Dec : CARDINAL);              FORWARD;
  93. PROCEDURE FieldName (D : DBFile; FieldNum  : CARDINAL;
  94.                      VAR FieldName : ARRAY OF CHAR);        FORWARD;
  95. PROCEDURE FileName  (D : DBFile; VAR Name : ARRAY OF CHAR); FORWARD;
  96. PROCEDURE GetExtErr () : CARDINAL;                          FORWARD;
  97. PROCEDURE GetField  (D : DBFile; FieldName : ARRAY OF CHAR;
  98.                      VAR TheField   : ARRAY OF CHAR);       FORWARD;
  99. PROCEDURE GetRec    (D : DBFile; RecNum : LONGCARD);        FORWARD;
  100. PROCEDURE GetRecBuf (D : DBFile; Buf : ADDRESS);            FORWARD;
  101. PROCEDURE HasMDX    (D : DBFile) : BOOLEAN;                 FORWARD;
  102. PROCEDURE Incomplete(D : DBFile) : BOOLEAN;                 FORWARD;
  103. PROCEDURE LockRec   (D : DBFile; RecNum : LONGCARD);        FORWARD;
  104. PROCEDURE NumFields (D : DBFile) : CARDINAL;                FORWARD;
  105. PROCEDURE OldField  (D : DBFile; FieldName : ARRAY OF CHAR;
  106.                      VAR TheField   : ARRAY OF CHAR);       FORWARD;
  107. PROCEDURE OpenDBF   (VAR D    : DBFile;
  108.                      FileName : ARRAY OF CHAR);             FORWARD;
  109. PROCEDURE PutField  (D : DBFile; FieldName : ARRAY OF CHAR;
  110.                      TheField   : ARRAY OF CHAR);           FORWARD;
  111. PROCEDURE PutRec    (D : DBFile; RecNum : LONGCARD);        FORWARD;
  112. PROCEDURE PutRecBuf (D : DBFile; Buf : ADDRESS);            FORWARD;
  113. PROCEDURE RecCount  (D : DBFile) : LONGCARD;                FORWARD;
  114. PROCEDURE RecNo     (D : DBFile) : LONGCARD;                FORWARD;
  115. PROCEDURE RecSize   (D : DBFile) : CARDINAL;                FORWARD;
  116. PROCEDURE UnDelRec  (D : DBFile);                           FORWARD;
  117. PROCEDURE UnLockRec (D : DBFile; RecNum : LONGCARD);        FORWARD;
  118.  
  119. (****************************************************************************)
  120. (* Error handling routines                                                  *)
  121. (****************************************************************************)
  122.  
  123. PROCEDURE HandleError(Proc : ARRAY OF CHAR; D : DBFile; Code : CARDINAL);
  124. VAR DialogWin : WinType;
  125.     Key       : CHAR;
  126. BEGIN
  127.    ErrCode := Code;
  128.    DosCode := GetExtErr();
  129.    IF ErrCheck = None THEN RETURN; END;
  130.    DialogWin := Open(WinDef(15, 5, 65, 13, White, Black,
  131.       TRUE, TRUE, FALSE, TRUE, DoubleFrame, White, Black));
  132.    WrStr('Error:'); WrLn;
  133.    WrStr('  Procedure: '); WrStr(Proc); WrLn;
  134.    IF (D # NIL) THEN
  135.       WrStr('  Data file: '); WrStr(D^.Name); WrLn;
  136.    END;
  137.    WrStr('  Message  : ');
  138.    CASE Code OF
  139.       ErrOpen  : WrStr('Unable to find/open file.');
  140.    |  ErrClose : WrStr('Unable to close file.');
  141.    |  ErrRead  : WrStr('Unable to read record.');
  142.    |  ErrWrite : WrStr('Unable to write record.');
  143.    |  ErrSeek  : WrStr('Unable to seek to record.');
  144.    |  ErrLock  : WrStr('Record locked by another user.');
  145.    |  ErrUnLock: WrStr('Unable to unlock record.');
  146.    |  ErrHandle: WrStr('Data file not open.');
  147.    |  ErrMemory: WrStr('Insufficient memory.');
  148.    |  ErrRecNo : WrStr('Invalid Record Number.');
  149.    |  ErrField : WrStr('Invalid field name.');
  150.    |  ErrBadDBF: WrStr('Data file invalid or damaged.');
  151.    |  ErrLockedDBF : WrStr('Data file locked by another user.');
  152.    ELSE WrStr('error cause unknown.');
  153.    END;
  154.    WrLn;
  155.    IF Code < ErrRecNo THEN
  156.       WrStr('  DOS Code : '); WrCard(DosCode, 3); WrLn;
  157.    END;
  158.    WrLn;
  159.    IF ErrCheck = AskUser THEN
  160.       WrStr('Press any key to continue or Esc to abort. ');
  161.       Key := RdKey();
  162.       Close(DialogWin);
  163.       IF Key = 33C THEN HALT; END;
  164.    ELSIF ErrCheck = Halt THEN
  165.       WrStr('Press any key to quit. ');
  166.       Key := RdKey();
  167.       Close(DialogWin);
  168.       HALT;
  169.    END;
  170. END HandleError;
  171.  
  172. (****************************************************************************)
  173. (* Miscellaneous low-level procedures                                       *)
  174. (****************************************************************************)
  175.  
  176. PROCEDURE RightTrim(VAR Str : ARRAY OF CHAR);   (* Remove Trailing spaces   *)
  177.                                                 (* dBase stores data padded *)
  178. VAR   Idx : CARDINAL;                           (* with spaces to the end   *)
  179. BEGIN                                           (* of the field.  RightTrim *)
  180.    IF (Length(Str) = 0) THEN                    (* removes trailing spaces  *)
  181.       RETURN;                                   (* and adds a null at the   *)
  182.    END;                                         (* end of the string to make*)
  183.    Idx := Length(Str);                          (* it Modula-2 compatible.  *)
  184.    REPEAT
  185.      DEC(Idx);
  186.      IF Str[Idx] = ' '
  187.         THEN Str[Idx] := 0C;
  188.         ELSE RETURN;
  189.      END;
  190.    UNTIL (Idx = 0);
  191. END RightTrim;
  192.  
  193. PROCEDURE GetSysDate(VAR Yr, Mn, Dt : CARDINAL);
  194. VAR Regs : Registers;                           (* Get current date from    *)
  195. BEGIN                                           (*    DOS via function      *)
  196.    Regs.AH := 02AH;                             (*    call 2Ah              *)
  197.    Dos(Regs);
  198.    Dt := VAL(CARDINAL, Regs.DL);
  199.    Mn := VAL(CARDINAL, Regs.DH);
  200.    Yr := Regs.CX;
  201. END GetSysDate;
  202.  
  203. PROCEDURE FLock(F:FIO.File; Ofs,Len : LONGCARD) : CARDINAL;
  204. CONST CF = 0;                                   (* Lock an area in a file   *)
  205. TYPE  AdrType = RECORD                          (*   via DOS record locking *)
  206.         Offset, Segment : CARDINAL;             (*   calls.                 *)
  207.       END;
  208. VAR   Regs   : Registers;
  209.       AdrPtr : AdrType;
  210. BEGIN
  211.    Regs.AX := 5C00H;                            (* DOS function 5Ch        *)
  212.    Regs.BX := F;                                (*     subfunction 00      *)
  213.    AdrPtr  := AdrType(Ofs);                     (*     locks range of file *)
  214.    Regs.CX := AdrPtr.Segment;                   (*     and returns with CF *)
  215.    Regs.DX := AdrPtr.Offset;                    (*     set if range already*)
  216.    AdrPtr  := AdrType(Len);                     (*     locked.             *)
  217.    Regs.SI := AdrPtr.Segment;                   (*     If CF not set, then *)
  218.    Regs.DI := AdrPtr.Offset;                    (*     area is locked OK.  *)
  219.    Dos(Regs);
  220.    IF CF IN Regs.Flags
  221.       THEN RETURN Regs.AX;
  222.       ELSE RETURN 0;
  223.    END;
  224. END FLock;
  225.  
  226. PROCEDURE FUnLock(F:FIO.File; Ofs,Len : LONGCARD) : CARDINAL;
  227. CONST CF = 0;                                   (* Unlock area in a file   *)
  228. TYPE  AdrType = RECORD                          (*   via DOS record unlock *)
  229.         Offset, Segment : CARDINAL;             (*   call.                 *)
  230.       END;
  231. VAR   Regs   : Registers;
  232.       AdrPtr : AdrType;
  233. BEGIN
  234.    Regs.AX := 5C01H;                            (* DOS function 5Ch        *)
  235.    Regs.BX := F;                                (*     subfunction 01h     *)
  236.    AdrPtr  := AdrType(Ofs);                     (*     unlocks range in a  *)
  237.    Regs.CX := AdrPtr.Segment;                   (*     file that was locked*)
  238.    Regs.DX := AdrPtr.Offset;                    (*     with subfunction 00 *)
  239.    AdrPtr  := AdrType(Len);
  240.    Regs.SI := AdrPtr.Segment;
  241.    Regs.DI := AdrPtr.Offset;
  242.    Dos(Regs);
  243.    IF CF IN Regs.Flags
  244.       THEN RETURN Regs.AX;
  245.       ELSE RETURN 0;
  246.    END;
  247. END FUnLock;
  248.  
  249. PROCEDURE FlushBuffers(F:FIO.File);             (* Flush any buffers for    *)
  250. CONST CF = 0;                                   (*   file specified to disk *)
  251. VAR Regs    : Registers;                        (* ( used to assure writes  *)
  252.     DiskWin : WinType;                          (*   make it to disk. )     *)
  253.     Key     : CHAR;
  254.     Attempts: CARDINAL;
  255. BEGIN
  256.    Attempts := 0;
  257.    REPEAT
  258.       Regs.AH := 68H;
  259.       Regs.BX := F;
  260.       Dos(Regs);
  261.       IF (CF IN Regs.Flags) AND (Regs.AX = 34) THEN
  262.          DiskWin := Open(WinDef(20, 5, 60, 10, White, Black,
  263.          TRUE, TRUE, FALSE, TRUE, DoubleFrame, White, Black));
  264.          WrLn;
  265.          WrStr('Replace data disk in drive.'); WrLn;
  266.          WrStr('Press any key to continue...');
  267.          Key := RdKey();
  268.          INC(Attempts);
  269.          Close(DiskWin);
  270.       END;
  271.    UNTIL (NOT ((CF IN Regs.Flags) AND (Regs.AX = 34)))
  272.          OR (Attempts = 5);
  273. END FlushBuffers;
  274.  
  275. PROCEDURE GetExtErr() : CARDINAL;
  276. VAR Regs : Registers;
  277. BEGIN
  278.    Regs.AH := 59H;
  279.    Dos(Regs);
  280.    RETURN Regs.AX;
  281. END GetExtErr;
  282.  
  283. (****************************************************************************)
  284. (* Record oriented procedures - Lock, Unlock, Get, Put                      *)
  285. (****************************************************************************)
  286.  
  287. PROCEDURE LockRec(D : DBFile; RecNum : LONGCARD);
  288. VAR FPtr       : LONGCARD;
  289.     Bytes      : LONGCARD;
  290. BEGIN
  291.    IF (RecNum=0) OR (RecNum > D^.NumRecs) THEN  (* If invalid record number *)
  292.       HandleError('LockRec', D, ErrRecNo);      (*     then handle error,   *)
  293.       RETURN;                                   (*     and abort lock proc. *)
  294.    END;                                         (* Else with valid rec no.  *)
  295.    FPtr := (RecNum-1)*VAL(LONGCARD,D^.RecLen) + (* Calculate location of    *)
  296.               VAL(LONGCARD, D^.HeadLen);        (* the record in the file   *)
  297.    Bytes := VAL(LONGCARD, D^.RecLen);           (* and the record length    *)
  298.    IF FLock(D^.Handle, FPtr, Bytes) > 1         (* Lock Record              *)
  299.       THEN HandleError('LockRec', D, ErrLock);  (* If error, handle it.     *)
  300.       ELSE ErrCode := 0;                        (* else set result code     *)
  301.    END;
  302. END LockRec;
  303.  
  304. PROCEDURE UnLockRec(D : DBFile; RecNum : LONGCARD);
  305. VAR FPtr : LONGCARD;
  306.     Bytes: LONGCARD;
  307. BEGIN
  308.    IF (RecNum=0) OR (RecNum > D^.NumRecs) THEN  (* If invalid record number *)
  309.       HandleError('UnLockRec', D, ErrRecNo);    (*    then handle error,    *)
  310.       RETURN;                                   (*    and abort lock proc.  *)
  311.    END;                                         (* Else with valid rec no.  *)
  312.    FPtr := (RecNum-1)*VAL(LONGCARD,D^.RecLen) + (* Calculate location of    *)
  313.               VAL(LONGCARD, D^.HeadLen);        (* the record in the file   *)
  314.    Bytes := VAL(LONGCARD, D^.RecLen);           (* and the record length    *)
  315.    IF FUnLock(D^.Handle, FPtr, Bytes) > 1 THEN  (* Unlock Record            *)
  316.       HandleError('UnLockRec', D, ErrUnLock);   (* If error, handle it      *)
  317.    ELSE ErrCode := 0;                           (* else set result OK code  *)
  318.    END;
  319. END UnLockRec;
  320.  
  321. PROCEDURE GetRec(D : DBFile; RecNum : LONGCARD);
  322. VAR FPtr        : LONGCARD;
  323.     nRead       : CARDINAL;
  324.     TempIOcheck : BOOLEAN;
  325. BEGIN
  326.    IF (RecNum=0) OR (RecNum > D^.NumRecs) THEN  (* If invalid record number *)
  327.       HandleError('GetRec', D, ErrRecNo);       (*     then handle error    *)
  328.       RETURN;                                   (*     and abort get rec.   *)
  329.    END;                                         (* Else with valid rec no.  *)
  330.    TempIOcheck := FIO.IOcheck;                  (* Save IOcheck state       *)
  331.    FIO.IOcheck := FALSE;                        (* Turn off FIO.IO checking *)
  332.    FPtr := (RecNum-1)*VAL(LONGCARD,D^.RecLen) + (* Calculate location of    *)
  333.            VAL(LONGCARD, D^.HeadLen);           (* the record in the file   *)
  334.    FIO.Seek(D^.Handle, FPtr);                   (* Seek to start of record  *)
  335.    IF FIO.IOresult() > 0 THEN                   (* If error seeking         *)
  336.       HandleError('GetRec', D, ErrSeek);        (*    handle error          *)
  337.       FIO.IOcheck := TempIOcheck;               (*    restore IOcheck state *)
  338.       RETURN;                                   (*    and abort GetRec      *)
  339.    END;                                         (* Else with file ptr set,  *)
  340.    nRead:=FIO.RdBin(D^.Handle,D^.Buf^,D^.RecLen);(* Read record.            *)
  341.    FIO.IOcheck := TempIOcheck;                  (* Restore IOcheck state    *)
  342.    IF (nRead # D^.RecLen) AND                   (* If record was locked by  *)
  343.       (GetExtErr() = 33) THEN                   (*    another user or app.  *)
  344.       HandleError('GetRec', D, ErrLock);        (*    handle error (lock)   *)
  345.       RETURN;                                   (*    and abort GetRec      *)
  346.    END;
  347.    IF FIO.IOresult() > 0 THEN                   (* If error reading,        *)
  348.       HandleError('GetRec', D, ErrRead);        (*    handle error          *)
  349.       RETURN;                                   (*    and abort GetRec      *)
  350.    END;                                         (* Else with record read OK *)
  351.    D^.CurRec := RecNum;                         (* Set current record number*)
  352.    Move(D^.Buf, D^.OldBuf, D^.RecLen);          (* Make backup copy of rec  *)
  353.    ErrCode := 0;                                (* Set result code to OK    *)
  354. END GetRec;
  355.  
  356. PROCEDURE PutRec(D : DBFile; RecNum : LONGCARD);
  357. VAR FPtr        : LONGCARD;
  358.     nRead       : CARDINAL;
  359.     TempIOcheck : BOOLEAN;
  360. BEGIN
  361.    IF (RecNum=0) OR (RecNum > D^.NumRecs) THEN  (* If invalid record number *)
  362.       HandleError('PutRec', D, ErrRecNo);       (*     then handle error    *)
  363.       RETURN;                                   (*     and abort put rec.   *)
  364.    END;                                         (* Else with valid rec no.  *)
  365.    TempIOcheck := FIO.IOcheck;                  (* Save IOcheck state       *)
  366.    FIO.IOcheck := FALSE;                        (* Turn off FIO.IO checking *)
  367.    FPtr := (RecNum-1)*VAL(LONGCARD,D^.RecLen) + (* Calculate location of    *)
  368.            VAL(LONGCARD, D^.HeadLen);           (* the record in the file   *)
  369.    FIO.Seek(D^.Handle, FPtr);                   (* Seek to start of record  *)
  370.    IF FIO.IOresult() > 0 THEN                   (* If error seeking         *)
  371.       HandleError('PutRec', D, ErrSeek);        (*    handle error          *)
  372.       FIO.IOcheck := TempIOcheck;               (*    restore IOcheck state *)
  373.       RETURN;                                   (*    and abort PutRec      *)
  374.    END;                                         (* Else with file ptr set,  *)
  375.    FIO.WrBin(D^.Handle, D^.Buf^, D^.RecLen);    (* Write record to file     *)
  376.    FIO.IOcheck := TempIOcheck;                  (* Restore IOcheck state    *)
  377.    IF FIO.IOresult() > 0 THEN                   (* If error writing,        *)
  378.       HandleError('PutRec', D, ErrWrite);       (*    handle error          *)
  379.       RETURN;                                   (*    and abort PutRec      *)
  380.    END;                                         (* Else with record written *)
  381.    IF Safety THEN                               (* If safety mode active,   *)
  382.       FlushBuffers(D^.Handle);                  (*    flush file buffers to *)
  383.    END;                                         (*    disk for safety.      *)
  384.    ErrCode := 0;                                (* Set result code to OK    *)
  385. END PutRec;
  386.  
  387. (****************************************************************************)
  388. (* Multi-user concurrency controls - Lock/UnLock/Get/Put Numrecs            *)
  389. (*     The only time multi-user intervention is absolutely necessary is     *)
  390. (*     when adding records.  If two users are adding records, the operations*)
  391. (*     must be serialized so that the Record count is kept accurate.        *)
  392. (****************************************************************************)
  393.  
  394. PROCEDURE LockNumRecs(D : DBFile);
  395. VAR LockStatus : CARDINAL;
  396.     Attempts   : CARDINAL;
  397. BEGIN
  398.   Attempts := 0;                                (* Lock attempts count      *)
  399.   REPEAT                                        (* Attempt to lock loop     *)
  400.      LockStatus:=FLock(D^.Handle, 4, 4);        (* Attempt to lock # recs   *)
  401.      IF LockStatus > 1 THEN                     (* If unable to lock,       *)
  402.         INC(Attempts);                          (*  Bump Lock attempt count *)
  403.      END;                                       (*  and continue trying till*)
  404.   UNTIL (LockStatus <= 1) OR                    (*  file is locked, or      *)
  405.         (Attempts > 100);                       (*  a minute and a half     *)
  406.   IF (LockStatus > 1) THEN                      (* If unable to lock file,  *)
  407.      HandleError('LockNumRecs', D, ErrLock);    (*    handle error.         *)
  408.      RETURN;                                    (*    and abort lock proc.  *)
  409.   END;                                          (* Else file is now locked  *)
  410.   ErrCode := 0;                                 (*    so procede with add   *)
  411. END LockNumRecs;
  412.  
  413. PROCEDURE UnLockNumRecs(D : DBFile);
  414. VAR UnLockStatus : CARDINAL;
  415.     Attempts     : CARDINAL;
  416. BEGIN
  417.   Attempts := 0;                                (* UnLock attempts count    *)
  418.   REPEAT                                        (* Attempt to unlock loop   *)
  419.      UnLockStatus:=FUnLock(D^.Handle, 4, 4);    (* Attempt to unlock # recs *)
  420.      IF UnLockStatus > 1 THEN                   (* If unable to unlock,     *)
  421.         INC(Attempts);                          (*    Bump attempt count    *)
  422.      END;                                       (*    and continue trying   *)
  423.   UNTIL (UnLockStatus <= 1) OR                  (* Until unlocked, or       *)
  424.         (Attempts > 100);                       (*    1.5 minutes elapsed   *)
  425.   IF (UnLockStatus > 1) THEN                    (* If unable to unlock file *)
  426.      HandleError('UnLockNumRecs', D, ErrUnLock);(*    handle error.         *)
  427.      RETURN;                                    (*    and abort lock proc.  *)
  428.   END;                                          (* Else file is now unlocked*)
  429.   ErrCode := 0;                                 (*    so return result OK   *)
  430. END UnLockNumRecs;
  431.  
  432. PROCEDURE GetNumRecs(D : DBFile);
  433. VAR nRead       : CARDINAL;
  434.     TempIOcheck : BOOLEAN;
  435. BEGIN
  436.   TempIOcheck := FIO.IOcheck;                   (* Save IOcheck state       *)
  437.   FIO.IOcheck := FALSE;                         (* Turn off FIO.IO checking *)
  438.   FIO.Seek(D^.Handle, 4);                       (* Seek to # recs field     *)
  439.   IF FIO.IOresult() > 0 THEN                    (* If error seeking,        *)
  440.      HandleError('GetNumRecs', D, ErrSeek);     (*    handle error          *)
  441.      FIO.IOcheck := TempIOcheck;                (*    Restore IOcheck state *)
  442.      RETURN;                                    (*    and abort procedure.  *)
  443.   END;                                          (* Else with file ptr set,  *)
  444.   nRead := FIO.RdBin(D^.Handle, D^.NumRecs, 4); (* Read # recs in DBF       *)
  445.   FIO.IOcheck := TempIOcheck;                   (* Restore IOcheck state    *)
  446.   IF (nRead # 4) AND (GetExtErr() = 33) THEN    (* If # records was locked, *)
  447.      HandleError('GetNumRecs', D, ErrLock);     (*    handle error          *)
  448.      RETURN;                                    (*    and abort procedure.  *)
  449.   END;
  450.   IF FIO.IOresult() > 0 THEN                    (* If error reading,        *)
  451.      HandleError('GetNumRecs', D, ErrRead);     (*    handle error          *)
  452.      RETURN;                                    (*    and abort procedure.  *)
  453.   END;                                          (* Else, number of recs was *)
  454.   ErrCode := 0;                                 (*    read OK.              *)
  455. END GetNumRecs;
  456.  
  457. PROCEDURE PutNumRecs(D : DBFile);
  458. VAR TempIOcheck : BOOLEAN;
  459. BEGIN
  460.   TempIOcheck := FIO.IOcheck;                   (* Save IOcheck state       *)
  461.   FIO.IOcheck := FALSE;                         (* Turn off FIO.IO checking *)
  462.   FIO.Seek(D^.Handle, 4);                       (* Seek to # recs field     *)
  463.   IF FIO.IOresult() > 0 THEN                    (* If error seeking,        *)
  464.      HandleError('PutNumRecs', D, ErrSeek);     (*    handle error          *)
  465.      FIO.IOcheck := TempIOcheck;                (*    restore IOcheck state *)
  466.      RETURN;                                    (*    and abort procedure.  *)
  467.   END;                                          (* Else with file ptr set,  *)
  468.   FIO.WrBin(D^.Handle, D^.NumRecs, 4);          (* Update # of recs in DBF  *)
  469.   FIO.IOcheck := TempIOcheck;                   (* Restore IOcheck state.   *)
  470.   IF FIO.IOresult() > 0 THEN                    (* If error writing,        *)
  471.      HandleError('PutNumRecs', D, ErrWrite);    (*    handle error          *)
  472.      RETURN;                                    (*    and abort procedure.  *)
  473.   END;                                          (* Else, number of recs was *)
  474.   ErrCode := 0;                                 (*    updated OK.           *)
  475. END PutNumRecs;
  476.  
  477. (****************************************************************************)
  478. (* Exported procedures for manipulating DBF records and files including     *)
  479. (*     AddRec,  CloseDBF, FieldName, FileName, OpenDBF, DelRec, UnDelRec,   *)
  480. (*     Deleted, GetFieldName, GetField, OldField, PutField, GetRecBuf,      *)
  481. (*     PutRecBuf, RecChanged, RecCount, RecNo, RecSize, Encrypted, HasMDX,  *)
  482. (*     Incomplete, FieldData                                                *)
  483. (* For details on each procedure, see DBF.DOC documentation.                *)
  484. (****************************************************************************)
  485.  
  486. PROCEDURE AddRec(D : DBFile);                   (* Add Record to data file  *)
  487. VAR FPtr        : LONGCARD;
  488.     TempIOcheck : BOOLEAN;
  489. BEGIN
  490.   IF D^.Shared THEN                             (* When multi-user,         *)
  491.      LockNumRecs(D);                            (*   Lock file against      *)
  492.      IF ErrCode > 0 THEN RETURN; END;           (*   simultaneous adds.     *)
  493.      GetNumRecs(D);                             (*   Get # of recs in file  *)
  494.      IF ErrCode > 0 THEN                        (*   If error reading,      *)
  495.         UnLockNumRecs(D);                       (*        unlock file,      *)
  496.         RETURN;                                 (*        and abort add.    *)
  497.      END;                                       (*   Else, file locked and  *)
  498.   END;                                          (*   last rec # retrieved.  *)
  499.   TempIOcheck := FIO.IOcheck;                   (* Save cur IOcheck state   *)
  500.   FIO.IOcheck := FALSE;                         (* Turn off FIO err checkng *)
  501.   FPtr := VAL(LONGCARD, D^.HeadLen) +           (* Calculate position for   *)
  502.       D^.NumRecs * VAL(LONGCARD,D^.RecLen);     (*    new record in file.   *)
  503.   FIO.Seek(D^.Handle, FPtr);                    (* Seek to it (to EOF)      *)
  504.   IF FIO.IOresult() > 0 THEN                    (* If error seeking to EOF, *)
  505.      IF D^.Shared THEN                          (*    If multi-user mode,   *)
  506.         UnLockNumRecs(D);                       (*       unlock file        *)
  507.      END;                                       (*       for other users    *)
  508.      HandleError('AddRec', D, ErrSeek);         (*    handle seek error     *)
  509.      FIO.IOcheck := TempIOcheck;                (*    restore IOcheck state *)
  510.      RETURN;                                    (*    and abort add.        *)
  511.   END;                                          (* Else ready to write rec  *)
  512.   D^.Buf^[1] := ' ';                            (* Mark rec as undeleted    *)
  513.   FIO.WrBin(D^.Handle, D^.Buf^, D^.RecLen);     (* Write record to file     *)
  514.   FIO.IOcheck := TempIOcheck;                   (* Restore IOcheck state    *)
  515.   IF FIO.IOresult() > 0 THEN                    (* If error writing record, *)
  516.      IF D^.Shared THEN                          (*    If multi-user mode,   *)
  517.         UnLockNumRecs(D);                       (*       unlock file        *)
  518.      END;                                       (*       for other users    *)
  519.      HandleError('AddRec', D, ErrWrite);        (*    handle write error    *)
  520.      RETURN;                                    (*    and abort add.        *)
  521.   END;                                          (* Else record written OK   *)
  522.   INC(D^.NumRecs);                              (* So bump # recs in file   *)
  523.   IF D^.Shared THEN                             (* If multi-user mode,      *)
  524.      PutNumRecs(D);                             (*    write updated # recs  *)
  525.      UnLockNumRecs(D);                          (*    and unlock data file  *)
  526.   END;                                          (* Make newly added record  *)
  527.   IF Safety THEN                                (* If safety mode then      *)
  528.      FlushBuffers(D^.Handle);                   (*    flush buffers to disk *)
  529.   END;                                          (*    for extra safety      *)
  530.   D^.CurRec := D^.NumRecs;                      (* Make new rec current     *)
  531.   ErrCode := 0;                                 (* Return result code: OK   *)
  532. END AddRec;
  533.  
  534. PROCEDURE CloseDBF (VAR D : DBFile);            (* Close data file         *)
  535. VAR Yr, Mn, Dt, H  : CARDINAL;
  536.     HPtr, NPtr     : HashPtr;
  537.     TempIOcheck    : BOOLEAN;
  538. BEGIN
  539.   ErrCode := 0;                                 (* Initialize result code   *)
  540.   TempIOcheck := FIO.IOcheck;                   (* Save IOcheck state       *)
  541.   FIO.IOcheck := FALSE;                         (* Turn off FIO err checking*)
  542.   GetSysDate(Yr, Mn, Dt);                       (* Read the system date,    *)
  543.   IF Yr > 1900 THEN Yr := Yr - 1900; END;       (* Adjust Year to 2 digits  *)
  544.   D^.LastUpdate[2] := CHR(Dt);                  (* Convert date to DBase    *)
  545.   D^.LastUpdate[1] := CHR(Mn);                  (*    file header date      *)
  546.   D^.LastUpdate[0] := CHR(Yr);                  (*    string format.        *)
  547.   FIO.Seek(D^.Handle, 1);                       (* Seek to 2nd byte in hdr, *)
  548.   IF FIO.IOresult() > 0 THEN                    (* If error seeking,        *)
  549.      HandleError('CloseDBF', D, ErrSeek);       (*    handle error.         *)
  550.   ELSE                                          (* Else with file ptr set,  *)
  551.      IF D^.Shared THEN                          (*   If sharing file,       *)
  552.         FIO.WrBin(D^.Handle, D^.LastUpdate, 3); (*      update just date    *)
  553.      ELSE                                       (*   Else, if single user,  *)
  554.         FIO.WrBin(D^.Handle, D^.LastUpdate, 7); (*      update date,numrecs *)
  555.      END;
  556.      IF FIO.IOresult() > 0 THEN                 (*   If error updating file *)
  557.         HandleError('CloseDBF', D, ErrWrite);   (*      handle error        *)
  558.      END;
  559.   END;
  560.   FIO.Close(D^.Handle);                         (* Close the file           *)
  561.   FIO.IOcheck := TempIOcheck;                   (* Restore IOcheck state    *)
  562.   IF FIO.IOresult() > 0 THEN                    (* If file not closed OK,   *)
  563.      HandleError('CloseDBF', D, ErrClose);      (*    handle erorr.         *)
  564.   END;
  565.   FOR H := 0 TO MaxFields DO                    (* Release all memory used  *)
  566.      HPtr := D^.HashTable[H];                   (*    Get ptr from table.   *)
  567.      WHILE HPtr # NIL DO                        (*    While not nil ptr,    *)
  568.         NPtr := HPtr^.Next;                     (*      Get ptr to next,    *)
  569.         DEALLOCATE(HPtr, SIZE(HashType));       (*      deallocate cur,     *)
  570.         HPtr := NPtr;                           (*      and try next ptr    *)
  571.      END;                                       (*      continue till NIL   *)
  572.   END;                                          (*    Do for all in table.  *)
  573.   DEALLOCATE(D^.Buf, D^.RecLen + 1);            (* Release file's rec buffr *)
  574.   DEALLOCATE(D^.OldBuf, D^.RecLen + 1);         (* Release aux rec buffer   *)
  575.   DEALLOCATE(D^.FIELDS, D^.HeadLen - 32);       (* Release file's field list*)
  576.   DEALLOCATE(D, SIZE(DBFRec));                  (* Deallocate DBF variable  *)
  577. END CloseDBF;
  578.  
  579. PROCEDURE FieldName(D: DBFile;                  (* Return name of field     *)
  580.              FieldNum : CARDINAL;               (*    specified by FieldNum *)
  581.              VAR FieldName : ARRAY OF CHAR);    (*    in string FieldName   *)
  582. BEGIN
  583.    IF (FieldNum > 0) AND                        (* If valid field number,   *)
  584.       (FieldNum <= D^.NumFields)                (*    get field's name from *)
  585.       THEN Copy(FieldName, D^.FIELDS^[FieldNum].Name); (* field array       *)
  586.            ErrCode := 0;                        (*    and set result = OK   *)
  587.       ELSE FieldName[0] := 0C;                  (* Else return blank name,  *)
  588.            ErrCode := ErrField;                 (*    and set error code.   *)
  589.    END;
  590. END FieldName;
  591.  
  592. PROCEDURE FileName(D : DBFile;                  (* Return name of DBF file  *)
  593.                    VAR FileName:ARRAY OF CHAR); (*   as it was opened.      *)
  594. BEGIN
  595.    Copy(FileName, D^.Name);                     (* Return file name         *)
  596.    ErrCode := 0;                                (* Set result = OK          *)
  597. END FileName;
  598.  
  599. PROCEDURE OpenDBF(VAR D : DBFile;               (* Open data file specified *)
  600.                   FileName : ARRAY OF CHAR);    (*      in FileName.        *)
  601. VAR H            : CARDINAL;
  602.     FPtr         : LONGCARD;
  603.     FieldBufLen  : CARDINAL;
  604.     nRead        : CARDINAL;
  605.     TempIOcheck  : BOOLEAN;
  606.  
  607.   PROCEDURE InsertHash(Str : ARRAY OF CHAR;     (* Insert field name into   *)
  608.                        FieldNum : CARDINAL);    (* hash table of field names*)
  609.   VAR ListPtr : HashPtr;                        (* for quick access to field*)
  610.       Hash    : CARDINAL;                       (* data by field name.      *)
  611.   BEGIN
  612.     Hash := HashString(Str, 128);               (* Get hash of field name   *)
  613.     IF NOT Available(SIZE(HashType)) THEN       (* If not enough memory,    *)
  614.        HandleError('OpenDBF', D, ErrMemory);    (*    handle error and      *)
  615.        RETURN;                                  (*    abort procedure.      *)
  616.     END;
  617.     IF D^.HashTable[Hash] = NIL THEN            (* If hash table entry empty*)
  618.        ALLOCATE(D^.HashTable[Hash], SIZE(HashType));  (* create entry in    *)
  619.        Copy(D^.HashTable[Hash]^.Name, Str);           (* table, and copy in *)
  620.        D^.HashTable[Hash]^.Field  := FieldNum;        (* field name         *)
  621.        D^.HashTable[Hash]^.Next   := NIL;             (* and init next ptr  *)
  622.     ELSE ListPtr := D^.HashTable[Hash];         (* Else if entry present,   *)
  623.        WHILE ListPtr^.Next # NIL DO                   (* follow next ptrs   *)
  624.           ListPtr := ListPtr^.Next;                   (* till an empty ptr  *)
  625.        END; (* While *)                               (* is found.          *)
  626.        ALLOCATE(ListPtr^.Next, SIZE(HashType)); (* create new entry in table*)
  627.        Copy(ListPtr^.Next^.Name, Str);                (* and copy in the    *)
  628.        ListPtr^.Next^.Field := FieldNum;              (* field name and     *)
  629.        ListPtr^.Next^.Next  := NIL;                   (* init next ptr      *)
  630.     END; (* If D^.HashTable = Nil *)
  631.   END InsertHash;
  632.  
  633.   PROCEDURE ReadHeader();                       (* Read DBF file header     *)
  634.   BEGIN
  635.     nRead:=FIO.RdBin(D^.Handle, D^.HasMemo, 32);(* Read header into buffer  *)
  636.     IF (nRead # 32) AND (GetExtErr() = 33) THEN (* If file header locked,   *)
  637.        HandleError('OpenDBF', D, ErrLockedDBF); (*    handle error          *)
  638.        RETURN;                                  (*    and abort procedure   *)
  639.     END;
  640.     IF (FIO.IOresult() > 0) OR                  (* If error reading, or     *)
  641.        (nRead # 32) OR                          (*    file too short or     *)
  642.        ((D^.HasMemo # 3) AND                    (*    invalid data in DBF   *)
  643.         (D^.HasMemo # 131)) OR                  (*    header, then the file *)
  644.        (D^.RecLen > MaxRecLen) OR               (*    is either damaged, or *)
  645.        (D^.Incomplete > 1) OR                   (*    not a valid DBF file. *)
  646.        (D^.Encrypted > 1) OR
  647.        (D^.HasMDX > 1) THEN
  648.           HandleError('OpenDBF', D, ErrBadDBF); (*    handle error          *)
  649.           RETURN;                               (*    and abort procedure   *)
  650.     END;
  651.   END ReadHeader;
  652.  
  653.   PROCEDURE ReadFieldList();                    (* Read list of fields from *)
  654.   VAR MemReq : CARDINAL;                        (*    DBF file header.      *)
  655.   BEGIN
  656.      FieldBufLen  := D^.HeadLen - 32;           (* Calc size of field buffer*)
  657.      D^.NumFields := (FieldBufLen DIV 32);      (* Calc. number of fields   *)
  658.      MemReq := (2 * (D^.RecLen + 1)) +          (* Calc amount of memory for*)
  659.                (FieldBufLen);                   (*   field and rec buffers. *)
  660.      IF NOT Available(MemReq) THEN              (* If not enough memory     *)
  661.         HandleError('OpenDBF', D, ErrMemory);   (*   handle error,          *)
  662.         RETURN;                                 (*   and abort procedure.   *)
  663.      END;                                       (* Else with adequate memory*)
  664.      ALLOCATE(D^.Buf, D^.RecLen+1);             (* Allocate record buffer   *)
  665.      ALLOCATE(D^.OldBuf, D^.RecLen+1);          (* Allocate change buffer   *)
  666.      ALLOCATE(D^.FIELDS, FieldBufLen);          (* Allocate field array and *)
  667.      nRead:=FIO.RdBin(D^.Handle, D^.FIELDS^, FieldBufLen);   (* Read array  *)
  668.      IF (nRead # FieldBufLen) AND               (* If field array was locked*)
  669.         (GetExtErr() = 33) THEN                 (*    by another user/appl. *)
  670.         HandleError('OpenDBF',D,ErrLockedDBF);  (*    handle error.         *)
  671.         RETURN;                                 (*    and abort procedure.  *)
  672.      END;
  673.      IF (FIO.IOresult() > 0) OR                 (* If error reading field   *)
  674.         (nRead # FieldBufLen) THEN              (*    array from disk,      *)
  675.         HandleError('OpenDBF',D,ErrBadDBF);     (*    handle error.         *)
  676.         RETURN;                                 (*    and abort procedure.  *)
  677.      END;
  678.   END ReadFieldList;
  679.  
  680.   PROCEDURE CalcFieldOfs();                     (* Calculate offset of each *)
  681.   VAR N, Offset : CARDINAL;                     (* field within the record  *)
  682.   BEGIN                                         (* 1st byte is deleted flag *)
  683.      Offset := 2;                               (* First field is at ofs 2  *)
  684.      FOR N := 1 TO D^.NumFields DO              (* For all preceding fields *)
  685.         D^.FIELDS^[N].Ofs := Offset;            (*    add field length of   *)
  686.         Offset := Offset +                      (*    preceding fields to   *)
  687.         VAL(CARDINAL, D^.FIELDS^[N].Len);       (*    offset of cur field.  *)
  688.      END;
  689.   END CalcFieldOfs;
  690.  
  691.   PROCEDURE HashFields();                       (* Hash field names into a  *)
  692.   VAR H : CARDINAL;                             (* hash table for rapid     *)
  693.   BEGIN                                         (* access by field name.    *)
  694.     FOR H := 0 TO MaxFields DO                  (* Initialize hash table    *)
  695.       D^.HashTable[H] := NIL;                   (*    for field names       *)
  696.     END;
  697.     FOR H := 1 TO D^.NumFields DO               (* Hash field names so      *)
  698.       InsertHash (D^.FIELDS^[H].Name, H);       (*    they can later be     *)
  699.       IF (ErrCode > 0) THEN RETURN; END;        (*    accessed by name      *)
  700.     END;
  701.   END HashFields;
  702.  
  703.   PROCEDURE ReleaseMem;                         (* Release memory allocated *)
  704.   BEGIN                                         (* for data file            *)
  705.      DEALLOCATE(D^.Buf, D^.RecLen+1);
  706.      DEALLOCATE(D^.OldBuf, D^.RecLen+1);
  707.      DEALLOCATE(D^.FIELDS, D^.HeadLen - 32);
  708.   END ReleaseMem;
  709.  
  710. BEGIN
  711.   IF NOT Available(SIZE(DBFRec)) THEN           (* If insufficient memory,  *)
  712.      HandleError('OpenDBF', D, ErrMemory);      (*    handle err.r          *)
  713.      RETURN;                                    (*    and abort procedure.  *)
  714.   END;                                          (* Else with adequate memory*)
  715.   ALLOCATE(D, SIZE(DBFRec));                    (* Allocate file variable   *)
  716.   Copy(D^.Name, FileName);                      (* Save filename            *)
  717.   Caps(D^.Name);                                (* Convert to upper case    *)
  718.   IF Pos(D^.Name, '.') > HIGH(D^.Name) THEN     (* If file extension not    *)
  719.      Append(D^.Name, '.DBF');                   (*    specified, append     *)
  720.   END;                                          (*    default of '.DBF'     *)
  721.   D^.Shared := MultiUser;                       (* Store sharing mode       *)
  722.   IF MultiUser                                  (* If in multi-user mode,   *)
  723.     THEN FIO.ShareMode := FIO.ShareDenyNone;    (*    setup for shared open *)
  724.     ELSE FIO.ShareMode := FIO.ShareCompat;      (*    else for exclusive    *)
  725.   END;                                          (*    access                *)
  726.   TempIOcheck := FIO.IOcheck;                   (* Save IOcheck state       *)
  727.   FIO.IOcheck := FALSE;                         (* Turn off FIO err checking*)
  728.   D^.Handle := FIO.Open(D^.Name);               (* Open data file           *)
  729.   IF FIO.IOresult() > 0 THEN                    (* If error opening DBF file*)
  730.      HandleError('OpenDBF', D, ErrOpen);        (*    handle error          *)
  731.      DEALLOCATE(D, SIZE(DBFRec));               (*    return used memory,   *)
  732.      FIO.IOcheck := TempIOcheck;                (*    restore IOcheck state *)
  733.      RETURN;                                    (*    and abort procedure   *)
  734.   END;
  735.   ReadHeader();                                 (* Read in DBF header       *)
  736.   IF (ErrCode > 0) THEN                         (* If error getting header, *)
  737.      FIO.Close(D^.Handle);                      (*    close DBF file,       *)
  738.      DEALLOCATE(D, SIZE(DBFRec));               (*    return used memory,   *)
  739.      FIO.IOcheck := TempIOcheck;                (*    restore IOcheck state *)
  740.      RETURN;                                    (*    and abort procedure.  *)
  741.   END;
  742.   ReadFieldList();                              (* Read in Field list       *)
  743.   IF (ErrCode > 0) THEN                         (* If error getting list,   *)
  744.      FIO.Close(D^.Handle);                      (*    close DBF file        *)
  745.      ReleaseMem();                              (*    release buffers,      *)
  746.      DEALLOCATE(D, SIZE(DBFRec));               (*    return used memory,   *)
  747.      FIO.IOcheck := TempIOcheck;                (*    restore IOcheck state *)
  748.      RETURN;                                    (*    and abort procedure.  *)
  749.   END;
  750.   CalcFieldOfs();                               (* Calc. Field offsets      *)
  751.   HashFields();                                 (* Generate hash table      *)
  752.   IF (ErrCode > 0) THEN                         (* If error making hash tbl *)
  753.      FIO.Close(D^.Handle);                      (*    close DBF file        *)
  754.      ReleaseMem();                              (*    release buffers       *)
  755.      DEALLOCATE(D, SIZE(DBFRec));               (*    return used memory,   *)
  756.      FIO.IOcheck := TempIOcheck;                (*    restore IOcheck state *)
  757.      RETURN;                                    (*    and abort procedure.  *)
  758.   END;
  759.   FIO.IOcheck := TempIOcheck;                   (* Restore IOcheck state    *)
  760.   D^.CurRec := VAL(LONGCARD, 0);                (* Set DBF's cur rec ptr    *)
  761.   ErrCode   := 0;                               (* Set result code to OK    *)
  762. END OpenDBF;
  763.  
  764. PROCEDURE DelRec(D : DBFile);                   (* Delete current record    *)
  765. BEGIN
  766.   D^.Buf^[1] := '*';                            (* Place deleted flag in rec*)
  767.   PutRec(D, D^.CurRec);                         (* Store record in file.    *)
  768. END DelRec;
  769.  
  770. PROCEDURE UnDelRec(D : DBFile);                 (* Undelete current record  *)
  771. BEGIN
  772.   D^.Buf^[1] := ' ';                            (* Clear deleted flag in rec*)
  773.   PutRec(D, D^.CurRec);                         (* Store record in file.    *)
  774. END UnDelRec;
  775.  
  776. PROCEDURE Deleted(D : DBFile) : BOOLEAN;        (* Return deleted status of *)
  777. BEGIN                                           (*    current record.       *)
  778.   RETURN D^.Buf^[1] = '*';                      (* Return status.           *)
  779.   ErrCode := 0;                                 (* Set return code          *)
  780. END Deleted;
  781.  
  782. PROCEDURE GetFieldNum(D   : DBFile;             (* Get number of field with *)
  783.              FieldName    : ARRAY OF CHAR;      (*     name specified       *)
  784.              VAR FieldNum : CARDINAL);
  785. VAR ListPtr : HashPtr;
  786.     Hash    : CARDINAL;
  787.     ErrStr  : ARRAY [0..25] OF CHAR;
  788. BEGIN
  789.   Caps(FieldName);                              (* Convert to upper case    *)
  790.   Hash := HashString(FieldName,128);            (* Hash fieldname           *)
  791.   ListPtr := D^.HashTable[Hash];                (* Get ptr to field data    *)
  792.   WHILE (ListPtr # NIL) AND                     (* Search hash list         *)
  793.     ((Compare(FieldName, ListPtr^.Name)) # 0) DO
  794.     ListPtr := ListPtr^.Next;
  795.   END; (* While *)
  796.   IF ListPtr # NIL THEN                         (* Check if field was found *)
  797.      FieldNum := ListPtr^.Field;                (* field num from Hash tbl. *)
  798.      ErrCode := 0;
  799.   ELSE                                          (* Else if field not found  *)
  800.      Concat(ErrStr,'GetFieldNum - ',FieldName); (*    prepare err message   *)
  801.      HandleError(ErrStr, D, ErrField);          (*    handle error.         *)
  802.   END;
  803. END GetFieldNum;
  804.  
  805. PROCEDURE GetField(D      : DBFile;             (* Get entry from current   *)
  806.              FieldName    : ARRAY OF CHAR;      (*     record for specified *)
  807.              VAR TheField : ARRAY OF CHAR);     (*     field.               *)
  808. VAR StrIdx, BufIdx : CARDINAL;
  809.     FieldNum       : CARDINAL;
  810. BEGIN
  811.   IF (D^.CurRec = 0)OR(D^.CurRec > D^.NumRecs)  (* If no current record,    *)
  812.      THEN HandleError('GetField', D, ErrRecNo); (*    handle error          *)
  813.           RETURN;                               (*    and abort procedure   *)
  814.   END;                                          (* Else with valid rec #    *)
  815.   GetFieldNum(D, FieldName, FieldNum);          (* Get field number         *)
  816.   IF ErrCode > 0 THEN                           (* If invalid field name,   *)
  817.      TheField[0] := 0C;                         (*    clear return field,   *)
  818.      RETURN;                                    (*    and end procedure.    *)
  819.   END;
  820.   StrIdx := 0;                                  (* Index into output Str    *)
  821.   BufIdx := D^.FIELDS^[FieldNum].Ofs;           (* Index into  record buff. *)
  822.   WHILE (StrIdx <= HIGH(TheField)) AND
  823.     (StrIdx < VAL(CARDINAL, D^.FIELDS^[FieldNum].Len)) DO
  824.     TheField[StrIdx] := D^.Buf^[BufIdx];        (* Copy data from rec buf.  *)
  825.     INC(StrIdx); INC(BufIdx);                   (* into the output field    *)
  826.   END;
  827.   IF (StrIdx <= HIGH(TheField)) THEN            (* If output str is larger  *)
  828.      TheField[StrIdx] := 0C;                    (* than the field, end it   *)
  829.   END;                                          (* with a NUL               *)
  830.   RightTrim(TheField);                          (* Remove trailing spaces   *)
  831. END GetField;
  832.  
  833. PROCEDURE OldField(D      : DBFile;             (* Get field entry from cur *)
  834.              FieldName    : ARRAY OF CHAR;      (*     record before it was *)
  835.              VAR TheField : ARRAY OF CHAR);     (*     modified             *)
  836. VAR StrIdx, BufIdx : CARDINAL;
  837.     FieldNum       : CARDINAL;
  838. BEGIN
  839.   IF (D^.CurRec = 0)OR(D^.CurRec > D^.NumRecs)  (* If no current record,    *)
  840.      THEN HandleError('OldField', D, ErrRecNo); (*    handle error          *)
  841.           RETURN;                               (*    and abort procedure   *)
  842.   END;                                          (* Else with valid rec #    *)
  843.   GetFieldNum(D, FieldName, FieldNum);          (* Get field number         *)
  844.   IF ErrCode > 0 THEN                           (* If invalid field name,   *)
  845.      TheField[0] := 0C;                         (*    clear return field,   *)
  846.      RETURN;                                    (*    and end procedure.    *)
  847.   END;
  848.   StrIdx := 0;                                  (* Index into output Str    *)
  849.   BufIdx := D^.FIELDS^[FieldNum].Ofs;           (* Index into record buff.  *)
  850.   WHILE (StrIdx <= HIGH(TheField)) AND
  851.     (StrIdx < VAL(CARDINAL, D^.FIELDS^[FieldNum].Len)) DO
  852.     TheField[StrIdx] := D^.OldBuf^[BufIdx];     (* Copy data from rec buf.  *)
  853.     INC(StrIdx); INC(BufIdx);                   (* into the output field    *)
  854.   END;
  855.   IF (StrIdx <= HIGH(TheField)) THEN            (* If output str is larger  *)
  856.      TheField[StrIdx] := 0C;                    (* than the field, end it   *)
  857.   END;                                          (* with a NUL               *)
  858.   RightTrim(TheField);                          (* Remove trailing spaces   *)
  859. END OldField;
  860.  
  861. PROCEDURE PutField(D      : DBFile;             (* Store string in field    *)
  862.              FieldName    : ARRAY OF CHAR;      (*    specified in current  *)
  863.              TheField     : ARRAY OF CHAR);     (*    record.               *)
  864. VAR StrIdx, BufIdx, FieldLen : CARDINAL;
  865.     FieldNum       : CARDINAL;
  866. BEGIN
  867.   GetFieldNum(D, FieldName, FieldNum);          (* Get field number         *)
  868.   IF ErrCode > 0 THEN                           (* If invalid field name,   *)
  869.      TheField[0] := 0C;                         (*    clear return field,   *)
  870.      RETURN;                                    (*    and end procedure.    *)
  871.   END;
  872.   StrIdx := 0;                                  (* Index into input Str     *)
  873.   FieldLen := Length(TheField);                 (* End of input string      *)
  874.   BufIdx := D^.FIELDS^[FieldNum].Ofs;           (* Index into  record buff. *)
  875.   WHILE (StrIdx < FieldLen) AND
  876.     (StrIdx < VAL(CARDINAL, D^.FIELDS^[FieldNum].Len)) DO
  877.     D^.Buf^[BufIdx] := TheField[StrIdx];        (* Copy data into rec buf.  *)
  878.     INC(StrIdx); INC(BufIdx);                   (* from the input field     *)
  879.   END;
  880.   WHILE (StrIdx < VAL(CARDINAL, D^.FIELDS^[FieldNum].Len)) DO
  881.     D^.Buf^[BufIdx] := ' ';                     (* right fill field with    *)
  882.     INC(StrIdx); INC(BufIdx);                   (* spaces for dBase         *)
  883.   END;                                          (* compatibility.           *)
  884. END PutField;
  885.  
  886. PROCEDURE GetRecBuf(D : DBFile; Buf : ADDRESS); (* Read entire current rec  *)
  887. BEGIN                                           (* into user record buffer  *)
  888.    Move(D^.Buf, Buf, D^.RecLen);                (* Copy rec to user buffer  *)
  889.    ErrCode := 0;                                (* Set result code          *)
  890. END GetRecBuf;
  891.  
  892. PROCEDURE PutRecBuf(D : DBFile; Buf : ADDRESS); (* Copy user record buffer  *)
  893. BEGIN                                           (*   to current record.     *)
  894.    Move(Buf, D^.Buf, D^.RecLen);                (* Copy rec to DBF rec buf  *)
  895.    ErrCode := 0;                                (* Set result code          *)
  896. END PutRecBuf;
  897.  
  898. PROCEDURE RecChanged(D : DBFile) : BOOLEAN;     (* Returns True if record   *)
  899. BEGIN                                           (* has been changed.        *)
  900.    ErrCode := 0;                                (* Set result code          *)
  901.    RETURN(D^.Buf # D^.OldBuf);                  (* Return changed status    *)
  902. END RecChanged;
  903.  
  904. PROCEDURE RecCount(D : DBFile) : LONGCARD;      (* Return # of recs in file *)
  905. VAR nRead       : CARDINAL;
  906.     Attempts    : CARDINAL;
  907.     TempIOcheck : BOOLEAN;
  908. BEGIN
  909.   IF NOT D^.Shared THEN                         (* If in single user mode,  *)
  910.      ErrCode := 0;                              (*    set result code       *)
  911.      RETURN D^.NumRecs;                         (*    return record count   *)
  912.   END;                                          (* Else if sharing file,    *)
  913.   TempIOcheck := FIO.IOcheck;                   (* Save cur IOcheck state   *)
  914.   FIO.IOcheck := FALSE;                         (* Turn off FIO err checking*)
  915.   FIO.Seek(D^.Handle, 4);                       (* Seek to # of recs field  *)
  916.   IF FIO.IOresult() > 0 THEN                    (* If error seeking,        *)
  917.      HandleError('RecCount', D, ErrSeek);       (*    handle error.         *)
  918.      FIO.IOcheck := TempIOcheck;                (*    restore IOcheck state *)
  919.      RETURN VAL(LONGCARD, 0);                   (*    and abort procedure.  *)
  920.   END;                                          (* Else with file ptr set,  *)
  921.   Attempts := 0;                                (* Init count of attempts   *)
  922.   REPEAT                                        (* Enter read numrecs loop  *)
  923.      nRead := FIO.RdBin(D^.Handle,D^.NumRecs,4);(*    Read # recs in DBF    *)
  924.      IF (nRead # 4) AND (GetExtErr() = 33) THEN (*    If # records locked,  *)
  925.         INC(Attempts);                          (*       bump retry count,  *)
  926.      END;                                       (*       and try again.     *)
  927.   UNTIL (nRead = 4) OR (Attempts > 20);         (* Continue for 20 attempts *)
  928.   FIO.IOcheck := TempIOcheck;                   (* Restore IOcheck state    *)
  929.   IF Attempts > 20 THEN                         (* If # of records locked,  *)
  930.      HandleError('RecCount', D, ErrLock);       (*    handle error          *)
  931.      RETURN VAL(LONGCARD, 0);                   (*    and abort procedure.  *)
  932.   END;                                          (* Else file not locked.    *)
  933.   IF FIO.IOresult() > 0 THEN                    (* If error reading,        *)
  934.      HandleError('RecCount', D, ErrRead);       (*    handle error          *)
  935.      RETURN VAL(LONGCARD, 0);                   (*    and abort procedure.  *)
  936.   END;                                          (* Else Num recs read OK so *)
  937.   ErrCode := 0;                                 (* Set result to OK and     *)
  938.   RETURN D^.NumRecs;                            (* Return # of records      *)
  939. END RecCount;
  940.  
  941. PROCEDURE RecNo (D : DBFile) : LONGCARD;        (* Return cur. rec. number  *)
  942. BEGIN
  943.    ErrCode := 0;                                (* Init result code         *)
  944.    RETURN D^.CurRec;                            (* Return current rec num.  *)
  945. END RecNo;
  946.  
  947. PROCEDURE RecSize (D : DBFile) : CARDINAL;      (* Return record size       *)
  948. BEGIN
  949.    ErrCode := 0;                                (* Init result code         *)
  950.    RETURN D^.RecLen;                            (* Return record length     *)
  951. END RecSize;
  952.  
  953. PROCEDURE Encrypted (D : DBFile) : BOOLEAN;     (* Return True if file is   *)
  954. BEGIN                                           (*   encrypted (DB IV only) *)
  955.    ErrCode := 0;                                (* Init result code         *)
  956.    RETURN (D^.Encrypted > 0);                   (* Return encrypted flag    *)
  957. END Encrypted;
  958.  
  959. PROCEDURE HasMDX (D : DBFile) : BOOLEAN;        (* Return True if file has  *)
  960. BEGIN                                           (*    an MDX (dBase IV only)*)
  961.    ErrCode := 0;                                (* Init result code         *)
  962.    RETURN (D^.HasMDX > 0);                      (* Return MDX present flag  *)
  963. END HasMDX;
  964.  
  965. PROCEDURE Incomplete (D : DBFile) : BOOLEAN;    (* Return True if incomplete*)
  966. BEGIN                                           (*    transaction occured   *)
  967.    ErrCode := 0;                                (*    (dBase IV only)       *)
  968.    RETURN (D^.Incomplete > 0);                  (* Return Incomplete flag   *)
  969. END Incomplete;
  970.  
  971. PROCEDURE NumFields(D : DBFile) : CARDINAL;     (* Get data on file struct. *)
  972. BEGIN
  973.    ErrCode   := 0;                              (* Set result code = OK     *)
  974.    RETURN D^.NumFields;                         (* Return fields per rec    *)
  975. END NumFields;
  976.  
  977. PROCEDURE FieldData(D:DBFile;                   (* Get data on field struct *)
  978.                     FieldName : ARRAY OF CHAR;  (* for field specified.     *)
  979.                     VAR Type     : CHAR;
  980.                     VAR Len, Dec : CARDINAL);
  981. VAR FieldNum : CARDINAL;
  982. BEGIN
  983.   Type := ''; Len  := 0; Dec := 0;              (* Initialize results       *)
  984.   GetFieldNum(D, FieldName, FieldNum);          (* Get field number         *)
  985.   IF ErrCode > 0 THEN RETURN; END;              (* If invalid field, exit   *)
  986.   Type:= D^.FIELDS^[FieldNum].Type;             (* Get field structure from *)
  987.   Len := VAL(CARDINAL,D^.FIELDS^[FieldNum].Len);(* DBF header.              *)
  988.   Dec := VAL(CARDINAL,D^.FIELDS^[FieldNum].Dec);
  989. END FieldData;
  990.  
  991. BEGIN
  992.    MultiUser   := FALSE;                        (* Init Single user mode    *)
  993.    Safety      := FALSE;                        (* Don't flush buf. on write*)
  994.    ErrCheck    := AskUser;                      (* Stop & report on errors  *)
  995.    ErrCode     := 0;                            (* Result code = OK         *)
  996.    DosCode     := 0;                            (* Dos Extended err code=OK *)
  997. END DBF.