home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / modula2 / library / dbf_file / buildndx.mod < prev    next >
Text File  |  1991-04-17  |  61KB  |  1,216 lines
  1. (*# data( stack_size => C000H ) *)
  2.  
  3. IMPLEMENTATION MODULE BuildNDX;
  4.  
  5. (**********************************************************************)
  6. (* Copyright 1990,1991 by David Albert                                *)
  7. (**********************************************************************)
  8. (* This module exports procedures and data to allow Modula-2 users to *)
  9. (* quickly and easily create complex index files compatible with      *)
  10. (* dBase III, III+, and IV index files.                               *)
  11. (* Complete documentation for this module can be found in DBF.DOC     *)
  12. (**********************************************************************)
  13. (* Modification History                                               *)
  14. (*    3/26/91 by DAA removed dependencies on non-standard libraries   *)
  15. (**********************************************************************)
  16.  
  17. IMPORT FIO;
  18. FROM IO      IMPORT KeyPressed, RdKey, WrChar, WrStr, WrLn, WrCard;
  19. FROM Lib     IMPORT Delay, Dos, Move, Fill, HashString;
  20. FROM Storage IMPORT ALLOCATE, DEALLOCATE, Available;
  21. FROM Str     IMPORT Append, Caps, Compare, Copy, Length, Pos, Slice;
  22. FROM SYSTEM  IMPORT Registers;
  23. FROM Window  IMPORT WinDef, WinType, Open, Close, Color, DoubleFrame;
  24.  
  25. CONST
  26.     MaxRecLen = 4000;                   (* Max dBase record length          *)
  27.     MaxFields = 200;                    (* Max dBase fields per record      *)
  28.     MaxKeyLen = 100;                    (* Max dBase key field length       *)
  29.     PageSize  = 512;                    (* dBase NDX index page size        *)
  30.  
  31. TYPE
  32.     HashPtr  = POINTER TO HashType;
  33.     HashType = RECORD
  34.                  Name    : ARRAY[0..10] OF CHAR;
  35.                  Field   : CARDINAL;
  36.                  Next    : HashPtr;
  37.                END; (* HashType *)
  38.     HashTable= ARRAY[0..MaxFields] OF HashPtr;
  39.  
  40.     DBFHeaderType = RECORD                      (* DBF file header          *)
  41.        HasMemo     : SHORTCARD;
  42.        LastUpdate  : ARRAY[0..2] OF CHAR;
  43.        NumRecs     : LONGCARD;                  (* Total recs in DBF        *)
  44.        HeadLen     : CARDINAL;                  (* DBF File header len      *)
  45.        RecLen      : CARDINAL;                  (* Data record length       *)
  46.        Reserved1   : ARRAY[0..1] OF CHAR;       (* Reserved for future use. *)
  47.        Incomplete  : SHORTCARD;                 (* Incomplete transctn flag *)
  48.        Encrypted   : SHORTCARD;                 (* Encrypted file flag      *)
  49.        Reserved2   : ARRAY[0..11] OF CHAR;      (* Reserved for Network use *)
  50.        HasMDX      : SHORTCARD;                 (* Associated MDX flag      *)
  51.        Reserved3   : ARRAY[0..2] OF CHAR;       (* Reserved for future use. *)
  52.     END;
  53.     DBFFieldType = RECORD
  54.        Name        : ARRAY[0..10] OF CHAR;
  55.        Type        : CHAR;
  56.        Reserved1   : ARRAY[0..3] OF CHAR;
  57.        Len         : SHORTCARD;
  58.        Dec         : SHORTCARD;
  59.        Ofs         : CARDINAL;                  (* Actually Reserved     *)
  60.        WorkAreaID  : SHORTCARD;
  61.        Reserved3   : ARRAY[0..10] OF CHAR;
  62.     END; (* FieldType *)
  63.     DBFFieldArray = ARRAY [1..200] OF DBFFieldType;
  64.     DBFRecType = ARRAY [0..MaxRecLen] OF CHAR;
  65.     DBFType  = RECORD
  66.        Handle      : CARDINAL;
  67.        Open        : BOOLEAN;
  68.        RecPtr      : POINTER TO DBFRecType;
  69.        Key         : ARRAY [0..MaxKeyLen-1] OF CHAR;
  70.        HashTable   : HashTable;
  71.        Hdr         : DBFHeaderType;
  72.        NumFields   : CARDINAL;
  73.        Fields      : POINTER TO DBFFieldArray;
  74.     END;
  75.  
  76.     NDXPageType = RECORD
  77.        InPage      : CARDINAL;
  78.        Dummy       : CARDINAL;
  79.        Keys        : ARRAY [0..609] OF CHAR;
  80.     END;
  81.     NDXKeyType  = RECORD
  82.        PPtr, RPtr  : LONGCARD;
  83.        Key         : ARRAY [0..99] OF CHAR;
  84.     END;
  85.     NDXType = RECORD
  86.        Handle      : CARDINAL;
  87.        Open        : BOOLEAN;
  88.        (* NDX Header *)
  89.        Root        : LONGCARD;
  90.        NextFree    : LONGCARD;
  91.        Dummy1      : LONGCARD;            (* Unused                   *)
  92.        KeyLen      : CARDINAL;            (* Length of key field      *)
  93.        KeysPerPage : CARDINAL;            (* # Keys per index page    *)
  94.        Numeric     : CARDINAL;            (* 1 = Numeric or Date      *)
  95.        KeySize     : CARDINAL;            (* Key + Pointers size      *)
  96.        Dummy2      : CARDINAL;
  97.        Unique      : CARDINAL;            (* 1 = Unique               *)
  98.        KeyField    : ARRAY[0..99] OF CHAR;
  99.        Dummy3      : ARRAY[0..387] OF CHAR;
  100.     END; (* NDXRec *)
  101.  
  102.     BufArray   = ARRAY [0..32767] OF CHAR;
  103.  
  104.     KeyType = RECORD
  105.        FName : ARRAY [0..10] OF CHAR;
  106.        FNum  : CARDINAL;
  107.        FLen  : CARDINAL;
  108.        FType : CHAR;
  109.     END;
  110.  
  111. VAR ProcName     : ARRAY [0..29] OF CHAR;
  112.     DBF          : DBFType;
  113.     NDX          : NDXType;
  114.     KeyCount     : LONGCARD;
  115.     KeyArray     : ARRAY [1..10] OF KeyType;
  116.     NumKeys      : CARDINAL;
  117.     Retries      : CARDINAL;
  118.  
  119. PROCEDURE Power(X, Y : LONGCARD) : LONGCARD;
  120. VAR Result : LONGCARD;
  121. BEGIN
  122.   Result := 1;
  123.   WHILE Y > 0 DO
  124.      Result := Result * X;
  125.      DEC(Y);
  126.   END;
  127.   RETURN Result;
  128. END Power;
  129.  
  130. PROCEDURE GetExtErr() : CARDINAL;
  131. VAR Regs : Registers;
  132. BEGIN
  133.    Regs.AH := 59H;
  134.    Dos(Regs);
  135.    RETURN Regs.AX;
  136. END GetExtErr;
  137.  
  138. PROCEDURE SetRetries(Delay, Retries : CARDINAL);
  139. VAR Regs : Registers;
  140. BEGIN
  141.    Regs.AX := 440BH;
  142.    Regs.CX := Delay;
  143.    Regs.DX := Retries;
  144.    Dos(Regs);
  145. END SetRetries;
  146.  
  147. (****************************************************************************)
  148. (* Error handling routines                                                  *)
  149. (****************************************************************************)
  150.  
  151. PROCEDURE HandleError(Proc : ARRAY OF CHAR; Code : CARDINAL);
  152. VAR DialogWin : WinType;
  153.     Key       : CHAR;
  154.     Status    : CARDINAL;
  155. BEGIN
  156.    ErrCode := Code;
  157.    DosCode := GetExtErr();
  158.    IF ErrCheck = None THEN                      (* If no Internal err chking*)
  159.       RETURN;                                   (*    just return error code*)
  160.    END;                                         (*    for caller to handle  *)
  161.    DialogWin := Open(WinDef(15, 5, 65, 12, White, Black,
  162.       TRUE, TRUE, FALSE, TRUE, DoubleFrame, White, Black));
  163.    WrStr('Error:'); WrLn;
  164.    WrStr('  Procedure : '); WrStr(Proc); WrLn;
  165.    WrStr('  Message   : ');
  166.    CASE Code OF
  167.       ErrOpen   : WrStr('Unable to find/open file.');
  168.    |  ErrClose  : WrStr('Unable to close file.');
  169.    |  ErrRead   : WrStr('Unable to read page.');
  170.    |  ErrWrite  : WrStr('Unable to write page.');
  171.    |  ErrSeek   : WrStr('Unable to seek to page.');
  172.    |  ErrLock   : WrStr('Index/page locked by another user.');
  173.    |  ErrUnLock : WrStr('Unable to unlock index/page.');
  174.    |  ErrHandle : WrStr('Index file not open.');
  175.    |  ErrMemory : WrStr('Insufficient memory.');
  176.    |  ErrPageNo : WrStr('Invalid Page Number.');
  177.    |  ErrBadNDX : WrStr('Index file invalid or damaged.');
  178.    |  ErrLockedNDX : WrStr('Index file locked by another user.');
  179.    |  ErrBadField  : WrStr('Invalid field specified.');
  180.    ELSE WrStr('error cause unknown.');
  181.    END;
  182.    WrLn;
  183.    IF Code < ErrPageNo THEN
  184.       WrStr('  DOS Code  : '); WrCard(DosCode, 3); WrLn;
  185.    END;
  186.    WrLn;
  187.    IF ErrCheck = AskUser THEN
  188.       WrStr('Press any key to continue or Esc to abort. ');
  189.       Key := RdKey();
  190.       Close(DialogWin);
  191.       IF Key = 33C THEN HALT; END;
  192.    ELSIF ErrCheck = Halt THEN
  193.       WrStr('Press any key to quit. ');
  194.       Key := RdKey();
  195.       Close(DialogWin);
  196.       HALT;
  197.    END;
  198. END HandleError;
  199.  
  200. PROCEDURE OpenDBF(VAR DBF : DBFType; Name : ARRAY OF CHAR);
  201. VAR nRead       : CARDINAL;
  202.     FNum, FOfs  : CARDINAL;
  203.     DBFName     : ARRAY [0..79] OF CHAR;
  204.     TempIOcheck   : BOOLEAN;
  205.     TempShareMode : BITSET;
  206.  
  207.  
  208.   PROCEDURE InsertHash(Str : ARRAY OF CHAR; FieldNum : CARDINAL);
  209.   VAR ListPtr : HashPtr;
  210.       Hash    : CARDINAL;
  211.   BEGIN
  212.     Hash := HashString(Str, 128);
  213.     IF NOT Available(SIZE(HashType)) THEN
  214.        HandleError('InsertHash', ErrMemory);
  215.        RETURN;
  216.     END;
  217.     IF DBF.HashTable[Hash] = NIL
  218.       THEN NEW(DBF.HashTable[Hash]);
  219.            Copy(DBF.HashTable[Hash]^.Name, Str);
  220.            DBF.HashTable[Hash]^.Field  := FieldNum;
  221.            DBF.HashTable[Hash]^.Next   := NIL;
  222.       ELSE ListPtr := DBF.HashTable[Hash];
  223.            WHILE ListPtr^.Next # NIL DO
  224.              ListPtr := ListPtr^.Next;
  225.            END; (* While *)
  226.            NEW(ListPtr^.Next);
  227.            Copy(ListPtr^.Next^.Name, Str);
  228.            ListPtr^.Next^.Field := FieldNum;
  229.            ListPtr^.Next^.Next  := NIL;
  230.     END; (* If DBF.HashTable = Nil *)
  231.   END InsertHash;
  232.  
  233.   PROCEDURE HashFields();
  234.   VAR H : CARDINAL;
  235.   BEGIN
  236.     FOR H := 0 TO MaxFields DO                  (* Initialize hash table    *)
  237.       DBF.HashTable[H] := NIL;                  (*    for field names       *)
  238.     END;
  239.     FOR H := 1 TO DBF.NumFields DO              (* Hash field names so      *)
  240.       InsertHash (DBF.Fields^[H].Name, H);      (*    they can later be     *)
  241.       IF ErrCode > 0 THEN RETURN; END;          (*    accessed by name      *)
  242.     END;
  243.   END HashFields;
  244.  
  245.   PROCEDURE CalcFieldOfs;
  246.   VAR FOfs, FNum : CARDINAL;
  247.   BEGIN
  248.      FOfs := 1;
  249.      FOR FNum := 1 TO DBF.NumFields DO
  250.          WITH DBF.Fields^[FNum] DO
  251.             Ofs := FOfs;
  252.             INC(FOfs, VAL(CARDINAL, Len));
  253.          END;
  254.      END;
  255.   END CalcFieldOfs;
  256.  
  257. BEGIN
  258.    DBF.Open := FALSE;                           (* Init DBF file status     *)
  259.    Copy(DBFName, Name);                         (* Copy file name to var.   *)
  260.    Caps(DBFName);                               (* Conver to upper case.    *)
  261.    IF Pos(DBFName,'.DBF') > HIGH(DBFName) THEN  (* If no extension given,   *)
  262.       Append(DBFName, '.DBF');                  (*    append '.DBF'         *)
  263.    END;                                         (*    to file name.         *)
  264.    TempIOcheck   := FIO.IOcheck;                (* Save err checking status *)
  265.    FIO.IOcheck   := FALSE;                      (* Turn off err checking    *)
  266.    TempShareMode := FIO.ShareMode;              (* Save sharing status      *)
  267.    FIO.ShareMode := FIO.ShareDenyNone;          (* Set file mode to shared  *)
  268.    DBF.Handle    := FIO.Open(DBFName);          (* and open DBF (data) file *)
  269.    FIO.IOcheck   := TempIOcheck;                (* Restore err checking     *)
  270.    FIO.ShareMode := TempShareMode;              (* Restore sharing mode     *)
  271.    IF FIO.IOresult() # 0 THEN                   (* If unable to open it,    *)
  272.       HandleError('OpenDBF', ErrOpen);          (*    display error message *)
  273.       RETURN;                                   (*    and abort now.        *)
  274.    END;                                         (* Else, DBF opened OK      *)
  275.    Retries := 0;                                (* Init retry count and     *)
  276.    LOOP                                         (* Attempt to read header   *)
  277.       TempIOcheck   := FIO.IOcheck;             (* Save err checking status *)
  278.       FIO.IOcheck   := FALSE;                   (* Turn off err checking    *)
  279.       nRead:=FIO.RdBin(DBF.Handle,DBF.Hdr,SIZE(DBF.Hdr)); (* Read DBF hdr   *)
  280.       FIO.IOcheck   := TempIOcheck;             (* Restore err checking     *)
  281.       IF GetExtErr() = 33 THEN                  (*  If header was locked,   *)
  282.          Delay(100);                            (*    wait for 1/10 second  *)
  283.          INC(Retries);                          (*    bump retry count,     *)
  284.          IF (Retries > 100) THEN                (*    If 100 retries,       *)
  285.             HandleError('OpenDBF', ErrLock);    (*       display error msg  *)
  286.             IF ErrCheck = None THEN RETURN; END;(*       ErrCheck=None->abrt*)
  287.             Retries := 0;                       (*       reset retry count  *)
  288.          END;                                   (*       and continue.      *)
  289.       ELSIF FIO.IOresult() > 0 THEN             (* If error reading header, *)
  290.          TempIOcheck   := FIO.IOcheck;          (*    Save err chking status*)
  291.          FIO.IOcheck   := FALSE;                (*    Turn off err checking *)
  292.          FIO.Close(DBF.Handle);                 (*    Close the file        *)
  293.          FIO.IOcheck := TempIOcheck;            (*    restore err checking  *)
  294.          HandleError('OpenDBF', ErrRead);       (*    display error message *)
  295.          RETURN;                                (*    and abort procedure   *)
  296.       ELSE EXIT;                                (* Else, header read OK     *)
  297.       END;
  298.    END;
  299.    DBF.NumFields:=(DBF.Hdr.HeadLen-32) DIV 32;  (* Calc # of fields in file *)
  300.    IF NOT Available(DBF.NumFields*32) THEN      (* If not enough memory,    *)
  301.       TempIOcheck   := FIO.IOcheck;             (*    Save err chking status*)
  302.       FIO.IOcheck   := FALSE;                   (*    Turn off err checking *)
  303.       FIO.Close(DBF.Handle);                    (*    close the file,       *)
  304.       FIO.IOcheck := TempIOcheck;               (*    restore err checking  *)
  305.       HandleError('OpenDBF', ErrMemory);        (*    display error message *)
  306.       RETURN;                                   (*    and abort procedure   *)
  307.    END;
  308.    ALLOCATE(DBF.Fields, DBF.NumFields * 32);    (* Allocate mem for fields  *)
  309.    TempIOcheck   := FIO.IOcheck;                (* Save err checking status *)
  310.    FIO.IOcheck   := FALSE;                      (* Turn off err checking    *)
  311.    nRead := FIO.RdBin(DBF.Handle,DBF.Fields^,DBF.NumFields*32); (* Read 'em *)
  312.    FIO.IOcheck   := TempIOcheck;                (* Restore err checking     *)
  313.    IF (FIO.IOresult() # 0) OR                   (* If error reading fields, *)
  314.       (nRead # (DBF.NumFields*32)) THEN         (*    or incomplete read,   *)
  315.       TempIOcheck   := FIO.IOcheck;             (*    Save err chking status*)
  316.       FIO.IOcheck   := FALSE;                   (*    Turn off err checking *)
  317.       FIO.Close(DBF.Handle);                    (*    close file,           *)
  318.       FIO.IOcheck := TempIOcheck;               (*    restore err checking  *)
  319.       DEALLOCATE(DBF.Fields,DBF.NumFields*32);  (*    return mem allocated  *)
  320.       HandleError('OpenDBF', ErrRead);          (*    display error message *)
  321.       RETURN;                                   (*    and abort procedure.  *)
  322.    END;
  323.    CalcFieldOfs();                              (* Calc ofs of fields in rec*)
  324.    HashFields();                                (* Make field name hash tbl *)
  325.    DBF.Open := TRUE;                            (* Else data file is opened *)
  326.    ErrCode  := 0;
  327. END OpenDBF;
  328.  
  329. PROCEDURE CloseDBF;
  330. VAR TempIOcheck : BOOLEAN;
  331. BEGIN
  332.    IF DBF.Open THEN                             (* If data file is open,    *)
  333.       TempIOcheck := FIO.IOcheck;               (*    Save err check state  *)
  334.       FIO.IOcheck := FALSE;                     (*    Turn off err checking *)
  335.       FIO.Close(DBF.Handle);                    (*    Close data file       *)
  336.       FIO.IOcheck := TempIOcheck;               (*    Restore err checking  *)
  337.       DEALLOCATE(DBF.Fields, DBF.NumFields*32); (*    Release DBF memory    *)
  338.       DBF.Open := FALSE;                        (*    Set DBF closed flag   *)
  339.       IF FIO.IOresult() # 0                     (*    If error closing,     *)
  340.          THEN HandleError('CloseDBF', ErrClose);(*       set error code     *)
  341.          ELSE ErrCode := 0;                     (*    else set closed = OK  *)
  342.       END;
  343.    END;
  344. END CloseDBF;
  345.  
  346. PROCEDURE CreateNDX(VAR NDX  : NDXType;  Name   : ARRAY OF CHAR;
  347.                     KeyType  : CHAR;
  348.                     KeyLen   : CARDINAL;
  349.                     KeyExp : ARRAY OF CHAR);
  350. VAR NDXName : ARRAY [0..79] OF CHAR;
  351.     S, nWrit : CARDINAL;
  352.     TempIOcheck : BOOLEAN;
  353. BEGIN
  354.    NDX.Open := FALSE;                           (* Init NDX files status    *)
  355.    Copy(NDXName, Name);                         (* Copy file name to var.   *)
  356.    Caps(NDXName);                               (* Convert to upper case    *)
  357.    IF Pos(NDXName,'.NDX') > HIGH(NDXName) THEN  (* If no extension given,   *)
  358.       Append(NDXName, '.NDX');                  (*    append '.NDX'         *)
  359.    END;                                         (*    to file name.         *)
  360.    TempIOcheck := FIO.IOcheck;                  (* Save cur IOcheck status  *)
  361.    FIO.IOcheck := FALSE;                        (* Then turn off IO checking*)
  362.    NDX.Handle  := FIO.Create(NDXName);          (* Attempt to create file.  *)
  363.    FIO.IOcheck := TempIOcheck;                  (* Restore IO err checking  *)
  364.    IF FIO.IOresult() > 0 THEN                   (* If unable to create,     *)
  365.       HandleError('CreateNDX', ErrCreate);      (*    display error message *)
  366.       RETURN;                                   (*    and abort procedure   *)
  367.    END;
  368.    NDX.Root        := 1;                        (* Init root pointer        *)
  369.    NDX.NextFree    := 1;                        (* Init next free page ptr  *)
  370.    NDX.Dummy1      := 0;                        (* Init dummy pointer.      *)
  371.    IF KeyType = 'N'
  372.       THEN NDX.Numeric := 1;
  373.            NDX.KeyLen  := 8;
  374.       ELSE NDX.Numeric := 0;
  375.            NDX.KeyLen  := KeyLen;
  376.    END;
  377.    IF (NDX.KeyLen MOD 4) = 0 THEN               (* Calculate size of each   *)
  378.       NDX.KeySize:=KeyLen + 8;                  (*    NDX key including the *)
  379.    ELSE                                         (*    record and page ptrs  *)
  380.       NDX.KeySize := NDX.KeyLen+8+
  381.                      (4 - (NDX.KeyLen MOD 4));
  382.    END;
  383.    NDX.KeysPerPage := 508 DIV NDX.KeySize;      (* Calculate keys per page  *)
  384.    NDX.Dummy2      := 0;                        (* Init dummy pointer.      *)
  385.    NDX.Unique      := 0;                        (* Set duplicates allowed   *)
  386.    Copy(NDX.KeyField, KeyExp);                  (* Copy key exp to header   *)
  387.    Fill(ADR(NDX.Dummy3), SIZE(NDX.Dummy3), 0C); (* Fill balance of header   *)
  388.    TempIOcheck := FIO.IOcheck;                  (* Save cur IOcheck status  *)
  389.    FIO.IOcheck := FALSE;                        (* Then turn off IO checking*)
  390.    FIO.WrBin(NDX.Handle, NDX.Root, PageSize);   (* Write NDX header to disk *)
  391.    FIO.IOcheck := TempIOcheck;                  (* Restore IO err checking  *)
  392.    IF (FIO.IOresult() > 0) THEN                 (* If error writing header, *)
  393.       TempIOcheck := FIO.IOcheck;               (*    Save IOcheck status   *)
  394.       FIO.IOcheck := FALSE;                     (*    Turn off IO checking  *)
  395.       FIO.Close(NDX.Handle);                    (*    close index file,     *)
  396.       FIO.IOcheck := TempIOcheck;               (*    restore err checking  *)
  397.       HandleError('CreateNDX', ErrWrite);       (*    display error message *)
  398.       RETURN;                                   (*    and abort procedure   *)
  399.    END;
  400.    NDX.Open := TRUE;                            (* Else NDX created OK.     *)
  401.    ErrCode  := 0;                               (* Set result code = OK     *)
  402. END CreateNDX;
  403.  
  404. PROCEDURE CloseNDX;
  405. VAR FPtr  : LONGCARD;
  406.     nWrit : CARDINAL;
  407.     TempIOcheck : BOOLEAN;
  408. BEGIN
  409.    IF NDX.Open THEN                             (* If index is open         *)
  410.       TempIOcheck := FIO.IOcheck;               (* Save IOchecking state    *)
  411.       FIO.IOcheck := FALSE;                     (* Turn off err checking    *)
  412.       FIO.Seek(NDX.Handle, 0);                  (* Seek to index header.    *)
  413.       FIO.IOcheck := TempIOcheck;               (* Restore IO err chcking   *)
  414.       IF FIO.IOresult() # 0 THEN                (* If error seeking,        *)
  415.          HandleError('CloseNDX', ErrSeek);      (*    display error message *)
  416.          RETURN;                                (*    and abort procedure.  *)
  417.       END;                                      (* Else ptr at top of NDX   *)
  418.       TempIOcheck := FIO.IOcheck;               (* Save IOchecking state    *)
  419.       FIO.IOcheck := FALSE;                     (* Turn off err checking    *)
  420.       FIO.WrBin(NDX.Handle, NDX.Root, PageSize);(* Write NDX header         *)
  421.       FIO.IOcheck := TempIOcheck;               (* Restore IO err chcking   *)
  422.       IF FIO.IOresult() > 0 THEN                (* If error writing header, *)
  423.          HandleError('CloseNDX', ErrWrite);     (*    display error message *)
  424.          RETURN;                                (*    and abort procedure   *)
  425.       END;
  426.       TempIOcheck := FIO.IOcheck;               (* Save IOchecking state    *)
  427.       FIO.IOcheck := FALSE;                     (* Turn off err checking    *)
  428.       FIO.Close(NDX.Handle);                    (* Close index file.        *)
  429.       FIO.IOcheck := TempIOcheck;               (* Restore I/O err chcking  *)
  430.       IF FIO.IOresult() # 0 THEN                (* If error closing file,   *)
  431.          HandleError('CloseNDX', ErrClose);     (*    display error message *)
  432.          RETURN;                                (*    and abort procedure.  *)
  433.       END;                                      (* Else file closed OK      *)
  434.       ErrCode := 0;                             (* Set result code to OK    *)
  435.       NDX.Open := FALSE;                        (* Set NDX status to closed *)
  436.    END;
  437. END CloseNDX;
  438.  
  439. (****************************************************************************)
  440. (* EXTRACT KEYS from data file and store in index leaf pages.               *)
  441. (****************************************************************************)
  442.  
  443. PROCEDURE ExtractKeys;
  444. VAR FPtr         : LONGCARD;
  445.     RecNum       : LONGCARD;
  446.     TempIOcheck  : BOOLEAN;
  447.  
  448.     InBuf        : POINTER TO BufArray;
  449.     InBufLen     : CARDINAL;
  450.     InBufStart   : LONGCARD;
  451.     InBufEnd     : LONGCARD;
  452.     InBufRecs    : CARDINAL;
  453.     InBufPtr     : CARDINAL;
  454.  
  455.     OutBuf       : POINTER TO BufArray;
  456.     OutBufLen    : CARDINAL;
  457.     OutBufPages  : CARDINAL;
  458.     OutPNum      : LONGCARD;
  459.     OutPagePtr   : POINTER TO NDXPageType;
  460.     OutKeyPtr    : POINTER TO NDXKeyType;
  461.  
  462.    PROCEDURE MakeBuffers;
  463.    BEGIN
  464.       InBufLen := (32767 DIV DBF.Hdr.RecLen) * DBF.Hdr.RecLen;
  465.       OutBufLen:= (32767 DIV PageSize) * PageSize;
  466.       WHILE NOT Available(InBufLen) DO          (* If not enough memory for *)
  467.          InBufLen := InBufLen - DBF.Hdr.RecLen; (*    input buffer, shrink  *)
  468.       END;                                      (*    buffer till enough.   *)
  469.       IF InBufLen < DBF.Hdr.RecLen THEN         (* If input buffer is too   *)
  470.          HandleError('MakeBuffers', ErrMemory); (*    small to be useful,   *)
  471.          RETURN;                                (*    abort with error msg  *)
  472.       END;                                      (* Else with input buf size *)
  473.       ALLOCATE(InBuf, InBufLen);                (* Allocate input buffer    *)
  474.       WHILE NOT Available(OutBufLen) DO         (* If not enough memory for *)
  475.          OutBufLen := OutBufLen - PageSize;     (*    output buffer, keep   *)
  476.       END;                                      (*    reducing size till ok *)
  477.       IF OutBufLen < PageSize THEN              (* If no memory left,       *)
  478.          DEALLOCATE(InBuf, InBufLen);           (*   Return InBuffer memory *)
  479.          HandleError('MakeBuffers', ErrMemory); (*   Display error message  *)
  480.          RETURN;                                (*   and abort procedure.   *)
  481.       END;                                      (* Else, memory available   *)
  482.       ALLOCATE(OutBuf, OutBufLen);              (* Allocate output buffer   *)
  483.       ErrCode := 0;                             (* Return result = OK       *)
  484.    END MakeBuffers;
  485.  
  486.    PROCEDURE RemoveBuffers;
  487.    BEGIN
  488.       DEALLOCATE(InBuf, InBufLen);              (* De-allocate input and    *)
  489.       DEALLOCATE(OutBuf, OutBufLen);            (* output buffers           *)
  490.    END RemoveBuffers;
  491.  
  492.    PROCEDURE RewindDBF;
  493.    VAR TempIOcheck : BOOLEAN;
  494.    BEGIN
  495.       TempIOcheck := FIO.IOcheck;               (* Save I/O err checking    *)
  496.       FIO.IOcheck := FALSE;                     (* Turn off err checking    *)
  497.       FPtr := VAL(LONGCARD, DBF.Hdr.HeadLen);   (* Set file pointer to      *)
  498.       FIO.Seek(DBF.Handle, FPtr);               (* first record in DBF file *)
  499.       FIO.IOcheck := TempIOcheck;               (* Restore IO err checking  *)
  500.       IF FIO.IOresult() > 0 THEN                (* If error seeking,        *)
  501.          HandleError('RewindDBF', ErrSeek);     (*    display error message *)
  502.          RETURN;                                (*    and abort procedure   *)
  503.       END;
  504.       InBufStart := VAL(LONGCARD, 0);           (* Set buffer start record  *)
  505.       InBufEnd   := VAL(LONGCARD, 0);           (* Set buffer end record    *)
  506.       InBufRecs  := 0;                          (* Set records in buffer    *)
  507.       RecNum     := VAL(LONGCARD, 0);           (* Set current record number*)
  508.    END RewindDBF;
  509.  
  510.    PROCEDURE ClrNDXBuf;
  511.    BEGIN
  512.       KeyCount    := VAL(LONGCARD, 0);
  513.       OutBufPages := 0;
  514.       OutPagePtr  := ADR(OutBuf^[0]);
  515.       Fill(OutPagePtr, PageSize, 0C);
  516.       OutKeyPtr   := ADR(OutPagePtr^.Keys[0]);
  517.       OutPNum     := NDX.NextFree;
  518.    END ClrNDXBuf;
  519.  
  520.    PROCEDURE ReadDBFKey;
  521.    VAR nRead   : CARDINAL;
  522.        Retries : CARDINAL;
  523.        TempIOcheck : BOOLEAN;
  524.    BEGIN
  525.       REPEAT                                    (* Repeat                   *)
  526.          IF (InBufRecs = 0) OR                  (* If no records in buffer  *)
  527.             (InBufPtr >= InBufLen) THEN         (*    at end of cur buffer, *)
  528.             Retries := 0;                       (* Init retry count and     *)
  529.             LOOP                                (* Attempt to read buffer   *)
  530.                TempIOcheck := FIO.IOcheck;      (* Save IO checking state   *)
  531.                FIO.IOcheck := FALSE;            (* Then turn off IO chking  *)
  532.                nRead:=FIO.RdBin(DBF.Handle,InBuf^, InBufLen); (* Read buffer*)
  533.                FIO.IOcheck := TempIOcheck;      (* Restore IO err checking  *)
  534.                IF GetExtErr() = 33 THEN         (*  If buffer was locked,   *)
  535.                   Delay(100);                   (*    wait for 1/10 second  *)
  536.                   INC(Retries);                 (*    bump retry count,     *)
  537.                   IF (Retries > 100) THEN       (*    If 100 retries,       *)
  538.                      HandleError('ReadDBFKey', ErrLock); (* display err msg *)
  539.                      IF ErrCheck = None THEN RETURN; END;(* and abort proc  *)
  540.                      Retries := 0;                       (* reset retries   *)
  541.                   END;                                   (* and continue.   *)
  542.                ELSIF FIO.IOresult() > 0 THEN    (* If error reading header, *)
  543.                   FIO.IOcheck := FALSE;                  (* Turn off err chk*)
  544.                   FIO.Close(DBF.Handle);                 (* Close the file  *)
  545.                   FIO.IOcheck := TempIOcheck;            (* Restore Err chk *)
  546.                   HandleError('ReadDBFKey', ErrRead);    (* display err msg *)
  547.                   RETURN;                                (* and abort proc  *)
  548.                ELSE EXIT;                       (* Else, header read OK     *)
  549.                END;                                      (* so exit loop    *)
  550.             END;
  551.             InBufStart := InBufEnd + 1;               (* calc buf start rec *)
  552.             InBufRecs  := nRead DIV DBF.Hdr.RecLen;   (* calc recs in buf   *)
  553.             INC(InBufEnd,VAL(LONGCARD, InBufRecs));   (* calc buf end rec   *)
  554.             InBufPtr   := 0;                          (* reset cur buf pos  *)
  555.          END;
  556.          DBF.RecPtr := ADR(InBuf^[InBufPtr]);          (* Set ptr to record  *)
  557.          INC(InBufPtr, DBF.Hdr.RecLen);                (* Bump buf rec ptr   *)
  558.          INC(RecNum);                                  (* Bump record number *)
  559.       UNTIL Filter() OR (RecNum > DBF.Hdr.NumRecs); (* Until no more recs or *)
  560.       KeyExp(DBF.Key);                              (* Get key from record   *)
  561.       ErrCode := 0;                                 (* Set result code = OK  *)
  562.    END ReadDBFKey;
  563.  
  564.    PROCEDURE WriteNDXPage;
  565.    VAR nWrit : CARDINAL;
  566.        TempIOcheck : BOOLEAN;
  567.    BEGIN
  568.       INC(NDX.NextFree);                        (* Bump index free page ptr *)
  569.       INC(OutPNum);                             (* Bump current page number *)
  570.       INC(OutBufPages);                         (* Bump num pages in buffer *)
  571.       IF (OutBufPages*PageSize >= OutBufLen) OR (* If NDX buffer is full or *)
  572.          (RecNum >= DBF.Hdr.NumRecs) THEN       (*    last page in sub-idx, *)
  573.          TempIOcheck := FIO.IOcheck;            (*    save IO checking state*)
  574.          FIO.IOcheck := FALSE;                  (*    turn off IO checking  *)
  575.          FIO.WrBin(NDX.Handle, OutBuf^, (OutBufPages*PageSize)); (* Wr page *)
  576.          FIO.IOcheck := TempIOcheck;            (*    restore IO checking   *)
  577.          IF FIO.IOresult() > 0 THEN
  578.             HandleError('WriteNDXPage', ErrWrite);
  579.             RETURN;
  580.          END;
  581.          OutBufPages := 0;
  582.       END;
  583.       OutPagePtr := ADR(OutBuf^[(OutBufPages * PageSize)]);
  584.       Fill(OutPagePtr, PageSize, 0C);
  585.       ErrCode := 0;
  586.    END WriteNDXPage;
  587.  
  588.    PROCEDURE WriteNDXKey;
  589.    BEGIN
  590.       WITH OutPagePtr^ DO                       (* With current NDX page,   *)
  591.         IF (InPage >= NDX.KeysPerPage) THEN     (* If page is full          *)
  592.            WriteNDXPage;                        (*    write page to buffer  *)
  593.            IF ErrCode > 0 THEN RETURN; END;     (*    If error, abort now   *)
  594.         END;                                    (*    and setup new page    *)
  595.       END;
  596.       WITH OutPagePtr^ DO                       (* With current NDX page,   *)
  597.         OutKeyPtr:=ADR(Keys[InPage*NDX.KeySize]); (* Set ptr to current key *)
  598.         INC(InPage);                            (* Bump # of keys in page   *)
  599.       END;
  600.       WITH OutKeyPtr^ DO                        (* With current NDX key,    *)
  601.         RPtr := RecNum;                         (* Set record number        *)
  602.         Move(ADR(DBF.Key),ADR(Key),NDX.KeyLen); (* Copy key to index page   *)
  603.       END;
  604.       ErrCode := 0;
  605.    END WriteNDXKey;
  606.  
  607. BEGIN
  608.    MakeBuffers;                                 (* Create data & idx bufs   *)
  609.    IF ErrCode > 0 THEN RETURN; END;             (* If error, abort now.     *)
  610.    RewindDBF;                                   (* Go to top of data file   *)
  611.    IF ErrCode > 0 THEN                          (* If error reading DBF,    *)
  612.       RemoveBuffers;                            (*    release buffer memory *)
  613.       RETURN;                                   (*    and return to caller  *)
  614.    END;                                         (*    with error set.       *)
  615.    ClrNDXBuf;                                   (* Initialize index buffer  *)
  616.    LOOP                                         (* For each record in DBF,  *)
  617.       ReadDBFKey;                               (*   Get a record & key,    *)
  618.       IF ErrCode > 0 THEN EXIT; END;            (*   If error, exit loop.   *)
  619.       IF RecNum <= DBF.Hdr.NumRecs THEN         (*   If valid record found, *)
  620.          WriteNDXKey;                           (*      add key to index    *)
  621.          IF ErrCode > 0 THEN EXIT; END;         (*      if error, abort now *)
  622.          INC(KeyCount);                         (*      and bump key count  *)
  623.       ELSE                                      (*   Else end of records,   *)
  624.          IF (KeyCount = 0) OR                   (*      if empty file, or   *)
  625.             (OutPagePtr^.InPage > 0) THEN       (*      page not written,   *)
  626.             WriteNDXPage;                       (*         write last page  *)
  627.             IF ErrCode > 0 THEN EXIT; END;      (*         if error, abort  *)
  628.          END;                                   (*         to index.        *)
  629.          ErrCode := 0;                          (*      set result = OK     *)
  630.          EXIT;                                  (*      exit loop           *)
  631.       END;
  632.    END;                                         (* Continue for each record *)
  633.    RemoveBuffers;                               (* Remove data & idx bufs   *)
  634.    ErrCode := 0;                                (* Set result code = OK     *)
  635. END ExtractKeys;
  636.  
  637. (****************************************************************************)
  638. (* SORT KEYS in index leafs into alphabetical order.                        *)
  639. (****************************************************************************)
  640.  
  641. PROCEDURE SortKeys;
  642. TYPE
  643.     BufType = POINTER TO BufArray;
  644. VAR SKey, EKey   : LONGCARD;
  645.     SPage, EPage : LONGCARD;
  646.     ELeaf        : LONGCARD;
  647.     Buf          : ARRAY [1..10] OF BufType;
  648.     BPages       : ARRAY [1..10] OF CARDINAL;
  649.     BStart       : ARRAY [1..10] OF LONGCARD;
  650.     NBufs        : CARDINAL;
  651.     BufLen       : CARDINAL;
  652.     BufEnd       : LONGCARD;
  653.     PagesPerBuf  : CARDINAL;
  654.     KeysPerBuf   : CARDINAL;
  655.  
  656.    PROCEDURE MakeSortBuffers;
  657.    VAR BNum   : CARDINAL;
  658.        MaxBuf : CARDINAL;
  659.    BEGIN
  660.       BNum := 0;
  661.       BufLen := (32767 DIV PageSize)*PageSize;  (* Calculate max buffer len *)
  662.       WHILE NOT Available(BufLen) DO            (* If not enough memory,    *)
  663.          BufLen := BufLen - PageSize;           (*    reduce buffer size,   *)
  664.       END;                                      (*    and try again.        *)
  665.       IF BufLen < PageSize THEN                 (* If no memory available,  *)
  666.          HandleError('MakeSortBuffers', ErrMemory); (*display error message *)
  667.          RETURN;                                (*    and abort procedure.  *)
  668.       END;                                      (* Else with memory avail.  *)
  669.       NBufs := 0;                               (* Init number of buffers   *)
  670.       FOR BNum := 1 TO 10 DO                    (* For each buffer,         *)
  671.          IF Available(BufLen) THEN              (* If memory available,     *)
  672.             ALLOCATE(Buf[BNum], BufLen);        (*    allocate the buffer   *)
  673.             INC(NBufs);                         (*    and bump buffer count *)
  674.          END;
  675.          BStart[BNum] := 0;                     (* Init starting page number*)
  676.          BPages[BNum] := 0;                     (* Init pages in buffer     *)
  677.       END;
  678.       ErrCode := 0;
  679.    END MakeSortBuffers;
  680.  
  681.    PROCEDURE RemoveSortBuffers;
  682.    VAR BNum : CARDINAL;
  683.    BEGIN
  684.       FOR BNum := 1 TO NBufs DO
  685.           DEALLOCATE(Buf[BNum], BufLen);
  686.       END;
  687.    END RemoveSortBuffers;
  688.  
  689.    PROCEDURE GetSortKeyData;
  690.    BEGIN
  691.       SPage      := VAL(LONGCARD, 1);           (* Start with first page.   *)
  692.       EPage      := NDX.NextFree - 1;           (* Get ending page number.  *)
  693.       SKey       := 1;                          (* Calc. start key number   *)
  694.       EKey       := KeyCount;                   (* Calc. end key number     *)
  695.       PagesPerBuf:= BufLen DIV PageSize;        (* Calc. pages per buffer   *)
  696.       KeysPerBuf := PagesPerBuf*NDX.KeysPerPage;(* Calc. keys per buffer    *)
  697.    END GetSortKeyData;
  698.  
  699.    PROCEDURE LoadBuffers;
  700.    VAR FPtr      : LONGCARD;
  701.        nRead     : CARDINAL;
  702.        BNum      : CARDINAL;
  703.        CurPage   : LONGCARD;
  704.        TempIOcheck : BOOLEAN;
  705.    BEGIN
  706.       FPtr     := VAL(LONGCARD, PageSize);      (* Calc first page position *)
  707.       TempIOcheck := FIO.IOcheck;
  708.       FIO.IOcheck := FALSE;
  709.       FIO.Seek(NDX.Handle, FPtr);               (* Seek to first subidx page*)
  710.       FIO.IOcheck := TempIOcheck;               (* Restore err checking     *)
  711.       IF FIO.IOresult() > 0 THEN                (* If error seeking,        *)
  712.          HandleError('LoadBuffers', ErrSeek);
  713.          RETURN;
  714.       END;
  715.       CurPage := VAL(LONGCARD, 1);              (* Init current page number *)
  716.       BNum    := 0;                             (* Start with first buffer. *)
  717.       REPEAT                                    (* For each buffer,         *)
  718.         INC(BNum);                              (* Bump cur buf num.        *)
  719.         FIO.IOcheck := FALSE;                   (* Turn off err checking    *)
  720.         nRead := FIO.RdBin(NDX.Handle, Buf[BNum]^, BufLen); (* Load buffer  *)
  721.         FIO.IOcheck := TempIOcheck;             (* Restore err checking     *)
  722.         IF FIO.IOresult() > 0 THEN
  723.            HandleError('LoadBuffers', ErrRead);
  724.            RETURN;
  725.         END;
  726.         BPages[BNum] := nRead DIV PageSize;       (* Calc pages in buffer   *)
  727.         BStart[BNum] := CurPage;                  (* Calc start page num    *)
  728.         INC(CurPage, VAL(LONGCARD,BPages[BNum])); (* update start page      *)
  729.       UNTIL (nRead < BufLen) OR                 (* Cont till end of file or *)
  730.             (BNum  = NBufs) OR                  (*    buffers full, or      *)
  731.             (CurPage >= EPage);                 (*    last key in sub-idx.  *)
  732.       BufEnd := CurPage - 1;                    (* Calculate end page       *)
  733.       ErrCode := 0;                             (* Set result code = OK     *)
  734.    END LoadBuffers;
  735.  
  736.    PROCEDURE SaveBuffers;
  737.    VAR FPtr    : LONGCARD;
  738.        nWrit   : CARDINAL;
  739.        BufSize : CARDINAL;
  740.        BNum    : CARDINAL;
  741.        TempIOcheck : BOOLEAN;
  742.    BEGIN
  743.       TempIOcheck := FIO.IOcheck;
  744.       FIO.IOcheck := FALSE;
  745.       FPtr    := VAL(LONGCARD, PageSize);       (* Calc first page position *)
  746.       FIO.Seek(NDX.Handle, FPtr);               (* Seek to first page       *)
  747.       FIO.IOcheck := TempIOcheck;               (* Restore I/O err chking   *)
  748.       IF FIO.IOresult() > 0 THEN                (* If error seeking,        *)
  749.          HandleError('SaveBuffers', ErrSeek);   (*    display error message *)
  750.          RETURN;                                (*    and abort procedure.  *)
  751.       END;
  752.       BNum := 1;                                (* Starting with first buf  *)
  753.       WHILE (BPages[BNum]>0)AND(BNum<=NBufs) DO (* For each buf with data,  *)
  754.          BufSize := BPages[BNum] * PageSize;       (* calc size of data     *)
  755.          FIO.IOcheck := FALSE;                     (* Turn off err checking *)
  756.          FIO.WrBin(NDX.Handle,Buf[BNum]^,BufSize); (* write buf to disk     *)
  757.          FIO.IOcheck := TempIOcheck;               (* Restore err checking  *)
  758.          IF FIO.IOresult() > 0 THEN                (* if error writing,     *)
  759.             HandleError('SaveBuffers', ErrWrite);  (*    display error msg  *)
  760.             RETURN;                                (*    and abort procedure*)
  761.          END;
  762.          INC(BNum);                                  (* bump to next buffer *)
  763.       END;
  764.       ErrCode := 0;
  765.    END SaveBuffers;
  766.  
  767.    PROCEDURE GetKey(KeyNum  : LONGCARD;
  768.                     VAR Key : NDXKeyType);
  769.    VAR BNum        : CARDINAL;                  (* Buffer number            *)
  770.        PNum        : LONGCARD;                  (* Page number              *)
  771.        LKNum       : LONGCARD;                  (* Key number (long)        *)
  772.        KNum        : CARDINAL;                  (* Key number (short)       *)
  773.        BufPtr      : CARDINAL;                  (* Position of key in page  *)
  774.        KPtr        : POINTER TO NDXKeyType;     (* Pointer to key in page   *)
  775.        nRead       : CARDINAL;
  776.        FPtr        : LONGCARD;
  777.        TempIOcheck : BOOLEAN;
  778.    BEGIN
  779.      PNum  := 1 + ((KeyNum - 1) DIV             (* Calculate number of page *)
  780.               VAL(LONGCARD, NDX.KeysPerPage));  (*   which contains key.    *)
  781.      LKNum := (KeyNum - 1) MOD                  (* Calculate number of key  *)
  782.               VAL(LONGCARD, NDX.KeysPerPage);   (*   within the page        *)
  783.      KNum  := VAL(CARDINAL, LKNum);             (* Convert key to cardinal  *)
  784.      IF PNum <= VAL(LONGCARD, BufEnd) THEN      (* If the page is in buffer *)
  785.         BNum:=VAL(CARDINAL, (PNum - 1) DIV      (*    calc which buffer it  *)
  786.               VAL(LONGCARD, PagesPerBuf)) + 1;  (*    is in.                *)
  787.         PNum := PNum - BStart[BNum];            (*    Calc page in buf      *)
  788.         BufPtr := (VAL(CARDINAL,PNum)*PageSize) (*    calc position of page *)
  789.                 + 4 + (KNum * NDX.KeySize);     (*    and key in page.      *)
  790.         KPtr  := ADR(Buf[BNum]^[BufPtr]);       (*    Set pointer to key    *)
  791.         Move(KPtr, ADR(Key), NDX.KeySize);      (*    Copy to output key.   *)
  792.      ELSE                                       (* Else if page on disk,    *)
  793.         FPtr := (PNum * PageSize) + 4 +         (*    calc position of page *)
  794.          (LKNum * (VAL(LONGCARD, NDX.KeySize)));(*    and key within page   *)
  795.         TempIOcheck := FIO.IOcheck;
  796.         FIO.IOcheck := FALSE;
  797.         FIO.Seek(NDX.Handle, FPtr);             (*    Seek to key on disk   *)
  798.         FIO.IOcheck := TempIOcheck;
  799.         IF FIO.IOresult() > 0 THEN
  800.            HandleError('GetKey', ErrSeek);
  801.            RETURN;
  802.         END;
  803.         FIO.IOcheck := FALSE;
  804.         nRead := FIO.RdBin(NDX.Handle, Key, NDX.KeySize); (* read key       *)
  805.         FIO.IOcheck := TempIOcheck;
  806.         IF FIO.IOresult() > 0 THEN
  807.            HandleError('GetKey', ErrRead);
  808.            RETURN;
  809.         END;
  810.      END;                                       (*    from disk             *)
  811.      ErrCode := 0;
  812.    END GetKey;
  813.  
  814.    PROCEDURE PutKey(KeyNum  : LONGCARD;
  815.                     VAR Key : NDXKeyType);
  816.    VAR BNum        : CARDINAL;                  (* Buffer number            *)
  817.        PNum        : LONGCARD;                  (* Page number              *)
  818.        LKNum       : LONGCARD;                  (* Key number (long)        *)
  819.        KNum        : CARDINAL;                  (* Key number (short)       *)
  820.        BufPtr      : CARDINAL;                  (* Position of key in page  *)
  821.        KPtr        : POINTER TO NDXKeyType;     (* Pointer to key in page   *)
  822.        nWrit       : CARDINAL;
  823.        FPtr        : LONGCARD;
  824.        TempIOcheck : BOOLEAN;
  825.    BEGIN
  826.      PNum  := 1 + ((KeyNum - 1) DIV             (* Calculate number of page *)
  827.               VAL(LONGCARD, NDX.KeysPerPage));  (*   which contains key.    *)
  828.      LKNum := (KeyNum - 1) MOD                  (* Calculate number of key  *)
  829.               VAL(LONGCARD, NDX.KeysPerPage);   (*   within the page        *)
  830.      KNum  := VAL(CARDINAL, LKNum);             (* Convert key to cardinal  *)
  831.      IF PNum <= VAL(LONGCARD, BufEnd) THEN      (* If the page is in buffer *)
  832.         BNum:=VAL(CARDINAL, (PNum - 1) DIV      (*    calc which buffer it  *)
  833.               VAL(LONGCARD, PagesPerBuf)) + 1;  (*    is in.                *)
  834.         PNum := PNum - BStart[BNum];            (*    Calc page in buf      *)
  835.         BufPtr := (VAL(CARDINAL,PNum)*PageSize) (*    calc position of page *)
  836.                 + 4 + (KNum * NDX.KeySize);     (*    and key in page.      *)
  837.         KPtr  := ADR(Buf[BNum]^[BufPtr]);       (*    Set pointer to key    *)
  838.         Move(ADR(Key), KPtr, NDX.KeySize);      (*    Copy to output key.   *)
  839.      ELSE                                       (* Else if page on disk,    *)
  840.         FPtr := (PNum * PageSize) + 4 +         (*    calc position of page *)
  841.         (LKNum * (VAL(LONGCARD, NDX.KeySize))); (*    and key within page   *)
  842.         TempIOcheck := FIO.IOcheck;
  843.         FIO.IOcheck := FALSE;
  844.         FIO.Seek(NDX.Handle, FPtr);             (*    Seek to key on disk   *)
  845.         FIO.IOcheck := TempIOcheck;
  846.         IF FIO.IOresult() > 0 THEN
  847.            HandleError('PutKey', ErrSeek);
  848.            RETURN;
  849.         END;
  850.         FIO.IOcheck := FALSE;
  851.         FIO.WrBin(NDX.Handle, Key, NDX.KeySize);(* Read key from disk       *)
  852.         FIO.IOcheck := TempIOcheck;
  853.         IF FIO.IOresult() > 0 THEN
  854.            HandleError('PutKey', ErrWrite);
  855.            RETURN;
  856.         END;
  857.      END;                                       (*    from disk             *)
  858.      ErrCode := 0;
  859.    END PutKey;
  860.  
  861.    PROCEDURE SwapKeys(K1, K2 : LONGCARD);
  862.    VAR Key1,
  863.        Key2,
  864.        TempKey  : NDXKeyType;
  865.    BEGIN
  866.      GetKey(K1, Key1);
  867.      IF ErrCode > 0 THEN RETURN; END;
  868.      GetKey(K2, Key2);
  869.      IF ErrCode > 0 THEN RETURN; END;
  870.      TempKey := Key2;
  871.      PutKey(K2, Key1);
  872.      IF ErrCode > 0 THEN RETURN; END;
  873.      PutKey(K1, TempKey);
  874.      IF ErrCode > 0 THEN RETURN; END;
  875.    END SwapKeys;
  876.  
  877.    PROCEDURE CmpKey( K1, K2 :ARRAY OF CHAR) :INTEGER;
  878.    VAR A            :CARDINAL;
  879.        EndK1, EndK2 :BOOLEAN;
  880.        I1,I2        :INTEGER;
  881.    BEGIN
  882.        A := 0;
  883.        LOOP
  884.            EndK1 := (A > HIGH(K1)) OR (K1[A] = 0C) OR (A = NDX.KeyLen);
  885.            EndK2 := (A > HIGH(K2)) OR (K2[A] = 0C) OR (A = NDX.KeyLen);
  886.            IF (EndK1 OR EndK2) THEN EXIT END;
  887.            IF (K1[A] = K2[A]) THEN INC(A)
  888.              ELSIF K1[A] < K2[A] THEN RETURN(-1)
  889.                ELSE RETURN(1)
  890.            END;
  891.        END;
  892.        I1 := INTEGER(ORD(EndK1));
  893.        I2 := INTEGER(ORD(EndK2));
  894.        RETURN (I2-I1);
  895.    END CmpKey;
  896.  
  897.    PROCEDURE QS(Left, Right: LONGCARD);
  898.    VAR
  899.       M, L, R : LONGCARD;
  900.       MKey,
  901.       LKey,
  902.       RKey    : NDXKeyType;
  903.    BEGIN
  904.       L := Left;
  905.       R := Right;
  906.       M := (L+R) DIV 2;
  907.       GetKey(M, MKey);
  908.       IF ErrCode > 0 THEN RETURN; END;
  909.       REPEAT
  910.          GetKey(L, LKey);
  911.          IF ErrCode > 0 THEN RETURN; END;
  912.          WHILE (CmpKey(LKey.Key, MKey.Key) < 0) DO
  913.                INC(L);
  914.                GetKey(L, LKey);
  915.                IF ErrCode > 0 THEN RETURN; END;
  916.          END;
  917.          GetKey(R, RKey);
  918.          IF ErrCode > 0 THEN RETURN; END;
  919.          WHILE (CmpKey(MKey.Key, RKey.Key) < 0) DO
  920.                DEC(R);
  921.                GetKey(R, RKey);
  922.                IF ErrCode > 0 THEN RETURN; END;
  923.    END;
  924.         IF (L <= R) THEN
  925.             SwapKeys(L, R);
  926.             IF ErrCode > 0 THEN RETURN; END;
  927.             INC(L);
  928.             DEC(R);
  929.          END;
  930.       UNTIL (L > R);
  931.       IF Left < R THEN
  932.          QS(Left, R);
  933.          IF ErrCode > 0 THEN RETURN; END;
  934.       END;
  935.       IF L < Right THEN
  936.          QS(L, Right);
  937.          IF ErrCode > 0 THEN RETURN; END;
  938.       END;
  939.    END QS;
  940.  
  941. (****************************************************************************)
  942. (* BUILD TREE create node pages from sorted leaf pages.                     *)
  943. (****************************************************************************)
  944.  
  945.    PROCEDURE InitPage(VAR P : NDXPageType);
  946.    BEGIN
  947.       P.InPage := 0;
  948.       P.Dummy  := 0;
  949.       Fill(ADR(P.Keys), SIZE(P.Keys), 0C);
  950.    END InitPage;
  951.  
  952.    PROCEDURE GetPage(PNum : LONGCARD;
  953.                      VAR P : NDXPageType);
  954.    VAR FPtr : LONGCARD;
  955.        nRead: CARDINAL;
  956.        TempIOcheck : BOOLEAN;
  957.    BEGIN
  958.       TempIOcheck := FIO.IOcheck;               (* Save cur I/O check state *)
  959.       FIO.IOcheck := FALSE;                     (* Turn off I/O err cheking *)
  960.       FPtr := PNum * PageSize;
  961.       FIO.Seek(NDX.Handle, FPtr);
  962.       FIO.IOcheck := TempIOcheck;               (* Restore I/O err checking *)
  963.       IF FIO.IOresult() > 0 THEN                (* If error seeking,        *)
  964.          HandleError('GetPage', ErrSeek);       (*    Display error message *)
  965.          RETURN;                                (*    and abort procedure.  *)
  966.       END;                                      (* Else, seek was OK.       *)
  967.       FIO.IOcheck := FALSE;
  968.       nRead := FIO.RdBin(NDX.Handle, P, PageSize);
  969.       FIO.IOcheck := TempIOcheck;
  970.       IF (FIO.IOresult() > 0) OR (nRead # PageSize) THEN
  971.          HandleError('GetPage', ErrRead);
  972.          RETURN;
  973.       END;
  974.       ErrCode := 0;
  975.    END GetPage;
  976.  
  977.    PROCEDURE PutPage(PNum : LONGCARD;
  978.                      VAR P: NDXPageType);
  979.    VAR FPtr : LONGCARD;
  980.        TempIOcheck : BOOLEAN;
  981.    BEGIN
  982.       TempIOcheck := FIO.IOcheck;               (* Save cur I/O check state *)
  983.       FIO.IOcheck := FALSE;                     (* Turn off I/O err cheking *)
  984.       FPtr := PNum * PageSize;                  (* Calculate page position  *)
  985.       FIO.Seek(NDX.Handle, FPtr);               (* Seek to page in file     *)
  986.       FIO.IOcheck := TempIOcheck;               (* Restore I/O err checking *)
  987.       IF FIO.IOresult() > 0 THEN                (* If error seeking,        *)
  988.          HandleError('GetPage', ErrSeek);       (*    Display error message *)
  989.          RETURN;                                (*    and abort procedure.  *)
  990.       END;                                      (* Else, seek was OK.       *)
  991.       FIO.IOcheck := FALSE;                     (* Turn off I/O err cheking *)
  992.       FIO.WrBin(NDX.Handle, P, PageSize);       (* So write page to disk    *)
  993.       FIO.IOcheck := TempIOcheck;               (* Restore I/O err checking *)
  994.       IF FIO.IOresult() > 0 THEN                (* If error seeking,        *)
  995.          HandleError('GetPage', ErrSeek);       (*    Display error message *)
  996.       END;                                      (* Else, write was OK.      *)
  997.       ErrCode := 0;
  998.    END PutPage;
  999.  
  1000.    PROCEDURE BuildLevel(Level : CARDINAL);
  1001.    VAR PInNum, POutNum : LONGCARD;
  1002.        LeafNum, LeafOfs: LONGCARD;
  1003.        PIn, POut       : NDXPageType;
  1004.        KIn, KOut       : POINTER TO NDXKeyType;
  1005.    BEGIN
  1006.       PInNum  := SPage;
  1007.       POutNum := EPage + 1;
  1008.       LeafOfs := Power(VAL(LONGCARD, NDX.KeysPerPage+1),
  1009.                        VAL(LONGCARD, Level-1));
  1010.       LeafNum := 0;
  1011.       WHILE PInNum <= EPage DO
  1012.          InitPage(POut);
  1013.          WHILE (PInNum <= EPage) AND
  1014.                (POut.InPage <= NDX.KeysPerPage) DO
  1015.             LeafNum := LeafNum + LeafOfs;
  1016.             IF LeafNum > ELeaf THEN LeafNum := ELeaf; END;
  1017.             GetPage(LeafNum, PIn);
  1018.             IF ErrCode > 0 THEN RETURN; END;
  1019.             KIn := ADR(PIn.Keys[(PIn.InPage-1) * NDX.KeySize]);
  1020.             KOut:= ADR(POut.Keys[POut.InPage * NDX.KeySize]);
  1021.             Move(KIn, KOut, NDX.KeySize);
  1022.             KOut^.PPtr := PInNum;
  1023.             KOut^.RPtr := VAL(LONGCARD, 0);
  1024.             INC(POut.InPage);
  1025.             INC(PInNum);
  1026.          END;
  1027.          DEC(POut.InPage);
  1028.          PutPage(POutNum, POut);
  1029.          IF ErrCode > 0 THEN RETURN; END;
  1030.          INC(POutNum);
  1031.          INC(NDX.NextFree);
  1032.       END;
  1033.       SPage   := EPage + 1;
  1034.       EPage   := POutNum - 1;
  1035.       ErrCode := 0;
  1036.    END BuildLevel;
  1037.  
  1038.    PROCEDURE BuildTree;
  1039.    VAR Level : CARDINAL;
  1040.        KNum  : LONGCARD;
  1041.    BEGIN
  1042.       Level := 1;
  1043.       ELeaf := EPage;
  1044.       WHILE EPage > SPage DO
  1045.          BuildLevel(Level);
  1046.          IF ErrCode > 0 THEN RETURN; END;
  1047.          INC(Level);
  1048.       END;
  1049.       NDX.Root := EPage;
  1050.       ErrCode  := 0;
  1051.    END BuildTree;
  1052.  
  1053. BEGIN
  1054.    MakeSortBuffers;                             (* Create buffers for sort  *)
  1055.    IF ErrCode > 0 THEN RETURN; END;             (* If error then abort.     *)
  1056.    GetSortKeyData;                              (* Get data on key field.   *)
  1057.    LoadBuffers;                                 (* Load buffers with keys.  *)
  1058.    IF ErrCode > 0 THEN                          (* If error loading buffers *)
  1059.       RemoveSortBuffers;                        (*    release sort buffers, *)
  1060.       RETURN;                                   (*    and abort sorting now *)
  1061.    END;                                         (* Else with buffers loaded *)
  1062.    QS(SKey, EKey);                              (* Sort all keys for subidx *)
  1063.    IF ErrCode > 0 THEN                          (* If error sorting keys,   *)
  1064.       RemoveSortBuffers;                        (*    release sort buffers, *)
  1065.       RETURN;                                   (*    and abort sorting now *)
  1066.    END;                                         (* Else with buffers sorted *)
  1067.    SaveBuffers;                                 (* Save buffers to disk.    *)
  1068.    IF ErrCode > 0 THEN                          (* If error saving buffers, *)
  1069.       RemoveSortBuffers;                        (*    release sort buffers, *)
  1070.       RETURN;                                   (*    and abort procedure.  *)
  1071.    END;                                         (* Else with buffers saved  *)
  1072.    BuildTree;                                   (* Build sub-index tree.    *)
  1073.    RemoveSortBuffers;                           (* Return buffers to memory *)
  1074. END SortKeys;
  1075.  
  1076. (****************************************************************************)
  1077. (* MAIN BODY OF INDEX program including support procedures                  *)
  1078. (****************************************************************************)
  1079.  
  1080. PROCEDURE Deleted() : BOOLEAN;
  1081. BEGIN
  1082.    RETURN DBF.RecPtr^[0] = '*';
  1083. END Deleted;
  1084.  
  1085. PROCEDURE GetFieldNum(FieldName    : ARRAY OF CHAR;
  1086.                       VAR FieldNum : CARDINAL);
  1087. VAR ListPtr : HashPtr;
  1088.     Hash    : CARDINAL;
  1089. BEGIN
  1090.   Caps(FieldName);                            (* Convert to upper case  *)
  1091.   Hash := HashString(FieldName,128);          (* Hash fieldname         *)
  1092.   ListPtr := DBF.HashTable[Hash];             (* Get ptr to field data  *)
  1093.   WHILE (ListPtr # NIL) AND                   (* Search hash list       *)
  1094.     ((Compare(FieldName, ListPtr^.Name)) # 0) DO
  1095.     ListPtr := ListPtr^.Next;
  1096.   END; (* While *)
  1097.   IF ListPtr = NIL THEN                       (* If field was not found, *)
  1098.      HandleError('GetFieldNum', ErrBadField);
  1099.      RETURN;
  1100.   END;
  1101.   FieldNum := ListPtr^.Field;                 (* field num from Hash tbl.*)
  1102.   ErrCode := 0;
  1103. END GetFieldNum;
  1104.  
  1105. PROCEDURE GetField(FieldName : ARRAY OF CHAR;
  1106.                    VAR Field : ARRAY OF CHAR);
  1107. VAR StrIdx, BufIdx : CARDINAL;
  1108.     FieldNum       : CARDINAL;
  1109. BEGIN
  1110.   GetFieldNum(FieldName, FieldNum);         (* Get field number        *)
  1111.   IF ErrCode > 0 THEN                       (* If invalid field name,  *)
  1112.      Field[0] := 0C;                        (*    clear return field,  *)
  1113.      RETURN;                                (*    and end procedure.   *)
  1114.   END;
  1115.   StrIdx := 0;                              (* Index into output Str   *)
  1116.   BufIdx := DBF.Fields^[FieldNum].Ofs;      (* Index into  record buff.*)
  1117.   WHILE (StrIdx <= HIGH(Field)) AND
  1118.     (StrIdx < VAL(CARDINAL, DBF.Fields^[FieldNum].Len)) DO
  1119.     Field[StrIdx] := DBF.RecPtr^[BufIdx];   (* Copy data from rec buf. *)
  1120.     INC(StrIdx); INC(BufIdx);               (* into the output field   *)
  1121.   END;
  1122.   IF (StrIdx <= HIGH(Field)) THEN           (* If output str is larger *)
  1123.      Field[StrIdx] := 0C;                   (* than the field, end it  *)
  1124.   END;                                      (* with a NUL              *)
  1125. END GetField;
  1126.  
  1127. PROCEDURE DefaultFilter() : BOOLEAN;
  1128. BEGIN
  1129.    RETURN TRUE;
  1130. END DefaultFilter;
  1131.  
  1132. PROCEDURE DefaultKeyExp(VAR Key : ARRAY OF CHAR);
  1133. VAR F : CARDINAL;
  1134.     Temp : ARRAY [0..MaxKeyLen-1] OF CHAR;
  1135. BEGIN
  1136.    Key[0] := 0C;
  1137.    FOR F := 1 TO NumKeys DO
  1138.        GetField(KeyArray[F].FName, Temp);
  1139.        Append(Key, Temp);
  1140.    END;
  1141. END DefaultKeyExp;
  1142.  
  1143. PROCEDURE MakeNDX(DBFName : ARRAY OF CHAR;     (* Name of DBF file         *)
  1144.                   NDXName : ARRAY OF CHAR;     (* Name of NDX file         *)
  1145.                   KeyName : ARRAY OF CHAR;     (* Key field expression     *)
  1146.                   KeyLen  : CARDINAL);         (* Key field length         *)
  1147. VAR  P, F, Field : CARDINAL;
  1148.      Expression  : ARRAY [0..255] OF CHAR;
  1149.      KeyType     : CHAR;
  1150. BEGIN
  1151.    IF Length(KeyName) = 0 THEN RETURN; END;     (* If no key exp, abort now *)
  1152.    Caps(KeyName);                               (* Else convert key expressn*)
  1153.    Copy(Expression, KeyName);                   (*    to upper case         *)
  1154.    OpenDBF(DBF, DBFName);                       (* Open database file       *)
  1155.    IF ErrCode > 0 THEN RETURN; END;             (* If error opening, abort  *)
  1156.    NumKeys := 0;                                (* Init # of keys to 0      *)
  1157.    REPEAT                                       (* For each key specified,  *)
  1158.       INC(NumKeys);                             (*    bump # of keys,       *)
  1159.       P := Pos(Expression, '+');                (*    and check for another *)
  1160.       WITH KeyArray[NumKeys] DO                 (*    if another found,     *)
  1161.          Slice(FName, Expression, 0, P);        (*       add to key array   *)
  1162.          GetFieldNum(FName, FNum);              (*       and get field data *)
  1163.          IF ErrCode > 0 THEN                    (*    if invalid field name *)
  1164.             CloseDBF;                           (*       close the DBF file *)
  1165.             RETURN;                             (*       and abort now.     *)
  1166.          END;                                   (*    Else valid field name *)
  1167.          FLen:=VAL(CARDINAL,DBF.Fields^[FNum].Len); (*   get field length   *)
  1168.          FType:= DBF.Fields^[FNum].Type;            (*   get field type     *)
  1169.       END;                                          (*   and store in array *)
  1170.       IF P < Length(Expression) THEN            (* Remove parsed key from   *)
  1171.          Slice(Expression,Expression,P+1,Length(Expression)); (* expression *)
  1172.       ELSE                                      (*       and check for      *)
  1173.          Expression[0] := 0C;                   (*       another key.  If   *)
  1174.       END;                                      (*       not found, clr exp *)
  1175.    UNTIL (Length(Expression) = 0);              (* Continue till exp parsed *)
  1176.    IF (NumKeys = 1) AND                         (* If only one key field,   *)
  1177.       ((KeyArray[1].FType = 'N') OR             (*    and it is a numeric   *)
  1178.        (KeyArray[1].FType = 'D')) THEN          (*    or date field then set*)
  1179.       KeyLen := 8;                              (*    set key length to 8   *)
  1180.       KeyType := 'N';                           (*    and key type numeric  *)
  1181.    ELSE                                         (* Else key will be string  *)
  1182.       KeyType := 'C';                           (*    so set key type to    *)
  1183.       IF KeyLen = 0 THEN                        (* If user did not specify  *)
  1184.          FOR F := 1 TO NumKeys DO               (*    key length, calc it   *)
  1185.             IF KeyArray[F].FType = 'C' THEN     (*    now.  If key type is  *)
  1186.                KeyLen:=KeyLen+KeyArray[F].FLen; (*    char, add len to tot  *)
  1187.             ELSE INC(KeyLen, 8);                (*    else, numeric key...  *)
  1188.             END;                                (*    length always 8.      *)
  1189.          END;                                   (* Continue for all keys    *)
  1190.       END;                                      (* With key type and length *)
  1191.    END;                                         (*    determined,           *)
  1192.    CreateNDX(NDX,NDXName,KeyType,KeyLen,KeyName);(* Create index file.      *)
  1193.    IF ErrCode > 0 THEN RETURN; END;             (* If error creating, abort *)
  1194.    WrChar('.');                                 (* Else, print dot          *)
  1195.    ExtractKeys;                                 (* Extract keys from DBF    *)
  1196.    IF ErrCode > 0 THEN RETURN; END;             (* If error extractng, abort*)
  1197.    CloseDBF;                                    (* Else, close data file    *)
  1198.    WrChar('.');                                 (* and print another dot    *)
  1199.    IF KeyCount > 0 THEN                         (* If any keys were found,  *)
  1200.       SortKeys;                                 (*    sort keys             *)
  1201.       IF ErrCode > 0 THEN RETURN; END;          (*    If error, abort       *)
  1202.    END;                                         (* With index built,        *)
  1203.    WrChar('.');                                 (* Write last dot,          *)
  1204.    CloseNDX;                                    (* Close index file         *)
  1205. END MakeNDX;
  1206.  
  1207. BEGIN
  1208.    FIO.IOcheck := FALSE;                        (* Turn off FIO err checking*)
  1209.    Safety      := FALSE;                        (* Don't flush bufs on write*)
  1210.    ErrCheck    := AskUser;                      (* Stop & Report on Errors  *)
  1211.    ErrCode     := 0;                            (* Init error return code   *)
  1212.    DosCode     := 0;                            (* Init DOS error code      *)
  1213.    Filter      := DefaultFilter;                (* Init filter (none)       *)
  1214.    KeyExp      := DefaultKeyExp;                (* Init key expression      *)
  1215. END BuildNDX.
  1216.