home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
modula2
/
library
/
dbf_file
/
ndx.mod
< prev
next >
Wrap
Text File
|
1991-07-16
|
80KB
|
1,312 lines
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.
