home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / database / ndx / ndx.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-03-23  |  17.3 KB  |  444 lines
  1. {$E+,I-,N+,R-,V- -80X87 emulation, no I/O errors,
  2.                    no range checks}
  3. UNIT NDX;
  4. {***********************************************************************}
  5. {     NDX.TPU    RKB   91/01/19.                                        }
  6. {     This unit support reading, seeking and traversing dBase III       }
  7. {     .NDX files.                                                       }
  8. {     dBase and dBase III are trademarks of Ashton-Tate Corp.           }
  9. {     Copyright (C) 1990-1991.  Robert K. BLaine/ECONO-SOFT.            }
  10. {     All rights reserved.                                              }
  11. {     Permission is hereby granted to freely use these routines         }
  12. {     as long as this copyright remains intact.                         }
  13. {***********************************************************************}
  14. {=======================}INTERFACE{=============================}
  15. CONST
  16.   MaxNDXKeyLength      = 511 - 24 + 1;  {***Bytes 24...511 of the header ***}
  17.   MaxNDXKeyValueLength = 100;
  18.   SetExact : Boolean   = FALSE;
  19. TYPE
  20.   NDXseekMode =
  21.     (NDXmodeSeekAll,    {*** to traverse entire NDX ***}
  22.      NDXmodeSeekFirst,  {*** for quick seek of first match ***}
  23.      NDXmodeSeekCall);  {*** call UserProc for all matches ***}
  24.   Str13        = String [13];
  25.   Str66        = String [66];
  26.   KeyStr       = String [MaxNDXKeyValueLength];
  27.   NDXheaderRec = Record
  28.     RootPage   : Longint;             {*** 0- 3: B+ tree root page number ***}
  29.     NextPage   : Longint;             {*** 4- 7: first unused page ***}
  30.     D0         : Longint;             {*** 8-11: (Reserved) ***}
  31.     KeyLen     : Word;                {*** 12-13: Key length ***}
  32.     KeysPage   : Word;                {*** 14-15: keys per page ***}
  33.     NumericKey : Boolean;             {*** 16: True if key is numeric *** }
  34.     D1         : Byte;                {*** 17: (reserved) ***}
  35.     EntrySize  : Word;                {*** 18-19: Length of entry. ***}
  36.     D2         : Longint;             {*** 20-23: (reserved) ***}
  37.     Key        : ARRAY [1..MaxNDXKeyLength] OF Char;
  38.   END;
  39.   NDXpageRec  = RECORD
  40.     NEntries  : Integer;              {* 0- 1: #active entries in this page *}
  41.     D0        : Integer;
  42.     Entries   : ARRAY [0..507] OF Byte;
  43.   END;
  44.  
  45.   {*****************************************************************}
  46.   {***                   NDXentry Notes:                         ***}
  47.   {*** -if RecNo or LEpage are not used, they are set to 0.      ***}
  48.   {*** -an entry has LEpage or RecNo but never both.             ***}
  49.   {*** -mumeric and date keys are stored as 8-byte 80x87 Double. ***}
  50.   {*****************************************************************}
  51.  
  52.   NDXentry     = ^NDXentryRec;
  53.   NDXentryRec  = Record
  54.     LEpage     : Longint;          {* 0- 3: page containing previous keys *}
  55.     RecNo      : Longint;          {*** 4- 7: record number matching Key ***}
  56.     Case Byte OF
  57.       1: (DoubleKey: Double);
  58.       2: (CharKey  : ARRAY [1..MaxNDXKeyValueLength] OF Char);
  59.     END;
  60.  
  61.   {********************************************************************}
  62.   {***  NDXpageInfo is used to keep position information within the ***}
  63.   {***  index file. Recursion is not used since the inkex could be  ***}
  64.   {***  much larger than available memory.                          ***}
  65.   {********************************************************************}
  66.  
  67.     NDXpageInfo = ^NDXpageInfoRec;
  68.     NDXpageInfoRec = Record
  69.        PageN   : Longint;               {*** page number ***}
  70.        Index   : Integer;               {*** index within page ***}
  71.        PrevPage: NDXpageInfo;           {*** previous page ***}
  72.     END;
  73.  
  74.      _NDX = Record                      {*** the .NDX file itself ***}
  75.        F           : File;              {*** the .NDX file header ***}
  76.        H           : NDXheaderRec;      {*** current index page ***}
  77.        CurrentPage : Longint;
  78.        Index       : Integer;           {*** index within the current page ***}
  79.        LastMatch   : Longint;           {*** last match on "Seek" ***}
  80.        Level       : Integer;           {*** current level of recursion ***}
  81.        MaxLevel    : Integer;           {*** maximum level of recursion ***}
  82.        NMatches    : Integer;           {*** # successful matches last "Seek" *}
  83.        PrevPages   : NDXpageInfo;       {*** list of previous pages ***}
  84.      END;
  85.  
  86.    {**********************************************************}
  87.    {*** A routine of type "NDXProc" is called when traversing.}
  88.    {**********************************************************}
  89.  
  90. NDXproc = PROCEDURE(Var N: _NDX; Var entry: NDXentry);
  91.  
  92. PROCEDURE NDXopen(Var N: _NDX; fn: Str66);
  93.  
  94. PROCEDURE NDXclose(Var N: _NDX);
  95.  
  96. FUNCTION  NDXgetKey(Var N: _NDX; Var entry: NDXentry; Limit: Integer): KeyStr;
  97.  
  98. FUNCTION  NDXSeek(Var N: _NDX; Key: KeyStr): Longint;
  99.  
  100. FUNCTION  NDXseekN(Var n: _NDX; Key: double): Longint;
  101.  
  102. PROCEDURE NDXseekAll(Var N: _NDX; UserProc: NDXProc; KEY: KeyStr);
  103.  
  104. PROCEDURE NDXseekALLN(Var N: _NDX; UserProc: NDXproc; Key: double);
  105.  
  106. PROCEDURE NDXTraverse(Var n: _NDX; UserProc: NDXproc);
  107.  
  108. {=========================}IMPLEMENTATION{===========================}
  109. PROCEDURE ErrorExit(Msg: Str66);
  110.   Begin
  111.     Writeln(Msg);
  112.     Halt(1)
  113.   End;
  114.  
  115. (****************************************************************************)
  116.  
  117. PROCEDURE NDXopen(Var N: _NDX; fn: Str66);
  118.  
  119.   {*********************************************************************}
  120.   {*** Open dBaseIII Index (.NDX) file.                             *** }
  121.   {***           entry conditions:                                  *** }
  122.   {***                        N= NDX control record                 *** }
  123.   {***                        fn= file specification.               *** }
  124.   {***           exit conditions:                                   *** }
  125.   {***                        Return : N = completely installed     *** }
  126.   {*********************************************************************}
  127.  
  128. Var
  129.   SizeRead: Word;
  130. Begin {NDXopen}
  131.   Assign(N.F, fn); Reset(N.F, 1);
  132.   IF IOResult <> 0 THEN
  133.     ErrorExit(' Could not open NDX.');
  134.  
  135.   BlockRead (N.F, N.H, SizeOf (N.H), SizeRead);
  136.   IF (IOResult <> 0) OR (SizeRead< SizeOf (N.H)) THEN
  137.     ErrorExit(' Could not read NDX header Page.');
  138.  
  139.   N.Level       := 0;
  140.   N.MaxLevel    := 0;
  141.   N.PrevPages   := NIL;
  142. END;
  143.  
  144. (****************************************************************************)
  145.  
  146. Procedure NDXclose(Var N: _NDX);
  147.  {**********************************************}
  148.  {*** Close A dBase II index (.NDX) file.    ***}
  149.  {***   Entry conditions:                    ***}
  150.  {***      passed : N = NDX control record.  ***}
  151.  {***   Exit conditions:                     ***}
  152.  {***     None.                              ***}
  153.  {**********************************************}
  154.  
  155. Begin {NDXclose}
  156.   Close(N.F);
  157.   IF IOResult <> 0 THEN
  158.     ErrorExit(' Could not close NDX.');
  159. End;
  160.  
  161. FUNCTION NDXGetKey(Var N: _NDX; Var entry: NDXentry; Limit: Integer): KeyStr;
  162.  
  163.  {*****************************************************************}
  164.  {***  Get the alphanumeric key associated with an index entry. ***}
  165.  {***   Entry conditions:                                       ***}
  166.  {***       passed : N = NDX control record.                    ***}
  167.  {***       Entry = Pointer to an entry record.                 ***}
  168.  {***       Limit = length of key to return (0 = full length).  ***}
  169.  {***   Exit conditions:                                        ***}
  170.  {***       return : Alphanumeric key.                          ***}
  171.  {*****************************************************************}
  172.  
  173. Var
  174.   S: KeyStr;
  175. Begin {NDXGetKey}
  176.   IF N.H.NumericKey THEN
  177.     NDXgetKey := ''
  178.   ELSE
  179.     Begin
  180.       IF (Limit = 0) OR (Limit > N.H.KeyLen) THEN
  181.         Limit := N.H.KeyLen;
  182.       Move(entry^.CharKey, S [1], Limit);
  183.       Byte(S [0]) := Limit;         {*** Length of String ***}
  184.       NDXgetKey := S;
  185.     End;
  186. End;  {*** NDXgetKey ***}
  187.  
  188. (****************************************************************************)
  189.  
  190. Procedure NDXreadPage(Var N: _NDX; page: Longint; Var PageBuf: NDXpageRec);
  191.  
  192.     {*********************************************}
  193.     {*** Read and NDX page.                    ***}
  194.     {***     entry conditions:                 ***}
  195.     {***      Passed : N = NDX control record. ***}
  196.     {***      Page = page number to read.      ***}
  197.     {***      PageBuf = recieving buffer.      ***}
  198.     {***                                       ***}
  199.     {***     Exit conditions:                  ***}
  200.     {***      None                             ***}
  201.     {*********************************************}
  202.  
  203. Var
  204.   BytesRead : Word;
  205. Begin   {*** NDXreadPage ***}
  206.   Seek (N.F, page SHL 9 {* 512});
  207.   If IOResult <> 0 Then
  208.     ErrorExit('Could not read requested index page.');
  209.  
  210.   N.CurrentPage := page;
  211. End;    {*** NDXreadPage ***}
  212.  
  213. (****************************************************************************)
  214.  
  215. Procedure NDXseekPrim(Var N: _NDX;UserProc:NDXProc;Var Key; Mode:NDXseekMode);
  216.  
  217.  {************************************************************************}
  218.  {*** Seek a dBase III Index (.NDX) file. "UserProc" is called         ***}
  219.  {*** for every match in the index (unless Mode=SeekFirst).            ***}
  220.  {***                                                                  ***}
  221.  {***    Entry conditions                                              ***}
  222.  {***          Passed : N =NDX control record.                         ***}
  223.  {***                   UserProc = user routine to process matches     ***}
  224.  {***                   Key = alphnumeric or numeric key.              ***}
  225.  {***                   Mode = SeekAll, SeekFirst, or SeekCall.        ***}
  226.  {***    Exit conditions                                               ***}
  227.  {***         None                                                     ***}
  228.  {*** Note: This routine is not interfaced and is not called directly. ***}
  229.  {************************************************************************}
  230.  
  231.  Var
  232.    NextPage: Longint;
  233.    entry   : NDXentry;
  234.    Found, Done : Boolean;
  235.    GTpage: ^Longint;
  236.    PageBuf: NDXpageRec;
  237.  
  238.    Procedure PushPage(NewPage: Longint);
  239.    {*** Push NDX page information onto PageInfo list. ***}
  240.    Var
  241.      T: NDXpageInfo;
  242.    Begin {*** PushPage ***}
  243.      IF Mode <> NDXmodeSeekFirst Then {*** does not need to return}
  244.       Begin
  245.        GetMem (T, SizeOf(NDXpageInfoRec));
  246.        T^.Index  := N.Index;
  247.        T^.PageN  := N.CurrentPage;
  248.        T^.PrevPage := N.PrevPages;
  249.        N.PrevPages := T;  {*** add to top of list ***}
  250.      End;
  251.    NextPage   := NewPage; {*** will force page Read ***}
  252.    N.Index    := 0;
  253.  End;   {*** PushPage ***}
  254.  
  255. (****************************************************************************)
  256.  
  257. Procedure PopPage;
  258. {*** Pop NDX page information off of PageInfo list. ***}
  259. Var
  260.   T: NDXPageInfo;
  261. Begin   {*** PopPage ***}
  262.   If N.PrevPages <> NIL Then
  263.    Begin
  264.     N.Index  := N.PrevPages^.Index;
  265.     NextPage := N.PrevPages^.PageN;  {*** force re-read ***}
  266.     T        := N.PrevPages^.PrevPage^.PrevPage;
  267.     FreeMem (N.PrevPages, SizeOf(NDXpageInfoRec));
  268.     N.PrevPages := T;
  269.     entry := Addr (PageBuf.Entries [N.Index * N.H.EntrySize]);
  270.    End;
  271.  End;     {*** PopPage ***}
  272. Type
  273.   TestMode = (LE, EQ, GT);
  274.  
  275. {****************************************************************************}
  276.  
  277. Function TestKey(TMode: TestMode) : Boolean;
  278. {*** Isolate tests for flexibility ***}
  279. Begin
  280.   If Mode = NDXmodeSeekAll Then
  281.     TestKey := True  {*** for full traverse ***}
  282.   Else If N.H.NumericKey Then
  283.    Case Tmode of
  284.      LE: TestKey := double(Key) <= entry^.DoubleKey;
  285.      EQ: TestKey := double(Key) <= entry^.DoubleKey;
  286.      GT: TestKey := double(Key) <= entry^.DoubleKey;
  287.    End {*** Case ***}
  288.   Else
  289.    Case Tmode Of
  290.      LE: TestKey:= KeyStr(Key) <= NDXgetKey(N, entry, length(KeyStr(Key)));
  291.      EQ: TestKey:= KeyStr(Key) <= NDXgetKey(N, entry, length(KeyStr(Key)));
  292.      GT: TestKey:= KeyStr(Key) <= NDXgetKey(N, entry, length(KeyStr(Key)));
  293.    End;  {*** Case ***}
  294.   End;   {*** TestKey ***}
  295.  
  296. Begin {NDXseekPrim}
  297.   Found := False;
  298.   Done  := False;
  299.   N.Index := 0;
  300.   N.LastMatch := 0;
  301.   N.Nmatches := 0;
  302.  
  303.   If NOT N.H.NumericKey AND SetExact Then
  304.     While Length (KeyStr(Key)) < N.H.KeyLen Do
  305.       KeyStr(Key) := KeyStr(Key) + ' ';
  306.   NextPage := N.H.RootPage;
  307.   Repeat
  308.     NDXreadPage(N, NextPage, PageBuf);
  309.     NextPage := 0;
  310.     While (N.Index< PageBuf.NEntries) AND (NextPage = 0) AND NOT Done Do
  311.      Begin
  312.       entry := Addr (PageBuf.Entries [N.Index * N.H.EntrySize]);
  313.       Inc (N.Index);
  314.       If entry^.LEpage <> 0 Then
  315.        IF TestKey(LE) Then
  316.          PushPage (entry^.LEPage);
  317.        If entry^.RecNo <> 0 Then
  318.         If TestKey (EQ) Then
  319.          Begin
  320.           Found := True;
  321.           Inc(N.NMatches);
  322.           N.LastMatch := entry^.RecNo;
  323.           If Mode = NDXmodeSeekFirst Then
  324.             Done := True
  325.           Else
  326.             UserProc(N, entry);
  327.           End
  328.          Else If found Then
  329.            Done := True;
  330.         End;
  331.        IF (NextPage = 0) AND (N.Index = PageBuf.NEntries) AND Not Done Then
  332.          Begin
  333.           GTPage := Addr (PageBuf.Entries [N.Index * N.H.EntrySize]);
  334.           Inc(N.Index);
  335.           If GTPage^ <> 0 Then
  336.             If TestKey(GT) Then
  337.               PushPage (GTpage^);
  338.          End;
  339.         If NextPage = 0 Then
  340.           PopPage;
  341.         Until NextPage = 0
  342.       End;
  343. (****************************************************************************)
  344.  
  345. Procedure NDXseekAll(Var N: _NDX; UserPRoc: NDXProc; Key: KeyStr);
  346.  
  347.   {***********************************************************************}
  348.   {*** Seek a dBase III Index (.NDX) file calling the user routine for ***}
  349.   {*** each entry in the index that matches the key.                   ***}
  350.   {***        Entry Conditions:                                        ***}
  351.   {***              Passed : N = NDX control record.                   ***}
  352.   {***                       UserProc = user routine call.             ***}
  353.   {***                       Key = alphanumeric key.                   ***}
  354.   {***        Exit Conditions:                                         ***}
  355.   {***             None                                                ***}
  356.   {***********************************************************************}
  357.  
  358. Begin {*** NDXseekAll ***}
  359.   If N.H.NumericKey Then
  360.     ErrorExit(' Improper alphanumeric Seek.');
  361.   NDXseekPrim(N, UserProc, Key, NDXmodeSeekCall);
  362. End;  {*** NDXseekAll ***}
  363.  
  364. {****************************************************************************}
  365.  
  366. Procedure NDXseekAllN(Var N: _NDX; UserProc: NDXProc; Key: Double);
  367.  
  368.   {***********************************************************************}
  369.   {*** Seek a dBase III Index (.NDX) file calling the user routine for ***}
  370.   {*** each entry in the index that matches the key.                   ***}
  371.   {***   Entry conditions:
  372.   {***      Passed : N = NDX control record.                           ***}
  373.   {***               UserProc = user routine call.                     ***}
  374.   {***               Key = numeric key.                                ***}
  375.   {***   Exit conditions:                                              ***}
  376.   {***               None                                              ***}
  377.   {***********************************************************************}
  378.  
  379. Begin  {*** NDXseekAllN ***}
  380.   If NOT N.H.NumericKey THEN
  381.     ErrorExit('Improper numeric Seek.');
  382.   NDXseekPrim(N, USerProc, Key, NDXmodeSeekCall);
  383. End;
  384.  
  385. {****************************************************************************}
  386.  
  387. {$F+} Procedure DummyUserProc(Var N: _NDX; Var entry: NDXentry);
  388. {*** For use when Mode=SeekFirst ***}
  389. Begin
  390.  Halt (1);
  391. End;
  392. {$F-}
  393.  
  394. {****************************************************************************}
  395.  
  396. Function NDXseek(Var N: _NDX; Key: KeyStr): Longint;
  397.  
  398.   {***********************************************************************}
  399.   {*** Seek a dBase III index (.NDX) file returning the first matching ***}
  400.   {*** record number.                                                  ***}
  401.   {***        Entry Conditions:                                        ***}
  402.   {***               Passed: N = NDX control record.                   ***}
  403.   {***                       Key = alphnumeric Key.                    ***}
  404.   {***        Exit Conditions:                                         ***}
  405.   {***              Return: record number of first match.              ***}
  406.   {***********************************************************************}
  407.  
  408. Begin  {*** NDXseek ***}
  409.   If N.H.NumericKey Then
  410.     ErrorExit(' Improper alphanumeric Seek.');
  411.  
  412.   NDXseekPrim (N, DummyUserProc, Key, NDXmodeSeekFirst);
  413.   NDXseek := N.LastMatch;
  414. End;  {*** NDXseek ***}
  415.  
  416. {****************************************************************************}
  417.  
  418. Function NDXseekN (Var N: _NDX; Key: Double): Longint;
  419. Begin
  420.   If not N.H.NumericKey Then
  421.     ErrorExit ('Improper numeric seek.');
  422.   NDXseekPrim (N, DummyUserProc, Key, NDXmodeSeekFirst);
  423.   NDXseekN := N.LastMatch;
  424. End;
  425.  
  426. {****************************************************************************}
  427.  
  428. Procedure NDXTraverse (Var N: _NDX; UserProc: NDXproc);
  429. Const
  430.   NullKey: String[1] = '';
  431. Begin
  432.  NDXseekPrim (N, UserProc, NullKey, NDXmodeSeekAll);
  433. End;
  434.  
  435. {****************************************************************************}
  436.  
  437. End.
  438.                      
  439.  
  440.  
  441.  
  442.  
  443.  
  444.