Topspeed_JPI/TS-V3/MODBASE/DBINDXES.LST

Listing:

    1  IMPLEMENTATION MODULE DBIndxes;
    2  (*# check(overflow=>off) *)
    3  (*/NOCHECK O *)
    4  (*
    5   *  ModBase
    6   *  Release 3.0
    7   *  (c) Copyright 1986 - 1990 Donald G. Fletcher
    8   *  (c) Copyright 1986 - 1991 PMI
    9      Copyright 1988 - 1991 John McMonagle
   10   *  P.O. Box 8402
   11   *  Green Bay Wi 53308
   12   *  All Rights Reserved
   13   *)
   14  
   15  
   16  (*
   17    - DBIndex
   18    - Bug in CloseIndex fixed April 2, 1987
   19    - DeleteEntry rewritten April 2, 1987
   20    - CloseIndex does not write its rootnode unless ndx^.open is TRUE
   21    - Most FOR loops have been rewritten to use Move or ShiftArrayRight
   22    - September 14, 1987 - Rewritten with LONGINT for Logitech 3.0
   23  *)
   24  (*System modules*)
   25  FROM SYSTEM IMPORT ADR,ADDRESS,SIZE,BYTE;
   26  FROM M2Strings IMPORT Assign,CompareStr, Copy,Length,Concat;
   27  (*PMI modules*)
   28  FROM LowLevel IMPORT Move, Fill, ShiftArrayRight,Address8086,
   29     BitwiseAnd,ShiftLeft;
   30  IMPORT StringIO; (*from Repertoire*)
   31  IMPORT HandleIO,FAPI;   (*from Repertoire*)
   32  FROM Numbers IMPORT Max;
   33  FROM StrEdit IMPORT CrunchBlanks,CAPstr,Append;
   34  FROM PosUtils IMPORT Equal;
   35  FROM NumTypes IMPORT Real8;
   36  (*ModBase modules*)
   37  FROM ErrorManager IMPORT WARN;
   38  FROM StrConv IMPORT StrToReal;
   39  FROM ModBase3 IMPORT DBFile, ReadDBRec,  GetField, SetDBBuffer,
   40    UpDateIndexes,SetRecordMode,OpenDBF,Appending,SetIndexList,
   41    IndexList,NumberRecords,FieldList,BufferSize,PosOfField,Record,
   42    DBFieldPtr,Deleted;
   43  FROM VStorage IMPORT
   44      DosAlloc, DosDealloc,DosAvail;
   45  (*   IMPORT ChkInd;   *)
   46  (*key numbering convention node[0] contains the number of keys but
   47    getkey etc. the first one is 1 not 0. *)
   48  IMPORT Locks,ModBase3;
*****               ^ duplicate identifier
   49    PROCEDURE DEALLOCATE(VAR loc:ADDRESS;size:CARDINAL);
   50    BEGIN
   51      DosDealloc(loc,size);
*****      ^ not supported yet
*****                 ^ not supported yet
*****                         ^ not supported yet
   52    END DEALLOCATE;
*****        ^ not supported yet
   53  
   54    PROCEDURE ALLOCATE(VAR loc:ADDRESS;size:CARDINAL);
   55    BEGIN
   56      DosAlloc(loc,size);
*****      ^ not supported yet
*****               ^ not supported yet
*****                       ^ not supported yet
   57    END ALLOCATE;
*****        ^ not supported yet
   58  
   59  CONST
   60    FirstKey = 0;  (* the number of the first key in a node *)
   61    MaxKey = 128;
   62    RecNumLen = 4;
   63    NodeSize = 512;
   64    IndexNameLength = 80;
   65    MaxField = 128;
   66    MaxDepth = 24;
   67    FirstNode = 0;
   68    RootNodePtrPos = 4;
   69    NextFreeNodePtrPos = 8;
   70    KeyLenPos = 12;
   71    KeyEntPos = 14;
   72    KeyTypePos = 22;
   73    KeyExpPos = 24;
   74    DepthPosition = 256;
   75    InitCode  =56317;
   76    Bins=128;
   77  
   78  TYPE
   79    HeaderNodeType=
   80      RECORD
   81        rootptr,
   82        nextfreenode,
   83        FreeList   :LONGINT; (* this may not be true dbase compatable *)
   84        keylength,
   85        keyspernode:CARDINAL;
   86        NumType,fill:BOOLEAN;
   87        entrylength:CARDINAL;
   88        Flag,
   89        fill2:CARDINAL;
   90        KeyExpression:ARRAY[0..487] OF CHAR;
*****                               ^ not supported yet
*****                                       ^ not supported yet
   91      END (* record *);
*****      ^ not supported yet
   92  
   93    NodeType = ARRAY [0..NodeSize-1] OF CHAR;
*****                                  ^ not supported yet
*****                                        ^ not supported yet
   94  
   95    IndexBuffer = POINTER TO NodeBuffType;
*****                             ^ undeclared identifier
   96  
   97    NodeBuffType =
   98      RECORD
   99        node: NodeType;
  100      (*  clean:CARDINAL; diag to test for overwriting node *)
  101        number: LONGINT;
  102        next, prev,NHash,PHash: IndexBuffer;
  103        Lock,NeedToWrite:BOOLEAN;
  104      END;
*****      ^ not supported yet
  105  
  106    KeyPosType = RECORD
  107      buffer:  IndexBuffer ;
  108      keynum : CARDINAL;
  109    END;
*****    ^ not supported yet
  110  
  111    Route = ARRAY [0..MaxDepth] OF KeyPosType;
*****                      ^ not supported yet
*****                                   ^ not supported yet
  112  
  113    EntryType =
  114      RECORD
  115        lowernode: LONGINT;
  116        recordnum: LONGINT;
  117        value    : ARRAY [0..MaxKey] OF CHAR;
*****                             ^ not supported yet
*****                                        ^ not supported yet
  118      END;
*****      ^ not supported yet
  119  
  120    KeyPointer=POINTER TO EntryType;
*****                          ^ not supported yet
  121  
  122    RealEntry =
  123      RECORD
  124        lowernode: LONGINT;
  125        recordnum: LONGINT;
  126        key:Real8;
  127      END;
*****      ^ not supported yet
  128  
  129    RealKeyPointer=POINTER TO RealEntry;
*****                              ^ not supported yet
  130  
  131   CompareType=(LT,EQ,GT);
  132  
  133   CompareProc= PROCEDURE( ADDRESS,ADDRESS,CARDINAL): CompareType;
*****                ^ not supported yet
*****                           ^ not supported yet
*****                                   ^ not supported yet
*****                                           ^ not supported yet
*****                                                      ^ not supported yet
  134  
  135  
  136    DBIndex= POINTER TO IndexRec;
*****                        ^ undeclared identifier
  137    IndexRec =
  138      RECORD
  139        name: ARRAY [1..IndexNameLength] OF CHAR;
*****                        ^ not supported yet
*****                                            ^ not supported yet
  140        f: CARDINAL; (* this is the file handle *)
  141        Locked:CARDINAL; (* indicates file is locked *)
  142        includedeleted,
  143        Exclusive, (* indicates file locking not needed *)
  144        Changed,
  145        open: BOOLEAN;
  146        Safety: BOOLEAN;
  147        KeyNumber,
  148        depth,
  149        Init:CARDINAL;
  150        alias:DBFile;
  151        Header:HeaderNodeType;
  152        KeyProc  :KeyProcedure;
*****                  ^ undeclared identifier
  153        posarray: Route;
  154        CASE :BOOLEAN OF
*****        ^ not supported yet
*****                      ^ 'POINTER' expected
  155          TRUE: currentkey: KeyPointer;|
  156          FALSE: numkey    : RealKeyPointer;
  157        END;
  158      first, last: IndexBuffer;
  159      currsize: CARDINAL;
  160      buffsize: CARDINAL;
  161      (* number of Nodes in Buffer *)
  162      UpdateList:DBIndex;(* consider having list in seperate record
  163            so that Index can be updated from more than one DBF *)
  164      Hash:ARRAY[0..Bins-1] OF IndexBuffer;
  165    END;
  166  
  167  PROCEDURE HashP(number:LONGINT):CARDINAL;
  168    TYPE
  169     LSet=SET OF [0..31];
  170  BEGIN
  171    RETURN   VAL(CARDINAL,LONGINT(LSet(127)*LSet(number) )  );
  172  END HashP;
  173  
  174  PROCEDURE AddToTable(ndx:DBIndex;BufPtr:IndexBuffer);
  175  VAR
  176    ptr:IndexBuffer;
  177    h:CARDINAL;
  178  BEGIN
  179    h:=HashP(BufPtr^.number);
  180    ptr:=ndx^.Hash[h];
  181    BufPtr^.NHash:=ptr;
  182    IF ptr#NIL THEN
  183      ptr^.PHash:=BufPtr
  184    END;
  185    BufPtr^.PHash:=NIL;
  186    ndx^.Hash[h]:=BufPtr;
  187  END AddToTable;
  188  
  189  PROCEDURE RemoveFromTable(ndx:DBIndex;BufPtr:IndexBuffer);
  190  BEGIN
  191    IF BufPtr^.PHash=NIL THEN
  192      ndx^.Hash[HashP(BufPtr^.number)]:=BufPtr^.NHash;
  193    ELSE
  194      BufPtr^.PHash^.NHash:=BufPtr^.NHash
  195    END;
  196    IF BufPtr^.NHash#NIL THEN
  197      BufPtr^.NHash^.PHash:=BufPtr^.PHash;
  198    END;
  199    BufPtr^.PHash:=NIL;
  200    BufPtr^.NHash:=NIL;
  201  END RemoveFromTable;
  202  
  203  PROCEDURE InitPosarray( ndx: DBIndex);
  204  VAR
  205    i:CARDINAL;
  206  BEGIN
  207    FOR i:= 0 TO MaxDepth DO
  208      ndx^.posarray[i].buffer:=NIL;
  209    END;
  210  END InitPosarray;
  211  
  212  PROCEDURE InBuffer( ndx: DBIndex; nodenumber: LONGINT; VAR
  213      BufPtr: IndexBuffer): BOOLEAN;
  214  
  215  BEGIN
  216    BufPtr:=ndx^.Hash[HashP(nodenumber)];
  217    IF BufPtr = NIL THEN
  218      RETURN FALSE
  219    ELSE
  220      LOOP
  221        WITH BufPtr^ DO
  222          IF (number = nodenumber) THEN
  223            RETURN TRUE
  224          END;
  225          IF  (NHash = NIL) THEN
  226            RETURN FALSE
  227          END;
  228        END (* WITH *);
  229        BufPtr := BufPtr^.NHash;
  230      END; (* loop *)
  231    END;
  232  END InBuffer;
  233  
  234  PROCEDURE AddBuffer( ndx:DBIndex;VAR buffer: IndexBuffer );
  235  BEGIN
  236    (* always add to top *)
  237    buffer^.next:=ndx^.first;
  238    buffer^.prev:=NIL;
  239    IF buffer^.next=NIL
  240    THEN
  241      ndx^.last:=buffer;
  242    ELSE
  243      ndx^.first^.prev:=buffer;
  244    END;
  245    ndx^.first:=buffer;
  246    buffer^.Lock:=TRUE;
  247    INC(ndx^.currsize);
  248  END AddBuffer;
  249  
  250  PROCEDURE RemoveBuffer(ndx:DBIndex;VAR buffer: IndexBuffer );
  251  BEGIN
  252    IF buffer^.next=NIL
  253    THEN
  254      IF buffer^.prev=NIL
  255      THEN
  256        ndx^.first:=NIL;
  257        ndx^.last:=NIL;
  258      ELSE
  259        ndx^.last:=buffer^.prev;
  260        buffer^.prev^.next:=buffer^.next;
  261      END;
  262    ELSE
  263      IF buffer^.prev=NIL
  264      THEN
  265        ndx^.first:=buffer^.next;
  266        buffer^.next^.prev:=buffer^.prev;
  267      ELSE
  268        buffer^.next^.prev:=buffer^.prev;
  269        buffer^.prev^.next:=buffer^.next;
  270      END;
  271    END;
  272    DEC(ndx^.currsize);
  273  END RemoveBuffer;
  274  
  275  
  276  PROCEDURE WriteNode( ndx: DBIndex; nodenumber: LONGINT;
  277   VAR nodeblock: NodeType);
  278  VAR pos: LONGINT;
  279  FileError: StringIO.ErrorMessage;
  280  
  281  (*PROCEDURE Errorchk;(* diag *)
  282  VAR
  283    buffer:IndexBuffer;
  284    i:CARDINAL;
  285  BEGIN
  286    IF  NOT InBuffer(ndx,nodenumber,buffer)
  287    THEN
  288      HALT;
  289    END;
  290    FOR i:=0 TO 511 DO
  291      IF buffer^.node[i]#nodeblock[i]
  292      THEN
  293        HALT;
  294      END;
  295    END;
  296  END Errorchk;*)
  297  
  298  BEGIN
  299  (*  IF nodenumber>VAL(LONGINT,1)
  300    THEN
  301      Errorchk
  302    END; *)
  303    pos := nodenumber * VAL(LONGINT, NodeSize);
  304    HandleIO.SetFilePtr(ndx^.f, HandleIO.FromStart, pos);
  305    FileError := HandleIO.BlockWrite(ndx^.f, ADR(nodeblock), NodeSize);
  306    IF FileError # StringIO.NoError THEN
  307      WARN('Block write failure in WriteNode');
  308    END;
  309    IF ndx^.Safety
  310    THEN
  311      HandleIO.UpdateDisk(ndx^.f);
  312    END;
  313  
  314  END WriteNode;
  315  
  316  PROCEDURE InitNode(VAR node: NodeType);
  317  BEGIN
  318    Fill(ADR(node), NodeSize, 0C);
  319  END InitNode;
  320  
  321  PROCEDURE FindFreeBuffer( ndx:DBIndex;VAR buffer: IndexBuffer ):BOOLEAN;
  322  BEGIN
  323    buffer:=ndx^.last;
  324    WHILE buffer^.Lock
  325    DO
  326      IF buffer^.prev=NIL
  327      THEN
  328        RETURN FALSE;
  329      END;
  330      buffer:=buffer^.prev;
  331   END;
  332    (* if one is looking for buffer it will be reused so write it
  333    out if safety is off *)
  334    IF buffer^.NeedToWrite
  335    THEN
  336      WriteNode(ndx,buffer^.number,buffer^.node);
  337    END;
  338    RETURN TRUE;
  339  END FindFreeBuffer;
  340  
  341  PROCEDURE GetBuffer( ndx:DBIndex;VAR buffer: IndexBuffer;
  342                      NodeNumber:LONGINT );
  343  BEGIN
  344    IF  (( ndx^.buffsize>ndx^.currsize) AND DosAvail(8000))
  345    THEN
  346      DosAlloc(buffer,SIZE(buffer^));
  347    ELSE;
  348      IF FindFreeBuffer(ndx,buffer)
  349      THEN
  350        RemoveBuffer(ndx,buffer);
  351        RemoveFromTable(ndx,buffer);
  352      ELSE
  353        DosAlloc(buffer,SIZE(buffer^));
  354      END;
  355    END;
  356    AddBuffer(ndx,buffer);
  357    (* init buffer *)
  358    buffer^.number:=NodeNumber;
  359    AddToTable(ndx,buffer);
  360    (* buffer^.clean:=37513;  diag *)
  361    buffer^.NeedToWrite:=FALSE;
  362    buffer^.Lock:=FALSE;
  363    InitNode(buffer^.node);
  364  END GetBuffer;
  365  
  366  PROCEDURE ReadNode( ndx: DBIndex;
  367                         nodenumber: LONGINT;
  368                     VAR buffer: IndexBuffer);
  369      (* the file associated with the index must already be open *)
  370  VAR pos: LONGINT;
  371  FileError: StringIO.ErrorMessage;
  372  BEGIN
  373    IF InBuffer(ndx,nodenumber,buffer)
  374    THEN
  375      RemoveBuffer(ndx,buffer);
  376      AddBuffer(ndx,buffer);
  377      RETURN
  378    END;
  379    GetBuffer(ndx,buffer,nodenumber);
  380    (*buffer^.number:=nodenumber;*)
  381    pos := nodenumber * VAL(LONGINT, NodeSize);
  382    HandleIO.SetFilePtr(ndx^.f, HandleIO.FromStart, pos);
  383    FileError := HandleIO.BlockRead(ndx^.f, ADR(buffer^.node), NodeSize);
  384    IF FileError # StringIO.NoError THEN
  385      WARN('Block read failure in ReadNode');
  386    END;
  387  END ReadNode;
  388  
  389  PROCEDURE NewNode( ndx:DBIndex;VAR buffer:IndexBuffer) ;
  390  BEGIN
  391    IF ndx^.Header.FreeList=VAL(LONGINT,0)
  392    THEN
  393      GetBuffer(ndx,buffer,ndx^.Header.nextfreenode);
  394      (*buffer^.number:=ndx^.Header.nextfreenode;*)
  395      INC(ndx^.Header.nextfreenode)
  396    ELSE
  397      ReadNode(ndx,ndx^.Header.FreeList,buffer);
  398      Move(ADR(buffer^.node),ADR(ndx^.Header.FreeList),4);
  399      InitNode(buffer^.node);
  400    END;
  401  
  402  END NewNode;
  403  
  404  PROCEDURE ReadIntoArray( ndx :DBIndex;
  405                          nodenumber: LONGINT;
  406                          level :CARDINAL);
  407  BEGIN
  408    IF ndx^.posarray[level].buffer#NIL
  409    THEN
  410      ndx^.posarray[level].buffer^.Lock:=FALSE;
  411    END;
  412    ReadNode(ndx, nodenumber, ndx^.posarray[level].buffer);
  413    ndx^.posarray[level].buffer^.number:=nodenumber;
  414    ndx^.posarray[level].buffer^.Lock:=TRUE;
  415  END ReadIntoArray;
  416  
  417  PROCEDURE ReadHeader( ndx:DBIndex);
  418  BEGIN
  419      HandleIO.SetFilePtr(ndx^.f, HandleIO.FromStart, 0);
  420      StringIO.PrintMessage(HandleIO.BlockRead(ndx^.f,ADR(ndx^.Header),
  421        SIZE(ndx^.Header)))
  422  END ReadHeader;
  423  
  424  PROCEDURE WriteHeader( ndx:DBIndex);
  425  BEGIN
  426      HandleIO.SetFilePtr(ndx^.f, HandleIO.FromStart, 0);
  427      StringIO.PrintMessage(HandleIO.BlockWrite(ndx^.f,ADR(ndx^.Header),
  428      SIZE(ndx^.Header)))
  429  
  430  END WriteHeader;
  431  
  432  PROCEDURE GetKeyPtr(VAR node: NodeType;
  433                   ndx:  DBIndex;
  434                   keynumber: CARDINAL):KeyPointer;
  435  
  436  BEGIN
  437    RETURN ADR(node[4 +(keynumber * ndx^.Header.entrylength)]);
  438  END GetKeyPtr;
  439  
  440  PROCEDURE GetKey(VAR node: NodeType;
  441                   ndx:  DBIndex;
  442                   keynumber: CARDINAL;
  443                   VAR key: EntryType);
  444  
  445  BEGIN
  446    (* entire procedure should be eliminated and placed in line.
  447    changes are based on assumption that the max key size is 128
  448    and 129 are avalable. error checking could be done in buildindex!!!!*)
  449    Move(ADR(node[4 +(keynumber * ndx^.Header.entrylength)]), ADR(key),
  450       ndx^.Header.entrylength);
  451    key.value[ndx^.Header.keylength]:=0C;
  452  END GetKey;
  453  
  454  (*
  455  PROCEDURE CompareKeyReal( ad1,ad2 : ADDRESS;size:CARDINAL) : CompareType;
  456  TYPE
  457    rp= RECORD
  458          CASE:CARDINAL OF
  459             1:
  460             r:POINTER TO Real8;
  461           | 2:
  462             b:POINTER TO ARRAY[0..7] OF BYTE;
  463           | 3:
  464             a:ADDRESS;
  465           END;
  466         END;
  467  VAR
  468    r1,r2:rp;
  469    BEGIN
  470     r1.a:=ad1;
  471     r2.a:=ad2;
  472     IF (r1.r^ < r2.r^) THEN
  473       RETURN LT
  474     ELSIF (r1.b^ = r2.b^) THEN
  475       RETURN EQ
  476      ELSE
  477        RETURN GT
  478      END;
  479    END CompareKeyReal;
  480    *)
  481    PROCEDURE CompareKeyReal(s1, s2 : ADDRESS;size:CARDINAL) : CompareType;
  482      TYPE
  483    rp= RECORD
  484          CASE:CARDINAL OF
  485             1:
  486             r:POINTER TO Real8;
  487           | 2:
  488             c:POINTER TO CARDINAL;
  489           | 3:
  490             a:ADDRESS;
  491           | 4:
  492            off,seg:CARDINAL;
  493           | 5:
  494             b:POINTER TO BITSET;
  495           END;
  496         END;
  497  
  498      VAR
  499        TmpAdr1, TmpAdr2 :  rp;
  500        cnt : CARDINAL;
  501        neg:BOOLEAN;
  502      BEGIN
  503        TmpAdr1.a := s1;
  504        TmpAdr2.a := s2;
  505        INC(TmpAdr1.off,6);
  506        INC(TmpAdr2.off,6);
  507        neg:=(15 IN TmpAdr1.b^) OR (15 IN TmpAdr2.b^);
  508        cnt := 0;
  509        WHILE cnt<4 DO
  510          IF TmpAdr1.c^#TmpAdr2.c^ THEN
  511            IF TmpAdr1.c^>TmpAdr2.c^ THEN
  512              IF neg THEN
  513                RETURN LT
  514              ELSE
  515                RETURN GT
  516              END;
  517            ELSE
  518              IF neg THEN
  519                RETURN GT
  520              ELSE
  521                RETURN LT;
  522              END;
  523            END;
  524          ELSE
  525            INC(cnt);
  526            DEC(TmpAdr1.off,2);
  527            DEC(TmpAdr2.off,2);
  528          END;
  529        END;
  530        RETURN EQ;
  531      END CompareKeyReal;
  532  
  533    PROCEDURE CompareKey(s1, s2 : ADDRESS;size:CARDINAL) : CompareType;
  534      VAR
  535        TmpAdr1, TmpAdr2 :  Address8086;
  536        cnt : CARDINAL;
  537      BEGIN
  538        TmpAdr1.a := s1;
  539        TmpAdr2.a := s2;
  540        cnt := 0;
  541        WHILE cnt<size DO
  542          IF TmpAdr1.b^#TmpAdr2.b^ THEN
  543            IF TmpAdr1.b^>TmpAdr2.b^ THEN
  544              RETURN GT;
  545            ELSE
  546              RETURN LT;
  547            END;
  548          ELSE
  549            IF (TmpAdr1.b^=0C)
  550            THEN (* if on 0C were done *)
  551              RETURN EQ
  552            END;
  553            INC(cnt);
  554            INC(TmpAdr1.off);
  555            INC(TmpAdr2.off);
  556          END;
  557        END;
  558        RETURN EQ;
  559      END CompareKey;
  560  
  561  PROCEDURE FindPosition( ndx: DBIndex;
  562                          KeyValue: ADDRESS;
  563                          VAR found: BOOLEAN;
  564                          CompareP:CompareProc);
  565  
  566  VAR level, keysinnode,
  567      diff,
  568      Top,Bottom,
  569      crrntkeynum: CARDINAL;
  570      done: BOOLEAN;
  571      keyptr:KeyPointer;
  572      nextnode: LONGINT;
  573  BEGIN
  574    IF   OpenIndex(ndx)=FALSE
  575    THEN
  576      WARN('Error opening Index in FindPosition');
  577    END;
  578    nextnode := ndx^.Header.rootptr;  (* start search with root node *)
  579    level := 0;
  580    found:=FALSE;
  581    REPEAT
  582      ReadIntoArray(ndx, nextnode, level);
  583      WITH  ndx^.posarray[level] DO
  584        keysinnode := ORD(buffer^.node[0]);
  585        Top:=keysinnode;
  586        Bottom:=0;
  587        crrntkeynum:=(Top)DIV 2;(* use shift operator? *)
  588        done := FALSE;
  589      (*  IF buffer^.clean# 37513 THEN HALT END;  diag *)
  590        LOOP
  591          keyptr:=GetKeyPtr(buffer^.node, ndx, crrntkeynum);
  592          WITH  keyptr^ DO
  593            CASE  CompareP(KeyValue,ADR(value),ndx^.Header.keylength) OF
  594              LT: (* key is less than tested value *)
  595                  diff:=crrntkeynum-Bottom;
  596                  IF diff<1
  597                  THEN
  598                    EXIT; (* done *)
  599                  END;
  600                  Top:=crrntkeynum; (* check lower half *)
  601                  crrntkeynum:=Bottom+(diff DIV 2);
  602               |GT:  (* key is greater than test *)
  603                  diff:=Top-crrntkeynum;
  604                  IF diff<=1
  605                  THEN
  606                    crrntkeynum:=Top; (*done but currect one was top*)
  607                    keyptr:=GetKeyPtr(buffer^.node, ndx, crrntkeynum);
  608                    EXIT;
  609                  END;
  610                  Bottom:=crrntkeynum; (* Next check upper half *)
  611                  crrntkeynum:=Bottom+(diff DIV 2);
  612               |EQ:
  613  	
  614  (* * * * * * * * * * * * * * * * * * * *testing stuff for ed *)
  615  (* found a position - might not be the first one though  *)
  616  (* loop backwards through the index to find the first if many   *)
  617                 LOOP
  618  		 IF crrntkeynum < 1
  619  		   THEN EXIT;
  620  		   END;  (* at the first *)
  621  		 DEC(crrntkeynum);
  622  		 keyptr := GetKeyPtr(buffer^.node,ndx,crrntkeynum);
  623  		 IF CompareP(KeyValue,ADR(keyptr^.value),ndx^.Header.keylength) = GT
  624  		   THEN INC(crrntkeynum);
  625  		        keyptr := GetKeyPtr(buffer^.node,ndx,crrntkeynum);
  626  		        EXIT;
  627  		   END;
  628  (* * * * * * * * * * *  End of stuff by ed * * * * * * * * * *  *)
  629  
  630  
  631  	
  632  	       END;  (* end of loop and end of my stuff *)
  633                  found:= TRUE;
  634                  EXIT;
  635            END; (* CASE *)
  636          END;
  637        END (*loop*);
  638  
  639           (* compare the key to the keys in the rootnode until the fieldstring
  640              <= currentkey or the last entry in the node is encountered *)
  641        keynum := crrntkeynum;
  642       (* currentkey set by getkey  *)
  643        nextnode:=keyptr^.lowernode;
  644      END;
  645      INC(level);
  646    UNTIL nextnode=VAL(LONGINT,0);
  647    ndx^.depth:=level-1;
  648    ndx^.currentkey:=keyptr;
  649  END FindPosition;
  650  
  651  PROCEDURE FindPositionCh( ndx: DBIndex;
  652                            keystr: ARRAY OF CHAR;
  653                           VAR found: BOOLEAN);
  654  VAR
  655      TestStr:ARRAY[0..MaxKey] OF CHAR;
  656  BEGIN
  657    Fill(ADR(TestStr),MaxKey,' ');
  658    Copy(keystr,0,Length(keystr),TestStr);
  659    FindPosition(ndx,ADR(TestStr),found,CompareKey);
  660  END FindPositionCh;
  661  
  662  PROCEDURE FindPositionR( ndx: DBIndex;
  663                          KeyValue: Real8;
  664                          VAR found: BOOLEAN);
  665  BEGIN
  666    FindPosition(ndx,ADR(KeyValue),found,CompareKeyReal);
  667  END FindPositionR;
  668  
  669  PROCEDURE FindPositionN(ndx: DBIndex;
  670                          keystr: ARRAY OF CHAR;
  671                          VAR found: BOOLEAN);
  672  VAR
  673      KeyValue:Real8;
  674  BEGIN
  675    IF NOT StrToReal(keystr, 0,KeyValue) THEN KeyValue:=0.0 END;
  676    FindPositionR(ndx,KeyValue,found);
  677  END FindPositionN;
  678  
  679  PROCEDURE AddRecord( alias: DBFile;
  680                       ndx: DBIndex);
  681  VAR
  682      fieldstring: ARRAY [1..MaxField] OF CHAR;
  683      found: BOOLEAN;
  684      key:
  685      RECORD
  686        CASE :BOOLEAN OF
  687          TRUE:num:Real8;|
  688          FALSE:str:ARRAY[0..7] OF CHAR;
  689        END;
  690      END;
  691  
  692  BEGIN
  693    IF   OpenIndex(ndx)=FALSE
  694    THEN
  695      WARN('Error opening Index in AddRecord');
  696    END;
  697    EnterLock(ndx);
  698    (* get key from record *);
  699    ndx^.KeyProc(alias,ndx,fieldstring);
  700    IF ndx^.Header.NumType  THEN
  701      IF NOT StrToReal(fieldstring, 0,key.num) THEN key.num:=0.0 END;
  702      FindPositionR(ndx, key.num, found);
  703      InsertEntry(ndx, key.str, Record(alias));
  704    ELSE
  705      FindPositionCh(ndx, fieldstring, found);
  706      InsertEntry(ndx, fieldstring, Record(alias));
  707    END; (* Now we have the position where the new Entry
  708          should be inserted *)
  709    ExitLock(ndx);
  710  END AddRecord;
  711  
  712  PROCEDURE DefaultKeyProcedure(alias:  DBFile; ndx: DBIndex;
  713       VAR str:ARRAY OF   CHAR );
  714  BEGIN
  715    GetField(alias, ndx^.KeyNumber, str);
  716  
  717  END DefaultKeyProcedure;
  718  
  719  PROCEDURE AdjustUpperNode( ndx: DBIndex;VAR KeyStr:ARRAY OF CHAR;
  720                        level: CARDINAL);
  721    (* need to pass keystring because may be fixing at the current level
  722     but not in the route level-1 must point to worknode!!*)
  723  VAR offset: CARDINAL;
  724    upkey,key:KeyPointer;
  725  BEGIN
  726    (* do not check to see if it is nessary but make sure level#0 *)
  727    IF (level=0)  THEN RETURN END;
  728    (*Adjust upernode*)
  729    IF (ndx^.posarray[level-1].keynum#
  730      ORD(ndx^.posarray[level-1].buffer^.node[0]))
  731    THEN  (* can simplify when changing upkey to upkey^ *)
  732      upkey:=GetKeyPtr(ndx^.posarray[level-1].buffer^.node,ndx,
  733        ndx^.posarray[level-1].keynum);
  734      Move(ADR(KeyStr), ADR(upkey^.value), ndx^.Header.keylength);
  735      IF ndx^.Safety OR NOT ndx^.Exclusive
  736      THEN
  737        WriteNode(ndx, ndx^.posarray[level-1].buffer^.number,
  738        ndx^.posarray[level-1].buffer^.node);
  739      ELSE
  740        ndx^.posarray[level-1].buffer^.NeedToWrite:=TRUE;
  741      END;
  742    ELSE
  743      AdjustUpperNode(ndx,KeyStr,level-1);
  744    END;
  745  END AdjustUpperNode;
  746  
  747  PROCEDURE DeleteEntry(ndx: DBIndex;
  748                        deletelevel: CARDINAL);
  749  VAR offset: CARDINAL;
  750    upkey,key:KeyPointer;
  751    empty:BOOLEAN;
  752  BEGIN
  753    (* 4/21/89 notes for changes pos is not need as parameter
  754      if top node is changed need to fix all the way down if
  755      needed not just one as it is there is some chance of error.
  756      cosider making procedure to fix uper node as it is used in
  757      move keys also *)
  758    (* Find the offset of the keyentry following
  759       the entry to be deleted, and then shift the rest of the
  760       node up to cover the deleted node *)
  761    ndx^.Changed:=TRUE;
  762    offset := ((ndx^.posarray[deletelevel].keynum + 1) * (ndx^.Header.entrylength)) + 4;
  763    Move(ADR(ndx^.posarray[deletelevel].buffer^.node[offset]),
  764        ADR(ndx^.posarray[deletelevel].buffer^.node[offset-ndx^.Header.entrylength]),
  765         NodeSize-offset);
  766   (* not correct or nessisary ?
  767    Fill(ADR(ndx^.posarray[deletelevel].buffer^.
  768      node[offset -ndx^.Header.entrylength]), ndx^.Header.entrylength, 0C);*)
  769  
  770    (* Next decrement the number of keys in the node and
  771       write the decremented number in the first byte of the
  772       node. *)
  773    empty:=FALSE;
  774    empty:=(ndx^.posarray[deletelevel].buffer^.node[0])=0C;
  775    IF NOT empty THEN
  776      DEC(ndx^.posarray[deletelevel].buffer^.node[0]);
  777      empty:=(ndx^.posarray[deletelevel].buffer^.node[0]=0C) AND
  778        (deletelevel =ndx^.depth)
  779    END;
  780    IF (deletelevel > 0)
  781    THEN
  782      IF empty
  783      THEN (* THE NODE IS EMPTY *)
  784      (* posarray must be good *)
  785        (* put in freenode list *)
  786        Move(ADR(ndx^.Header.FreeList),
  787          ADR(ndx^.posarray[deletelevel].buffer^.node),4);
  788        ndx^.Header.FreeList:=ndx^.posarray[deletelevel].buffer^.number;
  789        DeleteEntry(ndx,deletelevel-1);
  790      ELSE;
  791        (* Check to see if deleted top node *)
  792        IF deletelevel=ndx^.depth
  793        THEN
  794          offset:=1
  795        ELSE
  796          offset:=0
  797        END;
  798        IF ndx^.posarray[deletelevel].keynum =
  799         ( ORD(ndx^.posarray[deletelevel].buffer^.node[0])+1-offset)
  800        THEN
  801          key:=GetKeyPtr(ndx^.posarray[deletelevel].buffer^.node,
  802          ndx,ndx^.posarray[deletelevel].keynum-1);
  803          AdjustUpperNode(ndx,
  804          key^.value,
  805          deletelevel);
  806        END;
  807      END;
  808    END; (* if *)
  809  
  810    IF ndx^.Safety OR NOT ndx^.Exclusive
  811    THEN
  812      WriteNode(ndx, ndx^.posarray[deletelevel].buffer^.number,
  813      ndx^.posarray[deletelevel].buffer^.node);
  814    ELSE
  815      ndx^.posarray[deletelevel].buffer^.NeedToWrite:=TRUE;
  816    END;
  817  END DeleteEntry;
  818  
  819  
  820  PROCEDURE DeleteCurrentEntry( ndx: DBIndex);
  821  VAR
  822    rec:LONGINT;
  823  BEGIN
  824    IF   OpenIndex(ndx)=FALSE
  825    THEN
  826      WARN('Error opening Index in DeleteCurrentEntry');
  827    END;
  828    rec:=ndx^.currentkey^.recordnum;
  829    EnterLock(ndx);
  830    IF rec=ndx^.currentkey^.recordnum THEN (* do not delete if not there *)
  831      DeleteEntry(ndx, ndx^.depth);
  832    END;
  833    ExitLock(ndx);
  834  END DeleteCurrentEntry;
  835  
  836  PROCEDURE UpdateIndexHeader(ndx :DBIndex );
  837  
  838  VAR
  839      Buffer:IndexBuffer;
  840  BEGIN
  841    IF NOT ndx^.open
  842    THEN
  843      RETURN;
  844    END;
  845    HandleIO.SetFilePtr(ndx^.f,HandleIO.FromStart,VAL(LONGINT,0));
  846    StringIO.PrintMessage(
  847      HandleIO.BlockWrite(ndx^.f,ADR(ndx^.Header),SIZE(ndx^.Header)));
  848    IF NOT ndx^.Safety AND ndx^.Exclusive
  849    THEN (* Write out Buffers  if safety off*)
  850      Buffer:=ndx^.first;
  851      WHILE Buffer#NIL
  852      DO
  853        IF Buffer^.NeedToWrite
  854        THEN
  855          WriteNode(ndx,Buffer^.number,Buffer^.node);
  856          Buffer^.NeedToWrite:=FALSE;
  857        END;
  858        Buffer:=Buffer^.next;
  859      END;
  860    END;
  861  END UpdateIndexHeader;
  862  
  863  
  864  
  865  PROCEDURE InsertEntry( ndx: DBIndex;
  866                         kstr: ARRAY OF CHAR;
  867                         recno: LONGINT);
  868  VAR i,  level, middle: CARDINAL;
  869      tempkey:EntryType;
  870      NewRoot,NewBuffer:IndexBuffer;
  871      noOverflow,InHighNode: BOOLEAN;
  872      (*diag,*)oldnodenum, newnodenum, lowernodenum: LONGINT;
  873      key:
  874      RECORD
  875        CASE :BOOLEAN OF
  876          TRUE:num:Real8;|
  877          FALSE:str:ARRAY[0..7] OF CHAR;
  878        END;
  879      END;
  880  
  881  
  882  
  883  PROCEDURE AddKeyTo( lower, recnum: LONGINT; VAR node: NodeType;
  884                              val: ARRAY OF CHAR; NewKey:BOOLEAN);
  885       (* This procedure assumes that there is room in the node for another
  886          key entry; it does not test for correct positioning, it assumes
  887          that the ndx^.posarray has been correctly updated by all prior
  888          operations *)
  889     VAR moveblocksize, i,  entrypos, keystomove   : CARDINAL;
  890  
  891     BEGIN
  892       (* consider changing to copy into entry then move all *)
  893       entrypos := ndx^.posarray[level].keynum;
  894       keystomove := ORD(node[0])-entrypos+1;
  895       node[0] := CHR(ORD(node[0])+1);
  896       i := 4 + (entrypos * ndx^.Header.entrylength); (* 4 bytes reserved for key count *)
  897       (* make space for the new entry *)
  898       moveblocksize := keystomove*ndx^.Header.entrylength+4;
  899       ShiftArrayRight((* from *) ADR(node[i]),
  900                     (* size *) moveblocksize ,
  901                 (* distance *) ndx^.Header.entrylength);
  902       Move(ADR(recnum), ADR(node[i+4]), 4);
  903       (* trims to size *)
  904       Move(ADR(val),ADR(node[i+8]), ndx^.Header.entrylength - 8);
  905       Move(ADR(lower), ADR(node[i]), 4);
  906       (* the Move statement modifies the pointer after the inserted key
  907          so that it points to the appropriate node.  It is hard to
  908          remember that the only reason an entry would be inserted into
  909          a node other than a leaf node is because the lower node was split. *)
  910       IF  (ndx^.depth=level)
  911       THEN
  912         IF NewKey THEN
  913           ndx^.currentkey:=ADR(node[i])
  914         END;
  915         IF (keystomove=1)
  916         THEN
  917           AdjustUpperNode(ndx,val,level)
  918         END;
  919       END;
  920     END AddKeyTo;
  921  
  922     PROCEDURE Split(VAR old, new: IndexBuffer);
  923     VAR
  924      c:CHAR;
  925      key:EntryType;
  926      i, j,  middlekeypos,
  927      keysinold: CARDINAL;
  928     BEGIN
  929       keysinold := ORD(old^.node[0]);
  930       new^.node := old^.node;
  931       (* if a key has been handed up from a split node it points to the
  932          newnode created by the last split *)
  933       (* save node numbers in case root node is being split *)
  934       newnodenum:=new^.number;
  935       oldnodenum:=old^.number;
  936       middle := (ndx^.Header.keyspernode DIV 2);
  937       keysinold := keysinold - middle;
  938       middlekeypos := 4 + (middle)* ndx^.Header.entrylength;
  939       (* middlekeypos is the END of the middlekey *)
  940       Fill(ADR(new^.node[middlekeypos]), NodeSize - middlekeypos, 0C);
  941       (* the new node gets the first  keys, the rest are nulled out *)
  942       Move(ADR((*from*) old^.node[middlekeypos]),
  943                (* to *) ADR(old^.node[4]),
  944                (*size*) (NodeSize-middlekeypos));
  945       Fill(ADR(old^.node[8+keysinold*ndx^.Header.entrylength]),
  946             NodeSize-(8+keysinold*ndx^.Header.entrylength),0C);
  947       new^.node[0] := CHR(middle);
  948       old^.node[0] := CHR(keysinold);
  949   (*    IF new=old
  950       THEN
  951         HALT;
  952       END; (* diag *)
  953  *)
  954       IF ndx^.posarray[level].keynum <= middle THEN
  955         (* insert into new node ( lowernode ) *)
  956          (* new is yet in posarray so must trick  Addkeyto to not
  957          try and adjust upper node as it will be inserted latter*)
  958          INC(new^.node[0]);
  959          AddKeyTo(lowernodenum, recno, new^.node, kstr,TRUE);
  960          DEC(new^.node[0]);
  961          INC(middle); (* because an entry has been inserted ahead of it *)
  962          GetKey(new^.node,ndx,middle-1,key); (* get key value to
  963          insert in lowernode before we lose it *)
  964          IF lowernodenum#VAL(LONGINT,0)
  965          THEN (* not at leaf DBASEIII does not store entire lastkey in non leaf
  966            nodes *)
  967           DEC(new^.node[0])
  968          END;
  969          (* force new pos array *)
  970          InHighNode:=FALSE;
  971          (* need to put writes here because the readintoarray
  972            will lose a node *)
  973          IF ndx^.Safety OR NOT ndx^.Exclusive
  974          THEN
  975            WriteNode(ndx, new^.number, new^.node);
  976            WriteNode(ndx, old^.number, old^.node);
  977          ELSE
  978            new^.NeedToWrite:=TRUE;
  979            old^.NeedToWrite:=TRUE;
  980          END;
  981          ReadIntoArray(ndx, new^.number, level);
  982          old^.Lock:=FALSE;(* unlock other buffer *)
  983       ELSE
  984          (* insert into old (high) node *)
  985          GetKey(new^.node,ndx,middle-1,key); (* get key value to
  986          insert in lowernode before we lose it *)
  987          IF lowernodenum#VAL(LONGINT,0)
  988          THEN (* not at leaf DBASEIII does not store entire lastkey in non leaf
  989            nodes *)
  990            DEC(new^.node[0])
  991          END;
  992          ndx^.posarray[level].keynum := (ndx^.posarray[level].keynum - middle) ;
  993          AddKeyTo(lowernodenum, recno, old^.node, kstr,TRUE);
  994          IF ndx^.Safety OR NOT ndx^.Exclusive
  995          THEN
  996            WriteNode(ndx, new^.number, new^.node);
  997            WriteNode(ndx, old^.number, old^.node);
  998          ELSE
  999            new^.NeedToWrite:=TRUE;
 1000            old^.NeedToWrite:=TRUE;
 1001          END;
 1002          InHighNode:=TRUE;
 1003          (* force new pos array *)
 1004        (*  ReadIntoArray(ndx, old^.number, level); not neeed *)
 1005          new^.Lock:=FALSE;(* unlock other buffer *)
 1006       END;
 1007  
 1008       (* in order to place new node in tree, act as if was inserting
 1009          the last key in the lower(new) node, so must save info *)
 1010       lowernodenum:=newnodenum;
 1011       Assign(key.value,kstr);
 1012       recno:=key.recordnum;
 1013     END Split;
 1014  
 1015     PROCEDURE Balance(level:CARDINAL);
 1016       VAR
 1017         offset,
 1018         count,
 1019         insertpos,
 1020         keystomove,
 1021         keys,
 1022         downkeys,
 1023         upkeys:CARDINAL;
 1024         UpBuffer,DownBuffer:IndexBuffer;
 1025         upkey,tempkey:EntryType;
 1026      (*   found:BOOLEAN;(*diag *) *)
 1027  
 1028    PROCEDURE Movekeys ;
 1029     BEGIN
 1030  
 1031       noOverflow:=TRUE;
 1032       IF upkeys > downkeys
 1033       THEN (* move to lower node *)
 1034         keystomove:=(keys-downkeys+1) DIV 2;
 1035         count:=keystomove;
 1036         WHILE count>0  DO
 1037           (* get key to move and save*)
 1038           (* remove from bottom place on top *)
 1039           GetKey(ndx^.posarray[level].buffer^.node,
 1040            ndx, 0, tempkey);
 1041            ndx^.posarray[level].keynum:=0;
 1042            DeleteEntry(ndx,  level);
 1043            ndx^.posarray[level].keynum:=ORD(DownBuffer^.node[0]);
 1044            DEC(ndx^.posarray[level-1].keynum);
 1045            AddKeyTo(tempkey.lowernode,tempkey.recordnum,
 1046              DownBuffer^.node,tempkey.value,FALSE);(* addkey does not write *)
 1047            INC(ndx^.posarray[level-1].keynum);
 1048            DEC(count);
 1049         END (* while *);
 1050         IF insertpos  >= keystomove THEN
 1051           (* insert into new node ( lowernode ) *)
 1052            ndx^.posarray[level].keynum:=insertpos-keystomove;
 1053            AddKeyTo(lowernodenum, recno, ndx^.posarray[level].buffer^.node, kstr,TRUE);
 1054            (* force new pos array *)
 1055            (* need to put writes here because the readintoarray
 1056              will lose a node *)
 1057            IF ndx^.Safety OR NOT ndx^.Exclusive
 1058            THEN
 1059              WriteNode(ndx, ndx^.posarray[level].buffer^.number,
 1060                 ndx^.posarray[level].buffer^.node);
 1061              WriteNode(ndx, DownBuffer^.number, DownBuffer^.node);
 1062            ELSE
 1063              ndx^.posarray[level].buffer^.NeedToWrite:=TRUE;
 1064              DownBuffer^.NeedToWrite:=TRUE;
 1065            END;
 1066         ELSE
 1067            (* insert into other node *)
 1068            ndx^.posarray[level].keynum :=downkeys+insertpos;
 1069            DEC(ndx^.posarray[level-1].keynum);
 1070            AddKeyTo(lowernodenum, recno, DownBuffer^.node, kstr,TRUE);
 1071            IF ndx^.Safety OR NOT ndx^.Exclusive
 1072            THEN
 1073              WriteNode(ndx, ndx^.posarray[level].buffer^.number,
 1074                  ndx^.posarray[level].buffer^.node);
 1075              WriteNode(ndx, DownBuffer^.number, DownBuffer^.node);
 1076            ELSE
 1077              ndx^.posarray[level].buffer^.NeedToWrite:=TRUE;
 1078              DownBuffer^.NeedToWrite:=TRUE;
 1079            END;
 1080            (* force new pos array *)
 1081            ReadIntoArray(ndx, DownBuffer^.number, level);
 1082         END;
 1083  
 1084       ELSE (* move to upper *)
 1085         keystomove:=(keys-upkeys+1) DIV 2;
 1086         count:=keystomove;
 1087         WHILE count>0  DO
 1088           (* get key to move and save*)
 1089           (* remove from top place on bottom *)
 1090           GetKey(ndx^.posarray[level].buffer^.node,
 1091            ndx,ORD(ndx^.posarray[level].buffer^.node[0])-1, tempkey);
 1092            ndx^.posarray[level].keynum:=
 1093                  ORD(ndx^.posarray[level].buffer^.node[0])-1;
 1094            DeleteEntry(ndx,  level);
 1095            ndx^.posarray[level].keynum:=0;
 1096            AddKeyTo(tempkey.lowernode,tempkey.recordnum,
 1097              UpBuffer^.node,tempkey.value,FALSE);(* addkey does not write *)
 1098            DEC(count);
 1099         END (* while *);
 1100  
 1101         (* delete key fixed upper node *)
 1102         IF insertpos  < ORD(ndx^.posarray[level].buffer^.node[0]) THEN
 1103           (* insert into old node  *)
 1104            ndx^.posarray[level].keynum:=insertpos;
 1105            AddKeyTo(lowernodenum, recno, ndx^.posarray[level].buffer^.node, kstr,TRUE);
 1106            (* force new pos array *)
 1107            (* need to put writes here because the readintoarray
 1108              will lose a node *)
 1109            IF ndx^.Safety OR NOT ndx^.Exclusive
 1110            THEN
 1111              WriteNode(ndx, ndx^.posarray[level].buffer^.number,
 1112                 ndx^.posarray[level].buffer^.node);
 1113              WriteNode(ndx, UpBuffer^.number, UpBuffer^.node);
 1114            ELSE
 1115              ndx^.posarray[level].buffer^.NeedToWrite:=TRUE;
 1116              UpBuffer^.NeedToWrite:=TRUE;
 1117            END;
 1118         ELSE
 1119            (* insert into other node *)
 1120            ndx^.posarray[level].keynum :=
 1121              insertpos-ORD(ndx^.posarray[level].buffer^.node[0]);
 1122            INC(ndx^.posarray[level-1].keynum);
 1123            AddKeyTo(lowernodenum, recno, UpBuffer^.node, kstr,TRUE);
 1124            IF ndx^.Safety OR NOT ndx^.Exclusive
 1125            THEN
 1126              WriteNode(ndx, ndx^.posarray[level].buffer^.number,
 1127               ndx^.posarray[level].buffer^.node);
 1128              WriteNode(ndx, UpBuffer^.number, UpBuffer^.node);
 1129            ELSE
 1130              ndx^.posarray[level].buffer^.NeedToWrite:=TRUE;
 1131              UpBuffer^.NeedToWrite:=TRUE;
 1132            END;
 1133            (* force new pos array *)
 1134            ReadIntoArray(ndx, UpBuffer^.number, level);
 1135         END;
 1136  
 1137       END;
 1138  
 1139     END Movekeys ;
 1140  
 1141     PROCEDURE CanBalance():BOOLEAN ;
 1142     BEGIN
 1143       IF (upkeys>=keys) AND (downkeys>=keys)
 1144       THEN
 1145         RETURN FALSE;
 1146       ELSIF (upkeys>downkeys) AND (keys-downkeys=1)
 1147       THEN (* downkey has only one place *)
 1148         IF ndx^.posarray[level].keynum=0 THEN
 1149           RETURN FALSE;
 1150         END;
 1151       ELSIF (upkeys<=downkeys) AND (keys-upkeys=1)
 1152       THEN (* upkey has only one place *)
 1153         IF (ndx^.posarray[level].keynum+1)>=keys THEN
 1154           RETURN FALSE;
 1155         END;
 1156       END;
 1157       RETURN TRUE;
 1158  
 1159     END CanBalance;
 1160  
 1161     BEGIN  (*balance *)
 1162       downkeys:=65000;
 1163       upkeys:=65000;
 1164       DownBuffer:=NIL;
 1165       UpBuffer:=NIL;
 1166       IF (level=0) OR (level#ndx^.depth)
 1167       THEN
 1168       (* Because of complications do not balace nonleaf nodes *)
 1169         NewNode(ndx,NewBuffer);
 1170         Split(ndx^.posarray[level].buffer, NewBuffer);
 1171         RETURN;
 1172       END;
 1173       insertpos:=ndx^.posarray[level].keynum;
 1174       keys:=ORD(ndx^.posarray[level].buffer^.node[0]);
 1175       IF  ndx^.posarray[level-1].keynum <
 1176          (ORD(ndx^.posarray[level-1].buffer^.node[0])-1)
 1177       THEN (* get uper node (same level *)
 1178         GetKey(ndx^.posarray[level-1].buffer^.node,
 1179          ndx, ndx^.posarray[level-1].keynum+1, tempkey);
 1180         ReadNode(ndx,tempkey.lowernode,UpBuffer);
 1181         UpBuffer^.Lock:=TRUE;
 1182         upkeys:=ORD(UpBuffer^.node[0]);
 1183       END;
 1184       IF  ndx^.posarray[level-1].keynum > 0
 1185       THEN (* get lowernode (same level) *)
 1186         GetKey(ndx^.posarray[level-1].buffer^.node,
 1187          ndx, ndx^.posarray[level-1].keynum-1, tempkey);
 1188         ReadNode(ndx,tempkey.lowernode,DownBuffer);
 1189         DownBuffer^.Lock:=TRUE;
 1190         downkeys:=ORD(DownBuffer^.node[0]);
 1191       END;
 1192       (* determine if one can just move keys *)
 1193       IF CanBalance()
 1194       THEN
 1195         Movekeys;
 1196       (*  ChkInd.NDXChk(ndx);
 1197         FindPositionCh(ndx,kstr,found);
 1198         IF NOT found THEN HALT END;*)
 1199       ELSE
 1200         NewNode(ndx,NewBuffer);
 1201         Split(ndx^.posarray[level].buffer, NewBuffer);
 1202       END;
 1203       IF DownBuffer#NIL THEN DownBuffer^.Lock:=FALSE END;
 1204       IF UpBuffer#NIL THEN UpBuffer^.Lock:=FALSE END;
 1205     END Balance;
 1206  
 1207  BEGIN (* Insert Entry *)
 1208    (* update current key to keep all up to date *)
 1209    EnterLock(ndx);
 1210  (*  diag:=recno (* diag *);*)
 1211    ndx^.Changed:=TRUE;
 1212    InHighNode:=FALSE;
 1213  (*IF ndx^.Header.NumType
 1214    THEN
 1215      Move(ADR(kstr),ADR(NewKey.value),8);
 1216    ELSE
 1217      Assign(kstr,NewKey.value);
 1218    END;
 1219    NewKey.lowernode:=VAL(LONGINT,0);
 1220    NewKey.recordnum:=recno; *)
 1221    level := ndx^.depth;
 1222    lowernodenum := VAL(LONGINT,0);
 1223    REPEAT
 1224      noOverflow := ORD(ndx^.posarray[level].buffer^.node[0]) < ndx^.Header.keyspernode;
 1225      IF noOverflow THEN
 1226        AddKeyTo(lowernodenum, recno, ndx^.posarray[level].buffer^.node, kstr,TRUE);
 1227        IF InHighNode
 1228        THEN
 1229          INC(ndx^.posarray[level].keynum);
 1230        END;
 1231        IF ndx^.Safety OR NOT ndx^.Exclusive
 1232        THEN
 1233          WriteNode(ndx, ndx^.posarray[level].buffer^.number,
 1234            ndx^.posarray[level].buffer^.node);
 1235          ELSE
 1236            ndx^.posarray[level].buffer^.NeedToWrite:=TRUE;
 1237        END;
 1238      ELSE
 1239        Balance(level);
 1240        (* find out where kstr belongs and insert it *)
 1241        IF level = 0 THEN (* the root node was split *)
 1242          INC(ndx^.buffsize,2);(* enlarge buffer *)
 1243          INC(ndx^.depth);   (* prepare to add another level to the map *)
 1244          FOR i := ndx^.depth TO 1 BY -1 DO
 1245            ndx^.posarray[i] := ndx^.posarray[i-1]
 1246          END;    (* slide all the keypositions in the map up one notch *)
 1247          NewNode(ndx,NewRoot);
 1248            (* force NewRoot into root position *)
 1249          ndx^.Header.rootptr := NewRoot^.number;
 1250          ReadIntoArray(ndx, NewRoot^.number, 0);
 1251           (* KEYNUMBERS BEGIN at ZERO *)
 1252          ndx^.posarray[0].keynum := 0;
 1253          NewBuffer^.Lock:=FALSE;
 1254          AddKeyTo(oldnodenum, VAL(LONGINT,0), NewRoot^.node, '',FALSE);
 1255            (* the new node initially contains no key but points to the
 1256            new node which was written when the old root was split *)
 1257            (* the number of entries in the node is now 1 *)
 1258            (* now a key is inserted ahead of the 'keyless' pointer *)
 1259          AddKeyTo(newnodenum, recno, NewRoot^.node, kstr,TRUE);
 1260          ndx^.posarray[0].buffer^.node[0]:= 1C;(* top key does not count *)
 1261          IF ndx^.posarray[1].buffer^.number = newnodenum THEN
 1262            ndx^.posarray[0].keynum := 0
 1263          ELSE
 1264            ndx^.posarray[0].keynum := 1
 1265          END;
 1266          IF ndx^.Safety OR NOT ndx^.Exclusive
 1267          THEN
 1268            WriteNode(ndx, ndx^.Header.rootptr, NewRoot^.node);
 1269          ELSE
 1270            NewRoot^.NeedToWrite:=TRUE;
 1271          END;
 1272          noOverflow := TRUE;
 1273        END (* if *);
 1274        (* if safety is on update header when a node splits *)
 1275        IF ndx^.Safety OR NOT ndx^.Exclusive
 1276        THEN
 1277          UpdateIndexHeader(ndx);
 1278        END;
 1279  
 1280      END (* if *);
 1281      IF level > 0 THEN
 1282        DEC(level);
 1283      END (* if *);
 1284    UNTIL noOverflow;
 1285    ExitLock(ndx);
 1286   (* ChkInd.NDXChk(ndx);*)
 1287   (*  !!!! diag *)
 1288  (* IF diag # ndx^.currentkey^.recordnum
 1289   THEN HALT END (*diag *);  *)
 1290  END InsertEntry;
 1291  
 1292  PROCEDURE BuildIndex(ndx: DBIndex;
 1293                       keyexp: ARRAY OF CHAR):CARDINAL;
 1294  VAR
 1295   Fptr:DBFieldPtr;
 1296  BEGIN
 1297    IF NOT OpenDBF(ndx^.alias)
 1298    THEN (* check to make sure the file is open *)
 1299      WARN('Not able to DBFile file in BuildIndex');
 1300    END;
 1301    CrunchBlanks(keyexp);
 1302    CAPstr(keyexp);
 1303    ndx^.KeyNumber:=PosOfField(ndx^.alias,keyexp);
 1304    IF ndx^.KeyNumber=0 THEN
 1305      WARN('Bad index expression in BuildIndex');
 1306    END;
 1307    Fptr:=FieldList(ndx^.alias);
 1308    RETURN  BuildCompIndex(ndx,Fptr^[ndx^.KeyNumber].fldtype,
 1309    keyexp,Fptr^[ndx^.KeyNumber].size);
 1310  END BuildIndex;
 1311  
 1312  PROCEDURE BuildCompIndex( ndx: DBIndex;
 1313                            type:CHAR; (* C or N *)
 1314                            keyexp:ARRAY OF CHAR;
 1315                            size: CARDINAL
 1316                            ):CARDINAL;
 1317  VAR oldbuffsize,
 1318    olddbbuffersize,
 1319    i,
 1320    ActionTaken: CARDINAL;
 1321       worknode: NodeType;
 1322      recordnumber: LONGINT;
 1323      oldsafety,
 1324      oldexclusive:BOOLEAN;
 1325     FileError: StringIO.ErrorMessage;
 1326  
 1327  BEGIN
 1328    IF NOT OpenDBF(ndx^.alias) THEN
 1329      WARN('Unable to open DBFile in BuildCompIndex');
 1330    END;
 1331    CloseIndex(ndx);
 1332    IF ndx^.Init#InitCode
 1333    THEN
 1334      WARN('Uninitalized DBIndex in BuildCompIndex');
 1335    END;
 1336    InitPosarray(ndx);
 1337    (* open exclusive *)
 1338      (* create if the file does not exist; truncate if it does exist *)
 1339    FileError := FAPI.DOSOPEN( ADR(ndx^.name),
 1340        ADR(ndx^.f), ADR(ActionTaken), VAL(LONGINT,1024),
 1341        FAPI.FILE_NORMAL,CARDINAL( {1,4}),CARDINAL( {1,4}),
 1342        VAL(LONGINT,0) );
 1343    IF FileError#0 THEN RETURN FileError END;
 1344    Fill(ADR(ndx^.Header),SIZE(ndx^.Header),0);
 1345    olddbbuffersize:=BufferSize(ndx^.alias);
 1346    oldbuffsize:=ndx^.buffsize;
 1347    oldsafety := ndx^.Safety;
 1348    oldexclusive:=ndx^.Exclusive;
 1349    SetDBBuffer( ndx^.alias,32000 );
 1350    IF ndx^.buffsize<400 THEN SetIndexBuffers(ndx,400) END;
 1351    WITH ndx^ DO
 1352      FOR i:=0 TO (Bins-1) DO
 1353        Hash[i]:=NIL;
 1354      END;
 1355      Safety:=FALSE;
 1356      Exclusive:=TRUE;
 1357      Assign(keyexp,Header.KeyExpression);
 1358      CrunchBlanks(Header.KeyExpression);
 1359      CAPstr(Header.KeyExpression);
 1360      KeyNumber := PosOfField(alias,Header.KeyExpression);
 1361      Append(Header.KeyExpression,' ');(* do this to mimic dbase3 *)
 1362      Header.rootptr := VAL(LONGINT,1); (* the root begins as the second block *)
 1363                      (* The anchor node is 0 *)
 1364      Header.NumType := (type#'C');
 1365      IF type#'C'
 1366      THEN
 1367        Header.keylength:=8;
 1368        Header.entrylength :=16;
 1369      ELSE
 1370        Header.keylength :=  size;
 1371        Header.entrylength := Header.keylength + 2 * RecNumLen+1;
 1372        (*add 1 and make even to mimic dbase3 *)
 1373        IF ODD(Header.entrylength) THEN INC(Header.entrylength) END;
 1374      END;
 1375  
 1376      Header.keyspernode := (NodeSize - 8) DIV (Header.entrylength);
 1377        (* a key 'entry' is made up of a pointer to a lower node and a
 1378           record number in addition to the key value .  After the last key
 1379           entry there is a pointer to a lowerlevel node containing keys with
 1380           values greater than or equal to the the value of the key in the
 1381           last key entry *)
 1382      Header.nextfreenode := VAL(LONGINT,2);
 1383      open := TRUE;
 1384      depth := 0;
 1385    END;
 1386    InitNode(worknode);
 1387    WriteNode(ndx, VAL(LONGINT,1), worknode);
 1388    recordnumber := VAL(LONGINT,1);
 1389    WHILE recordnumber <= NumberRecords(ndx^.alias) DO
 1390      ReadDBRec(ndx^.alias, recordnumber);
 1391  (* change by ed ross*)
 1392      IF ndx^.includedeleted  OR NOT Deleted(ndx^.alias)
 1393        THEN
 1394           AddRecord(ndx^.alias, ndx);
 1395        END;	
 1396  (* * *End of change by ed *)
 1397     INC(recordnumber);
 1398    END;
 1399    CloseIndex(ndx);
 1400    ndx^.Exclusive:=oldexclusive;
 1401    ndx^.Safety:=oldsafety;
 1402    ndx^.buffsize:= oldbuffsize;
 1403    SetIndexBuffers(ndx,oldbuffsize);
 1404    SetDBBuffer( ndx^.alias,olddbbuffersize );
 1405    RETURN 0;
 1406  END BuildCompIndex;
 1407  
 1408  PROCEDURE GoTop(ndx: DBIndex);
 1409  VAR nextnodeptr: LONGINT;
 1410      level: CARDINAL;
 1411  BEGIN
 1412    IF   OpenIndex(ndx)=FALSE
 1413    THEN
 1414      WARN('Error opening Index in GoTop');
 1415    END;
 1416    EnterLock(ndx);
 1417    level := 0;
 1418    ReadIntoArray(ndx, ndx^.Header.rootptr, level);
 1419    Move(ADR(ndx^.posarray[level].buffer^.node[4]), ADR(nextnodeptr), 4);
 1420      (* all searches commence with the root *)
 1421      ndx^.posarray[level].keynum := FirstKey;
 1422    WHILE nextnodeptr#VAL(LONGINT,0) DO
 1423      INC(level);
 1424      ReadIntoArray(ndx, nextnodeptr, level);
 1425      ndx^.posarray[level].keynum := FirstKey;
 1426      Move(ADR(ndx^.posarray[level].buffer^.node[4]), ADR(nextnodeptr), 4);
 1427    END;
 1428    ndx^.currentkey:=GetKeyPtr(ndx^.posarray[level].buffer^.node, ndx, FirstKey);
 1429    ndx^.depth:=level;
 1430    ExitLock(ndx);
 1431  END GoTop;
 1432  
 1433  PROCEDURE GoBottom( ndx: DBIndex);
 1434  VAR
 1435      level: CARDINAL;
 1436  BEGIN
 1437    IF   OpenIndex(ndx)=FALSE
 1438    THEN
 1439      WARN('Error opening Index in GoBottom');
 1440    END;
 1441    EnterLock(ndx);
 1442    level := 0;
 1443    ReadIntoArray(ndx, ndx^.Header.rootptr, level);
 1444    ndx^.currentkey:=GetKeyPtr(ndx^.posarray[level].buffer^.node, ndx,
 1445       ORD(ndx^.posarray[level].buffer^.node[0]));
 1446      (* all searches commence with the root *)
 1447      ndx^.posarray[level].keynum := ORD(ndx^.posarray[level].buffer^.node[0]);
 1448    WHILE ndx^.currentkey^.lowernode # VAL(LONGINT,0) DO
 1449      INC(level);
 1450      ReadIntoArray(ndx, ndx^.currentkey^.lowernode, level);
 1451      ndx^.posarray[level].keynum := ORD(ndx^.posarray[level].buffer^.node[0]);
 1452      ndx^.currentkey:=GetKeyPtr(ndx^.posarray[level].buffer^.node, ndx,
 1453        ORD(ndx^.posarray[level].buffer^.node[0]));
 1454    END;
 1455    ndx^.posarray[level].keynum := ORD(ndx^.posarray[level].buffer^.node[0])-1;
 1456    ndx^.currentkey:=GetKeyPtr(ndx^.posarray[level].buffer^.node, ndx,
 1457        ORD(ndx^.posarray[level].buffer^.node[0])-1 );
 1458    ndx^.depth:=level;
 1459    ExitLock(ndx);
 1460  END GoBottom;
 1461  
 1462  
 1463  PROCEDURE AddToUpdateList( alias: DBFile;  ndx:
 1464        DBIndex);
 1465  BEGIN
 1466    ndx^.UpdateList:=IndexList(alias);
 1467    SetIndexList(alias,ndx);
 1468  
 1469  END AddToUpdateList;
 1470  
 1471  
 1472  PROCEDURE UpdateDBIndxes(alias:DBFile);
 1473  VAR
 1474    ndx:DBIndex;
 1475  
 1476    PROCEDURE Update ;
 1477    VAR
 1478      NewKey,OldKey:ARRAY[0..MaxField-1] OF CHAR;
 1479      found:BOOLEAN;
 1480      num:LONGINT;
 1481  
 1482      PROCEDURE KeyLocatedC():BOOLEAN ;
 1483        VAR
 1484        found:BOOLEAN;
 1485      BEGIN
 1486          FindPositionCh(ndx,OldKey,found);
 1487          LOOP
 1488            IF NOT Equal(OldKey,ndx^.currentkey^.value)
 1489            THEN
 1490              RETURN FALSE;
 1491            END;
 1492            IF (Record(alias) = ndx^.currentkey^.recordnum)
 1493            THEN
 1494              RETURN TRUE;
 1495            END;
 1496            IF NOT NextRecord(ndx,num)
 1497            THEN
 1498              RETURN FALSE;
 1499            END;
 1500          END;
 1501       END KeyLocatedC ;
 1502  
 1503      PROCEDURE KeyLocatedN():BOOLEAN ;
 1504        VAR
 1505        found:BOOLEAN;
 1506        key:Real8;
 1507      BEGIN
 1508          IF NOT StrToReal(OldKey, 0,key) THEN key:=0.0 END;
 1509          FindPositionN(ndx,OldKey,found);
 1510          LOOP
 1511            IF ndx^.numkey^.key # key
 1512            THEN
 1513              RETURN FALSE;
 1514            END;
 1515            IF (Record(alias) = ndx^.currentkey^.recordnum)
 1516            THEN
 1517              RETURN TRUE;
 1518            END;
 1519            IF NOT NextRecord(ndx,num)
 1520            THEN
 1521              RETURN FALSE;
 1522            END;
 1523          END;
 1524      END KeyLocatedN ;
 1525  
 1526    BEGIN
 1527      IF NOT Appending(alias)
 1528      THEN
 1529        SetRecordMode(alias,ModBase3.Buffer);
 1530        ndx^.KeyProc(alias,ndx,OldKey);
 1531        SetRecordMode(alias,ModBase3.CurrentRec);
 1532        ndx^.KeyProc(alias,ndx,NewKey);
 1533  (* * * * * * * * *  Changed by ed - delete index if deleting record* * * *)
 1534        IF ndx^.includedeleted OR NOT Deleted(alias)
 1535          THEN IF Equal(OldKey,NewKey)
 1536            THEN
 1537              RETURN
 1538  	  END;
 1539        END;
 1540        IF Record(alias) # ndx^.currentkey^.recordnum
 1541        THEN
 1542          (* find and delete old key if exists *)
 1543          IF ndx^.Header.NumType
 1544          THEN
 1545            found:=KeyLocatedN();
 1546          ELSE
 1547            found:=KeyLocatedC();
 1548          END;
 1549        ELSE
 1550          found :=TRUE;
 1551        END;
 1552        IF found
 1553        THEN
 1554          DeleteCurrentEntry(ndx);
 1555        ELSE
 1556          found:=FALSE; (* debugger trap *)
 1557        END;
 1558      END;
 1559  (* * * * * * * * Changed by Ed - same as above ** ** * * * *)
 1560      IF ndx^.includedeleted OR NOT Deleted(alias)
 1561        THEN
 1562          AddRecord(alias,ndx);
 1563        END;	
 1564    END Update;
 1565  
 1566  BEGIN
 1567    (* Nul Value of IndexList should be checked in Modbase *)
 1568    ndx:=IndexList(alias);
 1569    WHILE ndx#NIL  DO
 1570      IF   OpenIndex(ndx)=FALSE
 1571      THEN
 1572        WARN('Error opening Index in UpdateDBIndxes');
 1573      END;
 1574      EnterLock(ndx);
 1575      Update;
 1576      ExitLock(ndx);
 1577      ndx:=ndx^.UpdateList;
 1578    END (* while *);
 1579  END UpdateDBIndxes;
 1580  
 1581  PROCEDURE UpdateUnique( alias: DBFile; ndx: DBIndex):BOOLEAN;
 1582  VAR
 1583      NewKey,OldKey:ARRAY[0..MaxField-1] OF CHAR;
 1584      found:BOOLEAN;
 1585  
 1586  BEGIN
 1587      IF   OpenIndex(ndx)=FALSE
 1588      THEN
 1589        WARN('Error opening Index in UpdateUnique');
 1590      END;
 1591      EnterLock(ndx);
 1592      SetRecordMode(alias,ModBase3.CurrentRec);
 1593      ndx^.KeyProc(alias,ndx,NewKey);
 1594      IF NOT Appending(alias)
 1595      THEN
 1596        SetRecordMode(alias,ModBase3.Buffer);
 1597        ndx^.KeyProc(alias,ndx,OldKey);
 1598        SetRecordMode(alias,ModBase3.CurrentRec);
 1599        IF Equal(OldKey,NewKey)
 1600        THEN
 1601          ExitLock(ndx);
 1602          RETURN TRUE;
 1603        END;
 1604      END;
 1605      IF ndx^.Header.NumType
 1606      THEN
 1607        FindPositionN(ndx,NewKey,found);
 1608      ELSE
 1609        FindPositionCh(ndx,NewKey,found);
 1610      END;
 1611      ExitLock(ndx);
 1612      RETURN NOT found;
 1613  END UpdateUnique;
 1614  
 1615  
 1616  PROCEDURE SetSafetyOn( ndx: DBIndex);
 1617  BEGIN
 1618    UpdateIndex(ndx);
 1619    ndx^.Safety:=TRUE;
 1620  END SetSafetyOn;
 1621  
 1622  
 1623  PROCEDURE SetSafetyOff( ndx: DBIndex);
 1624  BEGIN
 1625    ndx^.Safety:=FALSE;
 1626  
 1627  END SetSafetyOff;
 1628  
 1629  PROCEDURE SetIndexBuffers( ndx: DBIndex;Buffers:CARDINAL);
 1630  VAR
 1631    buffer:IndexBuffer;
 1632  BEGIN
 1633    WITH ndx^ DO
 1634      buffsize := Max(Buffers,depth+6);
 1635      buffer:=last;
 1636      WHILE buffsize<currsize DO
 1637        WHILE buffer^.Lock DO
 1638          buffer:=buffer^.prev;
 1639        END;
 1640        IF buffer^.NeedToWrite
 1641        THEN
 1642          WriteNode(ndx,buffer^.number,buffer^.node);
 1643        END;
 1644        RemoveBuffer(ndx,buffer);
 1645        RemoveFromTable(ndx,buffer);
 1646        DosDealloc(buffer,SIZE(buffer^));
 1647      END;
 1648    END;
 1649  END SetIndexBuffers;
 1650  
 1651  
 1652  PROCEDURE DisposeIndex(VAR ndx: DBIndex);
 1653  BEGIN
 1654    CloseIndex(ndx);
 1655    DosDealloc(ndx,SIZE(ndx^));
 1656    ndx := NIL;
 1657  END DisposeIndex;
 1658  
 1659  PROCEDURE CurrentKeyCh( ndx: DBIndex;VAR val:ARRAY OF CHAR);
 1660  BEGIN
 1661    Assign(ndx^.currentkey^.value,val);
 1662  END CurrentKeyCh;
 1663  
 1664  PROCEDURE CurrentKeyN( ndx: DBIndex):Real8;
 1665  BEGIN
 1666    RETURN ndx^.numkey^.key;
 1667  
 1668  END CurrentKeyN;
 1669  
 1670  
 1671  PROCEDURE CurrentRec( ndx: DBIndex):LONGINT;
 1672  BEGIN
 1673    RETURN ndx^.currentkey^.recordnum;
 1674  END CurrentRec;
 1675  
 1676  PROCEDURE NumKeyType( ndx: DBIndex):BOOLEAN;
 1677  BEGIN
 1678    RETURN ndx^.Header.NumType;
 1679  END NumKeyType;
 1680  
 1681  PROCEDURE KeyLength( ndx: DBIndex):CARDINAL;
 1682  BEGIN
 1683    RETURN ndx^.Header.keylength;
 1684  END KeyLength;
 1685  
 1686  PROCEDURE InitCompIndex(indexname: ARRAY OF CHAR; VAR
 1687        ndx: DBIndex; alias:DBFile;Key :KeyProcedure; buffersize: CARDINAL
 1688        ; safety,IncludeDeleted,exclusive:BOOLEAN);
 1689  VAR i:CARDINAL;
 1690  BEGIN
 1691    DosAlloc(ndx,SIZE(ndx^));
 1692    ndx^.alias:=alias;
 1693    WITH ndx^ DO
 1694      Init:=InitCode;
 1695      Assign(indexname,name);
 1696      Locked:=0;
 1697      includedeleted:=IncludeDeleted;
 1698      Exclusive:=exclusive OR Locks.ExclusiveOnly;
 1699      open:=FALSE;
 1700      depth:=0;
 1701      KeyProc:=Key ;
 1702      buffsize:=buffersize;
 1703      Safety:=safety;
 1704      first:=NIL;
 1705      last:=NIL;
 1706      currsize := 0;
 1707      UpdateList:=NIL;
 1708    END;
 1709  END InitCompIndex;
 1710  
 1711  PROCEDURE InitIndex(indexname: ARRAY OF CHAR; VAR
 1712        ndx: DBIndex; alias:DBFile; buffersize: CARDINAL;
 1713        safety, IncludeDeleted,exclusive:BOOLEAN);
 1714  BEGIN
 1715    InitCompIndex(indexname,ndx,alias,DefaultKeyProcedure,buffersize,safety,
 1716    IncludeDeleted,exclusive);
 1717  END InitIndex;
 1718  
 1719  
 1720  
 1721  
 1722  PROCEDURE OpenIndex( ndx: DBIndex):BOOLEAN;
 1723  
 1724  VAR
 1725    str:ARRAY[0..387] OF CHAR;
 1726    ActionTaken,
 1727    i,res:CARDINAL;
 1728    filemode:BITSET;
 1729  BEGIN
 1730    IF ndx = NIL
 1731      THEN
 1732        WARN('Unititalized ndx in OpenIndex');
 1733        RETURN FALSE;
 1734      END;
 1735    IF ndx^.Init=InitCode
 1736    THEN
 1737      IF ndx^.open
 1738      THEN
 1739        RETURN  TRUE;
 1740      END;
 1741    ELSE
 1742      WARN('Uninitalized ndx in OpenIndex');
 1743    END;
 1744    ndx^.open := FALSE;
 1745     (* Open if it does exist; fail if it doesn't *)
 1746    IF ndx^.Exclusive THEN
 1747       filemode:={1,4}
 1748     ELSE
 1749       filemode:={1,6} (* allow all *)
 1750     END;
 1751     res := FAPI.DOSOPEN( ADR(ndx^.name),
 1752        ADR(ndx^.f), ADR(ActionTaken), VAL(LONGINT,0), FAPI.FILE_NORMAL,
 1753       CARDINAL( {0}), CARDINAL(filemode), VAL(LONGINT,0) );
 1754  
 1755    IF res # StringIO.NoError THEN
 1756      RETURN FALSE;
 1757    ELSE
 1758      IF Locks.NoLocking(ndx^.f) THEN ndx^.Exclusive:=TRUE END;
 1759      InitPosarray(ndx);
 1760      EnterLock(ndx);
 1761      IF HandleIO.BlockRead(ndx^.f,ADR(ndx^.Header),SIZE(ndx^.Header))#
 1762         StringIO.NoError
 1763      THEN
 1764        ExitLock(ndx);
 1765        StringIO.PrintMessage(HandleIO.CloseHandle(ndx^.f));
 1766        RETURN FALSE;
 1767      END;
 1768      WITH ndx^ DO
 1769        FOR i:=0 TO (Bins-1) DO
 1770          Hash[i]:=NIL;
 1771        END;
 1772        Assign(Header.KeyExpression,str);
 1773        CrunchBlanks(str);
 1774        CAPstr(str);
 1775        KeyNumber:=PosOfField(ndx^.alias,str);
 1776        SetIndexBuffers(ndx,buffsize);
 1777        open := TRUE;
 1778      END;
 1779      GoTop(ndx);
 1780      ExitLock(ndx);
 1781    END; (* IF *)
 1782    RETURN TRUE;
 1783  END OpenIndex;
 1784  
 1785  
 1786  PROCEDURE NextRecord( ndx: DBIndex;
 1787                       VAR recno: LONGINT): BOOLEAN;
 1788  
 1789    PROCEDURE NextEntry(ndx: DBIndex; level: CARDINAL): BOOLEAN;
 1790  
 1791    VAR
 1792      anotherkey: BOOLEAN;
 1793      key:KeyPointer;
 1794      factor:CARDINAL;
 1795    BEGIN
 1796      key:=ADR(ndx^.currentkey);
 1797      LOOP
 1798        IF level=ndx^.depth   (* ok depth becuse all of loop is in same route*)
 1799        THEN
 1800          factor:=1;
 1801        ELSE
 1802          factor:=0;
 1803        END;
 1804        anotherkey := ndx^.posarray[level].keynum <
 1805           ( ORD(ndx^.posarray[level].buffer^.node[0]) - factor);
 1806        IF anotherkey THEN
 1807          (* there is another entry in the node *)
 1808          (* note that the first entry is 0, so the number of the last entry
 1809             is one less than the number of keys in the node *)
 1810          WITH ndx^.posarray[level] DO
 1811            INC(keynum);
 1812            key:=GetKeyPtr(buffer^.node, ndx, keynum);
 1813            EXIT;
 1814          END;
 1815        ELSE
 1816          IF level = 0 THEN
 1817            EXIT
 1818          ELSE
 1819            DEC(level)
 1820          END;
 1821        END;
 1822      END; (* LOOP *)
 1823      IF anotherkey THEN
 1824        LOOP
 1825          IF key^.lowernode#VAL(LONGINT,0) THEN (* node is not a leaf node *)
 1826            INC(level);
 1827            ReadIntoArray(ndx, key^.lowernode, level);
 1828            WITH ndx^.posarray[level] DO
 1829              keynum := FirstKey;
 1830              key:=GetKeyPtr(buffer^.node, ndx, FirstKey);
 1831            END;
 1832          ELSE
 1833            EXIT
 1834          END;
 1835        END; (* LOOP2 *)
 1836        ndx^.depth:=level;
 1837        ndx^.currentkey:=key;
 1838        RETURN TRUE;
 1839      ELSE
 1840        ndx^.depth:=level;
 1841        ndx^.currentkey:=key;
 1842        RETURN FALSE;
 1843      END;
 1844    END NextEntry;
 1845  
 1846  BEGIN
 1847    IF   OpenIndex(ndx)=FALSE
 1848    THEN
 1849      WARN('Error opening Index in NextRecord');
 1850    END;
 1851    EnterLock(ndx);
 1852    IF NextEntry(ndx, ndx^.depth) THEN
 1853      recno := ndx^.currentkey^.recordnum;
 1854      ExitLock(ndx);
 1855      RETURN TRUE
 1856    ELSE
 1857      ExitLock(ndx);
 1858      RETURN FALSE
 1859    END;
 1860  END NextRecord;
 1861  
 1862  
 1863  PROCEDURE PrevRecord( ndx: DBIndex;
 1864                       VAR recno: LONGINT): BOOLEAN;
 1865  
 1866    PROCEDURE PrevEntry( ndx: DBIndex; level: CARDINAL): BOOLEAN;
 1867  
 1868    VAR anotherkey: BOOLEAN;
 1869        lastkey: CARDINAL;
 1870        key:KeyPointer;
 1871    BEGIN
 1872      key:=ADR(ndx^.currentkey);
 1873      LOOP
 1874        anotherkey := ndx^.posarray[level].keynum > 0;
 1875        IF anotherkey THEN
 1876          (* there is another entry in the node *)
 1877          (* note that the first entry is 0, so the number of the last entry
 1878             is one less than the number of keys in the node *)
 1879          WITH ndx^.posarray[level] DO
 1880            DEC(keynum);
 1881            key:=GetKeyPtr(buffer^.node, ndx, keynum);
 1882          END;
 1883          EXIT;
 1884        ELSE
 1885          IF level = 0 THEN
 1886            EXIT
 1887          ELSE
 1888            DEC(level)
 1889          END;
 1890        END;
 1891      END; (* LOOP *)
 1892      IF anotherkey THEN
 1893        LOOP
 1894          IF key^.lowernode#VAL(LONGINT,0) THEN (* node is not a leaf node *)
 1895            INC(level);
 1896            ReadIntoArray(ndx, key^.lowernode, level);
 1897            WITH ndx^.posarray[level] DO
 1898              lastkey := ORD(buffer^.node[0]);
 1899              keynum := lastkey;
 1900              key:=GetKeyPtr(buffer^.node, ndx, lastkey);
 1901              IF key^.lowernode=VAL(LONGINT,0)
 1902              THEN  (* backup one*)
 1903                DEC(lastkey);
 1904                keynum := lastkey;
 1905                key:=GetKeyPtr(buffer^.node, ndx, lastkey);
 1906              END;
 1907            END;
 1908          ELSE
 1909            EXIT
 1910          END;
 1911        END; (* LOOP2 *)
 1912        ndx^.depth:=level;
 1913        ndx^.currentkey:=key;
 1914        RETURN TRUE;
 1915      ELSE
 1916        ndx^.depth:=level;
 1917        ndx^.currentkey:=key;
 1918          RETURN FALSE;
 1919      END;
 1920    END PrevEntry;
 1921  BEGIN
 1922    IF   OpenIndex(ndx)=FALSE
 1923    THEN
 1924      WARN('Error opening Index in PrevRecord');
 1925    END;
 1926    EnterLock(ndx);
 1927    IF PrevEntry(ndx, ndx^.depth) THEN
 1928      recno := ndx^.currentkey^.recordnum;
 1929      ExitLock(ndx);
 1930      RETURN TRUE
 1931    ELSE
 1932      ExitLock(ndx);
 1933      RETURN FALSE
 1934    END;
 1935  END PrevRecord;
 1936  
 1937  PROCEDURE UpdateIndex( ndx :DBIndex);
 1938  
 1939  BEGIN
 1940    IF ndx^.open
 1941    THEN
 1942      EnterLock(ndx);
 1943      UpdateIndexHeader(ndx);
 1944      HandleIO.UpdateDisk(ndx^.f);
 1945      ExitLock(ndx);
 1946    END;
 1947  END UpdateIndex;
 1948  
 1949  PROCEDURE CloseIndex( ndx: DBIndex);
 1950  VAR
 1951    buffer:IndexBuffer;
 1952    FileError: StringIO.ErrorMessage;
 1953  BEGIN
 1954    IF ndx = NIL
 1955      THEN
 1956        RETURN;
 1957      END;
 1958    IF NOT ndx^.open
 1959    THEN
 1960      RETURN;
 1961    END;
 1962    IF ndx^.Exclusive  AND NOT ndx^.Safety
 1963    THEN
 1964      UpdateIndexHeader( ndx );
 1965    END;
 1966    FileError := HandleIO.CloseHandle(ndx^.f);
 1967    ndx^.open := FALSE;
 1968    WHILE ndx^.currsize#0 DO
 1969      buffer:=ndx^.last;
 1970      RemoveBuffer(ndx,buffer);
 1971      DosDealloc(buffer,SIZE(buffer^));
 1972    END;
 1973  
 1974  END CloseIndex;
 1975  
 1976  (* file locking procedures start here *)
 1977  PROCEDURE EnterLock( ndx:DBIndex);
 1978  VAR
 1979    realkey:Real8;
 1980    strkey:ARRAY[0..127] OF CHAR;
 1981    buffer:IndexBuffer;
 1982    ok,found:BOOLEAN;
 1983    i,
 1984    code,
 1985    Old :CARDINAL;
 1986    key,OldRecord:LONGINT;
 1987  BEGIN
 1988    (* lock file if needed *)
 1989    INC(ndx^.Locked);
 1990    IF (ndx^.Locked>1) OR ndx^.Exclusive THEN RETURN END;
 1991    (* read Header*)
 1992    StringIO.PrintMessage(Locks.LockFileRetry(ndx^.f,100,ndx^.name));
 1993    ndx^.Changed:=FALSE;
 1994    IF ndx^.open=FALSE THEN RETURN END;(* this should only be in open index *)
 1995    Old:=ndx^.Header.Flag;
 1996    ReadHeader(ndx);
 1997    IF Old=ndx^.Header.Flag THEN RETURN END;
 1998    OldRecord:=ndx^.currentkey^.recordnum;
 1999    IF ndx^.Header.NumType
 2000    THEN
 2001      realkey:=ndx^.numkey^.key;
 2002    ELSE
 2003      Assign(ndx^.currentkey^.value,strkey);
 2004    END;
 2005    (* purge buffers*)
 2006    WHILE ndx^.currsize#0 DO
 2007      buffer:=ndx^.last; (* it is forbidden here to have unwritten data *)
 2008      IF buffer^.NeedToWrite THEN (* not needed when debugged *)
 2009        WARN('buffer not writen in EnterLock');
 2010      END;
 2011      RemoveBuffer(ndx,buffer);
 2012      RemoveFromTable(ndx,buffer);
 2013      DosDealloc(buffer,SIZE(buffer^));
 2014    END;
 2015    FOR i:= 0 TO ndx^.depth DO
 2016      ndx^.posarray[i].buffer:=NIL;
 2017    END;
 2018    IF ndx^.Header.NumType
 2019    THEN
 2020      FindPositionR(ndx,realkey,found);
 2021    ELSE
 2022      FindPositionCh(ndx,strkey,found);
 2023    END;
 2024    IF NOT found
 2025    THEN RETURN (* key must have been removed *)
 2026    END;
 2027    REPEAT
 2028      IF OldRecord=ndx^.currentkey^.recordnum
 2029      THEN RETURN END; (* we got it*)
 2030      found:=NextRecord(ndx,key);
 2031      IF ndx^.Header.NumType
 2032      THEN
 2033         ok:=(realkey=ndx^.numkey^.key);
 2034      ELSE
 2035        ok:=Equal(ndx^.currentkey^.value,strkey);
 2036      END;
 2037    UNTIL NOT found OR NOT ok;
 2038    found:=PrevRecord(ndx,key); (* goback one*)
 2039  END EnterLock;
 2040  
 2041  PROCEDURE ExitLock( ndx:DBIndex);
 2042  VAR
 2043    code:CARDINAL;
 2044  BEGIN
 2045    DEC(ndx^.Locked);
 2046    (* If No change  or exclusive *)
 2047    IF ndx^.Exclusive OR ( ndx^.Locked#0)  THEN RETURN END;
 2048    IF  ndx^.Changed
 2049    THEN
 2050      INC(ndx^.Header.Flag); (* indicate change *)
 2051      WriteHeader(ndx); (* write header *)
 2052    END; (* if ndx^ changed *)
 2053    code:=Locks.UnLockFile(ndx^.f);
 2054    IF code#0 THEN WARN('Lock error in ExitLock') END;
 2055  END ExitLock;
 2056  
 2057  BEGIN;
 2058    UpDateIndexes:=UpdateDBIndxes;
 2059  
 2060  END DBIndxes.
 2061  

   36 errors