Topspeed_JPI/TS-V3/MODBASE/DBINDXES.MOD

IMPLEMENTATION MODULE DBIndxes;
(*# check(overflow=>off) *)
(*/NOCHECK O *)
(*
 *  ModBase
 *  Release 3.0
 *  (c) Copyright 1986 - 1990 Donald G. Fletcher
 *  (c) Copyright 1986 - 1991 PMI
    Copyright 1988 - 1991 John McMonagle
 *  P.O. Box 8402
 *  Green Bay Wi 53308
 *  All Rights Reserved
 *)


(*
  - DBIndex
  - Bug in CloseIndex fixed April 2, 1987
  - DeleteEntry rewritten April 2, 1987
  - CloseIndex does not write its rootnode unless ndx^.open is TRUE
  - Most FOR loops have been rewritten to use Move or ShiftArrayRight
  - September 14, 1987 - Rewritten with LONGINT for Logitech 3.0
*)
(*System modules*)
FROM SYSTEM IMPORT ADR,ADDRESS,SIZE,BYTE;
FROM M2Strings IMPORT Assign,CompareStr, Copy,Length,Concat;
(*PMI modules*)
FROM LowLevel IMPORT Move, Fill, ShiftArrayRight,Address8086,
   BitwiseAnd,ShiftLeft;
IMPORT StringIO; (*from Repertoire*)
IMPORT HandleIO,FAPI;   (*from Repertoire*)
FROM Numbers IMPORT Max;
FROM StrEdit IMPORT CrunchBlanks,CAPstr,Append;
FROM PosUtils IMPORT Equal;
FROM NumTypes IMPORT Real8;
(*ModBase modules*)
FROM ErrorManager IMPORT WARN;
FROM StrConv IMPORT StrToReal;
FROM ModBase3 IMPORT DBFile, ReadDBRec,  GetField, SetDBBuffer,
  UpDateIndexes,SetRecordMode,OpenDBF,Appending,SetIndexList,
  IndexList,NumberRecords,FieldList,BufferSize,PosOfField,Record,
  DBFieldPtr,Deleted;
FROM VStorage IMPORT
    DosAlloc, DosDealloc,DosAvail;
(*   IMPORT ChkInd;   *)
(*key numbering convention node[0] contains the number of keys but
  getkey etc. the first one is 1 not 0. *)
IMPORT Locks,ModBase3;
  PROCEDURE DEALLOCATE(VAR loc:ADDRESS;size:CARDINAL);
  BEGIN
    DosDealloc(loc,size);
  END DEALLOCATE;

  PROCEDURE ALLOCATE(VAR loc:ADDRESS;size:CARDINAL);
  BEGIN
    DosAlloc(loc,size);
  END ALLOCATE;

CONST
  FirstKey = 0;  (* the number of the first key in a node *)
  MaxKey = 128;
  RecNumLen = 4;
  NodeSize = 512;
  IndexNameLength = 80;
  MaxField = 128;
  MaxDepth = 24;
  FirstNode = 0;
  RootNodePtrPos = 4;
  NextFreeNodePtrPos = 8;
  KeyLenPos = 12;
  KeyEntPos = 14;
  KeyTypePos = 22;
  KeyExpPos = 24;
  DepthPosition = 256;
  InitCode  =56317;
  Bins=128;

TYPE
  HeaderNodeType=
    RECORD
      rootptr,
      nextfreenode,
      FreeList   :LONGINT; (* this may not be true dbase compatable *)
      keylength,
      keyspernode:CARDINAL;
      NumType,fill:BOOLEAN;
      entrylength:CARDINAL;
      Flag,
      fill2:CARDINAL;
      KeyExpression:ARRAY[0..487] OF CHAR;
    END (* record *);

  NodeType = ARRAY [0..NodeSize-1] OF CHAR;

  IndexBuffer = POINTER TO NodeBuffType;

  NodeBuffType =
    RECORD
      node: NodeType;
    (*  clean:CARDINAL; diag to test for overwriting node *)
      number: LONGINT;
      next, prev,NHash,PHash: IndexBuffer;
      Lock,NeedToWrite:BOOLEAN;
    END;

  KeyPosType = RECORD
    buffer:  IndexBuffer ;
    keynum : CARDINAL;
  END;

  Route = ARRAY [0..MaxDepth] OF KeyPosType;

  EntryType =
    RECORD
      lowernode: LONGINT;
      recordnum: LONGINT;
      value    : ARRAY [0..MaxKey] OF CHAR;
    END;

  KeyPointer=POINTER TO EntryType;

  RealEntry =
    RECORD
      lowernode: LONGINT;
      recordnum: LONGINT;
      key:Real8;
    END;

  RealKeyPointer=POINTER TO RealEntry;

 CompareType=(LT,EQ,GT);

 CompareProc= PROCEDURE( ADDRESS,ADDRESS,CARDINAL): CompareType;


  DBIndex= POINTER TO IndexRec;
  IndexRec =
    RECORD
      name: ARRAY [1..IndexNameLength] OF CHAR;
      f: CARDINAL; (* this is the file handle *)
      Locked:CARDINAL; (* indicates file is locked *)
      includedeleted,
      Exclusive, (* indicates file locking not needed *)
      Changed,
      open: BOOLEAN;
      Safety: BOOLEAN;
      KeyNumber,
      depth,
      Init:CARDINAL;
      alias:DBFile;
      Header:HeaderNodeType;
      KeyProc  :KeyProcedure;
      posarray: Route;
      CASE :BOOLEAN OF
        TRUE: currentkey: KeyPointer;|
        FALSE: numkey    : RealKeyPointer;
      END;
    first, last: IndexBuffer;
    currsize: CARDINAL;
    buffsize: CARDINAL;
    (* number of Nodes in Buffer *)
    UpdateList:DBIndex;(* consider having list in seperate record
          so that Index can be updated from more than one DBF *)
    Hash:ARRAY[0..Bins-1] OF IndexBuffer;
  END;

PROCEDURE HashP(number:LONGINT):CARDINAL;
  TYPE
   LSet=SET OF [0..31];
BEGIN
  RETURN   VAL(CARDINAL,LONGINT(LSet(127)*LSet(number) )  );
END HashP;

PROCEDURE AddToTable(ndx:DBIndex;BufPtr:IndexBuffer);
VAR
  ptr:IndexBuffer;
  h:CARDINAL;
BEGIN
  h:=HashP(BufPtr^.number);
  ptr:=ndx^.Hash[h];
  BufPtr^.NHash:=ptr;
  IF ptr#NIL THEN
    ptr^.PHash:=BufPtr
  END;
  BufPtr^.PHash:=NIL;
  ndx^.Hash[h]:=BufPtr;
END AddToTable;

PROCEDURE RemoveFromTable(ndx:DBIndex;BufPtr:IndexBuffer);
BEGIN
  IF BufPtr^.PHash=NIL THEN
    ndx^.Hash[HashP(BufPtr^.number)]:=BufPtr^.NHash;
  ELSE
    BufPtr^.PHash^.NHash:=BufPtr^.NHash
  END;
  IF BufPtr^.NHash#NIL THEN
    BufPtr^.NHash^.PHash:=BufPtr^.PHash;
  END;
  BufPtr^.PHash:=NIL;
  BufPtr^.NHash:=NIL;
END RemoveFromTable;

PROCEDURE InitPosarray( ndx: DBIndex);
VAR
  i:CARDINAL;
BEGIN
  FOR i:= 0 TO MaxDepth DO
    ndx^.posarray[i].buffer:=NIL;
  END;
END InitPosarray;

PROCEDURE InBuffer( ndx: DBIndex; nodenumber: LONGINT; VAR
    BufPtr: IndexBuffer): BOOLEAN;

BEGIN
  BufPtr:=ndx^.Hash[HashP(nodenumber)];
  IF BufPtr = NIL THEN
    RETURN FALSE
  ELSE
    LOOP
      WITH BufPtr^ DO
        IF (number = nodenumber) THEN
          RETURN TRUE
        END;
        IF  (NHash = NIL) THEN
          RETURN FALSE
        END;
      END (* WITH *);
      BufPtr := BufPtr^.NHash;
    END; (* loop *)
  END;
END InBuffer;

PROCEDURE AddBuffer( ndx:DBIndex;VAR buffer: IndexBuffer );
BEGIN
  (* always add to top *)
  buffer^.next:=ndx^.first;
  buffer^.prev:=NIL;
  IF buffer^.next=NIL
  THEN
    ndx^.last:=buffer;
  ELSE
    ndx^.first^.prev:=buffer;
  END;
  ndx^.first:=buffer;
  buffer^.Lock:=TRUE;
  INC(ndx^.currsize);
END AddBuffer;

PROCEDURE RemoveBuffer(ndx:DBIndex;VAR buffer: IndexBuffer );
BEGIN
  IF buffer^.next=NIL
  THEN
    IF buffer^.prev=NIL
    THEN
      ndx^.first:=NIL;
      ndx^.last:=NIL;
    ELSE
      ndx^.last:=buffer^.prev;
      buffer^.prev^.next:=buffer^.next;
    END;
  ELSE
    IF buffer^.prev=NIL
    THEN
      ndx^.first:=buffer^.next;
      buffer^.next^.prev:=buffer^.prev;
    ELSE
      buffer^.next^.prev:=buffer^.prev;
      buffer^.prev^.next:=buffer^.next;
    END;
  END;
  DEC(ndx^.currsize);
END RemoveBuffer;


PROCEDURE WriteNode( ndx: DBIndex; nodenumber: LONGINT;
 VAR nodeblock: NodeType);
VAR pos: LONGINT;
FileError: StringIO.ErrorMessage;

(*PROCEDURE Errorchk;(* diag *)
VAR
  buffer:IndexBuffer;
  i:CARDINAL;
BEGIN
  IF  NOT InBuffer(ndx,nodenumber,buffer)
  THEN
    HALT;
  END;
  FOR i:=0 TO 511 DO
    IF buffer^.node[i]#nodeblock[i]
    THEN
      HALT;
    END;
  END;
END Errorchk;*)

BEGIN
(*  IF nodenumber>VAL(LONGINT,1)
  THEN
    Errorchk
  END; *)
  pos := nodenumber * VAL(LONGINT, NodeSize);
  HandleIO.SetFilePtr(ndx^.f, HandleIO.FromStart, pos);
  FileError := HandleIO.BlockWrite(ndx^.f, ADR(nodeblock), NodeSize);
  IF FileError # StringIO.NoError THEN
    WARN('Block write failure in WriteNode');
  END;
  IF ndx^.Safety
  THEN
    HandleIO.UpdateDisk(ndx^.f);
  END;

END WriteNode;

PROCEDURE InitNode(VAR node: NodeType);
BEGIN
  Fill(ADR(node), NodeSize, 0C);
END InitNode;

PROCEDURE FindFreeBuffer( ndx:DBIndex;VAR buffer: IndexBuffer ):BOOLEAN;
BEGIN
  buffer:=ndx^.last;
  WHILE buffer^.Lock
  DO
    IF buffer^.prev=NIL
    THEN
      RETURN FALSE;
    END;
    buffer:=buffer^.prev;
 END;
  (* if one is looking for buffer it will be reused so write it
  out if safety is off *)
  IF buffer^.NeedToWrite
  THEN
    WriteNode(ndx,buffer^.number,buffer^.node);
  END;
  RETURN TRUE;
END FindFreeBuffer;

PROCEDURE GetBuffer( ndx:DBIndex;VAR buffer: IndexBuffer;
                    NodeNumber:LONGINT );
BEGIN
  IF  (( ndx^.buffsize>ndx^.currsize) AND DosAvail(8000))
  THEN
    DosAlloc(buffer,SIZE(buffer^));
  ELSE;
    IF FindFreeBuffer(ndx,buffer)
    THEN
      RemoveBuffer(ndx,buffer);
      RemoveFromTable(ndx,buffer);
    ELSE
      DosAlloc(buffer,SIZE(buffer^));
    END;
  END;
  AddBuffer(ndx,buffer);
  (* init buffer *)
  buffer^.number:=NodeNumber;
  AddToTable(ndx,buffer);
  (* buffer^.clean:=37513;  diag *)
  buffer^.NeedToWrite:=FALSE;
  buffer^.Lock:=FALSE;
  InitNode(buffer^.node);
END GetBuffer;

PROCEDURE ReadNode( ndx: DBIndex;
                       nodenumber: LONGINT;
                   VAR buffer: IndexBuffer);
    (* the file associated with the index must already be open *)
VAR pos: LONGINT;
FileError: StringIO.ErrorMessage;
BEGIN
  IF InBuffer(ndx,nodenumber,buffer)
  THEN
    RemoveBuffer(ndx,buffer);
    AddBuffer(ndx,buffer);
    RETURN
  END;
  GetBuffer(ndx,buffer,nodenumber);
  (*buffer^.number:=nodenumber;*)
  pos := nodenumber * VAL(LONGINT, NodeSize);
  HandleIO.SetFilePtr(ndx^.f, HandleIO.FromStart, pos);
  FileError := HandleIO.BlockRead(ndx^.f, ADR(buffer^.node), NodeSize);
  IF FileError # StringIO.NoError THEN
    WARN('Block read failure in ReadNode');
  END;
END ReadNode;

PROCEDURE NewNode( ndx:DBIndex;VAR buffer:IndexBuffer) ;
BEGIN
  IF ndx^.Header.FreeList=VAL(LONGINT,0)
  THEN
    GetBuffer(ndx,buffer,ndx^.Header.nextfreenode);
    (*buffer^.number:=ndx^.Header.nextfreenode;*)
    INC(ndx^.Header.nextfreenode)
  ELSE
    ReadNode(ndx,ndx^.Header.FreeList,buffer);
    Move(ADR(buffer^.node),ADR(ndx^.Header.FreeList),4);
    InitNode(buffer^.node);
  END;

END NewNode;

PROCEDURE ReadIntoArray( ndx :DBIndex;
                        nodenumber: LONGINT;
                        level :CARDINAL);
BEGIN
  IF ndx^.posarray[level].buffer#NIL
  THEN
    ndx^.posarray[level].buffer^.Lock:=FALSE;
  END;
  ReadNode(ndx, nodenumber, ndx^.posarray[level].buffer);
  ndx^.posarray[level].buffer^.number:=nodenumber;
  ndx^.posarray[level].buffer^.Lock:=TRUE;
END ReadIntoArray;

PROCEDURE ReadHeader( ndx:DBIndex);
BEGIN
    HandleIO.SetFilePtr(ndx^.f, HandleIO.FromStart, 0);
    StringIO.PrintMessage(HandleIO.BlockRead(ndx^.f,ADR(ndx^.Header),
      SIZE(ndx^.Header)))
END ReadHeader;

PROCEDURE WriteHeader( ndx:DBIndex);
BEGIN
    HandleIO.SetFilePtr(ndx^.f, HandleIO.FromStart, 0);
    StringIO.PrintMessage(HandleIO.BlockWrite(ndx^.f,ADR(ndx^.Header),
    SIZE(ndx^.Header)))

END WriteHeader;

PROCEDURE GetKeyPtr(VAR node: NodeType;
                 ndx:  DBIndex;
                 keynumber: CARDINAL):KeyPointer;

BEGIN
  RETURN ADR(node[4 +(keynumber * ndx^.Header.entrylength)]);
END GetKeyPtr;

PROCEDURE GetKey(VAR node: NodeType;
                 ndx:  DBIndex;
                 keynumber: CARDINAL;
                 VAR key: EntryType);

BEGIN
  (* entire procedure should be eliminated and placed in line.
  changes are based on assumption that the max key size is 128
  and 129 are avalable. error checking could be done in buildindex!!!!*)
  Move(ADR(node[4 +(keynumber * ndx^.Header.entrylength)]), ADR(key),
     ndx^.Header.entrylength);
  key.value[ndx^.Header.keylength]:=0C;
END GetKey;

(*
PROCEDURE CompareKeyReal( ad1,ad2 : ADDRESS;size:CARDINAL) : CompareType;
TYPE
  rp= RECORD
        CASE:CARDINAL OF
           1:
           r:POINTER TO Real8;
         | 2:
           b:POINTER TO ARRAY[0..7] OF BYTE;
         | 3:
           a:ADDRESS;
         END;
       END;
VAR
  r1,r2:rp;
  BEGIN
   r1.a:=ad1;
   r2.a:=ad2;
   IF (r1.r^ < r2.r^) THEN
     RETURN LT
   ELSIF (r1.b^ = r2.b^) THEN
     RETURN EQ
    ELSE
      RETURN GT
    END;
  END CompareKeyReal;
  *)
  PROCEDURE CompareKeyReal(s1, s2 : ADDRESS;size:CARDINAL) : CompareType;
    TYPE
  rp= RECORD
        CASE:CARDINAL OF
           1:
           r:POINTER TO Real8;
         | 2:
           c:POINTER TO CARDINAL;
         | 3:
           a:ADDRESS;
         | 4:
          off,seg:CARDINAL;
         | 5:
           b:POINTER TO BITSET;
         END;
       END;

    VAR
      TmpAdr1, TmpAdr2 :  rp;
      cnt : CARDINAL;
      neg:BOOLEAN;
    BEGIN
      TmpAdr1.a := s1;
      TmpAdr2.a := s2;
      INC(TmpAdr1.off,6);
      INC(TmpAdr2.off,6);
      neg:=(15 IN TmpAdr1.b^) OR (15 IN TmpAdr2.b^);
      cnt := 0;
      WHILE cnt<4 DO
        IF TmpAdr1.c^#TmpAdr2.c^ THEN
          IF TmpAdr1.c^>TmpAdr2.c^ THEN
            IF neg THEN
              RETURN LT
            ELSE
              RETURN GT
            END;
          ELSE
            IF neg THEN
              RETURN GT
            ELSE
              RETURN LT;
            END;
          END;
        ELSE
          INC(cnt);
          DEC(TmpAdr1.off,2);
          DEC(TmpAdr2.off,2);
        END;
      END;
      RETURN EQ;
    END CompareKeyReal;

  PROCEDURE CompareKey(s1, s2 : ADDRESS;size:CARDINAL) : CompareType;
    VAR
      TmpAdr1, TmpAdr2 :  Address8086;
      cnt : CARDINAL;
    BEGIN
      TmpAdr1.a := s1;
      TmpAdr2.a := s2;
      cnt := 0;
      WHILE cnt<size DO
        IF TmpAdr1.b^#TmpAdr2.b^ THEN
          IF TmpAdr1.b^>TmpAdr2.b^ THEN
            RETURN GT;
          ELSE
            RETURN LT;
          END;
        ELSE
          IF (TmpAdr1.b^=0C)
          THEN (* if on 0C were done *)
            RETURN EQ
          END;
          INC(cnt);
          INC(TmpAdr1.off);
          INC(TmpAdr2.off);
        END;
      END;
      RETURN EQ;
    END CompareKey;

PROCEDURE FindPosition( ndx: DBIndex;
                        KeyValue: ADDRESS;
                        VAR found: BOOLEAN;
                        CompareP:CompareProc);

VAR level, keysinnode,
    diff,
    Top,Bottom,
    crrntkeynum: CARDINAL;
    done: BOOLEAN;
    keyptr:KeyPointer;
    nextnode: LONGINT;
BEGIN
  IF   OpenIndex(ndx)=FALSE
  THEN
    WARN('Error opening Index in FindPosition');
  END;
  nextnode := ndx^.Header.rootptr;  (* start search with root node *)
  level := 0;
  found:=FALSE;
  REPEAT
    ReadIntoArray(ndx, nextnode, level);
    WITH  ndx^.posarray[level] DO
      keysinnode := ORD(buffer^.node[0]);
      Top:=keysinnode;
      Bottom:=0;
      crrntkeynum:=(Top)DIV 2;(* use shift operator? *)
      done := FALSE;
    (*  IF buffer^.clean# 37513 THEN HALT END;  diag *)
      LOOP
        keyptr:=GetKeyPtr(buffer^.node, ndx, crrntkeynum);
        WITH  keyptr^ DO
          CASE  CompareP(KeyValue,ADR(value),ndx^.Header.keylength) OF
            LT: (* key is less than tested value *)
                diff:=crrntkeynum-Bottom;
                IF diff<1
                THEN
                  EXIT; (* done *)
                END;
                Top:=crrntkeynum; (* check lower half *)
                crrntkeynum:=Bottom+(diff DIV 2);
             |GT:  (* key is greater than test *)
                diff:=Top-crrntkeynum;
                IF diff<=1
                THEN
                  crrntkeynum:=Top; (*done but currect one was top*)
                  keyptr:=GetKeyPtr(buffer^.node, ndx, crrntkeynum);
                  EXIT;
                END;
                Bottom:=crrntkeynum; (* Next check upper half *)
                crrntkeynum:=Bottom+(diff DIV 2);
             |EQ:
	
(* * * * * * * * * * * * * * * * * * * *testing stuff for ed *)
(* found a position - might not be the first one though  *)
(* loop backwards through the index to find the first if many   *)
               LOOP
		 IF crrntkeynum < 1
		   THEN EXIT;
		   END;  (* at the first *)
		 DEC(crrntkeynum);
		 keyptr := GetKeyPtr(buffer^.node,ndx,crrntkeynum);
		 IF CompareP(KeyValue,ADR(keyptr^.value),ndx^.Header.keylength) = GT
		   THEN INC(crrntkeynum);
		        keyptr := GetKeyPtr(buffer^.node,ndx,crrntkeynum);
		        EXIT;
		   END;
(* * * * * * * * * * *  End of stuff by ed * * * * * * * * * *  *)


	
	       END;  (* end of loop and end of my stuff *)
                found:= TRUE;
                EXIT;
          END; (* CASE *)
        END;
      END (*loop*);

         (* compare the key to the keys in the rootnode until the fieldstring
            <= currentkey or the last entry in the node is encountered *)
      keynum := crrntkeynum;
     (* currentkey set by getkey  *)
      nextnode:=keyptr^.lowernode;
    END;
    INC(level);
  UNTIL nextnode=VAL(LONGINT,0);
  ndx^.depth:=level-1;
  ndx^.currentkey:=keyptr;
END FindPosition;

PROCEDURE FindPositionCh( ndx: DBIndex;
                          keystr: ARRAY OF CHAR;
                         VAR found: BOOLEAN);
VAR
    TestStr:ARRAY[0..MaxKey] OF CHAR;
BEGIN
  Fill(ADR(TestStr),MaxKey,' ');
  Copy(keystr,0,Length(keystr),TestStr);
  FindPosition(ndx,ADR(TestStr),found,CompareKey);
END FindPositionCh;

PROCEDURE FindPositionR( ndx: DBIndex;
                        KeyValue: Real8;
                        VAR found: BOOLEAN);
BEGIN
  FindPosition(ndx,ADR(KeyValue),found,CompareKeyReal);
END FindPositionR;

PROCEDURE FindPositionN(ndx: DBIndex;
                        keystr: ARRAY OF CHAR;
                        VAR found: BOOLEAN);
VAR
    KeyValue:Real8;
BEGIN
  IF NOT StrToReal(keystr, 0,KeyValue) THEN KeyValue:=0.0 END;
  FindPositionR(ndx,KeyValue,found);
END FindPositionN;

PROCEDURE AddRecord( alias: DBFile;
                     ndx: DBIndex);
VAR
    fieldstring: ARRAY [1..MaxField] OF CHAR;
    found: BOOLEAN;
    key:
    RECORD
      CASE :BOOLEAN OF
        TRUE:num:Real8;|
        FALSE:str:ARRAY[0..7] OF CHAR;
      END;
    END;

BEGIN
  IF   OpenIndex(ndx)=FALSE
  THEN
    WARN('Error opening Index in AddRecord');
  END;
  EnterLock(ndx);
  (* get key from record *);
  ndx^.KeyProc(alias,ndx,fieldstring);
  IF ndx^.Header.NumType  THEN
    IF NOT StrToReal(fieldstring, 0,key.num) THEN key.num:=0.0 END;
    FindPositionR(ndx, key.num, found);
    InsertEntry(ndx, key.str, Record(alias));
  ELSE
    FindPositionCh(ndx, fieldstring, found);
    InsertEntry(ndx, fieldstring, Record(alias));
  END; (* Now we have the position where the new Entry
        should be inserted *)
  ExitLock(ndx);
END AddRecord;

PROCEDURE DefaultKeyProcedure(alias:  DBFile; ndx: DBIndex;
     VAR str:ARRAY OF   CHAR );
BEGIN
  GetField(alias, ndx^.KeyNumber, str);

END DefaultKeyProcedure;

PROCEDURE AdjustUpperNode( ndx: DBIndex;VAR KeyStr:ARRAY OF CHAR;
                      level: CARDINAL);
  (* need to pass keystring because may be fixing at the current level
   but not in the route level-1 must point to worknode!!*)
VAR offset: CARDINAL;
  upkey,key:KeyPointer;
BEGIN
  (* do not check to see if it is nessary but make sure level#0 *)
  IF (level=0)  THEN RETURN END;
  (*Adjust upernode*)
  IF (ndx^.posarray[level-1].keynum#
    ORD(ndx^.posarray[level-1].buffer^.node[0]))
  THEN  (* can simplify when changing upkey to upkey^ *)
    upkey:=GetKeyPtr(ndx^.posarray[level-1].buffer^.node,ndx,
      ndx^.posarray[level-1].keynum);
    Move(ADR(KeyStr), ADR(upkey^.value), ndx^.Header.keylength);
    IF ndx^.Safety OR NOT ndx^.Exclusive
    THEN
      WriteNode(ndx, ndx^.posarray[level-1].buffer^.number,
      ndx^.posarray[level-1].buffer^.node);
    ELSE
      ndx^.posarray[level-1].buffer^.NeedToWrite:=TRUE;
    END;
  ELSE
    AdjustUpperNode(ndx,KeyStr,level-1);
  END;
END AdjustUpperNode;

PROCEDURE DeleteEntry(ndx: DBIndex;
                      deletelevel: CARDINAL);
VAR offset: CARDINAL;
  upkey,key:KeyPointer;
  empty:BOOLEAN;
BEGIN
  (* 4/21/89 notes for changes pos is not need as parameter
    if top node is changed need to fix all the way down if
    needed not just one as it is there is some chance of error.
    cosider making procedure to fix uper node as it is used in
    move keys also *)
  (* Find the offset of the keyentry following
     the entry to be deleted, and then shift the rest of the
     node up to cover the deleted node *)
  ndx^.Changed:=TRUE;
  offset := ((ndx^.posarray[deletelevel].keynum + 1) * (ndx^.Header.entrylength)) + 4;
  Move(ADR(ndx^.posarray[deletelevel].buffer^.node[offset]),
      ADR(ndx^.posarray[deletelevel].buffer^.node[offset-ndx^.Header.entrylength]),
       NodeSize-offset);
 (* not correct or nessisary ?
  Fill(ADR(ndx^.posarray[deletelevel].buffer^.
    node[offset -ndx^.Header.entrylength]), ndx^.Header.entrylength, 0C);*)

  (* Next decrement the number of keys in the node and
     write the decremented number in the first byte of the
     node. *)
  empty:=FALSE;
  empty:=(ndx^.posarray[deletelevel].buffer^.node[0])=0C;
  IF NOT empty THEN
    DEC(ndx^.posarray[deletelevel].buffer^.node[0]);
    empty:=(ndx^.posarray[deletelevel].buffer^.node[0]=0C) AND
      (deletelevel =ndx^.depth)
  END;
  IF (deletelevel > 0)
  THEN
    IF empty
    THEN (* THE NODE IS EMPTY *)
    (* posarray must be good *)
      (* put in freenode list *)
      Move(ADR(ndx^.Header.FreeList),
        ADR(ndx^.posarray[deletelevel].buffer^.node),4);
      ndx^.Header.FreeList:=ndx^.posarray[deletelevel].buffer^.number;
      DeleteEntry(ndx,deletelevel-1);
    ELSE;
      (* Check to see if deleted top node *)
      IF deletelevel=ndx^.depth
      THEN
        offset:=1
      ELSE
        offset:=0
      END;
      IF ndx^.posarray[deletelevel].keynum =
       ( ORD(ndx^.posarray[deletelevel].buffer^.node[0])+1-offset)
      THEN
        key:=GetKeyPtr(ndx^.posarray[deletelevel].buffer^.node,
        ndx,ndx^.posarray[deletelevel].keynum-1);
        AdjustUpperNode(ndx,
        key^.value,
        deletelevel);
      END;
    END;
  END; (* if *)

  IF ndx^.Safety OR NOT ndx^.Exclusive
  THEN
    WriteNode(ndx, ndx^.posarray[deletelevel].buffer^.number,
    ndx^.posarray[deletelevel].buffer^.node);
  ELSE
    ndx^.posarray[deletelevel].buffer^.NeedToWrite:=TRUE;
  END;
END DeleteEntry;


PROCEDURE DeleteCurrentEntry( ndx: DBIndex);
VAR
  rec:LONGINT;
BEGIN
  IF   OpenIndex(ndx)=FALSE
  THEN
    WARN('Error opening Index in DeleteCurrentEntry');
  END;
  rec:=ndx^.currentkey^.recordnum;
  EnterLock(ndx);
  IF rec=ndx^.currentkey^.recordnum THEN (* do not delete if not there *)
    DeleteEntry(ndx, ndx^.depth);
  END;
  ExitLock(ndx);
END DeleteCurrentEntry;

PROCEDURE UpdateIndexHeader(ndx :DBIndex );

VAR
    Buffer:IndexBuffer;
BEGIN
  IF NOT ndx^.open
  THEN
    RETURN;
  END;
  HandleIO.SetFilePtr(ndx^.f,HandleIO.FromStart,VAL(LONGINT,0));
  StringIO.PrintMessage(
    HandleIO.BlockWrite(ndx^.f,ADR(ndx^.Header),SIZE(ndx^.Header)));
  IF NOT ndx^.Safety AND ndx^.Exclusive
  THEN (* Write out Buffers  if safety off*)
    Buffer:=ndx^.first;
    WHILE Buffer#NIL
    DO
      IF Buffer^.NeedToWrite
      THEN
        WriteNode(ndx,Buffer^.number,Buffer^.node);
        Buffer^.NeedToWrite:=FALSE;
      END;
      Buffer:=Buffer^.next;
    END;
  END;
END UpdateIndexHeader;



PROCEDURE InsertEntry( ndx: DBIndex;
                       kstr: ARRAY OF CHAR;
                       recno: LONGINT);
VAR i,  level, middle: CARDINAL;
    tempkey:EntryType;
    NewRoot,NewBuffer:IndexBuffer;
    noOverflow,InHighNode: BOOLEAN;
    (*diag,*)oldnodenum, newnodenum, lowernodenum: LONGINT;
    key:
    RECORD
      CASE :BOOLEAN OF
        TRUE:num:Real8;|
        FALSE:str:ARRAY[0..7] OF CHAR;
      END;
    END;



PROCEDURE AddKeyTo( lower, recnum: LONGINT; VAR node: NodeType;
                            val: ARRAY OF CHAR; NewKey:BOOLEAN);
     (* This procedure assumes that there is room in the node for another
        key entry; it does not test for correct positioning, it assumes
        that the ndx^.posarray has been correctly updated by all prior
        operations *)
   VAR moveblocksize, i,  entrypos, keystomove   : CARDINAL;

   BEGIN
     (* consider changing to copy into entry then move all *)
     entrypos := ndx^.posarray[level].keynum;
     keystomove := ORD(node[0])-entrypos+1;
     node[0] := CHR(ORD(node[0])+1);
     i := 4 + (entrypos * ndx^.Header.entrylength); (* 4 bytes reserved for key count *)
     (* make space for the new entry *)
     moveblocksize := keystomove*ndx^.Header.entrylength+4;
     ShiftArrayRight((* from *) ADR(node[i]),
                   (* size *) moveblocksize ,
               (* distance *) ndx^.Header.entrylength);
     Move(ADR(recnum), ADR(node[i+4]), 4);
     (* trims to size *)
     Move(ADR(val),ADR(node[i+8]), ndx^.Header.entrylength - 8);
     Move(ADR(lower), ADR(node[i]), 4);
     (* the Move statement modifies the pointer after the inserted key
        so that it points to the appropriate node.  It is hard to
        remember that the only reason an entry would be inserted into
        a node other than a leaf node is because the lower node was split. *)
     IF  (ndx^.depth=level)
     THEN
       IF NewKey THEN
         ndx^.currentkey:=ADR(node[i])
       END;
       IF (keystomove=1)
       THEN
         AdjustUpperNode(ndx,val,level)
       END;
     END;
   END AddKeyTo;

   PROCEDURE Split(VAR old, new: IndexBuffer);
   VAR
    c:CHAR;
    key:EntryType;
    i, j,  middlekeypos,
    keysinold: CARDINAL;
   BEGIN
     keysinold := ORD(old^.node[0]);
     new^.node := old^.node;
     (* if a key has been handed up from a split node it points to the
        newnode created by the last split *)
     (* save node numbers in case root node is being split *)
     newnodenum:=new^.number;
     oldnodenum:=old^.number;
     middle := (ndx^.Header.keyspernode DIV 2);
     keysinold := keysinold - middle;
     middlekeypos := 4 + (middle)* ndx^.Header.entrylength;
     (* middlekeypos is the END of the middlekey *)
     Fill(ADR(new^.node[middlekeypos]), NodeSize - middlekeypos, 0C);
     (* the new node gets the first  keys, the rest are nulled out *)
     Move(ADR((*from*) old^.node[middlekeypos]),
              (* to *) ADR(old^.node[4]),
              (*size*) (NodeSize-middlekeypos));
     Fill(ADR(old^.node[8+keysinold*ndx^.Header.entrylength]),
           NodeSize-(8+keysinold*ndx^.Header.entrylength),0C);
     new^.node[0] := CHR(middle);
     old^.node[0] := CHR(keysinold);
 (*    IF new=old
     THEN
       HALT;
     END; (* diag *)
*)
     IF ndx^.posarray[level].keynum <= middle THEN
       (* insert into new node ( lowernode ) *)
        (* new is yet in posarray so must trick  Addkeyto to not
        try and adjust upper node as it will be inserted latter*)
        INC(new^.node[0]);
        AddKeyTo(lowernodenum, recno, new^.node, kstr,TRUE);
        DEC(new^.node[0]);
        INC(middle); (* because an entry has been inserted ahead of it *)
        GetKey(new^.node,ndx,middle-1,key); (* get key value to
        insert in lowernode before we lose it *)
        IF lowernodenum#VAL(LONGINT,0)
        THEN (* not at leaf DBASEIII does not store entire lastkey in non leaf
          nodes *)
         DEC(new^.node[0])
        END;
        (* force new pos array *)
        InHighNode:=FALSE;
        (* need to put writes here because the readintoarray
          will lose a node *)
        IF ndx^.Safety OR NOT ndx^.Exclusive
        THEN
          WriteNode(ndx, new^.number, new^.node);
          WriteNode(ndx, old^.number, old^.node);
        ELSE
          new^.NeedToWrite:=TRUE;
          old^.NeedToWrite:=TRUE;
        END;
        ReadIntoArray(ndx, new^.number, level);
        old^.Lock:=FALSE;(* unlock other buffer *)
     ELSE
        (* insert into old (high) node *)
        GetKey(new^.node,ndx,middle-1,key); (* get key value to
        insert in lowernode before we lose it *)
        IF lowernodenum#VAL(LONGINT,0)
        THEN (* not at leaf DBASEIII does not store entire lastkey in non leaf
          nodes *)
          DEC(new^.node[0])
        END;
        ndx^.posarray[level].keynum := (ndx^.posarray[level].keynum - middle) ;
        AddKeyTo(lowernodenum, recno, old^.node, kstr,TRUE);
        IF ndx^.Safety OR NOT ndx^.Exclusive
        THEN
          WriteNode(ndx, new^.number, new^.node);
          WriteNode(ndx, old^.number, old^.node);
        ELSE
          new^.NeedToWrite:=TRUE;
          old^.NeedToWrite:=TRUE;
        END;
        InHighNode:=TRUE;
        (* force new pos array *)
      (*  ReadIntoArray(ndx, old^.number, level); not neeed *)
        new^.Lock:=FALSE;(* unlock other buffer *)
     END;

     (* in order to place new node in tree, act as if was inserting
        the last key in the lower(new) node, so must save info *)
     lowernodenum:=newnodenum;
     Assign(key.value,kstr);
     recno:=key.recordnum;
   END Split;

   PROCEDURE Balance(level:CARDINAL);
     VAR
       offset,
       count,
       insertpos,
       keystomove,
       keys,
       downkeys,
       upkeys:CARDINAL;
       UpBuffer,DownBuffer:IndexBuffer;
       upkey,tempkey:EntryType;
    (*   found:BOOLEAN;(*diag *) *)

  PROCEDURE Movekeys ;
   BEGIN

     noOverflow:=TRUE;
     IF upkeys > downkeys
     THEN (* move to lower node *)
       keystomove:=(keys-downkeys+1) DIV 2;
       count:=keystomove;
       WHILE count>0  DO
         (* get key to move and save*)
         (* remove from bottom place on top *)
         GetKey(ndx^.posarray[level].buffer^.node,
          ndx, 0, tempkey);
          ndx^.posarray[level].keynum:=0;
          DeleteEntry(ndx,  level);
          ndx^.posarray[level].keynum:=ORD(DownBuffer^.node[0]);
          DEC(ndx^.posarray[level-1].keynum);
          AddKeyTo(tempkey.lowernode,tempkey.recordnum,
            DownBuffer^.node,tempkey.value,FALSE);(* addkey does not write *)
          INC(ndx^.posarray[level-1].keynum);
          DEC(count);
       END (* while *);
       IF insertpos  >= keystomove THEN
         (* insert into new node ( lowernode ) *)
          ndx^.posarray[level].keynum:=insertpos-keystomove;
          AddKeyTo(lowernodenum, recno, ndx^.posarray[level].buffer^.node, kstr,TRUE);
          (* force new pos array *)
          (* need to put writes here because the readintoarray
            will lose a node *)
          IF ndx^.Safety OR NOT ndx^.Exclusive
          THEN
            WriteNode(ndx, ndx^.posarray[level].buffer^.number,
               ndx^.posarray[level].buffer^.node);
            WriteNode(ndx, DownBuffer^.number, DownBuffer^.node);
          ELSE
            ndx^.posarray[level].buffer^.NeedToWrite:=TRUE;
            DownBuffer^.NeedToWrite:=TRUE;
          END;
       ELSE
          (* insert into other node *)
          ndx^.posarray[level].keynum :=downkeys+insertpos;
          DEC(ndx^.posarray[level-1].keynum);
          AddKeyTo(lowernodenum, recno, DownBuffer^.node, kstr,TRUE);
          IF ndx^.Safety OR NOT ndx^.Exclusive
          THEN
            WriteNode(ndx, ndx^.posarray[level].buffer^.number,
                ndx^.posarray[level].buffer^.node);
            WriteNode(ndx, DownBuffer^.number, DownBuffer^.node);
          ELSE
            ndx^.posarray[level].buffer^.NeedToWrite:=TRUE;
            DownBuffer^.NeedToWrite:=TRUE;
          END;
          (* force new pos array *)
          ReadIntoArray(ndx, DownBuffer^.number, level);
       END;

     ELSE (* move to upper *)
       keystomove:=(keys-upkeys+1) DIV 2;
       count:=keystomove;
       WHILE count>0  DO
         (* get key to move and save*)
         (* remove from top place on bottom *)
         GetKey(ndx^.posarray[level].buffer^.node,
          ndx,ORD(ndx^.posarray[level].buffer^.node[0])-1, tempkey);
          ndx^.posarray[level].keynum:=
                ORD(ndx^.posarray[level].buffer^.node[0])-1;
          DeleteEntry(ndx,  level);
          ndx^.posarray[level].keynum:=0;
          AddKeyTo(tempkey.lowernode,tempkey.recordnum,
            UpBuffer^.node,tempkey.value,FALSE);(* addkey does not write *)
          DEC(count);
       END (* while *);

       (* delete key fixed upper node *)
       IF insertpos  < ORD(ndx^.posarray[level].buffer^.node[0]) THEN
         (* insert into old node  *)
          ndx^.posarray[level].keynum:=insertpos;
          AddKeyTo(lowernodenum, recno, ndx^.posarray[level].buffer^.node, kstr,TRUE);
          (* force new pos array *)
          (* need to put writes here because the readintoarray
            will lose a node *)
          IF ndx^.Safety OR NOT ndx^.Exclusive
          THEN
            WriteNode(ndx, ndx^.posarray[level].buffer^.number,
               ndx^.posarray[level].buffer^.node);
            WriteNode(ndx, UpBuffer^.number, UpBuffer^.node);
          ELSE
            ndx^.posarray[level].buffer^.NeedToWrite:=TRUE;
            UpBuffer^.NeedToWrite:=TRUE;
          END;
       ELSE
          (* insert into other node *)
          ndx^.posarray[level].keynum :=
            insertpos-ORD(ndx^.posarray[level].buffer^.node[0]);
          INC(ndx^.posarray[level-1].keynum);
          AddKeyTo(lowernodenum, recno, UpBuffer^.node, kstr,TRUE);
          IF ndx^.Safety OR NOT ndx^.Exclusive
          THEN
            WriteNode(ndx, ndx^.posarray[level].buffer^.number,
             ndx^.posarray[level].buffer^.node);
            WriteNode(ndx, UpBuffer^.number, UpBuffer^.node);
          ELSE
            ndx^.posarray[level].buffer^.NeedToWrite:=TRUE;
            UpBuffer^.NeedToWrite:=TRUE;
          END;
          (* force new pos array *)
          ReadIntoArray(ndx, UpBuffer^.number, level);
       END;

     END;

   END Movekeys ;

   PROCEDURE CanBalance():BOOLEAN ;
   BEGIN
     IF (upkeys>=keys) AND (downkeys>=keys)
     THEN
       RETURN FALSE;
     ELSIF (upkeys>downkeys) AND (keys-downkeys=1)
     THEN (* downkey has only one place *)
       IF ndx^.posarray[level].keynum=0 THEN
         RETURN FALSE;
       END;
     ELSIF (upkeys<=downkeys) AND (keys-upkeys=1)
     THEN (* upkey has only one place *)
       IF (ndx^.posarray[level].keynum+1)>=keys THEN
         RETURN FALSE;
       END;
     END;
     RETURN TRUE;

   END CanBalance;

   BEGIN  (*balance *)
     downkeys:=65000;
     upkeys:=65000;
     DownBuffer:=NIL;
     UpBuffer:=NIL;
     IF (level=0) OR (level#ndx^.depth)
     THEN
     (* Because of complications do not balace nonleaf nodes *)
       NewNode(ndx,NewBuffer);
       Split(ndx^.posarray[level].buffer, NewBuffer);
       RETURN;
     END;
     insertpos:=ndx^.posarray[level].keynum;
     keys:=ORD(ndx^.posarray[level].buffer^.node[0]);
     IF  ndx^.posarray[level-1].keynum <
        (ORD(ndx^.posarray[level-1].buffer^.node[0])-1)
     THEN (* get uper node (same level *)
       GetKey(ndx^.posarray[level-1].buffer^.node,
        ndx, ndx^.posarray[level-1].keynum+1, tempkey);
       ReadNode(ndx,tempkey.lowernode,UpBuffer);
       UpBuffer^.Lock:=TRUE;
       upkeys:=ORD(UpBuffer^.node[0]);
     END;
     IF  ndx^.posarray[level-1].keynum > 0
     THEN (* get lowernode (same level) *)
       GetKey(ndx^.posarray[level-1].buffer^.node,
        ndx, ndx^.posarray[level-1].keynum-1, tempkey);
       ReadNode(ndx,tempkey.lowernode,DownBuffer);
       DownBuffer^.Lock:=TRUE;
       downkeys:=ORD(DownBuffer^.node[0]);
     END;
     (* determine if one can just move keys *)
     IF CanBalance()
     THEN
       Movekeys;
     (*  ChkInd.NDXChk(ndx);
       FindPositionCh(ndx,kstr,found);
       IF NOT found THEN HALT END;*)
     ELSE
       NewNode(ndx,NewBuffer);
       Split(ndx^.posarray[level].buffer, NewBuffer);
     END;
     IF DownBuffer#NIL THEN DownBuffer^.Lock:=FALSE END;
     IF UpBuffer#NIL THEN UpBuffer^.Lock:=FALSE END;
   END Balance;

BEGIN (* Insert Entry *)
  (* update current key to keep all up to date *)
  EnterLock(ndx);
(*  diag:=recno (* diag *);*)
  ndx^.Changed:=TRUE;
  InHighNode:=FALSE;
(*IF ndx^.Header.NumType
  THEN
    Move(ADR(kstr),ADR(NewKey.value),8);
  ELSE
    Assign(kstr,NewKey.value);
  END;
  NewKey.lowernode:=VAL(LONGINT,0);
  NewKey.recordnum:=recno; *)
  level := ndx^.depth;
  lowernodenum := VAL(LONGINT,0);
  REPEAT
    noOverflow := ORD(ndx^.posarray[level].buffer^.node[0]) < ndx^.Header.keyspernode;
    IF noOverflow THEN
      AddKeyTo(lowernodenum, recno, ndx^.posarray[level].buffer^.node, kstr,TRUE);
      IF InHighNode
      THEN
        INC(ndx^.posarray[level].keynum);
      END;
      IF ndx^.Safety OR NOT ndx^.Exclusive
      THEN
        WriteNode(ndx, ndx^.posarray[level].buffer^.number,
          ndx^.posarray[level].buffer^.node);
        ELSE
          ndx^.posarray[level].buffer^.NeedToWrite:=TRUE;
      END;
    ELSE
      Balance(level);
      (* find out where kstr belongs and insert it *)
      IF level = 0 THEN (* the root node was split *)
        INC(ndx^.buffsize,2);(* enlarge buffer *)
        INC(ndx^.depth);   (* prepare to add another level to the map *)
        FOR i := ndx^.depth TO 1 BY -1 DO
          ndx^.posarray[i] := ndx^.posarray[i-1]
        END;    (* slide all the keypositions in the map up one notch *)
        NewNode(ndx,NewRoot);
          (* force NewRoot into root position *)
        ndx^.Header.rootptr := NewRoot^.number;
        ReadIntoArray(ndx, NewRoot^.number, 0);
         (* KEYNUMBERS BEGIN at ZERO *)
        ndx^.posarray[0].keynum := 0;
        NewBuffer^.Lock:=FALSE;
        AddKeyTo(oldnodenum, VAL(LONGINT,0), NewRoot^.node, '',FALSE);
          (* the new node initially contains no key but points to the
          new node which was written when the old root was split *)
          (* the number of entries in the node is now 1 *)
          (* now a key is inserted ahead of the 'keyless' pointer *)
        AddKeyTo(newnodenum, recno, NewRoot^.node, kstr,TRUE);
        ndx^.posarray[0].buffer^.node[0]:= 1C;(* top key does not count *)
        IF ndx^.posarray[1].buffer^.number = newnodenum THEN
          ndx^.posarray[0].keynum := 0
        ELSE
          ndx^.posarray[0].keynum := 1
        END;
        IF ndx^.Safety OR NOT ndx^.Exclusive
        THEN
          WriteNode(ndx, ndx^.Header.rootptr, NewRoot^.node);
        ELSE
          NewRoot^.NeedToWrite:=TRUE;
        END;
        noOverflow := TRUE;
      END (* if *);
      (* if safety is on update header when a node splits *)
      IF ndx^.Safety OR NOT ndx^.Exclusive
      THEN
        UpdateIndexHeader(ndx);
      END;

    END (* if *);
    IF level > 0 THEN
      DEC(level);
    END (* if *);
  UNTIL noOverflow;
  ExitLock(ndx);
 (* ChkInd.NDXChk(ndx);*)
 (*  !!!! diag *)
(* IF diag # ndx^.currentkey^.recordnum
 THEN HALT END (*diag *);  *)
END InsertEntry;

PROCEDURE BuildIndex(ndx: DBIndex;
                     keyexp: ARRAY OF CHAR):CARDINAL;
VAR
 Fptr:DBFieldPtr;
BEGIN
  IF NOT OpenDBF(ndx^.alias)
  THEN (* check to make sure the file is open *)
    WARN('Not able to DBFile file in BuildIndex');
  END;
  CrunchBlanks(keyexp);
  CAPstr(keyexp);
  ndx^.KeyNumber:=PosOfField(ndx^.alias,keyexp);
  IF ndx^.KeyNumber=0 THEN
    WARN('Bad index expression in BuildIndex');
  END;
  Fptr:=FieldList(ndx^.alias);
  RETURN  BuildCompIndex(ndx,Fptr^[ndx^.KeyNumber].fldtype,
  keyexp,Fptr^[ndx^.KeyNumber].size);
END BuildIndex;

PROCEDURE BuildCompIndex( ndx: DBIndex;
                          type:CHAR; (* C or N *)
                          keyexp:ARRAY OF CHAR;
                          size: CARDINAL
                          ):CARDINAL;
VAR oldbuffsize,
  olddbbuffersize,
  i,
  ActionTaken: CARDINAL;
     worknode: NodeType;
    recordnumber: LONGINT;
    oldsafety,
    oldexclusive:BOOLEAN;
   FileError: StringIO.ErrorMessage;

BEGIN
  IF NOT OpenDBF(ndx^.alias) THEN
    WARN('Unable to open DBFile in BuildCompIndex');
  END;
  CloseIndex(ndx);
  IF ndx^.Init#InitCode
  THEN
    WARN('Uninitalized DBIndex in BuildCompIndex');
  END;
  InitPosarray(ndx);
  (* open exclusive *)
    (* create if the file does not exist; truncate if it does exist *)
  FileError := FAPI.DOSOPEN( ADR(ndx^.name),
      ADR(ndx^.f), ADR(ActionTaken), VAL(LONGINT,1024),
      FAPI.FILE_NORMAL,CARDINAL( {1,4}),CARDINAL( {1,4}),
      VAL(LONGINT,0) );
  IF FileError#0 THEN RETURN FileError END;
  Fill(ADR(ndx^.Header),SIZE(ndx^.Header),0);
  olddbbuffersize:=BufferSize(ndx^.alias);
  oldbuffsize:=ndx^.buffsize;
  oldsafety := ndx^.Safety;
  oldexclusive:=ndx^.Exclusive;
  SetDBBuffer( ndx^.alias,32000 );
  IF ndx^.buffsize<400 THEN SetIndexBuffers(ndx,400) END;
  WITH ndx^ DO
    FOR i:=0 TO (Bins-1) DO
      Hash[i]:=NIL;
    END;
    Safety:=FALSE;
    Exclusive:=TRUE;
    Assign(keyexp,Header.KeyExpression);
    CrunchBlanks(Header.KeyExpression);
    CAPstr(Header.KeyExpression);
    KeyNumber := PosOfField(alias,Header.KeyExpression);
    Append(Header.KeyExpression,' ');(* do this to mimic dbase3 *)
    Header.rootptr := VAL(LONGINT,1); (* the root begins as the second block *)
                    (* The anchor node is 0 *)
    Header.NumType := (type#'C');
    IF type#'C'
    THEN
      Header.keylength:=8;
      Header.entrylength :=16;
    ELSE
      Header.keylength :=  size;
      Header.entrylength := Header.keylength + 2 * RecNumLen+1;
      (*add 1 and make even to mimic dbase3 *)
      IF ODD(Header.entrylength) THEN INC(Header.entrylength) END;
    END;

    Header.keyspernode := (NodeSize - 8) DIV (Header.entrylength);
      (* a key 'entry' is made up of a pointer to a lower node and a
         record number in addition to the key value .  After the last key
         entry there is a pointer to a lowerlevel node containing keys with
         values greater than or equal to the the value of the key in the
         last key entry *)
    Header.nextfreenode := VAL(LONGINT,2);
    open := TRUE;
    depth := 0;
  END;
  InitNode(worknode);
  WriteNode(ndx, VAL(LONGINT,1), worknode);
  recordnumber := VAL(LONGINT,1);
  WHILE recordnumber <= NumberRecords(ndx^.alias) DO
    ReadDBRec(ndx^.alias, recordnumber);
(* change by ed ross*)
    IF ndx^.includedeleted  OR NOT Deleted(ndx^.alias)
      THEN
         AddRecord(ndx^.alias, ndx);
      END;	
(* * *End of change by ed *)
   INC(recordnumber);
  END;
  CloseIndex(ndx);
  ndx^.Exclusive:=oldexclusive;
  ndx^.Safety:=oldsafety;
  ndx^.buffsize:= oldbuffsize;
  SetIndexBuffers(ndx,oldbuffsize);
  SetDBBuffer( ndx^.alias,olddbbuffersize );
  RETURN 0;
END BuildCompIndex;

PROCEDURE GoTop(ndx: DBIndex);
VAR nextnodeptr: LONGINT;
    level: CARDINAL;
BEGIN
  IF   OpenIndex(ndx)=FALSE
  THEN
    WARN('Error opening Index in GoTop');
  END;
  EnterLock(ndx);
  level := 0;
  ReadIntoArray(ndx, ndx^.Header.rootptr, level);
  Move(ADR(ndx^.posarray[level].buffer^.node[4]), ADR(nextnodeptr), 4);
    (* all searches commence with the root *)
    ndx^.posarray[level].keynum := FirstKey;
  WHILE nextnodeptr#VAL(LONGINT,0) DO
    INC(level);
    ReadIntoArray(ndx, nextnodeptr, level);
    ndx^.posarray[level].keynum := FirstKey;
    Move(ADR(ndx^.posarray[level].buffer^.node[4]), ADR(nextnodeptr), 4);
  END;
  ndx^.currentkey:=GetKeyPtr(ndx^.posarray[level].buffer^.node, ndx, FirstKey);
  ndx^.depth:=level;
  ExitLock(ndx);
END GoTop;

PROCEDURE GoBottom( ndx: DBIndex);
VAR
    level: CARDINAL;
BEGIN
  IF   OpenIndex(ndx)=FALSE
  THEN
    WARN('Error opening Index in GoBottom');
  END;
  EnterLock(ndx);
  level := 0;
  ReadIntoArray(ndx, ndx^.Header.rootptr, level);
  ndx^.currentkey:=GetKeyPtr(ndx^.posarray[level].buffer^.node, ndx,
     ORD(ndx^.posarray[level].buffer^.node[0]));
    (* all searches commence with the root *)
    ndx^.posarray[level].keynum := ORD(ndx^.posarray[level].buffer^.node[0]);
  WHILE ndx^.currentkey^.lowernode # VAL(LONGINT,0) DO
    INC(level);
    ReadIntoArray(ndx, ndx^.currentkey^.lowernode, level);
    ndx^.posarray[level].keynum := ORD(ndx^.posarray[level].buffer^.node[0]);
    ndx^.currentkey:=GetKeyPtr(ndx^.posarray[level].buffer^.node, ndx,
      ORD(ndx^.posarray[level].buffer^.node[0]));
  END;
  ndx^.posarray[level].keynum := ORD(ndx^.posarray[level].buffer^.node[0])-1;
  ndx^.currentkey:=GetKeyPtr(ndx^.posarray[level].buffer^.node, ndx,
      ORD(ndx^.posarray[level].buffer^.node[0])-1 );
  ndx^.depth:=level;
  ExitLock(ndx);
END GoBottom;


PROCEDURE AddToUpdateList( alias: DBFile;  ndx:
      DBIndex);
BEGIN
  ndx^.UpdateList:=IndexList(alias);
  SetIndexList(alias,ndx);

END AddToUpdateList;


PROCEDURE UpdateDBIndxes(alias:DBFile);
VAR
  ndx:DBIndex;

  PROCEDURE Update ;
  VAR
    NewKey,OldKey:ARRAY[0..MaxField-1] OF CHAR;
    found:BOOLEAN;
    num:LONGINT;

    PROCEDURE KeyLocatedC():BOOLEAN ;
      VAR
      found:BOOLEAN;
    BEGIN
        FindPositionCh(ndx,OldKey,found);
        LOOP
          IF NOT Equal(OldKey,ndx^.currentkey^.value)
          THEN
            RETURN FALSE;
          END;
          IF (Record(alias) = ndx^.currentkey^.recordnum)
          THEN
            RETURN TRUE;
          END;
          IF NOT NextRecord(ndx,num)
          THEN
            RETURN FALSE;
          END;
        END;
     END KeyLocatedC ;

    PROCEDURE KeyLocatedN():BOOLEAN ;
      VAR
      found:BOOLEAN;
      key:Real8;
    BEGIN
        IF NOT StrToReal(OldKey, 0,key) THEN key:=0.0 END;
        FindPositionN(ndx,OldKey,found);
        LOOP
          IF ndx^.numkey^.key # key
          THEN
            RETURN FALSE;
          END;
          IF (Record(alias) = ndx^.currentkey^.recordnum)
          THEN
            RETURN TRUE;
          END;
          IF NOT NextRecord(ndx,num)
          THEN
            RETURN FALSE;
          END;
        END;
    END KeyLocatedN ;

  BEGIN
    IF NOT Appending(alias)
    THEN
      SetRecordMode(alias,ModBase3.Buffer);
      ndx^.KeyProc(alias,ndx,OldKey);
      SetRecordMode(alias,ModBase3.CurrentRec);
      ndx^.KeyProc(alias,ndx,NewKey);
(* * * * * * * * *  Changed by ed - delete index if deleting record* * * *)
      IF ndx^.includedeleted OR NOT Deleted(alias)
        THEN IF Equal(OldKey,NewKey)
          THEN
            RETURN
	  END;
      END;
      IF Record(alias) # ndx^.currentkey^.recordnum
      THEN
        (* find and delete old key if exists *)
        IF ndx^.Header.NumType
        THEN
          found:=KeyLocatedN();
        ELSE
          found:=KeyLocatedC();
        END;
      ELSE
        found :=TRUE;
      END;
      IF found
      THEN
        DeleteCurrentEntry(ndx);
      ELSE
        found:=FALSE; (* debugger trap *)
      END;
    END;
(* * * * * * * * Changed by Ed - same as above ** ** * * * *)
    IF ndx^.includedeleted OR NOT Deleted(alias)
      THEN
        AddRecord(alias,ndx);
      END;	
  END Update;

BEGIN
  (* Nul Value of IndexList should be checked in Modbase *)
  ndx:=IndexList(alias);
  WHILE ndx#NIL  DO
    IF   OpenIndex(ndx)=FALSE
    THEN
      WARN('Error opening Index in UpdateDBIndxes');
    END;
    EnterLock(ndx);
    Update;
    ExitLock(ndx);
    ndx:=ndx^.UpdateList;
  END (* while *);
END UpdateDBIndxes;

PROCEDURE UpdateUnique( alias: DBFile; ndx: DBIndex):BOOLEAN;
VAR
    NewKey,OldKey:ARRAY[0..MaxField-1] OF CHAR;
    found:BOOLEAN;

BEGIN
    IF   OpenIndex(ndx)=FALSE
    THEN
      WARN('Error opening Index in UpdateUnique');
    END;
    EnterLock(ndx);
    SetRecordMode(alias,ModBase3.CurrentRec);
    ndx^.KeyProc(alias,ndx,NewKey);
    IF NOT Appending(alias)
    THEN
      SetRecordMode(alias,ModBase3.Buffer);
      ndx^.KeyProc(alias,ndx,OldKey);
      SetRecordMode(alias,ModBase3.CurrentRec);
      IF Equal(OldKey,NewKey)
      THEN
        ExitLock(ndx);
        RETURN TRUE;
      END;
    END;
    IF ndx^.Header.NumType
    THEN
      FindPositionN(ndx,NewKey,found);
    ELSE
      FindPositionCh(ndx,NewKey,found);
    END;
    ExitLock(ndx);
    RETURN NOT found;
END UpdateUnique;


PROCEDURE SetSafetyOn( ndx: DBIndex);
BEGIN
  UpdateIndex(ndx);
  ndx^.Safety:=TRUE;
END SetSafetyOn;


PROCEDURE SetSafetyOff( ndx: DBIndex);
BEGIN
  ndx^.Safety:=FALSE;

END SetSafetyOff;

PROCEDURE SetIndexBuffers( ndx: DBIndex;Buffers:CARDINAL);
VAR
  buffer:IndexBuffer;
BEGIN
  WITH ndx^ DO
    buffsize := Max(Buffers,depth+6);
    buffer:=last;
    WHILE buffsize<currsize DO
      WHILE buffer^.Lock DO
        buffer:=buffer^.prev;
      END;
      IF buffer^.NeedToWrite
      THEN
        WriteNode(ndx,buffer^.number,buffer^.node);
      END;
      RemoveBuffer(ndx,buffer);
      RemoveFromTable(ndx,buffer);
      DosDealloc(buffer,SIZE(buffer^));
    END;
  END;
END SetIndexBuffers;


PROCEDURE DisposeIndex(VAR ndx: DBIndex);
BEGIN
  CloseIndex(ndx);
  DosDealloc(ndx,SIZE(ndx^));
  ndx := NIL;
END DisposeIndex;

PROCEDURE CurrentKeyCh( ndx: DBIndex;VAR val:ARRAY OF CHAR);
BEGIN
  Assign(ndx^.currentkey^.value,val);
END CurrentKeyCh;

PROCEDURE CurrentKeyN( ndx: DBIndex):Real8;
BEGIN
  RETURN ndx^.numkey^.key;

END CurrentKeyN;


PROCEDURE CurrentRec( ndx: DBIndex):LONGINT;
BEGIN
  RETURN ndx^.currentkey^.recordnum;
END CurrentRec;

PROCEDURE NumKeyType( ndx: DBIndex):BOOLEAN;
BEGIN
  RETURN ndx^.Header.NumType;
END NumKeyType;

PROCEDURE KeyLength( ndx: DBIndex):CARDINAL;
BEGIN
  RETURN ndx^.Header.keylength;
END KeyLength;

PROCEDURE InitCompIndex(indexname: ARRAY OF CHAR; VAR
      ndx: DBIndex; alias:DBFile;Key :KeyProcedure; buffersize: CARDINAL
      ; safety,IncludeDeleted,exclusive:BOOLEAN);
VAR i:CARDINAL;
BEGIN
  DosAlloc(ndx,SIZE(ndx^));
  ndx^.alias:=alias;
  WITH ndx^ DO
    Init:=InitCode;
    Assign(indexname,name);
    Locked:=0;
    includedeleted:=IncludeDeleted;
    Exclusive:=exclusive OR Locks.ExclusiveOnly;
    open:=FALSE;
    depth:=0;
    KeyProc:=Key ;
    buffsize:=buffersize;
    Safety:=safety;
    first:=NIL;
    last:=NIL;
    currsize := 0;
    UpdateList:=NIL;
  END;
END InitCompIndex;

PROCEDURE InitIndex(indexname: ARRAY OF CHAR; VAR
      ndx: DBIndex; alias:DBFile; buffersize: CARDINAL;
      safety, IncludeDeleted,exclusive:BOOLEAN);
BEGIN
  InitCompIndex(indexname,ndx,alias,DefaultKeyProcedure,buffersize,safety,
  IncludeDeleted,exclusive);
END InitIndex;




PROCEDURE OpenIndex( ndx: DBIndex):BOOLEAN;

VAR
  str:ARRAY[0..387] OF CHAR;
  ActionTaken,
  i,res:CARDINAL;
  filemode:BITSET;
BEGIN
  IF ndx = NIL
    THEN
      WARN('Unititalized ndx in OpenIndex');
      RETURN FALSE;
    END;
  IF ndx^.Init=InitCode
  THEN
    IF ndx^.open
    THEN
      RETURN  TRUE;
    END;
  ELSE
    WARN('Uninitalized ndx in OpenIndex');
  END;
  ndx^.open := FALSE;
   (* Open if it does exist; fail if it doesn't *)
  IF ndx^.Exclusive THEN
     filemode:={1,4}
   ELSE
     filemode:={1,6} (* allow all *)
   END;
   res := FAPI.DOSOPEN( ADR(ndx^.name),
      ADR(ndx^.f), ADR(ActionTaken), VAL(LONGINT,0), FAPI.FILE_NORMAL,
     CARDINAL( {0}), CARDINAL(filemode), VAL(LONGINT,0) );

  IF res # StringIO.NoError THEN
    RETURN FALSE;
  ELSE
    IF Locks.NoLocking(ndx^.f) THEN ndx^.Exclusive:=TRUE END;
    InitPosarray(ndx);
    EnterLock(ndx);
    IF HandleIO.BlockRead(ndx^.f,ADR(ndx^.Header),SIZE(ndx^.Header))#
       StringIO.NoError
    THEN
      ExitLock(ndx);
      StringIO.PrintMessage(HandleIO.CloseHandle(ndx^.f));
      RETURN FALSE;
    END;
    WITH ndx^ DO
      FOR i:=0 TO (Bins-1) DO
        Hash[i]:=NIL;
      END;
      Assign(Header.KeyExpression,str);
      CrunchBlanks(str);
      CAPstr(str);
      KeyNumber:=PosOfField(ndx^.alias,str);
      SetIndexBuffers(ndx,buffsize);
      open := TRUE;
    END;
    GoTop(ndx);
    ExitLock(ndx);
  END; (* IF *)
  RETURN TRUE;
END OpenIndex;


PROCEDURE NextRecord( ndx: DBIndex;
                     VAR recno: LONGINT): BOOLEAN;

  PROCEDURE NextEntry(ndx: DBIndex; level: CARDINAL): BOOLEAN;

  VAR
    anotherkey: BOOLEAN;
    key:KeyPointer;
    factor:CARDINAL;
  BEGIN
    key:=ADR(ndx^.currentkey);
    LOOP
      IF level=ndx^.depth   (* ok depth becuse all of loop is in same route*)
      THEN
        factor:=1;
      ELSE
        factor:=0;
      END;
      anotherkey := ndx^.posarray[level].keynum <
         ( ORD(ndx^.posarray[level].buffer^.node[0]) - factor);
      IF anotherkey THEN
        (* there is another entry in the node *)
        (* note that the first entry is 0, so the number of the last entry
           is one less than the number of keys in the node *)
        WITH ndx^.posarray[level] DO
          INC(keynum);
          key:=GetKeyPtr(buffer^.node, ndx, keynum);
          EXIT;
        END;
      ELSE
        IF level = 0 THEN
          EXIT
        ELSE
          DEC(level)
        END;
      END;
    END; (* LOOP *)
    IF anotherkey THEN
      LOOP
        IF key^.lowernode#VAL(LONGINT,0) THEN (* node is not a leaf node *)
          INC(level);
          ReadIntoArray(ndx, key^.lowernode, level);
          WITH ndx^.posarray[level] DO
            keynum := FirstKey;
            key:=GetKeyPtr(buffer^.node, ndx, FirstKey);
          END;
        ELSE
          EXIT
        END;
      END; (* LOOP2 *)
      ndx^.depth:=level;
      ndx^.currentkey:=key;
      RETURN TRUE;
    ELSE
      ndx^.depth:=level;
      ndx^.currentkey:=key;
      RETURN FALSE;
    END;
  END NextEntry;

BEGIN
  IF   OpenIndex(ndx)=FALSE
  THEN
    WARN('Error opening Index in NextRecord');
  END;
  EnterLock(ndx);
  IF NextEntry(ndx, ndx^.depth) THEN
    recno := ndx^.currentkey^.recordnum;
    ExitLock(ndx);
    RETURN TRUE
  ELSE
    ExitLock(ndx);
    RETURN FALSE
  END;
END NextRecord;


PROCEDURE PrevRecord( ndx: DBIndex;
                     VAR recno: LONGINT): BOOLEAN;

  PROCEDURE PrevEntry( ndx: DBIndex; level: CARDINAL): BOOLEAN;

  VAR anotherkey: BOOLEAN;
      lastkey: CARDINAL;
      key:KeyPointer;
  BEGIN
    key:=ADR(ndx^.currentkey);
    LOOP
      anotherkey := ndx^.posarray[level].keynum > 0;
      IF anotherkey THEN
        (* there is another entry in the node *)
        (* note that the first entry is 0, so the number of the last entry
           is one less than the number of keys in the node *)
        WITH ndx^.posarray[level] DO
          DEC(keynum);
          key:=GetKeyPtr(buffer^.node, ndx, keynum);
        END;
        EXIT;
      ELSE
        IF level = 0 THEN
          EXIT
        ELSE
          DEC(level)
        END;
      END;
    END; (* LOOP *)
    IF anotherkey THEN
      LOOP
        IF key^.lowernode#VAL(LONGINT,0) THEN (* node is not a leaf node *)
          INC(level);
          ReadIntoArray(ndx, key^.lowernode, level);
          WITH ndx^.posarray[level] DO
            lastkey := ORD(buffer^.node[0]);
            keynum := lastkey;
            key:=GetKeyPtr(buffer^.node, ndx, lastkey);
            IF key^.lowernode=VAL(LONGINT,0)
            THEN  (* backup one*)
              DEC(lastkey);
              keynum := lastkey;
              key:=GetKeyPtr(buffer^.node, ndx, lastkey);
            END;
          END;
        ELSE
          EXIT
        END;
      END; (* LOOP2 *)
      ndx^.depth:=level;
      ndx^.currentkey:=key;
      RETURN TRUE;
    ELSE
      ndx^.depth:=level;
      ndx^.currentkey:=key;
        RETURN FALSE;
    END;
  END PrevEntry;
BEGIN
  IF   OpenIndex(ndx)=FALSE
  THEN
    WARN('Error opening Index in PrevRecord');
  END;
  EnterLock(ndx);
  IF PrevEntry(ndx, ndx^.depth) THEN
    recno := ndx^.currentkey^.recordnum;
    ExitLock(ndx);
    RETURN TRUE
  ELSE
    ExitLock(ndx);
    RETURN FALSE
  END;
END PrevRecord;

PROCEDURE UpdateIndex( ndx :DBIndex);

BEGIN
  IF ndx^.open
  THEN
    EnterLock(ndx);
    UpdateIndexHeader(ndx);
    HandleIO.UpdateDisk(ndx^.f);
    ExitLock(ndx);
  END;
END UpdateIndex;

PROCEDURE CloseIndex( ndx: DBIndex);
VAR
  buffer:IndexBuffer;
  FileError: StringIO.ErrorMessage;
BEGIN
  IF ndx = NIL
    THEN
      RETURN;
    END;
  IF NOT ndx^.open
  THEN
    RETURN;
  END;
  IF ndx^.Exclusive  AND NOT ndx^.Safety
  THEN
    UpdateIndexHeader( ndx );
  END;
  FileError := HandleIO.CloseHandle(ndx^.f);
  ndx^.open := FALSE;
  WHILE ndx^.currsize#0 DO
    buffer:=ndx^.last;
    RemoveBuffer(ndx,buffer);
    DosDealloc(buffer,SIZE(buffer^));
  END;

END CloseIndex;

(* file locking procedures start here *)
PROCEDURE EnterLock( ndx:DBIndex);
VAR
  realkey:Real8;
  strkey:ARRAY[0..127] OF CHAR;
  buffer:IndexBuffer;
  ok,found:BOOLEAN;
  i,
  code,
  Old :CARDINAL;
  key,OldRecord:LONGINT;
BEGIN
  (* lock file if needed *)
  INC(ndx^.Locked);
  IF (ndx^.Locked>1) OR ndx^.Exclusive THEN RETURN END;
  (* read Header*)
  StringIO.PrintMessage(Locks.LockFileRetry(ndx^.f,100,ndx^.name));
  ndx^.Changed:=FALSE;
  IF ndx^.open=FALSE THEN RETURN END;(* this should only be in open index *)
  Old:=ndx^.Header.Flag;
  ReadHeader(ndx);
  IF Old=ndx^.Header.Flag THEN RETURN END;
  OldRecord:=ndx^.currentkey^.recordnum;
  IF ndx^.Header.NumType
  THEN
    realkey:=ndx^.numkey^.key;
  ELSE
    Assign(ndx^.currentkey^.value,strkey);
  END;
  (* purge buffers*)
  WHILE ndx^.currsize#0 DO
    buffer:=ndx^.last; (* it is forbidden here to have unwritten data *)
    IF buffer^.NeedToWrite THEN (* not needed when debugged *)
      WARN('buffer not writen in EnterLock');
    END;
    RemoveBuffer(ndx,buffer);
    RemoveFromTable(ndx,buffer);
    DosDealloc(buffer,SIZE(buffer^));
  END;
  FOR i:= 0 TO ndx^.depth DO
    ndx^.posarray[i].buffer:=NIL;
  END;
  IF ndx^.Header.NumType
  THEN
    FindPositionR(ndx,realkey,found);
  ELSE
    FindPositionCh(ndx,strkey,found);
  END;
  IF NOT found
  THEN RETURN (* key must have been removed *)
  END;
  REPEAT
    IF OldRecord=ndx^.currentkey^.recordnum
    THEN RETURN END; (* we got it*)
    found:=NextRecord(ndx,key);
    IF ndx^.Header.NumType
    THEN
       ok:=(realkey=ndx^.numkey^.key);
    ELSE
      ok:=Equal(ndx^.currentkey^.value,strkey);
    END;
  UNTIL NOT found OR NOT ok;
  found:=PrevRecord(ndx,key); (* goback one*)
END EnterLock;

PROCEDURE ExitLock( ndx:DBIndex);
VAR
  code:CARDINAL;
BEGIN
  DEC(ndx^.Locked);
  (* If No change  or exclusive *)
  IF ndx^.Exclusive OR ( ndx^.Locked#0)  THEN RETURN END;
  IF  ndx^.Changed
  THEN
    INC(ndx^.Header.Flag); (* indicate change *)
    WriteHeader(ndx); (* write header *)
  END; (* if ndx^ changed *)
  code:=Locks.UnLockFile(ndx^.f);
  IF code#0 THEN WARN('Lock error in ExitLock') END;
END ExitLock;

BEGIN;
  UpDateIndexes:=UpdateDBIndxes;

END DBIndxes.