home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
modula2
/
library
/
dbf_file
/
buildndx.mod
< prev
next >
Wrap
Text File
|
1991-04-17
|
61KB
|
1,216 lines
(*# 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.