Turbo Toolbox/Turbo_Toolbox.iso/1990/09/tricks/isamtree.pas

Pascal/Delphi Source File | 1990-06-15 | 13.6 KB | 595 lines

(* ------------------------------------------------------ *)
(*                       ISAMTREE.PAS                     *)
(*     Unit zur Verwaltung indexsequentieller Dateien     *)
(*   mit Hilfe von Indices, die als Binär-Baum verwaltet  *)
(*      werden. ISAMTREE.PAS benötigt eine individuell    *)
(*             erstellte Version von DEFINES.INC.         *)
(*             (c)1990 Karlheinz Büker & TOOLBOX          *)
(* ------------------------------------------------------ *)
UNIT IsamTree;

INTERFACE

{$I Defines.inc}

TYPE
  FileType = (Data, Index);

  KeyPtr   = ^KeyType;
  KeyType  = RECORD
    OB    : Key;      { deklariert in DEFINES.INC }
    SetNr : WORD;     { Satznummer der Datendatei }
    Left  : KeyPtr;   { Linkszeiger auf OB <= aktueller OB }
    Right : KeyPtr;   { Rechtszeiger auf OB > aktueller OB }
    END;

VAR
  StartPtr  : KeyPtr;
  NextPtr   : KeyPtr;
  NextOB    : Key;
  IsamError : BYTE;

FUNCTION  ExistFile (F : FileType) : BOOLEAN;
          { TRUE, wenn Daten- bzw. Indexdatei existiert }

PROCEDURE CreateFile (F : FileType);
          { erstellt neue Daten- bzw. Indexdatei }

PROCEDURE EraseFile (F : FileType);
          { löscht Daten- bzw. Indexdatei }

PROCEDURE OpenDatabase;
          { Öffnet Daten- und Indexdatei und }
          { initialisiert Index-Tree im Heap }

PROCEDURE AddRecord (Data : DataType);
          { Fügt Datensatz in die Indexdatei }
          { und integriert den entspr. Key   }
          { in den Tree im Heap              }

PROCEDURE GetRecord
        (S : Key; VAR Data : DataType; VAR FilePos : WORD);
        { FilePos wird nur zum evtl. Löschen }
        { von Sätzen als Parameter benötigt. }
        { Liefert den ersten Datensatz zurück, }
        { dessen OB = S ist. }

PROCEDURE GetNextRecord
        (VAR Data : DataType; VAR FilePos : WORD);
        { Liefert den nächsten Datensatz,}
        { dessen Ordnungsbegriff gleich  }
        { dem zuletzt mit GetRecord oder }
        { GetNextRecord gelesenen Daten- }
        { satz ist. Diese Prozedur dient }
        { zum Auffinden von Sätzen mit   }
        { gleichen OBs. Ist DoubleAllowed}
        { = False dann wird IsamError = 1}
        { zurückgegeben }

PROCEDURE DelRecord (S : Key; VAR FilePos : WORD);
        { Löscht Indexsatz S und kennzeichnet   }
        { den Datensatz an FilePos als gelöscht.}
        { FilePos wird als Parameter durch      }
        { GetRecord zurückgeliefert             }

PROCEDURE ReorgDataFile;
        { entfernen der als ungültig deklarierten }
        { Sätze aus der Datendatei.               }

PROCEDURE Reko (Activate : BOOLEAN);
        { löscht Schlüsseldatei und erstellt   }
        { aus den Daten der Datendate eine neue}
        { Schlüsseldatei. Wird Activate=TRUE   }
        { übergeben, werden auch als gelöscht  }
        { gekennzeichnete Sätze wieder Reakti- }
        { viert                                }

PROCEDURE CloseDataBase;
{ Speichert Index-Tree und schließt Daten- und Indexdatei }
IMPLEMENTATION

TYPE
  IndexType = RECORD
                OB   : Key;
                SetNr : WORD;
              END;
  IFile     = FILE OF IndexType;

VAR
  Next      : WORD;
  HelpPtr   : KeyPtr;
  OldExit   : Pointer;
  DataFile  : FILE OF DataType;
  IndexFile : IFile;

{-----------------------------------------}

FUNCTION Upper (S : STRING) : STRING;
VAR a : BYTE;
BEGIN
  FOR a := 1 TO Length (S) DO
  BEGIN
    IF (S[a] >= 'a') AND (S[a] <= 'z')
      THEN S[a] := Chr(Ord(S[a]) - 32)
    ELSE IF S[a] = 'ä' THEN S[a] := 'Ä'
    ELSE IF S[a] = 'ö' THEN S[a] := 'Ö'
    ELSE IF S[a] = 'ü' THEN S[a] := 'Ü';
  END;
  Upper := S;
END;

{-----------------------------------------}

FUNCTION Expand (S : STRING) : STRING;
VAR a : BYTE;
BEGIN
  FOR a := 1 TO Length(S) DO
  BEGIN
    IF S[a] = 'ß' THEN
    BEGIN
      S[a] := 's'; Insert('s', S, a + 1);
    END;
    IF S[a] IN ['ä', 'Ä', 'ö', 'Ö', 'ü', 'Ü']
    THEN BEGIN
      CASE S[a] OF
        'ä' : S[a] := 'a';
        'Ä' : S[a] := 'A';
        'ö' : S[a] := 'o';
        'Ö' : S[a] := 'O';
        'ü' : S[a] := 'u';
        'Ü' : S[a] := 'U';
      END;
      IF S[a] IN ['a', 'o', 'u'] THEN
        Insert('e', S, a + 1)
        ELSE Insert('E', S, a + 1);
    END;
  END;
  Expand := S;
END;

{-----------------------------------------}

PROCEDURE SaveKey;
VAR I : IndexType;

  PROCEDURE Save (P : KeyPtr);
  BEGIN
    IF P <> NIL THEN WITH P^ DO
    BEGIN
      Save(P^.Left);
      I.OB    := P^.OB;
      I.SetNr := P^.SetNr;
      Write(IndexFile, I);
      Save(P^.Right);
      IF P <> NIL THEN Dispose(P);
    END;
  END;

BEGIN
  IF StartPtr = NIL THEN Exit;
  EraseFile(Index);
  Rewrite(IndexFile);
  Save(StartPtr);
  StartPtr := NIL;
  NextPtr := NIL;
END;

{-----------------------------------------}

FUNCTION GetKey (OB : Key) : WORD;
VAR Run   : KeyPtr;
    SetNo : WORD;

  PROCEDURE Get (    OB   : Key;
                 VAR Satz : WORD;
                 VAR Run  : KeyPtr);
  BEGIN
    IF Run = NIL THEN
    BEGIN
      IsamError := 1; Satz := 0; Exit;
    END
    ELSE BEGIN
      IF OB = Run^.OB THEN
      BEGIN
        IsamError := 0; Satz := Run^.SetNr;
        NextPtr := Run^.Left; NextOB := OB;
        Exit;
      END
      ELSE
        IF OB > Run^.OB THEN
          Get(OB, Satz, Run^.Right)
      ELSE Get(OB, Satz, Run^.Left);
    END;
  END;

BEGIN
  SetNo := 0;
  IF ExpandOB THEN OB := Expand(OB);
  IF IgnoreCase THEN OB := Upper(OB);
  IF StartPtr = NIL THEN
  BEGIN
    IsamError := 1; Exit;
  END
  ELSE Run := StartPtr;
  Get(OB, SetNo, Run);
  GetKey := SetNo;
END;

{-----------------------------------------}

PROCEDURE GetRecord(    S       : Key;
                    VAR Data    : DataType;
                    VAR FilePos : WORD);
BEGIN
  IF ExpandOB THEN S := Expand(s);
  IF IgnoreCase THEN S := Upper(S);
  IF Next = 0 THEN FilePos := GetKey(s);
  Next := 0;
  IF FilePos = 0 THEN
  BEGIN
    IsamError := 1; Exit;
  END;
  Seek(DataFile, FilePos - 1);
  Read(DataFile, Data);
END;

{-----------------------------------------}

PROCEDURE GetNextRecord(VAR Data:DataType;
VAR FilePos : WORD);
VAR FP : WORD;
BEGIN
  IF DoubleAllowed = FALSE THEN
  BEGIN
    IsamError := 1; Exit;
  END;
  HelpPtr := NextPtr;
  IF HelpPtr = NIL THEN
  BEGIN
    IsamError := 1; Exit;
  END
  ELSE IF NextOB <> HelpPtr^.OB THEN
  BEGIN
    NextPtr := NIL; IsamError := 1; Exit;
  END
  ELSE
  BEGIN
    FP := HelpPtr^.SetNr;
    IsamError := 0;
    Next := FP;
    GetRecord(HelpPtr^.OB, Data, FP);
    NextPtr := HelpPtr^.Left;
    FilePos := FP;
  END;
END;

{-----------------------------------------}

PROCEDURE Add (    Data    : DataType;
                   FilePos : WORD;
               VAR Run     : KeyPtr);
  BEGIN
    IF Run = NIL THEN
    BEGIN
      New(Run);
      IF StartPtr = NIL THEN
        StartPtr := Run;
      IF Run = NIL THEN
      BEGIN
        IsamError := 255; Exit;
      END;
      Run^.OB    := Data.OB;
      Run^.SetNr := FilePos;
      Run^.Left  := NIL;
      Run^.Right := NIL;
    END
    ELSE
    BEGIN
      IF Data.OB > Run^.OB THEN
        Add (Data, FilePos, Run^.Right)
      ELSE
        Add (Data, FilePos, Run^.Left)
    END;
  END;

PROCEDURE AddRecord (Data : DataType);
VAR FilePos : WORD;
    Run     : KeyPtr;

BEGIN
  IF (NOT DoubleAllowed) AND
     (GetKey(Data.OB) > 0) THEN
  BEGIN
    IsamError := 2; Exit;
  END;
  Data.Valid := TRUE;
  Seek(DataFile, FileSize(DataFile));
  Write(DataFile, Data);
  FilePos := System.FilePos(DataFile);
  IF ExpandOB THEN
    Data.OB := Expand(Data.OB);
  IF IgnoreCase THEN
    Data.OB := Upper(Data.OB);
  Add(Data, FilePos, StartPtr);
END;

{-----------------------------------------}

PROCEDURE InitKey;
VAR  I : IndexType;
     D : DataType;
     Z : WORD;

  PROCEDURE ReadIndex (VAR F     : IFile;
                           First,
                           Last : WORD);
  VAR
    Center : WORD;
  BEGIN
    Center := (First + Last) DIV 2;
    Seek(F, Center);
    Read(F, I);
    D.OB := I.OB;
    Add (D, I.SetNr, StartPtr);
    IF Center > First THEN
      ReadIndex(F, First, Center - 1);
    IF Center < Last THEN
      ReadIndex(F, Center + 1, Last);
  END;

BEGIN
  StartPtr := NIL;
  Z := FileSize(Indexfile);
  IF Z = 0 THEN Exit;
  ReadIndex(IndexFile, 0, Z - 1);
END;

{-----------------------------------------}

PROCEDURE DelRecord(    S : Key;
                    VAR FilePos : WORD);
VAR Data : DataType;
    Run  : KeyPtr;
    K    : Key;
  PROCEDURE Del (OB : Key;VAR Go : KeyPtr);
  VAR P : KeyPtr;

    PROCEDURE Kill (VAR Go : KeyPtr);
    BEGIN
      IF Go^.Right <> NIL THEN
        Kill(Go^.Right)
      ELSE BEGIN
        P^.OB := Go^.OB;
        P^.SetNr := Go^.SetNr;
        P := Go;
        Go := Go^.Left;
        Dispose (P);
      END;
    END;  { Kill }

  BEGIN { Del }
    IF Go = NIL THEN
    BEGIN
      IsamError := 1; Exit;
    END
    ELSE IF OB < Go^.OB THEN
      Del(OB, Go^.Left)
    ELSE IF OB > Go^.OB THEN
      Del(OB, Go^.Right)
    ELSE
    BEGIN
      P := Go;
      IF P^.Right = NIL THEN Go := P^.Left
      ELSE IF P^.Left = NIL THEN
        Go := P^.Right
      ELSE Kill(P^.Left);
    END;
  END;  { Del }

BEGIN { DelRecord }
  IF ExpandOB THEN S := Expand(S);
  IF IgnoreCase THEN S := Upper(S);
  IF (FilePos = 0) OR (GetKey(S) = 0) THEN
  BEGIN
    IsamError := 1; Exit;
  END;
  Seek(DataFile, FilePos - 1);
  Read (DataFile, Data);
  K := Data.OB;
  IF ExpandOB THEN K := Expand(K);
  IF IgnoreCase THEN K := Upper(K);
  IF K <> S THEN
  BEGIN
    IsamError := 1; Exit;
  END;
  Data.Valid := FALSE;
  Seek(DataFile, FilePos - 1);
  Write(DataFile, Data);
  IsamError := IOResult;
  IF StartPtr = NIL THEN
  BEGIN
    IsamError := 1; Exit;
  END
  ELSE Run := StartPtr;
  Del(S, Run);
  FilePos := 0;
END;

{-----------------------------------------}

FUNCTION ExistFile(F : FileType) : BOOLEAN;
VAR SF : FILE;
BEGIN
  ExistFile := FALSE;
  CASE F OF
    Data  : Assign (SF, FileName + '.DAT');
    Index : Assign (SF, FileName + '.IDX');
  END;
  {$I-} Reset(SF); {$I+}
  IF IOResult = 0 THEN
  BEGIN
    ExistFile := TRUE; Close (SF);
  END;
END;

{-----------------------------------------}

PROCEDURE CreateFile (F : FileType);
BEGIN
  {$I-}
    CASE F OF
      Data  : BEGIN
                Rewrite (Datafile);
                Close (DataFile);
              END;
      Index : BEGIN
                Rewrite (IndexFile);
                Close (IndexFile);
              END;
    END;
  {$I+}
  IsamError := IOResult;
END;

{-----------------------------------------}

PROCEDURE EraseFile (F : FileType);
BEGIN
  {$I-}
    CASE F OF
      Data  : BEGIN
                Close (Datafile);
                Erase (Datafile);
              END;
      Index : BEGIN
                Close (IndexFile);
                Erase (IndexFile);
              END;
    END;
  {$I+}
  IsamError := IOResult;
END;

{-----------------------------------------}

PROCEDURE OpenDatabase;
VAR IOR : WORD;
BEGIN
  IOR := 0;
  {$I-}
    Reset (DataFile);
    IOR := IOResult;
    Reset (IndexFile);
    IF IOR = 0 THEN IOR := IOResult;
  {$I+}
  IsamError := IOR;
  IF IsamError <> 0 THEN Exit;
  InitKey;
END;

{-----------------------------------------}

PROCEDURE ReorgDataFile;
VAR NewFile : FILE OF DataType;
    Data    : DataType;
BEGIN
  IF StartPtr = NIL THEN
  BEGIN
    IsamError := 1; Exit;
  END;
  SaveKey;
  Assign(NewFile, FileName + '.NEW');
  Rewrite(NewFile);
  Seek(DataFile, 0);
  While NOT EoF(DataFile) DO
  BEGIN
    Read(DataFile, Data);
    IF Data.Valid = TRUE THEN
      Write(NewFile, Data);
  END;
  Close (DataFile); Close (NewFile);
  Erase (DataFile);
  Rename (NewFile, FileName + '.DAT');
  Reset (DataFile);
  Reko(FALSE);
END;

{-----------------------------------------}

PROCEDURE Reko (Activate : BOOLEAN);
VAR Run    : KeyPtr;
    Data   : DataType;
    OBSave : Key;
BEGIN
  SaveKey;
  StartPtr := NIL;
  Seek(DataFile, 0);
  While NOT EoF(DataFile) DO
  BEGIN
    Read(DataFile, Data);
    IF Data.Valid OR
      ((NOT Data.Valid) AND Activate) THEN
    BEGIN
      Run := StartPtr;
      OBSave := Data.OB;
      IF IgnoreCase THEN Data.OB := Upper(Data.OB);
      IF ExpandOB THEN Data.OB := Expand(Data.OB);
      Add(Data, System.FilePos(DataFile), Run);
      Data.OB := OBSave;
    END;
    IF (NOT Data.Valid) AND Activate THEN
    BEGIN
      Seek(DataFile, System.FilePos(DataFile) - 1);
      Data.Valid := TRUE;
      Write(DataFile, Data);
    END;
  END;
END;

{-----------------------------------------}

PROCEDURE CloseDatabase;
VAR IOR : WORD;
BEGIN
  SaveKey;
  IOR := 0;
  {$I-}
    Close (DataFile);
    IOR := IOResult;
    Close (IndexFile);
    IF IOR = 0 THEN IOR := IOResult;
  {$I+}
  IsamError := IOR;
END;

{-----------------------------------------}

{$F+}
FUNCTION HeapFunc (Size : WORD) : INTEGER;
BEGIN
  IsamError := 1; HeapFunc := 1;
END;
{$F-}

{-----------------------------------------}

{$F+}
PROCEDURE NewExit;
BEGIN
  CloseDataBase;
  ExitProc := OldExit;
END;
{$F-}

{-----------------------------------------}

BEGIN { Initialisierungsteil }
  StartPtr  := NIL; HelpPtr   := NIL;
  NextPtr   := NIL; OldExit   := ExitProc;
  ExitProc  := @NewExit; Next := 0;
  HeapError := @HeapFunc;
  IsamError := 0;
  Assign (DataFile, FileName + '.DAT');
  Assign (IndexFile, FileName + '.IDX');
END.  { Initialisierungsteil }