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

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

(**********************************************************************)
(* 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 index files. Procedures *)
(* include: OpenNDX, CloseNDX, Find, Next, Prev, GoTop, GoBottom, *)
(* BOF, EOF, FOUND, etc. *)
(* The NDX Module is most effective when used in combination with the *)
(* independent DBF module which provides access to dBase data files. *)
(* Complete documentation for this module can be found in DBF.DOC *)
(**********************************************************************)
(* Modification History *)
(* 3/26/91 by DAA removed dependencies on non-standard (non-JPI) *)
(* libraries. Added error reporting. *)
(* 3/30/91 by DAA added improved error checking w/AskUser, Halt,...*)
(* 4/09/91 by DAA changed locking scheme to improve efficiency *)
(* 7/16/91 by DAA added CurKey procedure. *)
(**********************************************************************)

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

CONST
PageSize = 512; (* index page size = 512 *)
MaxDepth = 32; (* max depth of b-tree *)
MaxRetries = 50; (* max retries on locks *)

MaxLocks = 10;
LockOfs = 128;

TYPE
NDXFile = POINTER TO NDXRec; (* Exported NDX file type *)
PagePtr = POINTER TO PageType;
KeyPtr = POINTER TO KeyType;
StackRec= RECORD (* Index stack holds path *)
PageNum : LONGCARD; (* from root page to *)
KeyNum : CARDINAL; (* current leaf page/key. *)
END; (* Used to traverse the *)
StackType = ARRAY[0..MaxDepth] OF StackRec; (* b-tree. *)
KeyType = RECORD (* Index keys contain a ptr *)
PagePtr : LONGCARD; (* to the next lower page,*)
RecPtr : LONGCARD; (* a record pointer, and *)
Key : ARRAY[0..MaxKeyLen-1] OF CHAR; (* the key string itself. *)
END;
PageType = RECORD (* Index pages contain a *)
NumKeys : CARDINAL; (* buffer for keys and a *)
Dummy : CARDINAL; (* count of the number of *)
Keys : ARRAY[0..PageSize-3 + (* keys in the buffer. *)
MaxKeyLen+8] OF CHAR;
END;
BufType = RECORD
PageNum : LONGCARD;
NextBuf : POINTER TO BufType;
Page : POINTER TO PageType;
END;
NDXRec = RECORD (* Index file variable *)
OPEN, (* File open flag *)
RDLOCKED, (* File read-locked flag *)
WRLOCKED, (* File write-locked flag *)
CHANGED, (* File changed flag *)
BOF, (* Top of file flag *)
EOF, (* Bottom of file flag *)
FOUND : BOOLEAN; (* Key found flag *)
Name : ARRAY[0..63] OF CHAR; (* file name *)
Handle : CARDINAL; (* file handle *)
Shared : BOOLEAN; (* single/multi-user *)
Stack : StackType; (* Search path *)
LockedByte : CARDINAL; (* Byte read locked *)
SPtr : CARDINAL; (* Search stack pointer *)
Page : PageType; (* Index page buffer *)
PNum : LONGCARD; (* Current index page num *)
LeafPage : BOOLEAN; (* Cur Page = Leaf page? *)
Key : KeyType; (* Current index key *)
KPtr : KeyPtr; (* Ptr to Key in Idx page *)
KNum : CARDINAL; (* Num of key in Idx page *)
NumBufs : CARDINAL; (* Number of buffers *)
PageBuf : BufType; (* Page Buffer list *)
(* IDX Header *) (* Index file header *)
Root : LONGCARD; (* Root page number *)
NextFree : LONGCARD; (* Next free page number *)
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; (* Unused *)
Unique : CARDINAL; (* 1 = Unique *)
KeyField : ARRAY[0..99] OF CHAR; (* Key field expression *)
Changes : LONGCARD; (* bumped when ndx changd *)
Dummy3 : ARRAY[0..383] OF CHAR; (* Unused *)
END; (* NDXRec *)

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

PROCEDURE PadRight(VAR S : ARRAY OF CHAR; Len : CARDINAL);
VAR N : CARDINAL;
BEGIN
N := Length(S); (* Pad from end of string *)
WHILE N < Len DO (* out to Len bytes with *)
S[N] := ' '; (* spaces. This is used *)
INC(N); (* to convert modula-2 *)
END; (* strings to dBase fmt. *)
S[N] := 0C; (* terminate string w/null *)
END PadRight;

(****************************************************************************)
(* Dialog boxes *)
(****************************************************************************)

PROCEDURE ReplaceDiskDialog;
VAR DialogWin : WinType;
Key : CHAR;
BEGIN
DialogWin := 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 or Esc to quit...');
Key := RdKey();
Close(DialogWin);
IF (Key = 33C) THEN HALT; END;
END ReplaceDiskDialog;

PROCEDURE LockedDialog() : CHAR;
VAR DialogWin : WinType;
Key : CHAR;
BEGIN
WHILE KeyPressed() DO (* Clear any buffered *)
Key := RdKey(); (* keystrokes *)
END;
DialogWin := Open(WinDef(20, 5, 60, 10, (* Open dialog window *)
White, Black, TRUE, TRUE, FALSE, TRUE,
DoubleFrame, White, Black));
WrLn; (* Display message *)
WrStr('File is locked by another user.'); (* indicating that file *)
WrLn; (* is locked by another *)
WrStr("Press 'W' to wait or 'A' to abort "); (* user and ask if *)
REPEAT (* user wishes to wait *)
Key := CAP(RdKey()); (* or abort program. *)
UNTIL (Key = 'W')OR(Key = 'A')OR(Key = 33C); (* When user responds, *)
Close(DialogWin); (* close dialog window *)
RETURN Key; (* and return choice. *)
END LockedDialog;

(****************************************************************************)
(* DOS File I/O *)
(****************************************************************************)

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 *)
BEGIN (* make it to disk. ) *)
REPEAT
Regs.AH := 68H;
Regs.BX := F;
Dos(Regs);
IF (CF IN Regs.Flags) AND (Regs.AX = 34) THEN
ReplaceDiskDialog();
END;
UNTIL NOT ((CF IN Regs.Flags) AND (Regs.AX = 34));
END FlushBuffers;

PROCEDURE GetExtErr() : CARDINAL; (* Get extended DOS error *)
VAR Regs : Registers; (* information. *)
BEGIN
Regs.AH := 59H;
Dos(Regs);
RETURN Regs.AX;
END GetExtErr;

PROCEDURE SetRetries(Delay,Retries : CARDINAL); (* Set # of retries, and *)
VAR Regs : Registers; (* delay between each *)
BEGIN (* retry when attempting *)
Regs.AX := 440BH; (* to lock a region in a *)
Regs.CX := Delay; (* file. *)
Regs.DX := Retries;
Dos(Regs);
END SetRetries;

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

PROCEDURE UnLockNDX(N : NDXFile);
VAR Status, L : CARDINAL;
BEGIN
IF N^.WRLOCKED THEN
IF N^.LockedByte = 0 THEN
Status := FUnLock(N^.Handle, LockOfs, MaxLocks+1);
ELSE
FOR L := 0 TO MaxLocks DO
Status := FUnLock(N^.Handle, VAL(LONGCARD, LockOfs+L), 1);
END;
END;
N^.WRLOCKED := FALSE;
END;
IF N^.RDLOCKED THEN
Status:=FUnLock(N^.Handle,VAL(LONGCARD,(LockOfs+N^.LockedByte)),1);
N^.RDLOCKED := FALSE;
END;
END UnLockNDX;

PROCEDURE HandleError(Proc : ARRAY OF CHAR; N : NDXFile; Code : CARDINAL);
VAR DialogWin : WinType;
Key : CHAR;
BEGIN
ErrCode := Code;
DosCode := GetExtErr();
IF (N # NIL) THEN UnLockNDX(N); END; (* Remove any current locks *)
IF ErrCheck = Halt THEN (* If terminating program, *)
IF N # NIL THEN FIO.Close(N^.Handle); END;(* close index *)
END;
IF ErrCheck = None THEN (* If no Internal err chking*)
RETURN; (* just return error code*)
END; (* for caller to handle *)
DialogWin := Open(WinDef(20, 5, 60, 10, (* Open dialog window *)
White, Black, TRUE, TRUE, FALSE, TRUE,
DoubleFrame, White, Black));
WrStr('Error:'); WrLn;
WrStr(' Procedure : '); WrStr(Proc); WrLn;
IF (N # NIL) THEN
WrStr(' Index file: '); WrStr(N^.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 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.');
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;

(****************************************************************************)
(* Concurrency controls - ReadLock, ReadUnLock, WriteLock, WriteUnLock, *)
(* ReadHeader, WriteHeader, UpdateHeader *)
(****************************************************************************)
(* LOCKING SCHEME *)
(* In order to work with the b-trees in a multi-user environment, some *)
(* concurrency control is required to prevent damage to the index and to *)
(* maintain integrity during index accesses. *)
(* The scheme used here allows for multiple simultaneous readers, but *)
(* only one writer at a time. When writing to the index, no readers, and *)
(* no other writers may access the index until the update is complete. *)
(* - After each update, a 32-bit counter in an unused area of the index *)
(* header is incremented to notify other users of the change. *)
(* - In order to support all networks/multi-user DOS operating systems, *)
(* only standard DOS record locking function (5Ch) is used for control. *)
(* READER PROTOCOL: *)
(* 10 otherwise unused bytes in the index header are used as 'read locks'. *)
(* When a reader wishes to access the file, he locks the first available *)
(* read lock byte. When done, he unlocks it. The number of simultaneous *)
(* readers is limited by the number of read lock bytes. *)
(* WRITER PROTOCOL: *)
(* 1 additional unused byte in the index header is the 'write lock'. When *)
(* a writer wishes to update the file, he must lock this byte and all of *)
(* the read lock bytes as well. The writer first attempts to lock both *)
(* the write lock and all of the read locks at the same time. If unable *)
(* to do this, other readers or writers are present. So the writer must *)
(* first lock the write lock byte, insuring no other writers are present. *)
(* Then, each read lock is locked as it becomes available, gradually *)
(* squeezing out any readers. Eventually, the writer will get control. *)
(* When the update is complete, all locks are released. *)

PROCEDURE ReadLock(I : NDXFile); (* Lock one of the read *)
VAR Status : CARDINAL; (* lock bytes or wait *)
N : CARDINAL; (* until one is available *)
FPtr : LONGCARD; (* This locks out writers *)
BEGIN
IF NOT I^.Shared THEN RETURN; END; (* If not sharing, done. *)
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
IF I^.RDLOCKED THEN RETURN; END; (* If already locked, done. *)
LOOP (* Else enter lock loop. *)
FOR N := 1 TO MaxLocks DO (* For each read lock byte, *)
FPtr := VAL(LONGCARD, (LockOfs+N)); (* Set pointer to lock *)
Status := FLock(I^.Handle, FPtr, 1); (* Attempt to grab lock *)
IF Status <= 1 THEN (* If successful, *)
I^.RDLOCKED := TRUE; (* set locked flag, *)
I^.LockedByte := LockOfs+N; (* save locked byte # *)
RETURN; (* and return now. *)
END; (* IF locked *) (* Else, try next lock *)
END; (* FOR each lock byte *) (* until all tried *)
IF KeyPressed() THEN (* If no locks free, and key*)
IF LockedDialog() = 'A' THEN (* pressed, ask user if *)
HandleError('ReadLock', I, ErrLock);(* they wish to abort. *)
RETURN; (* If so disp msg & abort*)
END; (* IF user aborts *) (* Else, while if no key *)
END; (* IF Keypressed *) (* pressed, keep trying *)
END; (* LOOP *) (* Continue till locked. *)
END ReadLock;

PROCEDURE ReadUnLock(I : NDXFile); (* Release read lock byte *)
VAR Status : CARDINAL; (* to allow writers in. *)
FPtr : LONGCARD;
BEGIN
IF NOT I^.Shared THEN RETURN; END; (* If not sharing, done. *)
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
IF NOT I^.RDLOCKED THEN RETURN; END; (* If not locked, then done *)
FPtr := VAL(LONGCARD, I^.LockedByte); (* Else set pointer to byte *)
Status := FUnLock(I^.Handle, FPtr, 1); (* locked and unlock it. *)
I^.RDLOCKED := FALSE; (* Set locked status FALSE, *)
IF Status > 1 THEN (* If error unlocking, *)
HandleError('ReadUnLock', I, ErrUnLock); (* set error code. *)
END; (* Return. *)
END ReadUnLock;

PROCEDURE WriteLock(I : NDXFile); (* Lock the write lock byte *)
VAR Status : CARDINAL; (* to lock out other *)
N : CARDINAL; (* writers, then all of *)
FPtr : LONGCARD; (* the read lock bytes to*)
NumLocked : CARDINAL; (* lock out readers. *)
Locked : ARRAY [1..MaxLocks] OF BOOLEAN;
BEGIN
IF NOT I^.Shared THEN RETURN; END; (* If not sharing, done. *)
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
IF I^.WRLOCKED THEN RETURN; END; (* If already locked, done. *)
Status:=FLock(I^.Handle,LockOfs,MaxLocks+1); (* Attempt to lock all locks*)
IF Status <= 1 THEN (* at once. If successful, *)
I^.WRLOCKED := TRUE; (* set locked flag=TRUE *)
I^.LockedByte := 0; (* set lock type=BLOCK *)
RETURN; (* and return. *)
END; (* Else other users present *)
REPEAT (* Grab write lock byte to *)
Status := FLock(I^.Handle, LockOfs, 1); (* lock out other writers*)
IF (Status > 1) AND (KeyPressed()) THEN (* If unable, and key is hit*)
IF LockedDialog() = 'A' THEN (* If choses to abort, *)
HandleError('WriteLock',I,ErrLock); (* display error msg *)
RETURN; (* and abort now. *)
END; (* Else, user will wait *)
END; (* Else NDX is write locked *)
UNTIL Status <= 1; (* Continue till write lockd*)
I^.WRLOCKED := TRUE; (* set write locked flag *)
I^.LockedByte := 1; (* set lock type=INDIVIDUAL *)
FOR N := 1 TO MaxLocks DO (* Initialize an array *)
Locked[N] := FALSE; (* of flags for each *)
END; (* read lock *)
NumLocked := 0; (* Set # locked so far to 0 *)
REPEAT (* Lock bytes loop *)
FOR N := 1 TO MaxLocks DO (* For each byte to lock, *)
IF NOT Locked[N] THEN (* If not already locked, *)
FPtr := VAL(LONGCARD, (LockOfs+N)); (* calc byte position, *)
Status := FLock(I^.Handle, FPtr, 1);(* and attempt to lock *)
IF Status <= 1 THEN (* If successful, *)
Locked[N] := TRUE; (* set locked flag, *)
INC(NumLocked); (* and bump count. *)
END; (* Else unable to lock it *)
END; (* Else byte already locked*)
END; (* Continue for each byte *)
IF KeyPressed() THEN (* After each pass, if key *)
IF LockedDialog() = 'A' THEN (* hit, ask: Wait/Abort *)
HandleError('WriteLock',I,ErrLock); (* If user aborts, *)
RETURN; (* display error message*)
END; (* and abort procedure. *)
END; (* Continue grabbing locks *)
UNTIL (NumLocked = MaxLocks); (* until all are locked *)
END WriteLock;

PROCEDURE WriteUnLock(I : NDXFile); (* Release write lock byte *)
VAR N : CARDINAL; (* and all read lock *)
Status : CARDINAL; (* bytes in the same way *)
FPtr : LONGCARD; (* they were locked. *)
BEGIN
IF NOT I^.Shared THEN RETURN; END; (* If not sharing, done. *)
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
IF NOT I^.WRLOCKED THEN RETURN; END; (* If not locked, done. *)
IF I^.LockedByte = 0 THEN (* If block write locked *)
Status:=FUnLock(I^.Handle,LockOfs,MaxLocks+1); (* release block *)
I^.WRLOCKED := FALSE; (* set file unlocked flag*)
RETURN; (* and return to caller *)
END; (* Else individual locks so *)
FOR N := 0 TO MaxLocks DO (* Release each lock byte *)
FPtr := VAL(LONGCARD, (LockOfs+N)); (* individually *)
Status := FUnLock(I^.Handle, FPtr, 1); (* as they were created *)
END; (* Until all bytes unlocked *)
I^.WRLOCKED := FALSE; (* set file unlocked flag *)
END WriteUnLock;

PROCEDURE ReadHeader(I : NDXFile);
VAR TempIOcheck : BOOLEAN;
LastChanges : LONGCARD;
nRead : CARDINAL;
BEGIN
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
LastChanges := I^.Changes; (* Save last changes count *)
TempIOcheck := FIO.IOcheck; (* Save cur IOcheck status *)
FIO.IOcheck := FALSE; (* Turn off FIO err checking*)
FIO.Seek(I^.Handle, 0); (* Seek to index header *)
IF FIO.IOresult() > 0 THEN (* If error seeking, *)
FIO.IOcheck := TempIOcheck; (* restore IOcheck status *)
HandleError('ReadHeader', I, ErrSeek); (* handle error *)
RETURN; (* and abort procedure. *)
END; (* Else, with file ptr set, *)
nRead := FIO.RdBin(I^.Handle, I^.Root, 128); (* Get header from NDX file *)
FIO.IOcheck := TempIOcheck; (* Restore IOcheck status *)
IF (nRead#128) OR (FIO.IOresult() > 0) THEN (* If error reading header, *)
IF (GetExtErr() = 33) THEN (* If page was locked, *)
HandleError('ReadHeader', I, ErrLock); (* handle lock error. *)
ELSE (* Else was read error, so *)
HandleError('ReadHeader', I, ErrRead); (* handle read error *)
END; (* With either type of err, *)
I^.CHANGED := TRUE; (* set header changed, *)
RETURN; (* and abort procedure. *)
END; (* Else, header read OK. *)
I^.CHANGED := I^.Changes # LastChanges; (* Set index changed status *)
END ReadHeader;

PROCEDURE UpdateHeader(I : NDXFile);
BEGIN
IF NOT I^.Shared THEN RETURN; END; (* If not sharing, done. *)
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
ReadHeader(I); (* Else check for changes *)
END UpdateHeader;

PROCEDURE WriteHeader(I : NDXFile);
VAR TempIOcheck : BOOLEAN;
BEGIN
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
TempIOcheck := FIO.IOcheck; (* Save cur IOcheck status *)
FIO.IOcheck := FALSE; (* Turn off FIO err checking*)
FIO.Seek(I^.Handle, 0); (* Seek to start of header *)
IF FIO.IOresult() > 0 THEN (* If error seeking, *)
FIO.IOcheck := TempIOcheck; (* restore IOcheck status *)
HandleError('WriteHeader', I, ErrSeek); (* handle error *)
RETURN; (* and abort procedure. *)
END; (* Else, with file ptr set, *)
FIO.WrBin(I^.Handle, I^.Root, PageSize); (* Write header to disk *)
FIO.IOcheck := TempIOcheck; (* Restore IOcheck status *)
IF (FIO.IOresult() > 0) THEN (* If error writing page *)
HandleError('WriteHeader', I, ErrWrite); (* handle error *)
RETURN; (* and abort procedure *)
END;
IF Safety THEN (* If Safety mode active, *)
FlushBuffers(I^.Handle); (* Flush changes to disk *)
END; (* to insure all saved. *)
END WriteHeader;

(****************************************************************************)
(* Page oriented procedures - InitPage, GetPage, PutPage *)
(****************************************************************************)

PROCEDURE InitPage(VAR P : PageType);
BEGIN
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
P.NumKeys := 0; (* Init keys in page to 0 *)
P.Dummy := 0; (* Init dummy field *)
Fill(ADR(P.Keys), SIZE(P.Keys), 0C); (* Init key buffer *)
END InitPage;

PROCEDURE GetPage (I : NDXFile);
VAR FPtr : LONGCARD;
nRead : CARDINAL;
TempIOcheck : BOOLEAN;
BEGIN
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
IF (I^.PNum=0)OR(I^.PNum>=I^.NextFree) THEN (* If invalid page number *)
HandleError('GetPage', I, ErrPageNo); (* handle error *)
RETURN; (* and abort procedure. *)
END; (* Else, valid page to get *)
TempIOcheck := FIO.IOcheck; (* Save cur IOcheck status *)
FIO.IOcheck := FALSE; (* Turn off FIO err checking*)
FPtr := PageSize * I^.PNum; (* Calculate offset of page *)
FIO.Seek(I^.Handle, FPtr); (* in file and seek to it. *)
IF FIO.IOresult() > 0 THEN (* If error seeking, *)
HandleError('GetPage', I, ErrSeek); (* handle error *)
FIO.IOcheck := TempIOcheck; (* restore IOcheck status *)
RETURN; (* and abort procedure. *)
END; (* Else, with file ptr set, *)
nRead:=FIO.RdBin(I^.Handle,I^.Page,PageSize);(* Read page from disk. *)
FIO.IOcheck := TempIOcheck; (* Restore IOcheck status *)
IF (nRead#PageSize)OR(FIO.IOresult()>0) THEN (* If error reading page, *)
IF GetExtErr()=33 THEN (* If page was locked, *)
HandleError('GetPage', I, ErrLock); (* handle lock error *)
ELSE (* Else, read error, so *)
HandleError('GetPage', I, ErrRead); (* handle read error *)
END; (* Either way, *)
RETURN; (* abort procedure *)
END; (* Else, page read OK. *)
I^.KPtr := ADR(I^.Page.Keys[0]); (* Set pointer to first key *)
I^.LeafPage := (I^.KPtr^.PagePtr = 0); (* Set leaf page flag *)
END GetPage;

PROCEDURE PutPage (I : NDXFile);
VAR FPtr : LONGCARD;
TempIOcheck : BOOLEAN;
BEGIN
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
IF (I^.PNum=0) OR (I^.PNum>I^.NextFree) THEN (* If invalid page number *)
HandleError('PutPage', I, ErrPageNo); (* handle error *)
RETURN; (* and abort procedure. *)
END; (* Else valid page to write *)
TempIOcheck := FIO.IOcheck; (* Save cur IOcheck status *)
FIO.IOcheck := FALSE; (* Turn off FIO err checking*)
FPtr := PageSize * I^.PNum; (* Calculate offset of page *)
FIO.Seek(I^.Handle, FPtr); (* in file and seek to it. *)
IF FIO.IOresult() > 0 THEN (* If error seeking, *)
HandleError('PutPage', I, ErrSeek); (* handle error *)
FIO.IOcheck := TempIOcheck; (* restore IOcheck state *)
RETURN; (* and abort procedure *)
END; (* Else with file ptr set *)
FIO.WrBin(I^.Handle, I^.Page, PageSize); (* write page to disk. *)
FIO.IOcheck := TempIOcheck; (* Restore IOcheck status *)
IF FIO.IOresult() > 0 THEN (* If error writing page, *)
HandleError('PutPage', I, ErrWrite); (* handle error *)
RETURN; (* and abort procedure *)
END; (* Else page written OK. *)
IF Safety THEN (* If safety mode active, *)
FlushBuffers(I^.Handle); (* flush writes from *)
END; (* cache to disk now. *)
END PutPage;

(****************************************************************************)
(* Stack oriented procedures - ClearStack, PushPage, PopPage *)
(****************************************************************************)

PROCEDURE ClearStack(I : NDXFile);
BEGIN
I^.SPtr := 0; (* Reset stack pointer *)
END ClearStack;

PROCEDURE PushPage(I : NDXFile);
BEGIN
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
IF I^.SPtr >= MaxDepth THEN (* If past max stack depth, *)
HandleError('PushPage', I, ErrBadNDX); (* handle error *)
RETURN; (* and abort procedure *)
END;
I^.Stack[I^.SPtr].PageNum := I^.PNum; (* Save current page number *)
I^.Stack[I^.SPtr].KeyNum := I^.KNum; (* Save current key number *)
INC(I^.SPtr); (* Bump stack pointer *)
END PushPage;

PROCEDURE PopPage(I : NDXFile);
BEGIN
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
IF I^.SPtr = 0 THEN (* If stack is empty, *)
HandleError('PopPage', I, ErrBadNDX); (* handle error *)
RETURN; (* and abort procedure *)
END; (* Else page is on stack *)
DEC(I^.SPtr); (* Pop stack *)
I^.PNum := I^.Stack[I^.SPtr].PageNum; (* Get page number and *)
I^.KNum := I^.Stack[I^.SPtr].KeyNum; (* key number from stack *)
END PopPage;

PROCEDURE GetPtr(I : NDXFile) : LONGCARD;
VAR KeyOfs : CARDINAL;
BEGIN
IF ErrCode # 0 THEN RETURN 0; END; (* If error, abort now. *)
WITH I^ DO
KeyOfs := (KNum - 1) * KeySize; (* Calc location of key *)
KPtr := ADR(Page.Keys[KeyOfs]); (* Set ptr to key in page *)
Key.RecPtr := KPtr^.RecPtr; (* Copy out record pointer *)
Key.PagePtr := KPtr^.PagePtr; (* Copy out page pointer *)
Move(ADR(KPtr^.Key),ADR(Key.Key),KeyLen); (* Copy out key str. *)
IF LeafPage (* If page is leaf page, *)
THEN RETURN Key.RecPtr; (* return record pointer *)
ELSE RETURN Key.PagePtr; (* else next page ptr. *)
END;
END;
END GetPtr;

(****************************************************************************)
(* Key locating procedures - SeekTop, SeekEnd, SeekKey *)
(****************************************************************************)

PROCEDURE SeekTop(I : NDXFile);
BEGIN
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
ClearStack(I); (* Clear path to leaf level *)
I^.PNum := I^.Root; (* Set pointer to root page *)
GetPage(I); (* and read it from disk *)
IF ErrCode # 0 THEN RETURN; END; (* or abort if unable. *)
WHILE NOT I^.LeafPage DO (* While not at leaf level, *)
I^.KNum := 1; (* set ptr to first key *)
PushPage(I); (* and push page/key *)
IF ErrCode # 0 THEN RETURN; END; (* if error, abort. *)
I^.PNum := GetPtr(I); (* Get ptr to next page *)
GetPage(I); (* and get it from disk. *)
IF ErrCode # 0 THEN RETURN; END; (* or abort if unable. *)
END; (* Continue till leaf level *)
I^.Key.Key := ''; (* Set last key found to *)
I^.Key.RecPtr := 0; (* null (top of file) *)
I^.KNum := 0; (* Set ptr to start of page *)
I^.BOF := TRUE; (* Set BOF flag to true *)
I^.EOF := (I^.Page.NumKeys = 0); (* If empty index, then EOF *)
I^.FOUND := FALSE; (* Set FOUND flag to false *)
END SeekTop;

PROCEDURE SeekEnd(I : NDXFile);
BEGIN
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
ClearStack(I); (* Clear path to leaf level *)
I^.PNum := I^.Root; (* Set ptr to root page *)
GetPage(I); (* Read root from disk. *)
IF ErrCode # 0 THEN RETURN; END; (* Abortif unable to read *)
WHILE NOT I^.LeafPage DO (* While not at leaf level, *)
I^.KNum := I^.Page.NumKeys + 1; (* Set ptr to last key, *)
PushPage(I); (* and push page/key *)
IF ErrCode # 0 THEN RETURN; END; (* abort if error. *)
I^.PNum := GetPtr(I); (* get ptr to next page *)
GetPage(I); (* Get next page *)
IF ErrCode # 0 THEN RETURN; END; (* or abort if unable. *)
END; (* Continue till leaf level *)
Fill(ADR(I^.Key.Key), I^.KeyLen, CHR(255)); (* Set last key found to max*)
I^.Key.RecPtr := 999999999; (* (to EOF) *)
I^.KNum := I^.Page.NumKeys + 1; (* Set ptr to EOF *)
I^.BOF := (I^.Page.NumKeys = 0); (* If index empty then BOF *)
I^.EOF := TRUE; (* Set EOF true *)
I^.FOUND := FALSE; (* Set FOUND false *)
END SeekEnd;

PROCEDURE CmpKey(VAR K1,K2:ARRAY OF CHAR; KeyLen:CARDINAL):INTEGER;
VAR N : CARDINAL;
BEGIN
FOR N := 0 TO KeyLen-1 DO
IF K1[N] > K2[N] THEN RETURN 1;
ELSIF K1[N] < K2[N] THEN RETURN -1;
END;
END;
RETURN 0;
END CmpKey;

PROCEDURE CmpNum(N1, N2 : LONGREAL) : INTEGER;
BEGIN
IF N1 > N2 THEN RETURN 1;
ELSIF N1 < N2 THEN RETURN -1;
ELSE RETURN 0;
END;
END CmpNum;

PROCEDURE ScanPage(I:NDXFile; SKey:ARRAY OF CHAR; SPtr:LONGCARD):LONGCARD;
VAR Match : INTEGER;
NumPtr1, (* For numeric keys, set *)
NumPtr2 : POINTER TO LONGREAL; (* template strings->real *)
Ptr : LONGCARD;
BEGIN
I^.KNum := 1; (* Set ptr to 1st key in pg *)
Match := -1; (* Set match to none *)
IF I^.Numeric > 0 THEN (* If numeric key, set ptrs *)
NumPtr1 := ADR(SKey); (* to search and key *)
NumPtr2 := ADR(I^.Key.Key); (* strings to template *)
END; (* them as long reals *)
LOOP; (* Enter match loop *)
Ptr := GetPtr(I); (* Get key from page *)
IF I^.KNum > I^.Page.NumKeys THEN (* If last key in page, *)
EXIT; (* exit and return ptr *)
END; (* else, compare keys *)
IF I^.Numeric > 0 THEN (* and set Match to *)
Match := CmpNum(NumPtr2^, NumPtr1^); (* -1, 1, or 0 based *)
ELSE (* on comparison. *)
Match:=CmpKey(I^.Key.Key,SKey,I^.KeyLen);
END;
IF (Match = 0) AND (SPtr > 0) THEN (* If looking for exact *)
IF (I^.Key.RecPtr > SPtr) (* match, then compare *)
THEN Match := 1; (* record pointer to *)
ELSIF (I^.Key.RecPtr < SPtr) (* search record ptr *)
THEN Match := -1; (* too, and adjust *)
END; (* results accordingly *)
END; (* Else, ignore rec ptr *)
IF Match >= 0 (* If key >= searchkey *)
THEN EXIT; (* exit and return ptr *)
ELSE INC(I^.KNum); (* else bump to next key *)
END; (* in page. *)
END; (* Loop *) (* Continue for all keys *)
I^.FOUND := (Match = 0); (* Set exact match flag *)
RETURN Ptr; (* Return record/page ptr. *)
END ScanPage;

PROCEDURE SeekKey(I:NDXFile; Key:ARRAY OF CHAR; Ptr:LONGCARD);
VAR SKey : ARRAY [0..MaxKeyLen] OF CHAR;
NextPtr : LONGCARD;
BEGIN
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
IF I^.Numeric > 0 THEN (* If numeric key, copy it *)
Move(ADR(Key), ADR(SKey), 8); (* to search key string *)
ELSE (* Else if character key, *)
Copy(SKey, Key); (* make working copy *)
PadRight(SKey, I^.KeyLen); (* convert to dBase fmt *)
END;
ClearStack(I); (* Clear tree path stack. *)
I^.PNum := I^.Root; (* Start with root page. *)
REPEAT (* For all pages in path, *)
GetPage(I); (* Get page from disk, *)
IF ErrCode # 0 THEN RETURN; END; (* or abort if unable *)
NextPtr := ScanPage(I, SKey, Ptr); (* Scan page for next ptr *)
IF NOT I^.LeafPage THEN (* If page was a node, *)
PushPage(I); (* Update path stack, *)
IF ErrCode # 0 THEN RETURN; END; (* if error, abort. *)
I^.PNum := NextPtr; (* and cont w/new page *)
END; (* Continue for all nodes *)
UNTIL I^.LeafPage; (* Until leaf is reached. *)
I^.BOF := I^.Page.NumKeys = 0; (* Set Top of file status. *)
I^.EOF := (I^.KNum > I^.Page.NumKeys); (* Set End of File status. *)
IF I^.BOF THEN (* If at beginning of file, *)
I^.Key.Key := ''; (* Set key found to *)
I^.Key.RecPtr := 0; (* smallest possible key *)
ELSIF I^.EOF THEN (* If at end of file, *)
Fill(ADR(I^.Key.Key), I^.KeyLen, CHR(255));(* Set key found to *)
I^.Key.RecPtr := 9999999999; (* largest possible key. *)
ELSE (* Otherwise, *)
Ptr := GetPtr(I); (* Get key from page. *)
END;
END SeekKey;

(****************************************************************************)
(* Exported procedures for searching *)
(****************************************************************************)

PROCEDURE GoTop(I : NDXFile);
BEGIN
ErrCode := 0; (* Init result code *)
ReadLock(I); (* Read lock index. *)
UpdateHeader(I); (* Get current index header *)
SeekTop(I); (* Go to beginning of index *)
ReadUnLock(I); (* Release lock on index. *)
END GoTop;

PROCEDURE GoBottom(I : NDXFile);
BEGIN
ErrCode := 0; (* Init result code *)
ReadLock(I); (* Read lock index. *)
UpdateHeader(I); (* Get current index header *)
SeekEnd(I); (* Go to end of index *)
ReadUnLock(I); (* Release lock on index. *)
END GoBottom;

PROCEDURE Find(I : NDXFile; Key : ARRAY OF CHAR) : LONGCARD;
BEGIN
ErrCode := 0; (* Init result code *)
ReadLock(I); (* Read lock index. *)
UpdateHeader(I); (* Get current index header *)
SeekKey(I, Key, 0); (* Search index for key *)
ReadUnLock(I); (* Release lock on index. *)
RETURN I^.Key.RecPtr; (* Return key found *)
END Find;

PROCEDURE FindNKey(I : NDXFile; Num : LONGREAL) : LONGCARD;
VAR NumStr : ARRAY [0..7] OF CHAR;
BEGIN
ErrCode := 0; (* Init result code *)
ReadLock(I); (* Read lock index. *)
UpdateHeader(I); (* Get current index header *)
Move(ADR(Num), ADR(NumStr), 8); (* Copy real to key string *)
SeekKey(I, NumStr, 0); (* Search index for key *)
ReadUnLock(I); (* Release index lock. *)
RETURN I^.Key.RecPtr; (* Return key found. *)
END FindNKey;

PROCEDURE Next (I : NDXFile) : LONGCARD;
BEGIN
ErrCode := 0; (* Init result code *)
ReadLock(I); (* Read lock index. *)
UpdateHeader(I); (* Get current index header *)
IF I^.CHANGED THEN (* If index has changed *)
SeekKey(I, I^.Key.Key, I^.Key.RecPtr+1); (* find next key *)
RETURN I^.Key.RecPtr; (* and return rec ptr *)
END; (* Else index not changed *)
IF I^.EOF THEN (* If at end of NDX *)
ReadUnLock(I); (* Unlock NDX (if locked)*)
I^.BOF := (I^.Page.NumKeys = 0); (* Set BOF flag *)
I^.FOUND := FALSE; (* Set FOUND flag false *)
RETURN 0; (* and return 0 *)
END; (* Else, may be another key *)
INC(I^.KNum); (* Point to next in page. *)
IF I^.KNum <= I^.Page.NumKeys THEN (* If next key in cur page, *)
ReadUnLock(I); (* Release NDX if locked *)
I^.BOF := FALSE; (* Set BOF flag false *)
I^.EOF := FALSE; (* Set EOF flag false *)
I^.FOUND := TRUE; (* Set FOUND flag true *)
RETURN GetPtr(I); (* return record ptr *)
END; (* Else key not on cur page *)
IF I^.SPtr > 0 THEN (* If more leaves in index, *)
REPEAT (* Pop until node w/more *)
PopPage(I); (* keys is reached. *)
IF ErrCode # 0 THEN RETURN 0; END; (* or page number error. *)
GetPage(I); (* Read ancestor page *)
IF ErrCode # 0 THEN RETURN 0; END; (* if error, abort now. *)
UNTIL (I^.SPtr = 0) OR (* Continue till top of *)
(I^.KNum <= I^.Page.NumKeys); (* tree (root) reached. *)
END; (* Continue till root or *)
IF (I^.KNum > I^.Page.NumKeys) THEN (* node with more keys hit *)
SeekEnd(I); (* If no more keys, go EOF *)
ReadUnLock(I); (* Unlock index *)
RETURN 0; (* and return null now. *)
END; (* Else, node with more keys*)
INC(I^.KNum); (* bump to next key. *)
WHILE (NOT I^.LeafPage) DO (* Push setting path to 1st *)
PushPage(I); (* key of each page *)
I^.PNum := GetPtr(I); (* get next page number *)
I^.KNum := 1; (* till leaf level hit. *)
GetPage(I); (* (next leaf key found) *)
IF ErrCode # 0 THEN RETURN 0; END; (* or till error reading *)
END; (* With next key found, *)
ReadUnLock(I); (* Release index, *)
I^.EOF := FALSE; (* Set EOF flag false *)
I^.BOF := FALSE; (* Set BOF flag false *)
I^.FOUND := TRUE; (* Set FOUND flag true *)
RETURN GetPtr(I); (* Return record pointer *)
END Next;

PROCEDURE Prev (I : NDXFile) : LONGCARD;
VAR Ptr : LONGCARD;
BEGIN
ErrCode := 0; (* Init result code *)
ReadLock(I); (* Read lock index. *)
UpdateHeader(I); (* Get current index header *)
IF I^.CHANGED THEN (* If index changed, restore*)
SeekKey(I, I^.Key.Key, I^.Key.RecPtr); (* path to last key *)
END; (* Now index set as before. *)
IF I^.KNum > 1 THEN (* If more keys in cur page *)
ReadUnLock(I); (* unlock index *)
DEC(I^.KNum); (* bump key number *)
I^.BOF := FALSE; (* set BOF false *)
I^.EOF := FALSE; (* set EOF false *)
I^.FOUND := TRUE; (* set FOUND true *)
RETURN GetPtr(I); (* return record ptr *)
END; (* Else key not on cur page *)
IF I^.BOF THEN (* If at top of NDX *)
ReadUnLock(I); (* Unlock NDX (if locked)*)
I^.EOF := (I^.Page.NumKeys = 0); (* Set EOF flag *)
I^.FOUND := FALSE; (* Set FOUND flag false *)
ErrCode := 0; (* Set result code = OK *)
RETURN 0; (* and return 0 *)
END; (* Else, key on prev leaf. *)
WHILE (I^.KNum <= 1) AND (I^.SPtr > 0) DO (* Pop pages till page with *)
PopPage(I); (* more keys found or *)
END; (* continue till root hit*)
IF I^.KNum <= 1 THEN (* If no more keys found, *)
SeekTop(I); (* go to top of index, *)
ReadUnLock(I); (* so unlock index, *)
RETURN 0; (* and return 0 *)
END; (* Else, more keys found so *)
GetPage(I); (* Read page with keys *)
IF ErrCode # 0 THEN RETURN 0; END; (* or abort if error. *)
DEC(I^.KNum); (* bump to prev key *)
WHILE NOT I^.LeafPage DO (* Push pages setting path *)
PushPage(I); (* to last key of each pg*)
I^.PNum := GetPtr(I); (* Save page and key #s *)
GetPage(I); (* until leaf level *)
IF ErrCode # 0 THEN RETURN 0; END; (* or abort if error. *)
I^.KNum := I^.Page.NumKeys + 1; (* Set ptr to last key *)
END; (* Now prev leaf found. *)
ReadUnLock(I); (* so release index, *)
DEC(I^.KNum); (* Point to last key *)
I^.BOF := FALSE; (* Set BOF flag false *)
I^.EOF := FALSE; (* Set EOF flag false *)
I^.FOUND := TRUE; (* Set FOUND flag true *)
RETURN GetPtr(I); (* Return record ptr *)
END Prev;

(****************************************************************************)
(* Exported procedures for checking search status *)
(****************************************************************************)

PROCEDURE BOF(I : NDXFile) : BOOLEAN;
BEGIN
ErrCode := 0; (* Init result code *)
RETURN I^.BOF; (* Return BOF flag *)
END BOF;

PROCEDURE EOF(I : NDXFile) : BOOLEAN;
BEGIN
ErrCode := 0; (* Init result code *)
RETURN I^.EOF; (* Return EOF flag *)
END EOF;

PROCEDURE FOUND(I : NDXFile) : BOOLEAN;
BEGIN
ErrCode := 0; (* Init result code *)
RETURN I^.FOUND; (* Return FOUND flag *)
END FOUND;

(****************************************************************************)
(* Exported procedures for adding & deleting keys *)
(****************************************************************************)

PROCEDURE AddKey(I : NDXFile; Key : ARRAY OF CHAR; Ptr : LONGCARD);
VAR SKey : ARRAY[0..MaxKeyLen] OF CHAR;
Next : LONGCARD;
RecPtr : LONGCARD;
FPtr : LONGCARD;
New : PageType;
N : CARDINAL;

PROCEDURE InsertKey();
VAR SKey, SPos, Num : CARDINAL;
KPtr : KeyPtr;
BEGIN
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
SKey := I^.KNum - 1; (* Calc location in page *)
SPos := SKey * I^.KeySize; (* for key to be inserted *)
Num := (I^.Page.NumKeys-SKey)*I^.KeySize+8;(* and # of bytes to shift *)
WHILE Num > 0 DO (* Shift all higher keys up *)
DEC(Num); (* to make room for new one.*)
I^.Page.Keys[SPos + Num + I^.KeySize] :=
I^.Page.Keys[SPos + Num];
END;
KPtr := ADR(I^.Page.Keys[SPos]); (* Set ptr to new key pos *)
KPtr^.RecPtr := I^.Key.RecPtr; (* Copy in new rec pointer *)
KPtr^.PagePtr:= I^.Key.PagePtr; (* Copy in new page pointer *)
Move(ADR(I^.Key.Key), ADR(KPtr^.Key), I^.KeyLen); (* Copy in new key *)
INC(I^.Page.NumKeys); (* Bump # of keys in page *)
END InsertKey;

PROCEDURE Split();
VAR N, MKey, MPos, KPos : CARDINAL;
BEGIN
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
New := I^.Page; (* Make a copy of the page *)
MKey := I^.Page.NumKeys DIV 2; (* Calculate middle key *)
MPos := (I^.Page.NumKeys-MKey)*I^.KeySize; (* Set pointer to middle key*)
New.NumKeys := I^.Page.NumKeys - MKey; (* Lower page gets 1/2 keys *)
I^.Page.NumKeys := MKey; (* Upper page gets rest *)
FOR N := MPos TO HIGH(I^.Page.Keys) DO (* Shift high keys down on *)
I^.Page.Keys[N-MPos] := I^.Page.Keys[N]; (* upper (original) page *)
END;
PutPage(I); (* Write upper page to disk *)
IF ErrCode # 0 THEN RETURN; END; (* If error writing, abort *)
KPos := (New.NumKeys-1) * I^.KeySize; (* Set ptr to last key on *)
I^.KPtr := ADR(New.Keys[KPos]); (* the low page (mid key) *)
Copy(I^.Key.Key, I^.KPtr^.Key); (* Make a copy of the middle*)
I^.Key.RecPtr := 0; (* key, to pass to parent *)
IF NOT I^.LeafPage THEN (* If page was a node, then *)
DEC(New.NumKeys); (* don't save middle key *)
END; (* value, only pointer *)
I^.Page := New; (* Prepare to write lower *)
I^.PNum := I^.NextFree; (* (pointer to pass up to *)
PutPage(I); (* Write new page to disk. *)
IF ErrCode # 0 THEN RETURN; END; (* If error writing, abort *)
I^.Key.PagePtr := I^.NextFree; (* parent node w/mid key) *)
INC(I^.NextFree); (* Bump next free page # *)
END Split;

PROCEDURE NewRoot();
BEGIN
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
InitPage(I^.Page); (* Initialize new root page *)
I^.KNum := 1; (* and first key (pointer *)
InsertKey(); (* to the lower page) *)
I^.KNum := 2; (* Second key is pointer *)
I^.Key.PagePtr := I^.Root; (* to the higher page *)
I^.Key.RecPtr := 0; (* Old root *)
InsertKey(); (* Since this is a node, *)
I^.Page.NumKeys := 1; (* last key is ptr only *)
I^.Root := I^.NextFree; (* Get page number for new *)
INC(I^.NextFree); (* root and bump nextfree *)
I^.PNum := I^.Root; (* Write new root node to *)
PutPage(I); (* disk. *)
END NewRoot;

BEGIN
ErrCode := 0; (* Init result code *)
Copy(SKey, Key); (* Make working copy of key *)
PadRight(SKey, I^.KeyLen); (* Convert to dBase string *)
WriteLock(I); (* Write lock index. *)
UpdateHeader(I); (* Get current index header *)
(* Traverse tree down to leaf level *)
ClearStack(I); (* Clear tree path stack. *)
I^.PNum := I^.Root; (* Start with root page. *)
GetPage(I); (* Get root page from disk. *)
IF ErrCode # 0 THEN RETURN; END; (* If root error, abort now *)
WHILE (NOT I^.LeafPage) AND (ErrCode = 0) DO (* While not at leaf level, *)
Next := ScanPage(I, SKey, Ptr); (* get next page number. *)
PushPage(I); (* push current page/key *)
I^.PNum := Next; (* Make next page current *)
GetPage(I); (* Get page from disk, *)
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
END; (* continue till leaf page *)
(* Prepare new key for insertion into tree. *)
RecPtr := ScanPage(I, SKey, Ptr); (* find pos for new key *)
Copy(I^.Key.Key, SKey); (* Load new key string *)
I^.Key.RecPtr := Ptr; (* Load new key record ptr *)
I^.Key.PagePtr:= 0; (* Set new key's page ptr *)
(* Enter key in tree and re-organize as needed. *)
LOOP;
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
InsertKey(); (* Add key to cur page. *)
IF I^.Page.NumKeys <= I^.KeysPerPage THEN (* If no overflow occurred, *)
PutPage(I); (* replace cur page and *)
EXIT; (* exit loop now. *)
END; (* Else if page overflowed, *)
Split(); (* split current page. *)
IF I^.SPtr = 0 THEN (* If root page was split, *)
NewRoot(); (* create a new root *)
EXIT; (* and exit loop. *)
ELSE (* Otherwise, *)
PopPage(I); (* get no. of ancestor. *)
GetPage(I); (* get ancestor from disk*)
END; (* continue looping *)
END; (* pushing new key up *)
INC(I^.Changes); (* Set NDX changed flag *)
IF I^.Shared THEN (* If in multi-user mode, *)
WriteHeader(I); (* write changes to NDX *)
END; (* header. *)
WriteUnLock(I); (* Release write lock *)
ReadLock(I); (* Read lock index. *)
SeekKey(I, SKey, Ptr); (* Set path to new key. *)
ReadUnLock(I); (* Release index and return *)
END AddKey;

PROCEDURE AddNKey(I : NDXFile; Key : LONGREAL; Ptr : LONGCARD);
VAR KeyStr : ARRAY [0..7] OF CHAR;
BEGIN
Move(ADR(Key), ADR(KeyStr), 8);
AddKey(I, KeyStr, Ptr);
END AddNKey;

PROCEDURE DelKey(I : NDXFile); (* Delete last key found *)
PROCEDURE RemoveKey();
VAR CPos, SPos, Num : CARDINAL;
KPtr : KeyPtr;
BEGIN
SPos := (I^.KNum-1) * I^.KeySize; (* For key to be deleted, *)
Num:=(I^.Page.NumKeys-I^.KNum)*I^.KeySize+8;
CPos := 0;
WHILE CPos < Num DO
I^.Page.Keys[SPos + CPos] :=
I^.Page.Keys[SPos + CPos + I^.KeySize];
INC(CPos);
END;
DEC(I^.Page.NumKeys);
END RemoveKey;

BEGIN
ErrCode := 0; (* Init result code *)
IF NOT I^.FOUND THEN RETURN; END; (* If no cur key, were done *)
WriteLock(I); (* Write lock index. *)
UpdateHeader(I); (* Get current index header *)
IF I^.CHANGED THEN (* If structure changed, *)
SeekKey(I, I^.Key.Key, I^.Key.RecPtr); (* Set path to last key, *)
IF NOT I^.FOUND THEN RETURN; END; (* If already deleted, done.*)
END; (* Else with path set to *)
LOOP (* last key found, *)
IF ErrCode # 0 THEN RETURN; END; (* If error, abort now. *)
RemoveKey(); (* Remove key from page *)
PutPage(I); (* and write page to disk. *)
IF (I^.Page.NumKeys > 0) OR (I^.SPtr = 0) (* If more keys in page, *)
THEN EXIT; (* or at root, we're done*)
ELSE (* Else remove ancestor ptr *)
PopPage(I); (* Get ancestor pointer *)
GetPage(I); (* Retrieve from disk, *)
END;
END; (* Delete loop *)
INC(I^.Changes); (* Set NDX changed flag *)
IF I^.Shared THEN (* If in multi-user mode, *)
WriteHeader(I); (* update NDX header, *)
END;
WriteUnLock(I); (* Release write lock *)
ReadLock(I); (* Read lock index *)
SeekKey(I, I^.Key.Key, I^.Key.RecPtr); (* Set path to next key, *)
ReadUnLock(I); (* Release index and return *)
END DelKey;

(****************************************************************************)
(* Exported procedures for opening, closing, and creating indices *)
(****************************************************************************)

PROCEDURE OpenNDX (VAR I : NDXFile; FileName : ARRAY OF CHAR);
VAR TempIOcheck : BOOLEAN;
TempShareMode : BITSET;
BEGIN
ErrCode := 0; (* Init result code *)
IF NOT Available(SIZE(NDXRec)) THEN (* If not enough memory, *)
HandleError('OpenNDX', I, ErrMemory); (* display error message *)
RETURN; (* and abort opening NDX *)
END; (* Else with memory availble*)
ALLOCATE(I, SIZE(NDXRec)); (* Allocate NDX memory *)
Copy(I^.Name, FileName); (* Copy in file name to I *)
Caps(I^.Name); (* Convert to upper case. *)
IF (Pos(I^.Name, '.')) > (HIGH(I^.Name)) THEN (* Check for file extension *)
Append(I^.Name, '.NDX'); (* If none, append default *)
END; (* extension of '.NDX' *)
I^.Shared := MultiUser; (* Set sharing mode for NDX *)
I^.RDLOCKED := FALSE; (* Set read locked to false *)
I^.WRLOCKED := FALSE; (* Set write locked false *)
I^.CHANGED := FALSE; (* Set changed flag false *)
I^.OPEN := FALSE; (* Set file open flag false *)
TempShareMode := FIO.ShareMode; (* Save previous share mode *)
IF MultiUser (* If in multi-user mode, *)
THEN FIO.ShareMode := FIO.ShareDenyNone; (* Setup for shared access *)
ELSE FIO.ShareMode := FIO.ShareDenyRW; (* Else setup for excluseive*)
END; (* (Single user) access *)
TempIOcheck := FIO.IOcheck; (* Save IOchecking status *)
FIO.IOcheck := FALSE; (* Turn off IO err checking *)
I^.Handle := FIO.Open(I^.Name); (* Attempt to open file. *)
FIO.ShareMode := TempShareMode; (* Restore sharing mode *)
IF FIO.IOresult() > 0 THEN (* If error opening file, *)
DEALLOCATE(I, SIZE(NDXRec)); (* return memory used, *)
FIO.IOcheck := TempIOcheck; (* restore err checking *)
HandleError('OpenNDX', I, ErrOpen); (* display error message *)
RETURN; (* and abort opening NDX *)
END; (* Else, index opened OK, *)
I^.OPEN := TRUE; (* Set NDX open flag *)
ReadHeader(I); (* Read header from disk *)
IF ErrCode # 0 THEN (* If error reading header, *)
FIO.Close(I^.Handle); (* close NDX file, *)
DEALLOCATE(I, SIZE(NDXRec)); (* return memory used, *)
FIO.IOcheck := TempIOcheck; (* restore err checking *)
RETURN; (* and abort procedure. *)
END; (* Else header read OK. *)
IF (I^.KeyLen > MaxKeyLen) OR (* If header data is not *)
(I^.KeyLen = 0) OR (* valid for a dBase *)
(I^.KeySize < I^.KeyLen + 8) OR (* index file, (i.e. *)
((I^.KeySize MOD 2) # 0) OR (* Key length or size or *)
(I^.KeysPerPage < 4) OR (* keys per page is set *)
(I^.KeysPerPage > 50) THEN (* to an illegal value, *)
HandleError('OpenNDX', I, ErrBadNDX); (* display error message *)
FIO.Close(I^.Handle); (* close index file, *)
DEALLOCATE(I, SIZE(NDXRec)); (* return memory used, *)
FIO.IOcheck := TempIOcheck; (* restore err checking *)
RETURN; (* and abort procedure. *)
END; (* Else NDX header is OK. *)
FIO.IOcheck := TempIOcheck; (* Restore IO err checking *)
GoTop(I); (* Init to start of NDX *)
END OpenNDX;

PROCEDURE CloseNDX(VAR I : NDXFile);
VAR TempIOcheck : BOOLEAN;
BEGIN
ErrCode := 0; (* Init result code *)
IF NOT I^.Shared THEN (* If in single user mode, *)
WriteHeader(I); (* update index header *)
END; (* before closing. *)
TempIOcheck := FIO.IOcheck; (* Save IOchecking status *)
FIO.IOcheck := FALSE; (* Turn off IO err checking *)
FIO.Close(I^.Handle); (* Close index file. *)
FIO.IOcheck := TempIOcheck; (* Restore IO error checking*)
IF FIO.IOresult() > 0 THEN (* If error closing file, *)
HandleError('CloseNDX', I, ErrClose); (* set error return code *)
END; (* Either way, *)
DEALLOCATE(I, SIZE(NDXRec)); (* Return memory used. *)
END CloseNDX;

PROCEDURE CreateNDX(VAR I : NDXFile; FileName : ARRAY OF CHAR;
KeyField : ARRAY OF CHAR;
KeyType : CHAR;
KeyLen : CARDINAL);
VAR N : CARDINAL; (* For initializing root *)
TempIOcheck : BOOLEAN; (* FIO IOcheck mode storage *)
TempShareMode : BITSET; (* FIO Share mode storage *)
BEGIN
ErrCode := 0; (* Init result code *)
IF NOT Available(SIZE(NDXRec)) THEN (* If not enough memory, *)
HandleError('CreateNDX', I, ErrMemory); (* display error message *)
RETURN; (* and abort procedure. *)
END; (* Else, with mem available,*)
ALLOCATE(I, SIZE(NDXRec)); (* allocate memory. *)
I^.OPEN := FALSE; (* Initialize open and lockd*)
I^.RDLOCKED := FALSE; (* Read locked to false *)
I^.WRLOCKED := FALSE; (* Write locked to false *)
Caps(FileName); (* Convert to upper case. *)
Copy(I^.Name, FileName); (* Copy in file name to I *)
IF Pos('.', I^.Name) > HIGH(I^.Name) THEN (* Check for file extension *)
Append(I^.Name, '.NDX'); (* If none, append default *)
END; (* extension of '.NDX' *)
TempIOcheck := FIO.IOcheck; (* Save IOchecking status *)
FIO.IOcheck := FALSE; (* Turn off IO err checking *)
I^.Handle := FIO.Create(I^.Name); (* Create index file *)
FIO.IOcheck := TempIOcheck; (* Restore IO error checking*)
IF FIO.IOresult() # 0 THEN (* If error creating index, *)
DEALLOCATE(I, SIZE(NDXRec)); (* return memory used, *)
HandleError('CreateNDX', I, ErrOpen); (* display error message *)
RETURN; (* and abort procedure. *)
END; (* Else with NDX created *)
I^.OPEN := TRUE; (* Set file open flag *)
I^.Root := 1; (* Initialize root pointer *)
I^.NextFree := 2; (* Init Next free page ptr *)
I^.Dummy1 := 0; (* Init dummy fields to 0 *)
IF (KeyType = 'N') OR (KeyType = 'D') (* If key type is numeric, *)
THEN I^.Numeric := 1; (* set numeric flag *)
ELSE I^.Numeric := 0; (* Else clear numeric flag *)
END; (* Either way, set length *)
I^.KeyLen := KeyLen; (* as specified by caller*)
IF ((KeyLen MOD 4) > 0) (* Calculate value of key *)
THEN I^.KeySize := KeyLen + 8 + (* size (Key string len *)
(4 - (KeyLen MOD 4)); (* + length of key ptrs) *)
ELSE I^.KeySize := KeyLen + 8; (* for compatibility *)
END; (* with dBase NDX files *)
I^.KeysPerPage := 508 DIV I^.KeySize; (* Init Keys per page *)
I^.Dummy2 := 0; (* Init dummy fields to 0 *)
I^.Unique := 0; (* Init unique key to FALSE *)
Copy(I^.KeyField, KeyField); (* Copy in key expression *)
WriteHeader(I); (* Write new index header. *)
IF ErrCode # 0 THEN (* If error writing header, *)
FIO.IOcheck := FALSE; (* turn off IO err chkng *)
FIO.Close(I^.Handle); (* Close file. *)
FIO.IOcheck := TempIOcheck; (* restore IO err chking *)
DEALLOCATE(I, SIZE(NDXRec)); (* return memory used *)
RETURN; (* and abort procedure. *)
END; (* Else w/header written, *)
I^.Page.NumKeys := 0; (* Init root page *)
FOR N := 0 TO HIGH(I^.Page.Keys) DO (* Set # of keys to 0 *)
I^.Page.Keys[N] := 0C; (* and clear page. *)
END; (* with root page initializd*)
I^.PNum := I^.Root; (* Set cur page to root, *)
I^.KNum := 0; (* Set cur key to none, *)
PutPage(I); (* Write page to disk, *)
IF ErrCode # 0 THEN RETURN; END; (* If err writing root abort*)
FIO.IOcheck := FALSE; (* Else, turn off err chking*)
FIO.Close(I^.Handle); (* Close new index file, *)
FIO.IOcheck := TempIOcheck; (* Restore IO err checking *)
DEALLOCATE(I, SIZE(NDXRec)); (* Return memory used. *)
END CreateNDX;

(****************************************************************************)
(* Miscellaneous exported procedures *)
(****************************************************************************)

PROCEDURE Unique(I : NDXFile) : BOOLEAN;
BEGIN
ErrCode := 0; (* Set result code = OK *)
RETURN I^.Unique = 1; (* Return Unique flag *)
END Unique;

PROCEDURE KeyField(I : NDXFile; VAR Field : ARRAY OF CHAR);
BEGIN
ErrCode := 0; (* Set result code = OK *)
Copy(Field, I^.KeyField); (* Return key expresison *)
END KeyField;

PROCEDURE CurKey(I : NDXFile; VAR Field : ARRAY OF CHAR);
BEGIN
ErrCode := 0; (* Set result code to OK *)
Copy(Field, I^.Key.Key);
END CurKey;

BEGIN
SetRetries(0,0); (* Turn off auto retries *)
MultiUser := FALSE; (* Default is Single user *)
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 *)
END NDX.

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