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

 
Output of file : BUILDNDX.MOD contained in archive : DBFTOOLS.ZIP
(*# data( stack_size => C000H ) *)

IMPLEMENTATION MODULE BuildNDX;

(**********************************************************************)
(* Copyright 1990,1991 by David Albert *)
(**********************************************************************)
(* This module exports procedures and data to allow Modula-2 users to *)
(* quickly and easily create complex index files compatible with *)
(* dBase III, III+, and IV index files. *)
(* Complete documentation for this module can be found in DBF.DOC *)
(**********************************************************************)
(* Modification History *)
(* 3/26/91 by DAA removed dependencies on non-standard libraries *)
(**********************************************************************)

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

CONST
MaxRecLen = 4000; (* Max dBase record length *)
MaxFields = 200; (* Max dBase fields per record *)
MaxKeyLen = 100; (* Max dBase key field length *)
PageSize = 512; (* dBase NDX index page size *)

TYPE
HashPtr = POINTER TO HashType;
HashType = RECORD
Name : ARRAY[0..10] OF CHAR;
Field : CARDINAL;
Next : HashPtr;
END; (* HashType *)
HashTable= ARRAY[0..MaxFields] OF HashPtr;

DBFHeaderType = RECORD (* DBF file header *)
HasMemo : SHORTCARD;
LastUpdate : ARRAY[0..2] OF CHAR;
NumRecs : LONGCARD; (* Total recs in DBF *)
HeadLen : CARDINAL; (* DBF File header len *)
RecLen : CARDINAL; (* Data record length *)
Reserved1 : ARRAY[0..1] OF CHAR; (* Reserved for future use. *)
Incomplete : SHORTCARD; (* Incomplete transctn flag *)
Encrypted : SHORTCARD; (* Encrypted file flag *)
Reserved2 : ARRAY[0..11] OF CHAR; (* Reserved for Network use *)
HasMDX : SHORTCARD; (* Associated MDX flag *)
Reserved3 : ARRAY[0..2] OF CHAR; (* Reserved for future use. *)
END;
DBFFieldType = RECORD
Name : ARRAY[0..10] OF CHAR;
Type : CHAR;
Reserved1 : ARRAY[0..3] OF CHAR;
Len : SHORTCARD;
Dec : SHORTCARD;
Ofs : CARDINAL; (* Actually Reserved *)
WorkAreaID : SHORTCARD;
Reserved3 : ARRAY[0..10] OF CHAR;
END; (* FieldType *)
DBFFieldArray = ARRAY [1..200] OF DBFFieldType;
DBFRecType = ARRAY [0..MaxRecLen] OF CHAR;
DBFType = RECORD
Handle : CARDINAL;
Open : BOOLEAN;
RecPtr : POINTER TO DBFRecType;
Key : ARRAY [0..MaxKeyLen-1] OF CHAR;
HashTable : HashTable;
Hdr : DBFHeaderType;
NumFields : CARDINAL;
Fields : POINTER TO DBFFieldArray;
END;

NDXPageType = RECORD
InPage : CARDINAL;
Dummy : CARDINAL;
Keys : ARRAY [0..609] OF CHAR;
END;
NDXKeyType = RECORD
PPtr, RPtr : LONGCARD;
Key : ARRAY [0..99] OF CHAR;
END;
NDXType = RECORD
Handle : CARDINAL;
Open : BOOLEAN;
(* NDX Header *)
Root : LONGCARD;
NextFree : LONGCARD;
Dummy1 : LONGCARD; (* Unused *)
KeyLen : CARDINAL; (* Length of key field *)
KeysPerPage : CARDINAL; (* # Keys per index page *)
Numeric : CARDINAL; (* 1 = Numeric or Date *)
KeySize : CARDINAL; (* Key + Pointers size *)
Dummy2 : CARDINAL;
Unique : CARDINAL; (* 1 = Unique *)
KeyField : ARRAY[0..99] OF CHAR;
Dummy3 : ARRAY[0..387] OF CHAR;
END; (* NDXRec *)

BufArray = ARRAY [0..32767] OF CHAR;

KeyType = RECORD
FName : ARRAY [0..10] OF CHAR;
FNum : CARDINAL;
FLen : CARDINAL;
FType : CHAR;
END;

VAR ProcName : ARRAY [0..29] OF CHAR;
DBF : DBFType;
NDX : NDXType;
KeyCount : LONGCARD;
KeyArray : ARRAY [1..10] OF KeyType;
NumKeys : CARDINAL;
Retries : CARDINAL;

PROCEDURE Power(X, Y : LONGCARD) : LONGCARD;
VAR Result : LONGCARD;
BEGIN
Result := 1;
WHILE Y > 0 DO
Result := Result * X;
DEC(Y);
END;
RETURN Result;
END Power;

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

PROCEDURE SetRetries(Delay, Retries : CARDINAL);
VAR Regs : Registers;
BEGIN
Regs.AX := 440BH;
Regs.CX := Delay;
Regs.DX := Retries;
Dos(Regs);
END SetRetries;

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

PROCEDURE HandleError(Proc : ARRAY OF CHAR; Code : CARDINAL);
VAR DialogWin : WinType;
Key : CHAR;
Status : CARDINAL;
BEGIN
ErrCode := Code;
DosCode := GetExtErr();
IF ErrCheck = None THEN (* If no Internal err chking*)
RETURN; (* just return error code*)
END; (* for caller to handle *)
DialogWin := Open(WinDef(15, 5, 65, 12, White, Black,
TRUE, TRUE, FALSE, TRUE, DoubleFrame, White, Black));
WrStr('Error:'); WrLn;
WrStr(' Procedure : '); WrStr(Proc); WrLn;
WrStr(' Message : ');
CASE Code OF
ErrOpen : WrStr('Unable to find/open file.');
| ErrClose : WrStr('Unable to close file.');
| ErrRead : WrStr('Unable to read page.');
| ErrWrite : WrStr('Unable to write page.');
| ErrSeek : WrStr('Unable to seek to page.');
| ErrLock : WrStr('Index/page locked by another user.');
| ErrUnLock : WrStr('Unable to unlock index/page.');
| ErrHandle : WrStr('Index file not open.');
| ErrMemory : WrStr('Insufficient memory.');
| ErrPageNo : WrStr('Invalid Page Number.');
| ErrBadNDX : WrStr('Index file invalid or damaged.');
| ErrLockedNDX : WrStr('Index file locked by another user.');
| ErrBadField : WrStr('Invalid field specified.');
ELSE WrStr('error cause unknown.');
END;
WrLn;
IF Code < ErrPageNo 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;

PROCEDURE OpenDBF(VAR DBF : DBFType; Name : ARRAY OF CHAR);
VAR nRead : CARDINAL;
FNum, FOfs : CARDINAL;
DBFName : ARRAY [0..79] OF CHAR;
TempIOcheck : BOOLEAN;
TempShareMode : BITSET;


PROCEDURE InsertHash(Str : ARRAY OF CHAR; FieldNum : CARDINAL);
VAR ListPtr : HashPtr;
Hash : CARDINAL;
BEGIN
Hash := HashString(Str, 128);
IF NOT Available(SIZE(HashType)) THEN
HandleError('InsertHash', ErrMemory);
RETURN;
END;
IF DBF.HashTable[Hash] = NIL
THEN NEW(DBF.HashTable[Hash]);
Copy(DBF.HashTable[Hash]^.Name, Str);
DBF.HashTable[Hash]^.Field := FieldNum;
DBF.HashTable[Hash]^.Next := NIL;
ELSE ListPtr := DBF.HashTable[Hash];
WHILE ListPtr^.Next # NIL DO
ListPtr := ListPtr^.Next;
END; (* While *)
NEW(ListPtr^.Next);
Copy(ListPtr^.Next^.Name, Str);
ListPtr^.Next^.Field := FieldNum;
ListPtr^.Next^.Next := NIL;
END; (* If DBF.HashTable = Nil *)
END InsertHash;

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

PROCEDURE CalcFieldOfs;
VAR FOfs, FNum : CARDINAL;
BEGIN
FOfs := 1;
FOR FNum := 1 TO DBF.NumFields DO
WITH DBF.Fields^[FNum] DO
Ofs := FOfs;
INC(FOfs, VAL(CARDINAL, Len));
END;
END;
END CalcFieldOfs;

BEGIN
DBF.Open := FALSE; (* Init DBF file status *)
Copy(DBFName, Name); (* Copy file name to var. *)
Caps(DBFName); (* Conver to upper case. *)
IF Pos(DBFName,'.DBF') > HIGH(DBFName) THEN (* If no extension given, *)
Append(DBFName, '.DBF'); (* append '.DBF' *)
END; (* to file name. *)
TempIOcheck := FIO.IOcheck; (* Save err checking status *)
FIO.IOcheck := FALSE; (* Turn off err checking *)
TempShareMode := FIO.ShareMode; (* Save sharing status *)
FIO.ShareMode := FIO.ShareDenyNone; (* Set file mode to shared *)
DBF.Handle := FIO.Open(DBFName); (* and open DBF (data) file *)
FIO.IOcheck := TempIOcheck; (* Restore err checking *)
FIO.ShareMode := TempShareMode; (* Restore sharing mode *)
IF FIO.IOresult() # 0 THEN (* If unable to open it, *)
HandleError('OpenDBF', ErrOpen); (* display error message *)
RETURN; (* and abort now. *)
END; (* Else, DBF opened OK *)
Retries := 0; (* Init retry count and *)
LOOP (* Attempt to read header *)
TempIOcheck := FIO.IOcheck; (* Save err checking status *)
FIO.IOcheck := FALSE; (* Turn off err checking *)
nRead:=FIO.RdBin(DBF.Handle,DBF.Hdr,SIZE(DBF.Hdr)); (* Read DBF hdr *)
FIO.IOcheck := TempIOcheck; (* Restore err checking *)
IF GetExtErr() = 33 THEN (* If header was locked, *)
Delay(100); (* wait for 1/10 second *)
INC(Retries); (* bump retry count, *)
IF (Retries > 100) THEN (* If 100 retries, *)
HandleError('OpenDBF', ErrLock); (* display error msg *)
IF ErrCheck = None THEN RETURN; END;(* ErrCheck=None->abrt*)
Retries := 0; (* reset retry count *)
END; (* and continue. *)
ELSIF FIO.IOresult() > 0 THEN (* If error reading header, *)
TempIOcheck := FIO.IOcheck; (* Save err chking status*)
FIO.IOcheck := FALSE; (* Turn off err checking *)
FIO.Close(DBF.Handle); (* Close the file *)
FIO.IOcheck := TempIOcheck; (* restore err checking *)
HandleError('OpenDBF', ErrRead); (* display error message *)
RETURN; (* and abort procedure *)
ELSE EXIT; (* Else, header read OK *)
END;
END;
DBF.NumFields:=(DBF.Hdr.HeadLen-32) DIV 32; (* Calc # of fields in file *)
IF NOT Available(DBF.NumFields*32) THEN (* If not enough memory, *)
TempIOcheck := FIO.IOcheck; (* Save err chking status*)
FIO.IOcheck := FALSE; (* Turn off err checking *)
FIO.Close(DBF.Handle); (* close the file, *)
FIO.IOcheck := TempIOcheck; (* restore err checking *)
HandleError('OpenDBF', ErrMemory); (* display error message *)
RETURN; (* and abort procedure *)
END;
ALLOCATE(DBF.Fields, DBF.NumFields * 32); (* Allocate mem for fields *)
TempIOcheck := FIO.IOcheck; (* Save err checking status *)
FIO.IOcheck := FALSE; (* Turn off err checking *)
nRead := FIO.RdBin(DBF.Handle,DBF.Fields^,DBF.NumFields*32); (* Read 'em *)
FIO.IOcheck := TempIOcheck; (* Restore err checking *)
IF (FIO.IOresult() # 0) OR (* If error reading fields, *)
(nRead # (DBF.NumFields*32)) THEN (* or incomplete read, *)
TempIOcheck := FIO.IOcheck; (* Save err chking status*)
FIO.IOcheck := FALSE; (* Turn off err checking *)
FIO.Close(DBF.Handle); (* close file, *)
FIO.IOcheck := TempIOcheck; (* restore err checking *)
DEALLOCATE(DBF.Fields,DBF.NumFields*32); (* return mem allocated *)
HandleError('OpenDBF', ErrRead); (* display error message *)
RETURN; (* and abort procedure. *)
END;
CalcFieldOfs(); (* Calc ofs of fields in rec*)
HashFields(); (* Make field name hash tbl *)
DBF.Open := TRUE; (* Else data file is opened *)
ErrCode := 0;
END OpenDBF;

PROCEDURE CloseDBF;
VAR TempIOcheck : BOOLEAN;
BEGIN
IF DBF.Open THEN (* If data file is open, *)
TempIOcheck := FIO.IOcheck; (* Save err check state *)
FIO.IOcheck := FALSE; (* Turn off err checking *)
FIO.Close(DBF.Handle); (* Close data file *)
FIO.IOcheck := TempIOcheck; (* Restore err checking *)
DEALLOCATE(DBF.Fields, DBF.NumFields*32); (* Release DBF memory *)
DBF.Open := FALSE; (* Set DBF closed flag *)
IF FIO.IOresult() # 0 (* If error closing, *)
THEN HandleError('CloseDBF', ErrClose);(* set error code *)
ELSE ErrCode := 0; (* else set closed = OK *)
END;
END;
END CloseDBF;

PROCEDURE CreateNDX(VAR NDX : NDXType; Name : ARRAY OF CHAR;
KeyType : CHAR;
KeyLen : CARDINAL;
KeyExp : ARRAY OF CHAR);
VAR NDXName : ARRAY [0..79] OF CHAR;
S, nWrit : CARDINAL;
TempIOcheck : BOOLEAN;
BEGIN
NDX.Open := FALSE; (* Init NDX files status *)
Copy(NDXName, Name); (* Copy file name to var. *)
Caps(NDXName); (* Convert to upper case *)
IF Pos(NDXName,'.NDX') > HIGH(NDXName) THEN (* If no extension given, *)
Append(NDXName, '.NDX'); (* append '.NDX' *)
END; (* to file name. *)
TempIOcheck := FIO.IOcheck; (* Save cur IOcheck status *)
FIO.IOcheck := FALSE; (* Then turn off IO checking*)
NDX.Handle := FIO.Create(NDXName); (* Attempt to create file. *)
FIO.IOcheck := TempIOcheck; (* Restore IO err checking *)
IF FIO.IOresult() > 0 THEN (* If unable to create, *)
HandleError('CreateNDX', ErrCreate); (* display error message *)
RETURN; (* and abort procedure *)
END;
NDX.Root := 1; (* Init root pointer *)
NDX.NextFree := 1; (* Init next free page ptr *)
NDX.Dummy1 := 0; (* Init dummy pointer. *)
IF KeyType = 'N'
THEN NDX.Numeric := 1;
NDX.KeyLen := 8;
ELSE NDX.Numeric := 0;
NDX.KeyLen := KeyLen;
END;
IF (NDX.KeyLen MOD 4) = 0 THEN (* Calculate size of each *)
NDX.KeySize:=KeyLen + 8; (* NDX key including the *)
ELSE (* record and page ptrs *)
NDX.KeySize := NDX.KeyLen+8+
(4 - (NDX.KeyLen MOD 4));
END;
NDX.KeysPerPage := 508 DIV NDX.KeySize; (* Calculate keys per page *)
NDX.Dummy2 := 0; (* Init dummy pointer. *)
NDX.Unique := 0; (* Set duplicates allowed *)
Copy(NDX.KeyField, KeyExp); (* Copy key exp to header *)
Fill(ADR(NDX.Dummy3), SIZE(NDX.Dummy3), 0C); (* Fill balance of header *)
TempIOcheck := FIO.IOcheck; (* Save cur IOcheck status *)
FIO.IOcheck := FALSE; (* Then turn off IO checking*)
FIO.WrBin(NDX.Handle, NDX.Root, PageSize); (* Write NDX header to disk *)
FIO.IOcheck := TempIOcheck; (* Restore IO err checking *)
IF (FIO.IOresult() > 0) THEN (* If error writing header, *)
TempIOcheck := FIO.IOcheck; (* Save IOcheck status *)
FIO.IOcheck := FALSE; (* Turn off IO checking *)
FIO.Close(NDX.Handle); (* close index file, *)
FIO.IOcheck := TempIOcheck; (* restore err checking *)
HandleError('CreateNDX', ErrWrite); (* display error message *)
RETURN; (* and abort procedure *)
END;
NDX.Open := TRUE; (* Else NDX created OK. *)
ErrCode := 0; (* Set result code = OK *)
END CreateNDX;

PROCEDURE CloseNDX;
VAR FPtr : LONGCARD;
nWrit : CARDINAL;
TempIOcheck : BOOLEAN;
BEGIN
IF NDX.Open THEN (* If index is open *)
TempIOcheck := FIO.IOcheck; (* Save IOchecking state *)
FIO.IOcheck := FALSE; (* Turn off err checking *)
FIO.Seek(NDX.Handle, 0); (* Seek to index header. *)
FIO.IOcheck := TempIOcheck; (* Restore IO err chcking *)
IF FIO.IOresult() # 0 THEN (* If error seeking, *)
HandleError('CloseNDX', ErrSeek); (* display error message *)
RETURN; (* and abort procedure. *)
END; (* Else ptr at top of NDX *)
TempIOcheck := FIO.IOcheck; (* Save IOchecking state *)
FIO.IOcheck := FALSE; (* Turn off err checking *)
FIO.WrBin(NDX.Handle, NDX.Root, PageSize);(* Write NDX header *)
FIO.IOcheck := TempIOcheck; (* Restore IO err chcking *)
IF FIO.IOresult() > 0 THEN (* If error writing header, *)
HandleError('CloseNDX', ErrWrite); (* display error message *)
RETURN; (* and abort procedure *)
END;
TempIOcheck := FIO.IOcheck; (* Save IOchecking state *)
FIO.IOcheck := FALSE; (* Turn off err checking *)
FIO.Close(NDX.Handle); (* Close index file. *)
FIO.IOcheck := TempIOcheck; (* Restore I/O err chcking *)
IF FIO.IOresult() # 0 THEN (* If error closing file, *)
HandleError('CloseNDX', ErrClose); (* display error message *)
RETURN; (* and abort procedure. *)
END; (* Else file closed OK *)
ErrCode := 0; (* Set result code to OK *)
NDX.Open := FALSE; (* Set NDX status to closed *)
END;
END CloseNDX;

(****************************************************************************)
(* EXTRACT KEYS from data file and store in index leaf pages. *)
(****************************************************************************)

PROCEDURE ExtractKeys;
VAR FPtr : LONGCARD;
RecNum : LONGCARD;
TempIOcheck : BOOLEAN;

InBuf : POINTER TO BufArray;
InBufLen : CARDINAL;
InBufStart : LONGCARD;
InBufEnd : LONGCARD;
InBufRecs : CARDINAL;
InBufPtr : CARDINAL;

OutBuf : POINTER TO BufArray;
OutBufLen : CARDINAL;
OutBufPages : CARDINAL;
OutPNum : LONGCARD;
OutPagePtr : POINTER TO NDXPageType;
OutKeyPtr : POINTER TO NDXKeyType;

PROCEDURE MakeBuffers;
BEGIN
InBufLen := (32767 DIV DBF.Hdr.RecLen) * DBF.Hdr.RecLen;
OutBufLen:= (32767 DIV PageSize) * PageSize;
WHILE NOT Available(InBufLen) DO (* If not enough memory for *)
InBufLen := InBufLen - DBF.Hdr.RecLen; (* input buffer, shrink *)
END; (* buffer till enough. *)
IF InBufLen < DBF.Hdr.RecLen THEN (* If input buffer is too *)
HandleError('MakeBuffers', ErrMemory); (* small to be useful, *)
RETURN; (* abort with error msg *)
END; (* Else with input buf size *)
ALLOCATE(InBuf, InBufLen); (* Allocate input buffer *)
WHILE NOT Available(OutBufLen) DO (* If not enough memory for *)
OutBufLen := OutBufLen - PageSize; (* output buffer, keep *)
END; (* reducing size till ok *)
IF OutBufLen < PageSize THEN (* If no memory left, *)
DEALLOCATE(InBuf, InBufLen); (* Return InBuffer memory *)
HandleError('MakeBuffers', ErrMemory); (* Display error message *)
RETURN; (* and abort procedure. *)
END; (* Else, memory available *)
ALLOCATE(OutBuf, OutBufLen); (* Allocate output buffer *)
ErrCode := 0; (* Return result = OK *)
END MakeBuffers;

PROCEDURE RemoveBuffers;
BEGIN
DEALLOCATE(InBuf, InBufLen); (* De-allocate input and *)
DEALLOCATE(OutBuf, OutBufLen); (* output buffers *)
END RemoveBuffers;

PROCEDURE RewindDBF;
VAR TempIOcheck : BOOLEAN;
BEGIN
TempIOcheck := FIO.IOcheck; (* Save I/O err checking *)
FIO.IOcheck := FALSE; (* Turn off err checking *)
FPtr := VAL(LONGCARD, DBF.Hdr.HeadLen); (* Set file pointer to *)
FIO.Seek(DBF.Handle, FPtr); (* first record in DBF file *)
FIO.IOcheck := TempIOcheck; (* Restore IO err checking *)
IF FIO.IOresult() > 0 THEN (* If error seeking, *)
HandleError('RewindDBF', ErrSeek); (* display error message *)
RETURN; (* and abort procedure *)
END;
InBufStart := VAL(LONGCARD, 0); (* Set buffer start record *)
InBufEnd := VAL(LONGCARD, 0); (* Set buffer end record *)
InBufRecs := 0; (* Set records in buffer *)
RecNum := VAL(LONGCARD, 0); (* Set current record number*)
END RewindDBF;

PROCEDURE ClrNDXBuf;
BEGIN
KeyCount := VAL(LONGCARD, 0);
OutBufPages := 0;
OutPagePtr := ADR(OutBuf^[0]);
Fill(OutPagePtr, PageSize, 0C);
OutKeyPtr := ADR(OutPagePtr^.Keys[0]);
OutPNum := NDX.NextFree;
END ClrNDXBuf;

PROCEDURE ReadDBFKey;
VAR nRead : CARDINAL;
Retries : CARDINAL;
TempIOcheck : BOOLEAN;
BEGIN
REPEAT (* Repeat *)
IF (InBufRecs = 0) OR (* If no records in buffer *)
(InBufPtr >= InBufLen) THEN (* at end of cur buffer, *)
Retries := 0; (* Init retry count and *)
LOOP (* Attempt to read buffer *)
TempIOcheck := FIO.IOcheck; (* Save IO checking state *)
FIO.IOcheck := FALSE; (* Then turn off IO chking *)
nRead:=FIO.RdBin(DBF.Handle,InBuf^, InBufLen); (* Read buffer*)
FIO.IOcheck := TempIOcheck; (* Restore IO err checking *)
IF GetExtErr() = 33 THEN (* If buffer was locked, *)
Delay(100); (* wait for 1/10 second *)
INC(Retries); (* bump retry count, *)
IF (Retries > 100) THEN (* If 100 retries, *)
HandleError('ReadDBFKey', ErrLock); (* display err msg *)
IF ErrCheck = None THEN RETURN; END;(* and abort proc *)
Retries := 0; (* reset retries *)
END; (* and continue. *)
ELSIF FIO.IOresult() > 0 THEN (* If error reading header, *)
FIO.IOcheck := FALSE; (* Turn off err chk*)
FIO.Close(DBF.Handle); (* Close the file *)
FIO.IOcheck := TempIOcheck; (* Restore Err chk *)
HandleError('ReadDBFKey', ErrRead); (* display err msg *)
RETURN; (* and abort proc *)
ELSE EXIT; (* Else, header read OK *)
END; (* so exit loop *)
END;
InBufStart := InBufEnd + 1; (* calc buf start rec *)
InBufRecs := nRead DIV DBF.Hdr.RecLen; (* calc recs in buf *)
INC(InBufEnd,VAL(LONGCARD, InBufRecs)); (* calc buf end rec *)
InBufPtr := 0; (* reset cur buf pos *)
END;
DBF.RecPtr := ADR(InBuf^[InBufPtr]); (* Set ptr to record *)
INC(InBufPtr, DBF.Hdr.RecLen); (* Bump buf rec ptr *)
INC(RecNum); (* Bump record number *)
UNTIL Filter() OR (RecNum > DBF.Hdr.NumRecs); (* Until no more recs or *)
KeyExp(DBF.Key); (* Get key from record *)
ErrCode := 0; (* Set result code = OK *)
END ReadDBFKey;

PROCEDURE WriteNDXPage;
VAR nWrit : CARDINAL;
TempIOcheck : BOOLEAN;
BEGIN
INC(NDX.NextFree); (* Bump index free page ptr *)
INC(OutPNum); (* Bump current page number *)
INC(OutBufPages); (* Bump num pages in buffer *)
IF (OutBufPages*PageSize >= OutBufLen) OR (* If NDX buffer is full or *)
(RecNum >= DBF.Hdr.NumRecs) THEN (* last page in sub-idx, *)
TempIOcheck := FIO.IOcheck; (* save IO checking state*)
FIO.IOcheck := FALSE; (* turn off IO checking *)
FIO.WrBin(NDX.Handle, OutBuf^, (OutBufPages*PageSize)); (* Wr page *)
FIO.IOcheck := TempIOcheck; (* restore IO checking *)
IF FIO.IOresult() > 0 THEN
HandleError('WriteNDXPage', ErrWrite);
RETURN;
END;
OutBufPages := 0;
END;
OutPagePtr := ADR(OutBuf^[(OutBufPages * PageSize)]);
Fill(OutPagePtr, PageSize, 0C);
ErrCode := 0;
END WriteNDXPage;

PROCEDURE WriteNDXKey;
BEGIN
WITH OutPagePtr^ DO (* With current NDX page, *)
IF (InPage >= NDX.KeysPerPage) THEN (* If page is full *)
WriteNDXPage; (* write page to buffer *)
IF ErrCode > 0 THEN RETURN; END; (* If error, abort now *)
END; (* and setup new page *)
END;
WITH OutPagePtr^ DO (* With current NDX page, *)
OutKeyPtr:=ADR(Keys[InPage*NDX.KeySize]); (* Set ptr to current key *)
INC(InPage); (* Bump # of keys in page *)
END;
WITH OutKeyPtr^ DO (* With current NDX key, *)
RPtr := RecNum; (* Set record number *)
Move(ADR(DBF.Key),ADR(Key),NDX.KeyLen); (* Copy key to index page *)
END;
ErrCode := 0;
END WriteNDXKey;

BEGIN
MakeBuffers; (* Create data & idx bufs *)
IF ErrCode > 0 THEN RETURN; END; (* If error, abort now. *)
RewindDBF; (* Go to top of data file *)
IF ErrCode > 0 THEN (* If error reading DBF, *)
RemoveBuffers; (* release buffer memory *)
RETURN; (* and return to caller *)
END; (* with error set. *)
ClrNDXBuf; (* Initialize index buffer *)
LOOP (* For each record in DBF, *)
ReadDBFKey; (* Get a record & key, *)
IF ErrCode > 0 THEN EXIT; END; (* If error, exit loop. *)
IF RecNum <= DBF.Hdr.NumRecs THEN (* If valid record found, *)
WriteNDXKey; (* add key to index *)
IF ErrCode > 0 THEN EXIT; END; (* if error, abort now *)
INC(KeyCount); (* and bump key count *)
ELSE (* Else end of records, *)
IF (KeyCount = 0) OR (* if empty file, or *)
(OutPagePtr^.InPage > 0) THEN (* page not written, *)
WriteNDXPage; (* write last page *)
IF ErrCode > 0 THEN EXIT; END; (* if error, abort *)
END; (* to index. *)
ErrCode := 0; (* set result = OK *)
EXIT; (* exit loop *)
END;
END; (* Continue for each record *)
RemoveBuffers; (* Remove data & idx bufs *)
ErrCode := 0; (* Set result code = OK *)
END ExtractKeys;

(****************************************************************************)
(* SORT KEYS in index leafs into alphabetical order. *)
(****************************************************************************)

PROCEDURE SortKeys;
TYPE
BufType = POINTER TO BufArray;
VAR SKey, EKey : LONGCARD;
SPage, EPage : LONGCARD;
ELeaf : LONGCARD;
Buf : ARRAY [1..10] OF BufType;
BPages : ARRAY [1..10] OF CARDINAL;
BStart : ARRAY [1..10] OF LONGCARD;
NBufs : CARDINAL;
BufLen : CARDINAL;
BufEnd : LONGCARD;
PagesPerBuf : CARDINAL;
KeysPerBuf : CARDINAL;

PROCEDURE MakeSortBuffers;
VAR BNum : CARDINAL;
MaxBuf : CARDINAL;
BEGIN
BNum := 0;
BufLen := (32767 DIV PageSize)*PageSize; (* Calculate max buffer len *)
WHILE NOT Available(BufLen) DO (* If not enough memory, *)
BufLen := BufLen - PageSize; (* reduce buffer size, *)
END; (* and try again. *)
IF BufLen < PageSize THEN (* If no memory available, *)
HandleError('MakeSortBuffers', ErrMemory); (*display error message *)
RETURN; (* and abort procedure. *)
END; (* Else with memory avail. *)
NBufs := 0; (* Init number of buffers *)
FOR BNum := 1 TO 10 DO (* For each buffer, *)
IF Available(BufLen) THEN (* If memory available, *)
ALLOCATE(Buf[BNum], BufLen); (* allocate the buffer *)
INC(NBufs); (* and bump buffer count *)
END;
BStart[BNum] := 0; (* Init starting page number*)
BPages[BNum] := 0; (* Init pages in buffer *)
END;
ErrCode := 0;
END MakeSortBuffers;

PROCEDURE RemoveSortBuffers;
VAR BNum : CARDINAL;
BEGIN
FOR BNum := 1 TO NBufs DO
DEALLOCATE(Buf[BNum], BufLen);
END;
END RemoveSortBuffers;

PROCEDURE GetSortKeyData;
BEGIN
SPage := VAL(LONGCARD, 1); (* Start with first page. *)
EPage := NDX.NextFree - 1; (* Get ending page number. *)
SKey := 1; (* Calc. start key number *)
EKey := KeyCount; (* Calc. end key number *)
PagesPerBuf:= BufLen DIV PageSize; (* Calc. pages per buffer *)
KeysPerBuf := PagesPerBuf*NDX.KeysPerPage;(* Calc. keys per buffer *)
END GetSortKeyData;

PROCEDURE LoadBuffers;
VAR FPtr : LONGCARD;
nRead : CARDINAL;
BNum : CARDINAL;
CurPage : LONGCARD;
TempIOcheck : BOOLEAN;
BEGIN
FPtr := VAL(LONGCARD, PageSize); (* Calc first page position *)
TempIOcheck := FIO.IOcheck;
FIO.IOcheck := FALSE;
FIO.Seek(NDX.Handle, FPtr); (* Seek to first subidx page*)
FIO.IOcheck := TempIOcheck; (* Restore err checking *)
IF FIO.IOresult() > 0 THEN (* If error seeking, *)
HandleError('LoadBuffers', ErrSeek);
RETURN;
END;
CurPage := VAL(LONGCARD, 1); (* Init current page number *)
BNum := 0; (* Start with first buffer. *)
REPEAT (* For each buffer, *)
INC(BNum); (* Bump cur buf num. *)
FIO.IOcheck := FALSE; (* Turn off err checking *)
nRead := FIO.RdBin(NDX.Handle, Buf[BNum]^, BufLen); (* Load buffer *)
FIO.IOcheck := TempIOcheck; (* Restore err checking *)
IF FIO.IOresult() > 0 THEN
HandleError('LoadBuffers', ErrRead);
RETURN;
END;
BPages[BNum] := nRead DIV PageSize; (* Calc pages in buffer *)
BStart[BNum] := CurPage; (* Calc start page num *)
INC(CurPage, VAL(LONGCARD,BPages[BNum])); (* update start page *)
UNTIL (nRead < BufLen) OR (* Cont till end of file or *)
(BNum = NBufs) OR (* buffers full, or *)
(CurPage >= EPage); (* last key in sub-idx. *)
BufEnd := CurPage - 1; (* Calculate end page *)
ErrCode := 0; (* Set result code = OK *)
END LoadBuffers;

PROCEDURE SaveBuffers;
VAR FPtr : LONGCARD;
nWrit : CARDINAL;
BufSize : CARDINAL;
BNum : CARDINAL;
TempIOcheck : BOOLEAN;
BEGIN
TempIOcheck := FIO.IOcheck;
FIO.IOcheck := FALSE;
FPtr := VAL(LONGCARD, PageSize); (* Calc first page position *)
FIO.Seek(NDX.Handle, FPtr); (* Seek to first page *)
FIO.IOcheck := TempIOcheck; (* Restore I/O err chking *)
IF FIO.IOresult() > 0 THEN (* If error seeking, *)
HandleError('SaveBuffers', ErrSeek); (* display error message *)
RETURN; (* and abort procedure. *)
END;
BNum := 1; (* Starting with first buf *)
WHILE (BPages[BNum]>0)AND(BNum<=NBufs) DO (* For each buf with data, *)
BufSize := BPages[BNum] * PageSize; (* calc size of data *)
FIO.IOcheck := FALSE; (* Turn off err checking *)
FIO.WrBin(NDX.Handle,Buf[BNum]^,BufSize); (* write buf to disk *)
FIO.IOcheck := TempIOcheck; (* Restore err checking *)
IF FIO.IOresult() > 0 THEN (* if error writing, *)
HandleError('SaveBuffers', ErrWrite); (* display error msg *)
RETURN; (* and abort procedure*)
END;
INC(BNum); (* bump to next buffer *)
END;
ErrCode := 0;
END SaveBuffers;

PROCEDURE GetKey(KeyNum : LONGCARD;
VAR Key : NDXKeyType);
VAR BNum : CARDINAL; (* Buffer number *)
PNum : LONGCARD; (* Page number *)
LKNum : LONGCARD; (* Key number (long) *)
KNum : CARDINAL; (* Key number (short) *)
BufPtr : CARDINAL; (* Position of key in page *)
KPtr : POINTER TO NDXKeyType; (* Pointer to key in page *)
nRead : CARDINAL;
FPtr : LONGCARD;
TempIOcheck : BOOLEAN;
BEGIN
PNum := 1 + ((KeyNum - 1) DIV (* Calculate number of page *)
VAL(LONGCARD, NDX.KeysPerPage)); (* which contains key. *)
LKNum := (KeyNum - 1) MOD (* Calculate number of key *)
VAL(LONGCARD, NDX.KeysPerPage); (* within the page *)
KNum := VAL(CARDINAL, LKNum); (* Convert key to cardinal *)
IF PNum <= VAL(LONGCARD, BufEnd) THEN (* If the page is in buffer *)
BNum:=VAL(CARDINAL, (PNum - 1) DIV (* calc which buffer it *)
VAL(LONGCARD, PagesPerBuf)) + 1; (* is in. *)
PNum := PNum - BStart[BNum]; (* Calc page in buf *)
BufPtr := (VAL(CARDINAL,PNum)*PageSize) (* calc position of page *)
+ 4 + (KNum * NDX.KeySize); (* and key in page. *)
KPtr := ADR(Buf[BNum]^[BufPtr]); (* Set pointer to key *)
Move(KPtr, ADR(Key), NDX.KeySize); (* Copy to output key. *)
ELSE (* Else if page on disk, *)
FPtr := (PNum * PageSize) + 4 + (* calc position of page *)
(LKNum * (VAL(LONGCARD, NDX.KeySize)));(* and key within page *)
TempIOcheck := FIO.IOcheck;
FIO.IOcheck := FALSE;
FIO.Seek(NDX.Handle, FPtr); (* Seek to key on disk *)
FIO.IOcheck := TempIOcheck;
IF FIO.IOresult() > 0 THEN
HandleError('GetKey', ErrSeek);
RETURN;
END;
FIO.IOcheck := FALSE;
nRead := FIO.RdBin(NDX.Handle, Key, NDX.KeySize); (* read key *)
FIO.IOcheck := TempIOcheck;
IF FIO.IOresult() > 0 THEN
HandleError('GetKey', ErrRead);
RETURN;
END;
END; (* from disk *)
ErrCode := 0;
END GetKey;

PROCEDURE PutKey(KeyNum : LONGCARD;
VAR Key : NDXKeyType);
VAR BNum : CARDINAL; (* Buffer number *)
PNum : LONGCARD; (* Page number *)
LKNum : LONGCARD; (* Key number (long) *)
KNum : CARDINAL; (* Key number (short) *)
BufPtr : CARDINAL; (* Position of key in page *)
KPtr : POINTER TO NDXKeyType; (* Pointer to key in page *)
nWrit : CARDINAL;
FPtr : LONGCARD;
TempIOcheck : BOOLEAN;
BEGIN
PNum := 1 + ((KeyNum - 1) DIV (* Calculate number of page *)
VAL(LONGCARD, NDX.KeysPerPage)); (* which contains key. *)
LKNum := (KeyNum - 1) MOD (* Calculate number of key *)
VAL(LONGCARD, NDX.KeysPerPage); (* within the page *)
KNum := VAL(CARDINAL, LKNum); (* Convert key to cardinal *)
IF PNum <= VAL(LONGCARD, BufEnd) THEN (* If the page is in buffer *)
BNum:=VAL(CARDINAL, (PNum - 1) DIV (* calc which buffer it *)
VAL(LONGCARD, PagesPerBuf)) + 1; (* is in. *)
PNum := PNum - BStart[BNum]; (* Calc page in buf *)
BufPtr := (VAL(CARDINAL,PNum)*PageSize) (* calc position of page *)
+ 4 + (KNum * NDX.KeySize); (* and key in page. *)
KPtr := ADR(Buf[BNum]^[BufPtr]); (* Set pointer to key *)
Move(ADR(Key), KPtr, NDX.KeySize); (* Copy to output key. *)
ELSE (* Else if page on disk, *)
FPtr := (PNum * PageSize) + 4 + (* calc position of page *)
(LKNum * (VAL(LONGCARD, NDX.KeySize))); (* and key within page *)
TempIOcheck := FIO.IOcheck;
FIO.IOcheck := FALSE;
FIO.Seek(NDX.Handle, FPtr); (* Seek to key on disk *)
FIO.IOcheck := TempIOcheck;
IF FIO.IOresult() > 0 THEN
HandleError('PutKey', ErrSeek);
RETURN;
END;
FIO.IOcheck := FALSE;
FIO.WrBin(NDX.Handle, Key, NDX.KeySize);(* Read key from disk *)
FIO.IOcheck := TempIOcheck;
IF FIO.IOresult() > 0 THEN
HandleError('PutKey', ErrWrite);
RETURN;
END;
END; (* from disk *)
ErrCode := 0;
END PutKey;

PROCEDURE SwapKeys(K1, K2 : LONGCARD);
VAR Key1,
Key2,
TempKey : NDXKeyType;
BEGIN
GetKey(K1, Key1);
IF ErrCode > 0 THEN RETURN; END;
GetKey(K2, Key2);
IF ErrCode > 0 THEN RETURN; END;
TempKey := Key2;
PutKey(K2, Key1);
IF ErrCode > 0 THEN RETURN; END;
PutKey(K1, TempKey);
IF ErrCode > 0 THEN RETURN; END;
END SwapKeys;

PROCEDURE CmpKey( K1, K2 :ARRAY OF CHAR) :INTEGER;
VAR A :CARDINAL;
EndK1, EndK2 :BOOLEAN;
I1,I2 :INTEGER;
BEGIN
A := 0;
LOOP
EndK1 := (A > HIGH(K1)) OR (K1[A] = 0C) OR (A = NDX.KeyLen);
EndK2 := (A > HIGH(K2)) OR (K2[A] = 0C) OR (A = NDX.KeyLen);
IF (EndK1 OR EndK2) THEN EXIT END;
IF (K1[A] = K2[A]) THEN INC(A)
ELSIF K1[A] < K2[A] THEN RETURN(-1)
ELSE RETURN(1)
END;
END;
I1 := INTEGER(ORD(EndK1));
I2 := INTEGER(ORD(EndK2));
RETURN (I2-I1);
END CmpKey;

PROCEDURE QS(Left, Right: LONGCARD);
VAR
M, L, R : LONGCARD;
MKey,
LKey,
RKey : NDXKeyType;
BEGIN
L := Left;
R := Right;
M := (L+R) DIV 2;
GetKey(M, MKey);
IF ErrCode > 0 THEN RETURN; END;
REPEAT
GetKey(L, LKey);
IF ErrCode > 0 THEN RETURN; END;
WHILE (CmpKey(LKey.Key, MKey.Key) < 0) DO
INC(L);
GetKey(L, LKey);
IF ErrCode > 0 THEN RETURN; END;
END;
GetKey(R, RKey);
IF ErrCode > 0 THEN RETURN; END;
WHILE (CmpKey(MKey.Key, RKey.Key) < 0) DO
DEC(R);
GetKey(R, RKey);
IF ErrCode > 0 THEN RETURN; END;
END;
IF (L <= R) THEN
SwapKeys(L, R);
IF ErrCode > 0 THEN RETURN; END;
INC(L);
DEC(R);
END;
UNTIL (L > R);
IF Left < R THEN
QS(Left, R);
IF ErrCode > 0 THEN RETURN; END;
END;
IF L < Right THEN
QS(L, Right);
IF ErrCode > 0 THEN RETURN; END;
END;
END QS;

(****************************************************************************)
(* BUILD TREE create node pages from sorted leaf pages. *)
(****************************************************************************)

PROCEDURE InitPage(VAR P : NDXPageType);
BEGIN
P.InPage := 0;
P.Dummy := 0;
Fill(ADR(P.Keys), SIZE(P.Keys), 0C);
END InitPage;

PROCEDURE GetPage(PNum : LONGCARD;
VAR P : NDXPageType);
VAR FPtr : LONGCARD;
nRead: CARDINAL;
TempIOcheck : BOOLEAN;
BEGIN
TempIOcheck := FIO.IOcheck; (* Save cur I/O check state *)
FIO.IOcheck := FALSE; (* Turn off I/O err cheking *)
FPtr := PNum * PageSize;
FIO.Seek(NDX.Handle, FPtr);
FIO.IOcheck := TempIOcheck; (* Restore I/O err checking *)
IF FIO.IOresult() > 0 THEN (* If error seeking, *)
HandleError('GetPage', ErrSeek); (* Display error message *)
RETURN; (* and abort procedure. *)
END; (* Else, seek was OK. *)
FIO.IOcheck := FALSE;
nRead := FIO.RdBin(NDX.Handle, P, PageSize);
FIO.IOcheck := TempIOcheck;
IF (FIO.IOresult() > 0) OR (nRead # PageSize) THEN
HandleError('GetPage', ErrRead);
RETURN;
END;
ErrCode := 0;
END GetPage;

PROCEDURE PutPage(PNum : LONGCARD;
VAR P: NDXPageType);
VAR FPtr : LONGCARD;
TempIOcheck : BOOLEAN;
BEGIN
TempIOcheck := FIO.IOcheck; (* Save cur I/O check state *)
FIO.IOcheck := FALSE; (* Turn off I/O err cheking *)
FPtr := PNum * PageSize; (* Calculate page position *)
FIO.Seek(NDX.Handle, FPtr); (* Seek to page in file *)
FIO.IOcheck := TempIOcheck; (* Restore I/O err checking *)
IF FIO.IOresult() > 0 THEN (* If error seeking, *)
HandleError('GetPage', ErrSeek); (* Display error message *)
RETURN; (* and abort procedure. *)
END; (* Else, seek was OK. *)
FIO.IOcheck := FALSE; (* Turn off I/O err cheking *)
FIO.WrBin(NDX.Handle, P, PageSize); (* So write page to disk *)
FIO.IOcheck := TempIOcheck; (* Restore I/O err checking *)
IF FIO.IOresult() > 0 THEN (* If error seeking, *)
HandleError('GetPage', ErrSeek); (* Display error message *)
END; (* Else, write was OK. *)
ErrCode := 0;
END PutPage;

PROCEDURE BuildLevel(Level : CARDINAL);
VAR PInNum, POutNum : LONGCARD;
LeafNum, LeafOfs: LONGCARD;
PIn, POut : NDXPageType;
KIn, KOut : POINTER TO NDXKeyType;
BEGIN
PInNum := SPage;
POutNum := EPage + 1;
LeafOfs := Power(VAL(LONGCARD, NDX.KeysPerPage+1),
VAL(LONGCARD, Level-1));
LeafNum := 0;
WHILE PInNum <= EPage DO
InitPage(POut);
WHILE (PInNum <= EPage) AND
(POut.InPage <= NDX.KeysPerPage) DO
LeafNum := LeafNum + LeafOfs;
IF LeafNum > ELeaf THEN LeafNum := ELeaf; END;
GetPage(LeafNum, PIn);
IF ErrCode > 0 THEN RETURN; END;
KIn := ADR(PIn.Keys[(PIn.InPage-1) * NDX.KeySize]);
KOut:= ADR(POut.Keys[POut.InPage * NDX.KeySize]);
Move(KIn, KOut, NDX.KeySize);
KOut^.PPtr := PInNum;
KOut^.RPtr := VAL(LONGCARD, 0);
INC(POut.InPage);
INC(PInNum);
END;
DEC(POut.InPage);
PutPage(POutNum, POut);
IF ErrCode > 0 THEN RETURN; END;
INC(POutNum);
INC(NDX.NextFree);
END;
SPage := EPage + 1;
EPage := POutNum - 1;
ErrCode := 0;
END BuildLevel;

PROCEDURE BuildTree;
VAR Level : CARDINAL;
KNum : LONGCARD;
BEGIN
Level := 1;
ELeaf := EPage;
WHILE EPage > SPage DO
BuildLevel(Level);
IF ErrCode > 0 THEN RETURN; END;
INC(Level);
END;
NDX.Root := EPage;
ErrCode := 0;
END BuildTree;

BEGIN
MakeSortBuffers; (* Create buffers for sort *)
IF ErrCode > 0 THEN RETURN; END; (* If error then abort. *)
GetSortKeyData; (* Get data on key field. *)
LoadBuffers; (* Load buffers with keys. *)
IF ErrCode > 0 THEN (* If error loading buffers *)
RemoveSortBuffers; (* release sort buffers, *)
RETURN; (* and abort sorting now *)
END; (* Else with buffers loaded *)
QS(SKey, EKey); (* Sort all keys for subidx *)
IF ErrCode > 0 THEN (* If error sorting keys, *)
RemoveSortBuffers; (* release sort buffers, *)
RETURN; (* and abort sorting now *)
END; (* Else with buffers sorted *)
SaveBuffers; (* Save buffers to disk. *)
IF ErrCode > 0 THEN (* If error saving buffers, *)
RemoveSortBuffers; (* release sort buffers, *)
RETURN; (* and abort procedure. *)
END; (* Else with buffers saved *)
BuildTree; (* Build sub-index tree. *)
RemoveSortBuffers; (* Return buffers to memory *)
END SortKeys;

(****************************************************************************)
(* MAIN BODY OF INDEX program including support procedures *)
(****************************************************************************)

PROCEDURE Deleted() : BOOLEAN;
BEGIN
RETURN DBF.RecPtr^[0] = '*';
END Deleted;

PROCEDURE GetFieldNum(FieldName : ARRAY OF CHAR;
VAR FieldNum : CARDINAL);
VAR ListPtr : HashPtr;
Hash : CARDINAL;
BEGIN
Caps(FieldName); (* Convert to upper case *)
Hash := HashString(FieldName,128); (* Hash fieldname *)
ListPtr := DBF.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 (* If field was not found, *)
HandleError('GetFieldNum', ErrBadField);
RETURN;
END;
FieldNum := ListPtr^.Field; (* field num from Hash tbl.*)
ErrCode := 0;
END GetFieldNum;

PROCEDURE GetField(FieldName : ARRAY OF CHAR;
VAR Field : ARRAY OF CHAR);
VAR StrIdx, BufIdx : CARDINAL;
FieldNum : CARDINAL;
BEGIN
GetFieldNum(FieldName, FieldNum); (* Get field number *)
IF ErrCode > 0 THEN (* If invalid field name, *)
Field[0] := 0C; (* clear return field, *)
RETURN; (* and end procedure. *)
END;
StrIdx := 0; (* Index into output Str *)
BufIdx := DBF.Fields^[FieldNum].Ofs; (* Index into record buff.*)
WHILE (StrIdx <= HIGH(Field)) AND
(StrIdx < VAL(CARDINAL, DBF.Fields^[FieldNum].Len)) DO
Field[StrIdx] := DBF.RecPtr^[BufIdx]; (* Copy data from rec buf. *)
INC(StrIdx); INC(BufIdx); (* into the output field *)
END;
IF (StrIdx <= HIGH(Field)) THEN (* If output str is larger *)
Field[StrIdx] := 0C; (* than the field, end it *)
END; (* with a NUL *)
END GetField;

PROCEDURE DefaultFilter() : BOOLEAN;
BEGIN
RETURN TRUE;
END DefaultFilter;

PROCEDURE DefaultKeyExp(VAR Key : ARRAY OF CHAR);
VAR F : CARDINAL;
Temp : ARRAY [0..MaxKeyLen-1] OF CHAR;
BEGIN
Key[0] := 0C;
FOR F := 1 TO NumKeys DO
GetField(KeyArray[F].FName, Temp);
Append(Key, Temp);
END;
END DefaultKeyExp;

PROCEDURE MakeNDX(DBFName : ARRAY OF CHAR; (* Name of DBF file *)
NDXName : ARRAY OF CHAR; (* Name of NDX file *)
KeyName : ARRAY OF CHAR; (* Key field expression *)
KeyLen : CARDINAL); (* Key field length *)
VAR P, F, Field : CARDINAL;
Expression : ARRAY [0..255] OF CHAR;
KeyType : CHAR;
BEGIN
IF Length(KeyName) = 0 THEN RETURN; END; (* If no key exp, abort now *)
Caps(KeyName); (* Else convert key expressn*)
Copy(Expression, KeyName); (* to upper case *)
OpenDBF(DBF, DBFName); (* Open database file *)
IF ErrCode > 0 THEN RETURN; END; (* If error opening, abort *)
NumKeys := 0; (* Init # of keys to 0 *)
REPEAT (* For each key specified, *)
INC(NumKeys); (* bump # of keys, *)
P := Pos(Expression, '+'); (* and check for another *)
WITH KeyArray[NumKeys] DO (* if another found, *)
Slice(FName, Expression, 0, P); (* add to key array *)
GetFieldNum(FName, FNum); (* and get field data *)
IF ErrCode > 0 THEN (* if invalid field name *)
CloseDBF; (* close the DBF file *)
RETURN; (* and abort now. *)
END; (* Else valid field name *)
FLen:=VAL(CARDINAL,DBF.Fields^[FNum].Len); (* get field length *)
FType:= DBF.Fields^[FNum].Type; (* get field type *)
END; (* and store in array *)
IF P < Length(Expression) THEN (* Remove parsed key from *)
Slice(Expression,Expression,P+1,Length(Expression)); (* expression *)
ELSE (* and check for *)
Expression[0] := 0C; (* another key. If *)
END; (* not found, clr exp *)
UNTIL (Length(Expression) = 0); (* Continue till exp parsed *)
IF (NumKeys = 1) AND (* If only one key field, *)
((KeyArray[1].FType = 'N') OR (* and it is a numeric *)
(KeyArray[1].FType = 'D')) THEN (* or date field then set*)
KeyLen := 8; (* set key length to 8 *)
KeyType := 'N'; (* and key type numeric *)
ELSE (* Else key will be string *)
KeyType := 'C'; (* so set key type to *)
IF KeyLen = 0 THEN (* If user did not specify *)
FOR F := 1 TO NumKeys DO (* key length, calc it *)
IF KeyArray[F].FType = 'C' THEN (* now. If key type is *)
KeyLen:=KeyLen+KeyArray[F].FLen; (* char, add len to tot *)
ELSE INC(KeyLen, 8); (* else, numeric key... *)
END; (* length always 8. *)
END; (* Continue for all keys *)
END; (* With key type and length *)
END; (* determined, *)
CreateNDX(NDX,NDXName,KeyType,KeyLen,KeyName);(* Create index file. *)
IF ErrCode > 0 THEN RETURN; END; (* If error creating, abort *)
WrChar('.'); (* Else, print dot *)
ExtractKeys; (* Extract keys from DBF *)
IF ErrCode > 0 THEN RETURN; END; (* If error extractng, abort*)
CloseDBF; (* Else, close data file *)
WrChar('.'); (* and print another dot *)
IF KeyCount > 0 THEN (* If any keys were found, *)
SortKeys; (* sort keys *)
IF ErrCode > 0 THEN RETURN; END; (* If error, abort *)
END; (* With index built, *)
WrChar('.'); (* Write last dot, *)
CloseNDX; (* Close index file *)
END MakeNDX;

BEGIN
FIO.IOcheck := FALSE; (* Turn off FIO err checking*)
Safety := FALSE; (* Don't flush bufs on write*)
ErrCheck := AskUser; (* Stop & Report on Errors *)
ErrCode := 0; (* Init error return code *)
DosCode := 0; (* Init DOS error code *)
Filter := DefaultFilter; (* Init filter (none) *)
KeyExp := DefaultKeyExp; (* Init key expression *)
END BuildNDX.


  3 Responses to “Category : Modula II Source Code
Archive   : DBFTOOLS.ZIP
Filename : BUILDNDX.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/