Category : Modula II Source Code
Archive   : DBFTOOLS.ZIP
Filename : DBF.MOD

 
Output of file : DBF.MOD contained in archive : DBFTOOLS.ZIP
IMPLEMENTATION MODULE DBF; (* version 1.3 *)

(**********************************************************************)
(* Copyright 1988,1989,1990,1991 by David Albert *)
(**********************************************************************)
(* This module exports procedures and data to allow Modula-2 users to *)
(* easily access dBase III, III+, and IV data files. Procedures *)
(* include: OpenDBF, CloseDBF, GetRec, PutRec, GetField, PutField, *)
(* RecCount, RecSize, etc. *)
(* The DBF Module is most effective when used in combination with the *)
(* independent NDX module which provides access to dBase index files. *)
(* Complete documentation for this module can be found in DBF.DOC *)
(**********************************************************************)
(* Modification History *)
(* 9/2/88 by DAA reduced imported code added RightTrim *)
(* 10/7/88 by DAA fixed NumRecs locking for AddRec *)
(* 12/14/88 by DAA Added null to str retrned by GetField *)
(* 2/27/89 by DAA modified to run under TopSpeed M2 *)
(* 4/17/89 by DAA removed much unnecessary locking *)
(* 5/1/89 by DAA added DBase IV compatibility *)
(* 6/1/90 by DAA fixed bug in Field array allocation. *)
(* 7/11/90 by DAA added ErrRecNo check for Get & PutRec *)
(* 3/26/91 by DAA removed dependencies on non-standard libraries *)
(* 3/29/91 by DAA centralized and improved error handling. *)
(**********************************************************************)

IMPORT FIO;
FROM Storage IMPORT ALLOCATE, DEALLOCATE, Available;
FROM Str IMPORT Append, Caps, Compare, Concat, Copy, Pos, Length;
FROM Lib IMPORT HashString, Move, Dos;
FROM SYSTEM IMPORT Registers;
FROM IO IMPORT RdKey, WrStr, WrCard, WrLn;
FROM Window IMPORT WinDef, WinType, Open, Close, Color, DoubleFrame;

TYPE
DBFile = POINTER TO DBFRec; (* Exported DBF File Type *)
RecPtr = POINTER TO RecType; (* Pointer to rec buffer *)
RecType = ARRAY[1..MaxRecLen] OF CHAR; (* Record buffer type *)
FieldType = RECORD (* Field definition record *)
Name : ARRAY[0..10] OF CHAR; (* Field name *)
Type : CHAR; (* Field type (CNLD) *)
Reserved1 : ARRAY[0..3] OF CHAR; (* Not used *)
Len : SHORTCARD; (* Field length *)
Dec : SHORTCARD; (* Decimal places *)
Ofs : CARDINAL; (* Not used/Rec offset *)
WorkAreaID : SHORTCARD; (* Work area ID *)
Reserved3 : ARRAY[0..10] OF CHAR; (* Not used *)
END; (* FieldType *)
Fields = ARRAY[1..MaxFields] OF FieldType; (* Array of all field defs *)
HashPtr = POINTER TO HashType; (* Field names are stored *)
HashType = RECORD (* in a hash table for *)
Name : ARRAY[0..10] OF CHAR; (* rapid access to data *)
Field : CARDINAL; (* by field name. *)
Next : HashPtr; (* (instead of by field *)
END; (* HashType *) (* number) *)
HashTable= ARRAY[0..MaxFields] OF HashPtr; (* Hashtable of field names*)
DBFRec = RECORD (* For each DBF opened, *)
Name : ARRAY [0..63] OF CHAR; (* a record is kept of *)
Handle : FIO.File; (* the file name, handle*)
Shared : BOOLEAN; (* and sharing mode *)
(* DBF File header *) (* The DBF file header *)
HasMemo : SHORTCARD; (* - Memo file flag *)
LastUpdate : ARRAY[0..2] OF CHAR; (* - Last update date *)
NumRecs : LONGCARD; (* - Total recs in DBF *)
HeadLen : CARDINAL; (* - File header len *)
RecLen : CARDINAL; (* - Data record length *)
Reserved1 : ARRAY[0..1] OF CHAR; (* - Not used *)
Incomplete : SHORTCARD; (* - Incomplete transctn*)
Encrypted : SHORTCARD; (* - Encrypted file flag*)
Reserved2 : ARRAY[0..11] OF CHAR; (* - Resrvd for Network *)
HasMDX : SHORTCARD; (* - Associated MDX flag*)
Reserved3 : ARRAY[0..2] OF CHAR; (* - Reserved for future*)
(* End of DBF Header *) (* Data/Record buffers *)
CurRec : LONGCARD; (* - Cur Rec # (0 = EOF)*)
OldBuf : RecPtr; (* - Un-modified record *)
Buf : RecPtr; (* - Modified record *)
NumFields : CARDINAL; (* - # of fields per rec*)
FIELDS : POINTER TO Fields; (* - Field data array *)
HashTable : HashTable; (* - Hash of field names*)
END; (* DBFRec *)

(****************************************************************************)
(* DBF Procedures (Forward declarations) *)
(****************************************************************************)
PROCEDURE AddRec (D : DBFile); FORWARD;
PROCEDURE CloseDBF (VAR D : DBFile); FORWARD;
PROCEDURE Deleted (D : DBFile) : BOOLEAN; FORWARD;
PROCEDURE DelRec (D : DBFile); FORWARD;
PROCEDURE Encrypted (D : DBFile) : BOOLEAN; FORWARD;
PROCEDURE FieldData (D : DBFile; FieldName : ARRAY OF CHAR;
VAR Type : CHAR;
VAR Len, Dec : CARDINAL); FORWARD;
PROCEDURE FieldName (D : DBFile; FieldNum : CARDINAL;
VAR FieldName : ARRAY OF CHAR); FORWARD;
PROCEDURE FileName (D : DBFile; VAR Name : ARRAY OF CHAR); FORWARD;
PROCEDURE GetExtErr () : CARDINAL; FORWARD;
PROCEDURE GetField (D : DBFile; FieldName : ARRAY OF CHAR;
VAR TheField : ARRAY OF CHAR); FORWARD;
PROCEDURE GetRec (D : DBFile; RecNum : LONGCARD); FORWARD;
PROCEDURE GetRecBuf (D : DBFile; Buf : ADDRESS); FORWARD;
PROCEDURE HasMDX (D : DBFile) : BOOLEAN; FORWARD;
PROCEDURE Incomplete(D : DBFile) : BOOLEAN; FORWARD;
PROCEDURE LockRec (D : DBFile; RecNum : LONGCARD); FORWARD;
PROCEDURE NumFields (D : DBFile) : CARDINAL; FORWARD;
PROCEDURE OldField (D : DBFile; FieldName : ARRAY OF CHAR;
VAR TheField : ARRAY OF CHAR); FORWARD;
PROCEDURE OpenDBF (VAR D : DBFile;
FileName : ARRAY OF CHAR); FORWARD;
PROCEDURE PutField (D : DBFile; FieldName : ARRAY OF CHAR;
TheField : ARRAY OF CHAR); FORWARD;
PROCEDURE PutRec (D : DBFile; RecNum : LONGCARD); FORWARD;
PROCEDURE PutRecBuf (D : DBFile; Buf : ADDRESS); FORWARD;
PROCEDURE RecCount (D : DBFile) : LONGCARD; FORWARD;
PROCEDURE RecNo (D : DBFile) : LONGCARD; FORWARD;
PROCEDURE RecSize (D : DBFile) : CARDINAL; FORWARD;
PROCEDURE UnDelRec (D : DBFile); FORWARD;
PROCEDURE UnLockRec (D : DBFile; RecNum : LONGCARD); FORWARD;

(****************************************************************************)
(* Error handling routines *)
(****************************************************************************)

PROCEDURE HandleError(Proc : ARRAY OF CHAR; D : DBFile; Code : CARDINAL);
VAR DialogWin : WinType;
Key : CHAR;
BEGIN
ErrCode := Code;
DosCode := GetExtErr();
IF ErrCheck = None THEN RETURN; END;
DialogWin := Open(WinDef(15, 5, 65, 13, White, Black,
TRUE, TRUE, FALSE, TRUE, DoubleFrame, White, Black));
WrStr('Error:'); WrLn;
WrStr(' Procedure: '); WrStr(Proc); WrLn;
IF (D # NIL) THEN
WrStr(' Data file: '); WrStr(D^.Name); WrLn;
END;
WrStr(' Message : ');
CASE Code OF
ErrOpen : WrStr('Unable to find/open file.');
| ErrClose : WrStr('Unable to close file.');
| ErrRead : WrStr('Unable to read record.');
| ErrWrite : WrStr('Unable to write record.');
| ErrSeek : WrStr('Unable to seek to record.');
| ErrLock : WrStr('Record locked by another user.');
| ErrUnLock: WrStr('Unable to unlock record.');
| ErrHandle: WrStr('Data file not open.');
| ErrMemory: WrStr('Insufficient memory.');
| ErrRecNo : WrStr('Invalid Record Number.');
| ErrField : WrStr('Invalid field name.');
| ErrBadDBF: WrStr('Data file invalid or damaged.');
| ErrLockedDBF : WrStr('Data file locked by another user.');
ELSE WrStr('error cause unknown.');
END;
WrLn;
IF Code < ErrRecNo THEN
WrStr(' DOS Code : '); WrCard(DosCode, 3); WrLn;
END;
WrLn;
IF ErrCheck = AskUser THEN
WrStr('Press any key to continue or Esc to abort. ');
Key := RdKey();
Close(DialogWin);
IF Key = 33C THEN HALT; END;
ELSIF ErrCheck = Halt THEN
WrStr('Press any key to quit. ');
Key := RdKey();
Close(DialogWin);
HALT;
END;
END HandleError;

(****************************************************************************)
(* Miscellaneous low-level procedures *)
(****************************************************************************)

PROCEDURE RightTrim(VAR Str : ARRAY OF CHAR); (* Remove Trailing spaces *)
(* dBase stores data padded *)
VAR Idx : CARDINAL; (* with spaces to the end *)
BEGIN (* of the field. RightTrim *)
IF (Length(Str) = 0) THEN (* removes trailing spaces *)
RETURN; (* and adds a null at the *)
END; (* end of the string to make*)
Idx := Length(Str); (* it Modula-2 compatible. *)
REPEAT
DEC(Idx);
IF Str[Idx] = ' '
THEN Str[Idx] := 0C;
ELSE RETURN;
END;
UNTIL (Idx = 0);
END RightTrim;

PROCEDURE GetSysDate(VAR Yr, Mn, Dt : CARDINAL);
VAR Regs : Registers; (* Get current date from *)
BEGIN (* DOS via function *)
Regs.AH := 02AH; (* call 2Ah *)
Dos(Regs);
Dt := VAL(CARDINAL, Regs.DL);
Mn := VAL(CARDINAL, Regs.DH);
Yr := Regs.CX;
END GetSysDate;

PROCEDURE FLock(F:FIO.File; Ofs,Len : LONGCARD) : CARDINAL;
CONST CF = 0; (* Lock an area in a file *)
TYPE AdrType = RECORD (* via DOS record locking *)
Offset, Segment : CARDINAL; (* calls. *)
END;
VAR Regs : Registers;
AdrPtr : AdrType;
BEGIN
Regs.AX := 5C00H; (* DOS function 5Ch *)
Regs.BX := F; (* subfunction 00 *)
AdrPtr := AdrType(Ofs); (* locks range of file *)
Regs.CX := AdrPtr.Segment; (* and returns with CF *)
Regs.DX := AdrPtr.Offset; (* set if range already*)
AdrPtr := AdrType(Len); (* locked. *)
Regs.SI := AdrPtr.Segment; (* If CF not set, then *)
Regs.DI := AdrPtr.Offset; (* area is locked OK. *)
Dos(Regs);
IF CF IN Regs.Flags
THEN RETURN Regs.AX;
ELSE RETURN 0;
END;
END FLock;

PROCEDURE FUnLock(F:FIO.File; Ofs,Len : LONGCARD) : CARDINAL;
CONST CF = 0; (* Unlock area in a file *)
TYPE AdrType = RECORD (* via DOS record unlock *)
Offset, Segment : CARDINAL; (* call. *)
END;
VAR Regs : Registers;
AdrPtr : AdrType;
BEGIN
Regs.AX := 5C01H; (* DOS function 5Ch *)
Regs.BX := F; (* subfunction 01h *)
AdrPtr := AdrType(Ofs); (* unlocks range in a *)
Regs.CX := AdrPtr.Segment; (* file that was locked*)
Regs.DX := AdrPtr.Offset; (* with subfunction 00 *)
AdrPtr := AdrType(Len);
Regs.SI := AdrPtr.Segment;
Regs.DI := AdrPtr.Offset;
Dos(Regs);
IF CF IN Regs.Flags
THEN RETURN Regs.AX;
ELSE RETURN 0;
END;
END FUnLock;

PROCEDURE FlushBuffers(F:FIO.File); (* Flush any buffers for *)
CONST CF = 0; (* file specified to disk *)
VAR Regs : Registers; (* ( used to assure writes *)
DiskWin : WinType; (* make it to disk. ) *)
Key : CHAR;
Attempts: CARDINAL;
BEGIN
Attempts := 0;
REPEAT
Regs.AH := 68H;
Regs.BX := F;
Dos(Regs);
IF (CF IN Regs.Flags) AND (Regs.AX = 34) THEN
DiskWin := Open(WinDef(20, 5, 60, 10, White, Black,
TRUE, TRUE, FALSE, TRUE, DoubleFrame, White, Black));
WrLn;
WrStr('Replace data disk in drive.'); WrLn;
WrStr('Press any key to continue...');
Key := RdKey();
INC(Attempts);
Close(DiskWin);
END;
UNTIL (NOT ((CF IN Regs.Flags) AND (Regs.AX = 34)))
OR (Attempts = 5);
END FlushBuffers;

PROCEDURE GetExtErr() : CARDINAL;
VAR Regs : Registers;
BEGIN
Regs.AH := 59H;
Dos(Regs);
RETURN Regs.AX;
END GetExtErr;

(****************************************************************************)
(* Record oriented procedures - Lock, Unlock, Get, Put *)
(****************************************************************************)

PROCEDURE LockRec(D : DBFile; RecNum : LONGCARD);
VAR FPtr : LONGCARD;
Bytes : LONGCARD;
BEGIN
IF (RecNum=0) OR (RecNum > D^.NumRecs) THEN (* If invalid record number *)
HandleError('LockRec', D, ErrRecNo); (* then handle error, *)
RETURN; (* and abort lock proc. *)
END; (* Else with valid rec no. *)
FPtr := (RecNum-1)*VAL(LONGCARD,D^.RecLen) + (* Calculate location of *)
VAL(LONGCARD, D^.HeadLen); (* the record in the file *)
Bytes := VAL(LONGCARD, D^.RecLen); (* and the record length *)
IF FLock(D^.Handle, FPtr, Bytes) > 1 (* Lock Record *)
THEN HandleError('LockRec', D, ErrLock); (* If error, handle it. *)
ELSE ErrCode := 0; (* else set result code *)
END;
END LockRec;

PROCEDURE UnLockRec(D : DBFile; RecNum : LONGCARD);
VAR FPtr : LONGCARD;
Bytes: LONGCARD;
BEGIN
IF (RecNum=0) OR (RecNum > D^.NumRecs) THEN (* If invalid record number *)
HandleError('UnLockRec', D, ErrRecNo); (* then handle error, *)
RETURN; (* and abort lock proc. *)
END; (* Else with valid rec no. *)
FPtr := (RecNum-1)*VAL(LONGCARD,D^.RecLen) + (* Calculate location of *)
VAL(LONGCARD, D^.HeadLen); (* the record in the file *)
Bytes := VAL(LONGCARD, D^.RecLen); (* and the record length *)
IF FUnLock(D^.Handle, FPtr, Bytes) > 1 THEN (* Unlock Record *)
HandleError('UnLockRec', D, ErrUnLock); (* If error, handle it *)
ELSE ErrCode := 0; (* else set result OK code *)
END;
END UnLockRec;

PROCEDURE GetRec(D : DBFile; RecNum : LONGCARD);
VAR FPtr : LONGCARD;
nRead : CARDINAL;
TempIOcheck : BOOLEAN;
BEGIN
IF (RecNum=0) OR (RecNum > D^.NumRecs) THEN (* If invalid record number *)
HandleError('GetRec', D, ErrRecNo); (* then handle error *)
RETURN; (* and abort get rec. *)
END; (* Else with valid rec no. *)
TempIOcheck := FIO.IOcheck; (* Save IOcheck state *)
FIO.IOcheck := FALSE; (* Turn off FIO.IO checking *)
FPtr := (RecNum-1)*VAL(LONGCARD,D^.RecLen) + (* Calculate location of *)
VAL(LONGCARD, D^.HeadLen); (* the record in the file *)
FIO.Seek(D^.Handle, FPtr); (* Seek to start of record *)
IF FIO.IOresult() > 0 THEN (* If error seeking *)
HandleError('GetRec', D, ErrSeek); (* handle error *)
FIO.IOcheck := TempIOcheck; (* restore IOcheck state *)
RETURN; (* and abort GetRec *)
END; (* Else with file ptr set, *)
nRead:=FIO.RdBin(D^.Handle,D^.Buf^,D^.RecLen);(* Read record. *)
FIO.IOcheck := TempIOcheck; (* Restore IOcheck state *)
IF (nRead # D^.RecLen) AND (* If record was locked by *)
(GetExtErr() = 33) THEN (* another user or app. *)
HandleError('GetRec', D, ErrLock); (* handle error (lock) *)
RETURN; (* and abort GetRec *)
END;
IF FIO.IOresult() > 0 THEN (* If error reading, *)
HandleError('GetRec', D, ErrRead); (* handle error *)
RETURN; (* and abort GetRec *)
END; (* Else with record read OK *)
D^.CurRec := RecNum; (* Set current record number*)
Move(D^.Buf, D^.OldBuf, D^.RecLen); (* Make backup copy of rec *)
ErrCode := 0; (* Set result code to OK *)
END GetRec;

PROCEDURE PutRec(D : DBFile; RecNum : LONGCARD);
VAR FPtr : LONGCARD;
nRead : CARDINAL;
TempIOcheck : BOOLEAN;
BEGIN
IF (RecNum=0) OR (RecNum > D^.NumRecs) THEN (* If invalid record number *)
HandleError('PutRec', D, ErrRecNo); (* then handle error *)
RETURN; (* and abort put rec. *)
END; (* Else with valid rec no. *)
TempIOcheck := FIO.IOcheck; (* Save IOcheck state *)
FIO.IOcheck := FALSE; (* Turn off FIO.IO checking *)
FPtr := (RecNum-1)*VAL(LONGCARD,D^.RecLen) + (* Calculate location of *)
VAL(LONGCARD, D^.HeadLen); (* the record in the file *)
FIO.Seek(D^.Handle, FPtr); (* Seek to start of record *)
IF FIO.IOresult() > 0 THEN (* If error seeking *)
HandleError('PutRec', D, ErrSeek); (* handle error *)
FIO.IOcheck := TempIOcheck; (* restore IOcheck state *)
RETURN; (* and abort PutRec *)
END; (* Else with file ptr set, *)
FIO.WrBin(D^.Handle, D^.Buf^, D^.RecLen); (* Write record to file *)
FIO.IOcheck := TempIOcheck; (* Restore IOcheck state *)
IF FIO.IOresult() > 0 THEN (* If error writing, *)
HandleError('PutRec', D, ErrWrite); (* handle error *)
RETURN; (* and abort PutRec *)
END; (* Else with record written *)
IF Safety THEN (* If safety mode active, *)
FlushBuffers(D^.Handle); (* flush file buffers to *)
END; (* disk for safety. *)
ErrCode := 0; (* Set result code to OK *)
END PutRec;

(****************************************************************************)
(* Multi-user concurrency controls - Lock/UnLock/Get/Put Numrecs *)
(* The only time multi-user intervention is absolutely necessary is *)
(* when adding records. If two users are adding records, the operations*)
(* must be serialized so that the Record count is kept accurate. *)
(****************************************************************************)

PROCEDURE LockNumRecs(D : DBFile);
VAR LockStatus : CARDINAL;
Attempts : CARDINAL;
BEGIN
Attempts := 0; (* Lock attempts count *)
REPEAT (* Attempt to lock loop *)
LockStatus:=FLock(D^.Handle, 4, 4); (* Attempt to lock # recs *)
IF LockStatus > 1 THEN (* If unable to lock, *)
INC(Attempts); (* Bump Lock attempt count *)
END; (* and continue trying till*)
UNTIL (LockStatus <= 1) OR (* file is locked, or *)
(Attempts > 100); (* a minute and a half *)
IF (LockStatus > 1) THEN (* If unable to lock file, *)
HandleError('LockNumRecs', D, ErrLock); (* handle error. *)
RETURN; (* and abort lock proc. *)
END; (* Else file is now locked *)
ErrCode := 0; (* so procede with add *)
END LockNumRecs;

PROCEDURE UnLockNumRecs(D : DBFile);
VAR UnLockStatus : CARDINAL;
Attempts : CARDINAL;
BEGIN
Attempts := 0; (* UnLock attempts count *)
REPEAT (* Attempt to unlock loop *)
UnLockStatus:=FUnLock(D^.Handle, 4, 4); (* Attempt to unlock # recs *)
IF UnLockStatus > 1 THEN (* If unable to unlock, *)
INC(Attempts); (* Bump attempt count *)
END; (* and continue trying *)
UNTIL (UnLockStatus <= 1) OR (* Until unlocked, or *)
(Attempts > 100); (* 1.5 minutes elapsed *)
IF (UnLockStatus > 1) THEN (* If unable to unlock file *)
HandleError('UnLockNumRecs', D, ErrUnLock);(* handle error. *)
RETURN; (* and abort lock proc. *)
END; (* Else file is now unlocked*)
ErrCode := 0; (* so return result OK *)
END UnLockNumRecs;

PROCEDURE GetNumRecs(D : DBFile);
VAR nRead : CARDINAL;
TempIOcheck : BOOLEAN;
BEGIN
TempIOcheck := FIO.IOcheck; (* Save IOcheck state *)
FIO.IOcheck := FALSE; (* Turn off FIO.IO checking *)
FIO.Seek(D^.Handle, 4); (* Seek to # recs field *)
IF FIO.IOresult() > 0 THEN (* If error seeking, *)
HandleError('GetNumRecs', D, ErrSeek); (* handle error *)
FIO.IOcheck := TempIOcheck; (* Restore IOcheck state *)
RETURN; (* and abort procedure. *)
END; (* Else with file ptr set, *)
nRead := FIO.RdBin(D^.Handle, D^.NumRecs, 4); (* Read # recs in DBF *)
FIO.IOcheck := TempIOcheck; (* Restore IOcheck state *)
IF (nRead # 4) AND (GetExtErr() = 33) THEN (* If # records was locked, *)
HandleError('GetNumRecs', D, ErrLock); (* handle error *)
RETURN; (* and abort procedure. *)
END;
IF FIO.IOresult() > 0 THEN (* If error reading, *)
HandleError('GetNumRecs', D, ErrRead); (* handle error *)
RETURN; (* and abort procedure. *)
END; (* Else, number of recs was *)
ErrCode := 0; (* read OK. *)
END GetNumRecs;

PROCEDURE PutNumRecs(D : DBFile);
VAR TempIOcheck : BOOLEAN;
BEGIN
TempIOcheck := FIO.IOcheck; (* Save IOcheck state *)
FIO.IOcheck := FALSE; (* Turn off FIO.IO checking *)
FIO.Seek(D^.Handle, 4); (* Seek to # recs field *)
IF FIO.IOresult() > 0 THEN (* If error seeking, *)
HandleError('PutNumRecs', D, ErrSeek); (* handle error *)
FIO.IOcheck := TempIOcheck; (* restore IOcheck state *)
RETURN; (* and abort procedure. *)
END; (* Else with file ptr set, *)
FIO.WrBin(D^.Handle, D^.NumRecs, 4); (* Update # of recs in DBF *)
FIO.IOcheck := TempIOcheck; (* Restore IOcheck state. *)
IF FIO.IOresult() > 0 THEN (* If error writing, *)
HandleError('PutNumRecs', D, ErrWrite); (* handle error *)
RETURN; (* and abort procedure. *)
END; (* Else, number of recs was *)
ErrCode := 0; (* updated OK. *)
END PutNumRecs;

(****************************************************************************)
(* Exported procedures for manipulating DBF records and files including *)
(* AddRec, CloseDBF, FieldName, FileName, OpenDBF, DelRec, UnDelRec, *)
(* Deleted, GetFieldName, GetField, OldField, PutField, GetRecBuf, *)
(* PutRecBuf, RecChanged, RecCount, RecNo, RecSize, Encrypted, HasMDX, *)
(* Incomplete, FieldData *)
(* For details on each procedure, see DBF.DOC documentation. *)
(****************************************************************************)

PROCEDURE AddRec(D : DBFile); (* Add Record to data file *)
VAR FPtr : LONGCARD;
TempIOcheck : BOOLEAN;
BEGIN
IF D^.Shared THEN (* When multi-user, *)
LockNumRecs(D); (* Lock file against *)
IF ErrCode > 0 THEN RETURN; END; (* simultaneous adds. *)
GetNumRecs(D); (* Get # of recs in file *)
IF ErrCode > 0 THEN (* If error reading, *)
UnLockNumRecs(D); (* unlock file, *)
RETURN; (* and abort add. *)
END; (* Else, file locked and *)
END; (* last rec # retrieved. *)
TempIOcheck := FIO.IOcheck; (* Save cur IOcheck state *)
FIO.IOcheck := FALSE; (* Turn off FIO err checkng *)
FPtr := VAL(LONGCARD, D^.HeadLen) + (* Calculate position for *)
D^.NumRecs * VAL(LONGCARD,D^.RecLen); (* new record in file. *)
FIO.Seek(D^.Handle, FPtr); (* Seek to it (to EOF) *)
IF FIO.IOresult() > 0 THEN (* If error seeking to EOF, *)
IF D^.Shared THEN (* If multi-user mode, *)
UnLockNumRecs(D); (* unlock file *)
END; (* for other users *)
HandleError('AddRec', D, ErrSeek); (* handle seek error *)
FIO.IOcheck := TempIOcheck; (* restore IOcheck state *)
RETURN; (* and abort add. *)
END; (* Else ready to write rec *)
D^.Buf^[1] := ' '; (* Mark rec as undeleted *)
FIO.WrBin(D^.Handle, D^.Buf^, D^.RecLen); (* Write record to file *)
FIO.IOcheck := TempIOcheck; (* Restore IOcheck state *)
IF FIO.IOresult() > 0 THEN (* If error writing record, *)
IF D^.Shared THEN (* If multi-user mode, *)
UnLockNumRecs(D); (* unlock file *)
END; (* for other users *)
HandleError('AddRec', D, ErrWrite); (* handle write error *)
RETURN; (* and abort add. *)
END; (* Else record written OK *)
INC(D^.NumRecs); (* So bump # recs in file *)
IF D^.Shared THEN (* If multi-user mode, *)
PutNumRecs(D); (* write updated # recs *)
UnLockNumRecs(D); (* and unlock data file *)
END; (* Make newly added record *)
IF Safety THEN (* If safety mode then *)
FlushBuffers(D^.Handle); (* flush buffers to disk *)
END; (* for extra safety *)
D^.CurRec := D^.NumRecs; (* Make new rec current *)
ErrCode := 0; (* Return result code: OK *)
END AddRec;

PROCEDURE CloseDBF (VAR D : DBFile); (* Close data file *)
VAR Yr, Mn, Dt, H : CARDINAL;
HPtr, NPtr : HashPtr;
TempIOcheck : BOOLEAN;
BEGIN
ErrCode := 0; (* Initialize result code *)
TempIOcheck := FIO.IOcheck; (* Save IOcheck state *)
FIO.IOcheck := FALSE; (* Turn off FIO err checking*)
GetSysDate(Yr, Mn, Dt); (* Read the system date, *)
IF Yr > 1900 THEN Yr := Yr - 1900; END; (* Adjust Year to 2 digits *)
D^.LastUpdate[2] := CHR(Dt); (* Convert date to DBase *)
D^.LastUpdate[1] := CHR(Mn); (* file header date *)
D^.LastUpdate[0] := CHR(Yr); (* string format. *)
FIO.Seek(D^.Handle, 1); (* Seek to 2nd byte in hdr, *)
IF FIO.IOresult() > 0 THEN (* If error seeking, *)
HandleError('CloseDBF', D, ErrSeek); (* handle error. *)
ELSE (* Else with file ptr set, *)
IF D^.Shared THEN (* If sharing file, *)
FIO.WrBin(D^.Handle, D^.LastUpdate, 3); (* update just date *)
ELSE (* Else, if single user, *)
FIO.WrBin(D^.Handle, D^.LastUpdate, 7); (* update date,numrecs *)
END;
IF FIO.IOresult() > 0 THEN (* If error updating file *)
HandleError('CloseDBF', D, ErrWrite); (* handle error *)
END;
END;
FIO.Close(D^.Handle); (* Close the file *)
FIO.IOcheck := TempIOcheck; (* Restore IOcheck state *)
IF FIO.IOresult() > 0 THEN (* If file not closed OK, *)
HandleError('CloseDBF', D, ErrClose); (* handle erorr. *)
END;
FOR H := 0 TO MaxFields DO (* Release all memory used *)
HPtr := D^.HashTable[H]; (* Get ptr from table. *)
WHILE HPtr # NIL DO (* While not nil ptr, *)
NPtr := HPtr^.Next; (* Get ptr to next, *)
DEALLOCATE(HPtr, SIZE(HashType)); (* deallocate cur, *)
HPtr := NPtr; (* and try next ptr *)
END; (* continue till NIL *)
END; (* Do for all in table. *)
DEALLOCATE(D^.Buf, D^.RecLen + 1); (* Release file's rec buffr *)
DEALLOCATE(D^.OldBuf, D^.RecLen + 1); (* Release aux rec buffer *)
DEALLOCATE(D^.FIELDS, D^.HeadLen - 32); (* Release file's field list*)
DEALLOCATE(D, SIZE(DBFRec)); (* Deallocate DBF variable *)
END CloseDBF;

PROCEDURE FieldName(D: DBFile; (* Return name of field *)
FieldNum : CARDINAL; (* specified by FieldNum *)
VAR FieldName : ARRAY OF CHAR); (* in string FieldName *)
BEGIN
IF (FieldNum > 0) AND (* If valid field number, *)
(FieldNum <= D^.NumFields) (* get field's name from *)
THEN Copy(FieldName, D^.FIELDS^[FieldNum].Name); (* field array *)
ErrCode := 0; (* and set result = OK *)
ELSE FieldName[0] := 0C; (* Else return blank name, *)
ErrCode := ErrField; (* and set error code. *)
END;
END FieldName;

PROCEDURE FileName(D : DBFile; (* Return name of DBF file *)
VAR FileName:ARRAY OF CHAR); (* as it was opened. *)
BEGIN
Copy(FileName, D^.Name); (* Return file name *)
ErrCode := 0; (* Set result = OK *)
END FileName;

PROCEDURE OpenDBF(VAR D : DBFile; (* Open data file specified *)
FileName : ARRAY OF CHAR); (* in FileName. *)
VAR H : CARDINAL;
FPtr : LONGCARD;
FieldBufLen : CARDINAL;
nRead : CARDINAL;
TempIOcheck : BOOLEAN;

PROCEDURE InsertHash(Str : ARRAY OF CHAR; (* Insert field name into *)
FieldNum : CARDINAL); (* hash table of field names*)
VAR ListPtr : HashPtr; (* for quick access to field*)
Hash : CARDINAL; (* data by field name. *)
BEGIN
Hash := HashString(Str, 128); (* Get hash of field name *)
IF NOT Available(SIZE(HashType)) THEN (* If not enough memory, *)
HandleError('OpenDBF', D, ErrMemory); (* handle error and *)
RETURN; (* abort procedure. *)
END;
IF D^.HashTable[Hash] = NIL THEN (* If hash table entry empty*)
ALLOCATE(D^.HashTable[Hash], SIZE(HashType)); (* create entry in *)
Copy(D^.HashTable[Hash]^.Name, Str); (* table, and copy in *)
D^.HashTable[Hash]^.Field := FieldNum; (* field name *)
D^.HashTable[Hash]^.Next := NIL; (* and init next ptr *)
ELSE ListPtr := D^.HashTable[Hash]; (* Else if entry present, *)
WHILE ListPtr^.Next # NIL DO (* follow next ptrs *)
ListPtr := ListPtr^.Next; (* till an empty ptr *)
END; (* While *) (* is found. *)
ALLOCATE(ListPtr^.Next, SIZE(HashType)); (* create new entry in table*)
Copy(ListPtr^.Next^.Name, Str); (* and copy in the *)
ListPtr^.Next^.Field := FieldNum; (* field name and *)
ListPtr^.Next^.Next := NIL; (* init next ptr *)
END; (* If D^.HashTable = Nil *)
END InsertHash;

PROCEDURE ReadHeader(); (* Read DBF file header *)
BEGIN
nRead:=FIO.RdBin(D^.Handle, D^.HasMemo, 32);(* Read header into buffer *)
IF (nRead # 32) AND (GetExtErr() = 33) THEN (* If file header locked, *)
HandleError('OpenDBF', D, ErrLockedDBF); (* handle error *)
RETURN; (* and abort procedure *)
END;
IF (FIO.IOresult() > 0) OR (* If error reading, or *)
(nRead # 32) OR (* file too short or *)
((D^.HasMemo # 3) AND (* invalid data in DBF *)
(D^.HasMemo # 131)) OR (* header, then the file *)
(D^.RecLen > MaxRecLen) OR (* is either damaged, or *)
(D^.Incomplete > 1) OR (* not a valid DBF file. *)
(D^.Encrypted > 1) OR
(D^.HasMDX > 1) THEN
HandleError('OpenDBF', D, ErrBadDBF); (* handle error *)
RETURN; (* and abort procedure *)
END;
END ReadHeader;

PROCEDURE ReadFieldList(); (* Read list of fields from *)
VAR MemReq : CARDINAL; (* DBF file header. *)
BEGIN
FieldBufLen := D^.HeadLen - 32; (* Calc size of field buffer*)
D^.NumFields := (FieldBufLen DIV 32); (* Calc. number of fields *)
MemReq := (2 * (D^.RecLen + 1)) + (* Calc amount of memory for*)
(FieldBufLen); (* field and rec buffers. *)
IF NOT Available(MemReq) THEN (* If not enough memory *)
HandleError('OpenDBF', D, ErrMemory); (* handle error, *)
RETURN; (* and abort procedure. *)
END; (* Else with adequate memory*)
ALLOCATE(D^.Buf, D^.RecLen+1); (* Allocate record buffer *)
ALLOCATE(D^.OldBuf, D^.RecLen+1); (* Allocate change buffer *)
ALLOCATE(D^.FIELDS, FieldBufLen); (* Allocate field array and *)
nRead:=FIO.RdBin(D^.Handle, D^.FIELDS^, FieldBufLen); (* Read array *)
IF (nRead # FieldBufLen) AND (* If field array was locked*)
(GetExtErr() = 33) THEN (* by another user/appl. *)
HandleError('OpenDBF',D,ErrLockedDBF); (* handle error. *)
RETURN; (* and abort procedure. *)
END;
IF (FIO.IOresult() > 0) OR (* If error reading field *)
(nRead # FieldBufLen) THEN (* array from disk, *)
HandleError('OpenDBF',D,ErrBadDBF); (* handle error. *)
RETURN; (* and abort procedure. *)
END;
END ReadFieldList;

PROCEDURE CalcFieldOfs(); (* Calculate offset of each *)
VAR N, Offset : CARDINAL; (* field within the record *)
BEGIN (* 1st byte is deleted flag *)
Offset := 2; (* First field is at ofs 2 *)
FOR N := 1 TO D^.NumFields DO (* For all preceding fields *)
D^.FIELDS^[N].Ofs := Offset; (* add field length of *)
Offset := Offset + (* preceding fields to *)
VAL(CARDINAL, D^.FIELDS^[N].Len); (* offset of cur field. *)
END;
END CalcFieldOfs;

PROCEDURE HashFields(); (* Hash field names into a *)
VAR H : CARDINAL; (* hash table for rapid *)
BEGIN (* access by field name. *)
FOR H := 0 TO MaxFields DO (* Initialize hash table *)
D^.HashTable[H] := NIL; (* for field names *)
END;
FOR H := 1 TO D^.NumFields DO (* Hash field names so *)
InsertHash (D^.FIELDS^[H].Name, H); (* they can later be *)
IF (ErrCode > 0) THEN RETURN; END; (* accessed by name *)
END;
END HashFields;

PROCEDURE ReleaseMem; (* Release memory allocated *)
BEGIN (* for data file *)
DEALLOCATE(D^.Buf, D^.RecLen+1);
DEALLOCATE(D^.OldBuf, D^.RecLen+1);
DEALLOCATE(D^.FIELDS, D^.HeadLen - 32);
END ReleaseMem;

BEGIN
IF NOT Available(SIZE(DBFRec)) THEN (* If insufficient memory, *)
HandleError('OpenDBF', D, ErrMemory); (* handle err.r *)
RETURN; (* and abort procedure. *)
END; (* Else with adequate memory*)
ALLOCATE(D, SIZE(DBFRec)); (* Allocate file variable *)
Copy(D^.Name, FileName); (* Save filename *)
Caps(D^.Name); (* Convert to upper case *)
IF Pos(D^.Name, '.') > HIGH(D^.Name) THEN (* If file extension not *)
Append(D^.Name, '.DBF'); (* specified, append *)
END; (* default of '.DBF' *)
D^.Shared := MultiUser; (* Store sharing mode *)
IF MultiUser (* If in multi-user mode, *)
THEN FIO.ShareMode := FIO.ShareDenyNone; (* setup for shared open *)
ELSE FIO.ShareMode := FIO.ShareCompat; (* else for exclusive *)
END; (* access *)
TempIOcheck := FIO.IOcheck; (* Save IOcheck state *)
FIO.IOcheck := FALSE; (* Turn off FIO err checking*)
D^.Handle := FIO.Open(D^.Name); (* Open data file *)
IF FIO.IOresult() > 0 THEN (* If error opening DBF file*)
HandleError('OpenDBF', D, ErrOpen); (* handle error *)
DEALLOCATE(D, SIZE(DBFRec)); (* return used memory, *)
FIO.IOcheck := TempIOcheck; (* restore IOcheck state *)
RETURN; (* and abort procedure *)
END;
ReadHeader(); (* Read in DBF header *)
IF (ErrCode > 0) THEN (* If error getting header, *)
FIO.Close(D^.Handle); (* close DBF file, *)
DEALLOCATE(D, SIZE(DBFRec)); (* return used memory, *)
FIO.IOcheck := TempIOcheck; (* restore IOcheck state *)
RETURN; (* and abort procedure. *)
END;
ReadFieldList(); (* Read in Field list *)
IF (ErrCode > 0) THEN (* If error getting list, *)
FIO.Close(D^.Handle); (* close DBF file *)
ReleaseMem(); (* release buffers, *)
DEALLOCATE(D, SIZE(DBFRec)); (* return used memory, *)
FIO.IOcheck := TempIOcheck; (* restore IOcheck state *)
RETURN; (* and abort procedure. *)
END;
CalcFieldOfs(); (* Calc. Field offsets *)
HashFields(); (* Generate hash table *)
IF (ErrCode > 0) THEN (* If error making hash tbl *)
FIO.Close(D^.Handle); (* close DBF file *)
ReleaseMem(); (* release buffers *)
DEALLOCATE(D, SIZE(DBFRec)); (* return used memory, *)
FIO.IOcheck := TempIOcheck; (* restore IOcheck state *)
RETURN; (* and abort procedure. *)
END;
FIO.IOcheck := TempIOcheck; (* Restore IOcheck state *)
D^.CurRec := VAL(LONGCARD, 0); (* Set DBF's cur rec ptr *)
ErrCode := 0; (* Set result code to OK *)
END OpenDBF;

PROCEDURE DelRec(D : DBFile); (* Delete current record *)
BEGIN
D^.Buf^[1] := '*'; (* Place deleted flag in rec*)
PutRec(D, D^.CurRec); (* Store record in file. *)
END DelRec;

PROCEDURE UnDelRec(D : DBFile); (* Undelete current record *)
BEGIN
D^.Buf^[1] := ' '; (* Clear deleted flag in rec*)
PutRec(D, D^.CurRec); (* Store record in file. *)
END UnDelRec;

PROCEDURE Deleted(D : DBFile) : BOOLEAN; (* Return deleted status of *)
BEGIN (* current record. *)
RETURN D^.Buf^[1] = '*'; (* Return status. *)
ErrCode := 0; (* Set return code *)
END Deleted;

PROCEDURE GetFieldNum(D : DBFile; (* Get number of field with *)
FieldName : ARRAY OF CHAR; (* name specified *)
VAR FieldNum : CARDINAL);
VAR ListPtr : HashPtr;
Hash : CARDINAL;
ErrStr : ARRAY [0..25] OF CHAR;
BEGIN
Caps(FieldName); (* Convert to upper case *)
Hash := HashString(FieldName,128); (* Hash fieldname *)
ListPtr := D^.HashTable[Hash]; (* Get ptr to field data *)
WHILE (ListPtr # NIL) AND (* Search hash list *)
((Compare(FieldName, ListPtr^.Name)) # 0) DO
ListPtr := ListPtr^.Next;
END; (* While *)
IF ListPtr # NIL THEN (* Check if field was found *)
FieldNum := ListPtr^.Field; (* field num from Hash tbl. *)
ErrCode := 0;
ELSE (* Else if field not found *)
Concat(ErrStr,'GetFieldNum - ',FieldName); (* prepare err message *)
HandleError(ErrStr, D, ErrField); (* handle error. *)
END;
END GetFieldNum;

PROCEDURE GetField(D : DBFile; (* Get entry from current *)
FieldName : ARRAY OF CHAR; (* record for specified *)
VAR TheField : ARRAY OF CHAR); (* field. *)
VAR StrIdx, BufIdx : CARDINAL;
FieldNum : CARDINAL;
BEGIN
IF (D^.CurRec = 0)OR(D^.CurRec > D^.NumRecs) (* If no current record, *)
THEN HandleError('GetField', D, ErrRecNo); (* handle error *)
RETURN; (* and abort procedure *)
END; (* Else with valid rec # *)
GetFieldNum(D, FieldName, FieldNum); (* Get field number *)
IF ErrCode > 0 THEN (* If invalid field name, *)
TheField[0] := 0C; (* clear return field, *)
RETURN; (* and end procedure. *)
END;
StrIdx := 0; (* Index into output Str *)
BufIdx := D^.FIELDS^[FieldNum].Ofs; (* Index into record buff. *)
WHILE (StrIdx <= HIGH(TheField)) AND
(StrIdx < VAL(CARDINAL, D^.FIELDS^[FieldNum].Len)) DO
TheField[StrIdx] := D^.Buf^[BufIdx]; (* Copy data from rec buf. *)
INC(StrIdx); INC(BufIdx); (* into the output field *)
END;
IF (StrIdx <= HIGH(TheField)) THEN (* If output str is larger *)
TheField[StrIdx] := 0C; (* than the field, end it *)
END; (* with a NUL *)
RightTrim(TheField); (* Remove trailing spaces *)
END GetField;

PROCEDURE OldField(D : DBFile; (* Get field entry from cur *)
FieldName : ARRAY OF CHAR; (* record before it was *)
VAR TheField : ARRAY OF CHAR); (* modified *)
VAR StrIdx, BufIdx : CARDINAL;
FieldNum : CARDINAL;
BEGIN
IF (D^.CurRec = 0)OR(D^.CurRec > D^.NumRecs) (* If no current record, *)
THEN HandleError('OldField', D, ErrRecNo); (* handle error *)
RETURN; (* and abort procedure *)
END; (* Else with valid rec # *)
GetFieldNum(D, FieldName, FieldNum); (* Get field number *)
IF ErrCode > 0 THEN (* If invalid field name, *)
TheField[0] := 0C; (* clear return field, *)
RETURN; (* and end procedure. *)
END;
StrIdx := 0; (* Index into output Str *)
BufIdx := D^.FIELDS^[FieldNum].Ofs; (* Index into record buff. *)
WHILE (StrIdx <= HIGH(TheField)) AND
(StrIdx < VAL(CARDINAL, D^.FIELDS^[FieldNum].Len)) DO
TheField[StrIdx] := D^.OldBuf^[BufIdx]; (* Copy data from rec buf. *)
INC(StrIdx); INC(BufIdx); (* into the output field *)
END;
IF (StrIdx <= HIGH(TheField)) THEN (* If output str is larger *)
TheField[StrIdx] := 0C; (* than the field, end it *)
END; (* with a NUL *)
RightTrim(TheField); (* Remove trailing spaces *)
END OldField;

PROCEDURE PutField(D : DBFile; (* Store string in field *)
FieldName : ARRAY OF CHAR; (* specified in current *)
TheField : ARRAY OF CHAR); (* record. *)
VAR StrIdx, BufIdx, FieldLen : CARDINAL;
FieldNum : CARDINAL;
BEGIN
GetFieldNum(D, FieldName, FieldNum); (* Get field number *)
IF ErrCode > 0 THEN (* If invalid field name, *)
TheField[0] := 0C; (* clear return field, *)
RETURN; (* and end procedure. *)
END;
StrIdx := 0; (* Index into input Str *)
FieldLen := Length(TheField); (* End of input string *)
BufIdx := D^.FIELDS^[FieldNum].Ofs; (* Index into record buff. *)
WHILE (StrIdx < FieldLen) AND
(StrIdx < VAL(CARDINAL, D^.FIELDS^[FieldNum].Len)) DO
D^.Buf^[BufIdx] := TheField[StrIdx]; (* Copy data into rec buf. *)
INC(StrIdx); INC(BufIdx); (* from the input field *)
END;
WHILE (StrIdx < VAL(CARDINAL, D^.FIELDS^[FieldNum].Len)) DO
D^.Buf^[BufIdx] := ' '; (* right fill field with *)
INC(StrIdx); INC(BufIdx); (* spaces for dBase *)
END; (* compatibility. *)
END PutField;

PROCEDURE GetRecBuf(D : DBFile; Buf : ADDRESS); (* Read entire current rec *)
BEGIN (* into user record buffer *)
Move(D^.Buf, Buf, D^.RecLen); (* Copy rec to user buffer *)
ErrCode := 0; (* Set result code *)
END GetRecBuf;

PROCEDURE PutRecBuf(D : DBFile; Buf : ADDRESS); (* Copy user record buffer *)
BEGIN (* to current record. *)
Move(Buf, D^.Buf, D^.RecLen); (* Copy rec to DBF rec buf *)
ErrCode := 0; (* Set result code *)
END PutRecBuf;

PROCEDURE RecChanged(D : DBFile) : BOOLEAN; (* Returns True if record *)
BEGIN (* has been changed. *)
ErrCode := 0; (* Set result code *)
RETURN(D^.Buf # D^.OldBuf); (* Return changed status *)
END RecChanged;

PROCEDURE RecCount(D : DBFile) : LONGCARD; (* Return # of recs in file *)
VAR nRead : CARDINAL;
Attempts : CARDINAL;
TempIOcheck : BOOLEAN;
BEGIN
IF NOT D^.Shared THEN (* If in single user mode, *)
ErrCode := 0; (* set result code *)
RETURN D^.NumRecs; (* return record count *)
END; (* Else if sharing file, *)
TempIOcheck := FIO.IOcheck; (* Save cur IOcheck state *)
FIO.IOcheck := FALSE; (* Turn off FIO err checking*)
FIO.Seek(D^.Handle, 4); (* Seek to # of recs field *)
IF FIO.IOresult() > 0 THEN (* If error seeking, *)
HandleError('RecCount', D, ErrSeek); (* handle error. *)
FIO.IOcheck := TempIOcheck; (* restore IOcheck state *)
RETURN VAL(LONGCARD, 0); (* and abort procedure. *)
END; (* Else with file ptr set, *)
Attempts := 0; (* Init count of attempts *)
REPEAT (* Enter read numrecs loop *)
nRead := FIO.RdBin(D^.Handle,D^.NumRecs,4);(* Read # recs in DBF *)
IF (nRead # 4) AND (GetExtErr() = 33) THEN (* If # records locked, *)
INC(Attempts); (* bump retry count, *)
END; (* and try again. *)
UNTIL (nRead = 4) OR (Attempts > 20); (* Continue for 20 attempts *)
FIO.IOcheck := TempIOcheck; (* Restore IOcheck state *)
IF Attempts > 20 THEN (* If # of records locked, *)
HandleError('RecCount', D, ErrLock); (* handle error *)
RETURN VAL(LONGCARD, 0); (* and abort procedure. *)
END; (* Else file not locked. *)
IF FIO.IOresult() > 0 THEN (* If error reading, *)
HandleError('RecCount', D, ErrRead); (* handle error *)
RETURN VAL(LONGCARD, 0); (* and abort procedure. *)
END; (* Else Num recs read OK so *)
ErrCode := 0; (* Set result to OK and *)
RETURN D^.NumRecs; (* Return # of records *)
END RecCount;

PROCEDURE RecNo (D : DBFile) : LONGCARD; (* Return cur. rec. number *)
BEGIN
ErrCode := 0; (* Init result code *)
RETURN D^.CurRec; (* Return current rec num. *)
END RecNo;

PROCEDURE RecSize (D : DBFile) : CARDINAL; (* Return record size *)
BEGIN
ErrCode := 0; (* Init result code *)
RETURN D^.RecLen; (* Return record length *)
END RecSize;

PROCEDURE Encrypted (D : DBFile) : BOOLEAN; (* Return True if file is *)
BEGIN (* encrypted (DB IV only) *)
ErrCode := 0; (* Init result code *)
RETURN (D^.Encrypted > 0); (* Return encrypted flag *)
END Encrypted;

PROCEDURE HasMDX (D : DBFile) : BOOLEAN; (* Return True if file has *)
BEGIN (* an MDX (dBase IV only)*)
ErrCode := 0; (* Init result code *)
RETURN (D^.HasMDX > 0); (* Return MDX present flag *)
END HasMDX;

PROCEDURE Incomplete (D : DBFile) : BOOLEAN; (* Return True if incomplete*)
BEGIN (* transaction occured *)
ErrCode := 0; (* (dBase IV only) *)
RETURN (D^.Incomplete > 0); (* Return Incomplete flag *)
END Incomplete;

PROCEDURE NumFields(D : DBFile) : CARDINAL; (* Get data on file struct. *)
BEGIN
ErrCode := 0; (* Set result code = OK *)
RETURN D^.NumFields; (* Return fields per rec *)
END NumFields;

PROCEDURE FieldData(D:DBFile; (* Get data on field struct *)
FieldName : ARRAY OF CHAR; (* for field specified. *)
VAR Type : CHAR;
VAR Len, Dec : CARDINAL);
VAR FieldNum : CARDINAL;
BEGIN
Type := ''; Len := 0; Dec := 0; (* Initialize results *)
GetFieldNum(D, FieldName, FieldNum); (* Get field number *)
IF ErrCode > 0 THEN RETURN; END; (* If invalid field, exit *)
Type:= D^.FIELDS^[FieldNum].Type; (* Get field structure from *)
Len := VAL(CARDINAL,D^.FIELDS^[FieldNum].Len);(* DBF header. *)
Dec := VAL(CARDINAL,D^.FIELDS^[FieldNum].Dec);
END FieldData;

BEGIN
MultiUser := FALSE; (* Init Single user mode *)
Safety := FALSE; (* Don't flush buf. on write*)
ErrCheck := AskUser; (* Stop & report on errors *)
ErrCode := 0; (* Result code = OK *)
DosCode := 0; (* Dos Extended err code=OK *)
END DBF.

  3 Responses to “Category : Modula II Source Code
Archive   : DBFTOOLS.ZIP
Filename : DBF.MOD

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/