Power-Programmierung/CD1.mdf/pascal/library/dos/database/oodb/oodb.pas

Pascal/Delphi Source File | 1992-07-13 | 25.3 KB | 747 lines

unit OODB;

interface

   uses Objects;

   const
      PIDLimit: Word = $7FFF;
      Delta = 4;
      Hallmark = 9999;
      IndexPointerLocation = 4;
      StorageStart = 8;

   type

      { Record type for object registration }

      IndRec =
         record
            ID        : Word;
            StartPos,
            Size      : Longint;
            Base      : Integer
         end;
      PIndRec = ^IndRec;

      { Stream for object size evaluation }

      TNullStream =
         object (TStream)
            SizeCounter : Longint;
            constructor Init;
            procedure   ResetCounter;                   virtual;
            procedure   Write (var Buf; Count: Word);   virtual;
            function    SizeInStream: Longint;          virtual;
         end;
      PNullStream = ^TNullStream;

      { Stream - database main storage }

      DBStream = TStream;
      PDBStream = ^DBStream;

      { Collection for indexes }

      TIndexCollection =
         object (TCollection)
            procedure FreeItem (Item: Pointer);                 virtual;
            function  GetItem (var S: TStream): Pointer;        virtual;
            procedure PutItem (var S: TStream; Item: Pointer);  virtual;
         end;
      PIndexCollection = ^TIndexCollection;

      { --- TBASE - the main class --- }

      TBase =
         object (TObject)

            BaseStream : PDBStream;         { Main storage pointer }
            DBIndex,                        { Database index }
            HolesIndex : PIndexCollection;  { Holes index }
            PIDCurrent : Word;              { Unique identifier }
            NS         : PNullStream;       { For object size evaluation }
            DoneFlag   : Boolean;           { True if OODB is being disposed }

            function  BytesInStream (P: PObject): Longint ;
                               virtual;
            procedure IndexSort (Cat: PIndexCollection; StOrd: Boolean);
                               virtual;
            function  IndexFound (Cat: PIndexCollection;
                                  LookFor: Longint;
                                  var Pos: Integer;
                                  PIDSorted: Boolean): Boolean;
                               virtual;
            function  HoleFound (S: Longint; var Pos: Longint): Boolean;
                               virtual;

            procedure   Abort;                          virtual;
            procedure   Commit;                         virtual;
            constructor Init (AStream: PDBStream);
            destructor  Done;                           virtual;
            function    Create: Word;                   virtual;
            procedure   Put (PID: Word; P: PObject);    virtual;
            function    Get (PID: Word): PObject;       virtual;
            procedure   Destroy (PID: Word);            virtual;

            function    ObjSize (PID: Word): Longint;   virtual;
            function    Count: Integer;                 virtual;

            procedure   IdlePack;                       virtual;

         end; { -- TBase -- }
      PBase = ^TBase;

implementation

   { -- Implementation of TNullStream -- }

   constructor TNullStream.Init;
      begin
         TStream.Init;
         ResetCounter
      end;

   procedure TNullStream.ResetCounter;
      begin
         SizeCounter := 0
      end;

   procedure TNullStream.Write (var Buf; Count: Word);
      { Overrides TStream.Write method }
      begin
         SizeCounter := SizeCounter + Count
      end;

   function TNullStream.SizeInStream: Longint;
      begin
         SizeInStream := SizeCounter
      end;

   { -- End of TNullStream implementation -- }

   { -- Implementation of TIndexCollection -- }

   procedure TIndexCollection.FreeItem (Item: Pointer);

      begin
         Dispose (Item)
      end;  { FreeItem }

   function TIndexCollection.GetItem (var S: TStream): Pointer;

      var Item : PIndRec;

      begin
         New (Item);
         with S do
              with Item^ do
                   begin
                      Read (ID, SizeOf(ID));
                      Read (StartPos, SizeOf(StartPos));
                      Read (Size, SizeOf(Size));
                      Read (Base, SizeOf(Base))
                   end;
         GetItem := Item
      end;  { GetItem }

   procedure TIndexCollection.PutItem (var S: TStream; Item: Pointer);

      begin
         with S do
              with IndRec(Item^) do
                   begin
                      Write (ID, SizeOf(ID));
                      Write (StartPos, SizeOf(StartPos));
                      Write (Size, SizeOf(Size));
                      Write (Base, SizeOf(Base))
                   end
      end;  { PutItem }

   { -- End of TIndexCollection implementation -- }

   { -- TBASE IMPLEMENTATION -- }

   { ----- BytesInStream ------------------------------------------ }

   function TBase.BytesInStream (P: PObject): Longint ;

   { Determines the number of bytes required
     to put an object into the stream }

      begin
         with NS^ do
              begin
                 ResetCounter;
                 Put (P);
                 BytesInStream := SizeInStream
              end
      end;

   { ----- IndexSort ---------------------------------------------- }

   procedure TBase.IndexSort (Cat: PIndexCollection; StOrd: Boolean);

   { Bubble-sorts any index (DBIndex or HolesIndex) according either to
     StartPos'es in a stream (StOrd = True) or to PID's (StOrd = False) }

      var
         i, j, k : Integer;
         Min     : Longint;
         Aux     : PIndRec;

      begin

         with Cat^ do

              for i := 0 to Count-2 do

                  begin
                     if StOrd
                        then begin
                                Min := IndRec(At(i)^).StartPos; k := i;
                                for j := i+1 to Count-1 do
                                    if IndRec(At(j)^).StartPos < Min
                                        then begin
                                                k := j;
                                                Min := IndRec(At(k)^).StartPos
                                             end
                             end
                        else begin
                                Min := IndRec(At(i)^).ID; k := i;
                                for j := i+1 to Count-1 do
                                    if IndRec(At(j)^).ID < Min
                                       then begin
                                               k := j;
                                               Min := IndRec(At(k)^).ID
                                            end
                             end;
                     Aux := At (i);
                     AtPut (i,At(k)); AtPut (k,Aux)    { Bubble is up }
                  end  { for }

      end; { IndexSort }

   { ----- IndexFound --------------------------------------------- }

   function TBase.IndexFound
                  (Cat: PIndexCollection; LookFor: Longint;
                   var Pos: Integer; PIDSorted: Boolean)    : Boolean;

   { Looks for LookFor in Cat^ index (binary search) and returns True
     if hits it. Position for LookFor (Pos) is located by all means }

      var
         m, j  : Integer;
         Value : Longint;     { Value that is found }

      begin

         IndexFound := False;
         with Cat^ do
              begin
                 Pos := 0; j := Count-1;
                 if j < Pos
                    then Exit;
                 while j > Pos do
                       begin
                          m := ( Pos + j ) div 2;
                          if ( PIDSorted and
                               (IndRec(At(m)^).ID >= LookFor) )
                             or
                             ( not PIDSorted and
                               (IndRec(At(m)^).StartPos >= LookFor) )
                             then j := m
                             else Pos := m + 1
                       end; { while }
                 if PIDSorted
                    then Value := IndRec(At(Pos)^).ID
                    else Value := IndRec(At(Pos)^).StartPos;
                 if Value < LookFor
                    then Pos := Pos + 1
                    else if Value = LookFor
                            then IndexFound := True
              end  { with }

      end; { IndexFound }

   { ----- HoleFound ---------------------------------------------- }

   function TBase.HoleFound (S: Longint; var Pos: Longint): Boolean;

   { Looks for a hole in a storage stream.
     Linear search, FIRST-FIT }

      var
         Found : Boolean;
         i     : Integer;

      begin

         with HolesIndex^ do
              begin
                 Found := False; i := 0;
                 while not (Found or (i > Count-1)) do
                       begin
                          with IndRec(At(i)^) do
                               if Size >= S
                                  then begin
                                          Found := True;
                                          Pos := StartPos;
                                          Size := Size - S;
                                          if Size = 0
                                             then AtDelete(i)
                                       end; { if }
                          i := i + 1
                       end  { while }
              end;  { with }
         HoleFound := Found

      end; { HoleFound }

   { ----- Abort ---------------------------------------------- }

   procedure TBase.Abort;

   { Cancels transaction. Restores old DBIndex and HolesIndex }

      var
         HoleStart,               { Start of probable hole }
         Diff,                    { Length of probable hole }
         IndLoc      : Longint;   { Old DBIndex location in stream }
         i           : Integer;
         NewRec      : PIndRec;   { Hole registration card }

      begin

         Dispose (DBIndex, Done);    { Destroying old indexes }
         Dispose (HolesIndex, Done);
         with BaseStream^ do
              begin
                 Seek (IndexPointerLocation); Read (IndLoc,4);
                 Seek (IndLoc); DBIndex := PIndexCollection (Get)
              end;
         New (HolesIndex, Init(PIDLimit,Delta));
         with DBIndex^ do
              begin
                 HoleStart := StorageStart;
                 for i := 0 to Count-1 do
                     begin
                        Diff := IndRec(At(i)^).StartPos - HoleStart;
                        if Diff > 0
                           then begin
                                   New (NewRec);
                                   with NewRec^ do
                                        begin
                                           StartPos := HoleStart;
                                           Size := Diff
                                        end;
                                   HolesIndex^.Insert(NewRec)
                                end;  { if }
                        HoleStart := IndRec(At(i)^).StartPos +
                                        IndRec(At(i)^).Size
                     end;  { for }
                 BaseStream^.Seek (HoleStart); BaseStream^.Truncate
              end;  { with }
         IndexSort (DBIndex, False);
         IndexSort (HolesIndex, True);
         PIDCurrent := IndRec(DBIndex^.At(DBIndex^.Count-1)^).ID + 1

      end;  { Abort }

   { ----- Commit ---------------------------------------------- }

   procedure TBase.Commit;

   { Acknowledges transaction by putting DBIndex into the stream }

      var
         S,                      { Size of DBIndex }
         IndLoc     : Longint;   { Index location in stream }
         i, BasePos : Integer;   { Auxiliary variables }

      begin

         with DBIndex^ do
              begin

                 for i := 0 to Count-1 do
                     begin
                        BasePos := IndRec(At(i)^).Base;
                        if (BasePos <> -1) and (BasePos <> i)
                           then begin
                                   IndRec(At(i)^).Size :=
                                         IndRec(At(BasePos)^).Size;
                                   IndRec(At(i)^).StartPos :=
                                         IndRec(At(BasePos)^).StartPos;
                                   IndRec(At(i)^).Base := i;
                                   IndRec(At(BasePos)^).Base := -1
                                end
                     end;  { for }

                 i := 0;
                 while ( i < Count ) do
                       if IndRec(At(i)^).Base = -1
                          then AtDelete (i)
                          else i := i + 1;

                 for i := 0 to Count-1 do
                     IndRec(At(i)^).Base := i

              end;   { with }

         S := BytesInStream (DBIndex);
         if not HoleFound (S, IndLoc)
            then IndLoc := BaseStream^.GetSize;
         with IndRec(DBIndex^.At(0)^) do
              begin
                 ID := 0;
                 StartPos := IndLoc;
                 Size := S;
                 Base := 0
              end;
         IndexSort (DBIndex, True);
         with BaseStream^ do
              begin
                 Seek (IndLoc); Put (DBIndex);
                 Seek (IndexPointerLocation); Write (IndLoc,4)
              end;
         if not DoneFlag
            then Abort

      end;  { Commit }

   { ----- Init ---------------------------------------------- }

   constructor TBase.Init (AStream: PDBStream);

   { Opens an existing database stream or creates a new one }

      var
         Descr     : Longint;    { Stream descriptor }
         IndexCard : PIndRec;    { DBIndex registration card }

      begin

         TObject.Init;
         BaseStream := AStream;
         New (NS, Init);
         New (DBIndex, Init(PIDLimit,Delta));
         New (HolesIndex, Init(PIDLimit,Delta));
         DoneFlag := False;
         with BaseStream^ do
              begin
                 Descr := 0;
                 Seek (0);
                 if GetSize > 3 then
                    Read (Descr,4);
                 if Descr = Hallmark
                    then Abort
                    else begin
                            Descr := Hallmark;
                            Seek (0); Truncate; Write (Descr,4);
                            Seek (IndexPointerLocation); Write (Descr,4);
                            New (IndexCard);
                            With IndexCard^ do
                                 begin
                                    ID := 0;
                                    StartPos := StorageStart;
                                    Size := 0;
                                    Base := 0
                                 end;
                            DBIndex^.AtInsert (0,IndexCard);
                            Commit
                         end
              end  { with }

      end;  {  Init  }

   { ----- Done ---------------------------------------------- }

   destructor TBase.Done;

   { Done is done ! }

      begin
         DoneFlag := True;
         Commit;
         Dispose (NS, Done);
         Dispose (DBIndex, Done);
         Dispose (HolesIndex, Done)
      end;  { Done }

   { ----- Create ---------------------------------------------- }

   function TBase.Create : Word;

   { Generates unique identifier }

      begin
         if PIDCurrent < PIDLimit
            then begin
                    Create := PIDCurrent;
                    PIDCurrent := PIDCurrent + 1
                 end
            else Create := 0
      end;  { Create }

   { ----- Destroy ---------------------------------------------- }

   procedure TBase.Destroy (PID: Word);

   { Marks object registration card in DBIndex as destroyed (Base = -1).
     If object's base has existed in a stream, it becomes a hole.
     Object doesn't vanish from a stream until transaction is over
     (Commit or Done). }

      var
         Pos,                     { Number of object's card in DBIndex }
         HolePos,                 { Number of a potential hole }
         BasePos     : Integer;
         BaseStart,
         BaseSize    : Longint;   { Charasteristics of object's base }
         NewRec      : PIndRec;   { New hole }
         i           : Integer;

      begin

         with DBIndex^ do
           begin
             if not IndexFound (DBIndex, PID, Pos, True)
                then Exit;
             BasePos := IndRec(At(Pos)^).Base;
             IndRec(At(Pos)^).Base := -1;
             if (BasePos = -1) or (BasePos = Pos)
                then Exit;
             if IndexFound (HolesIndex, IndRec(At(BasePos)^).StartPos,
                            HolePos, False)
                then Halt (1);
             BaseStart := IndRec(At(BasePos)^).StartPos;
             BaseSize  := IndRec(At(BasePos)^).Size;
             if HolePos < HolesIndex^.Count
                then if BaseStart + BasePos =
                        IndRec(HolesIndex^.At(HolePos)^).StartPos
                        then begin
                               IndRec(HolesIndex^.At(HolePos)^).StartPos :=
                                      BaseStart;
                               IndRec(HolesIndex^.At(HolePos)^).Size :=
                                      IndRec(HolesIndex^.At(HolePos)^).Size +
                                      BaseSize;
                               Exit
                             end;
             if BaseStart + BaseSize < BaseStream^.GetSize
                then begin
                        New (NewRec);
                        NewRec^.StartPos := BaseStart;
                        NewRec^.Size := BaseSize;
                        HolesIndex^.AtInsert (HolePos, NewRec)
                     end
                else begin
                        BaseStream^.Seek (BaseStart);
                        BaseStream^.Truncate
                     end;
             AtDelete (BasePos);
             for i := BasePos to Count-1 do
                 if IndRec(At(i)^).Base <> -1
                    then IndRec(At(i)^).Base := IndRec(At(i)^).Base-1
           end  { with }

      end;  { Destroy }

   { ----- Put ---------------------------------------------- }

   procedure TBase.Put (PID: Word; P: PObject);

   { Puts an object into the database }

      var
         StreamPos, S : Longint;   { Location and size of an object }
         Pos,                      { Number of object registration card }
         BasePos      : Integer;   { Number of object's base card }
         NewRec       : PIndRec;   { Object registration card }

      begin

         if PID >= PIDLimit
            then Exit;
         with DBIndex^ do
              if IndexFound (DBIndex, PID, Pos, True)
                 then begin
                         BasePos := IndRec(At(Pos)^).Base;
                         if BasePos <> Pos
                            then begin
                                    if BasePos <> -1
                                       then Exit;
                                    PID := Create;
                                    if IndexFound (DBIndex, PID,
                                                   BasePos, True )
                                       then Halt (1);
                                    IndRec(At(Pos)^).Base := BasePos;
                                    Pos := BasePos
                                 end  { if }
                      end;  { if }
         S := BytesInStream (P);
         if not HoleFound (S, StreamPos)
            then StreamPos := BaseStream^.GetSize;
         New (NewRec);
         with NewRec^ do
              begin
                 ID := PID;
                 StartPos := StreamPos;
                 Size := S;
                 Base := Pos
              end;
         DBIndex^.AtInsert (Pos, NewRec);
         with BaseStream^ do
              begin
                 Seek (StreamPos); Put (P)
              end

      end;  { Put }

   { ----- Get ---------------------------------------------- }

   function TBase.Get (PID: Word): PObject;

   { Gets an object from the database }

      var
         Pos,                { Number of object registration card }
         BasePos : Integer;  { Number of object's base card }

      begin
         Get := Nil;
         if IndexFound (DBIndex, PID, Pos, True)
            then begin
                    BasePos := IndRec(DBIndex^.At(Pos)^).Base;
                    if BasePos <> -1
                       then begin
                               BaseStream^.Seek
                                   (IndRec(DBIndex^.At(BasePos)^).StartPos);
                               Get := BaseStream^.Get
                            end  { if }
                 end  { if }
      end;  { Get }

   { ----- ObjSize ---------------------------------------------- }

   function TBase.ObjSize (PID: Word): Longint;

   { Returns the size of an object }

      var
         Pos,                { Number of object registration card }
         BasePos : Integer;  { Number of object's base card }

      begin
         ObjSize := 0;
         if IndexFound (DBIndex, PID, Pos, True)
            then begin
                    BasePos := IndRec(DBIndex^.At(Pos)^).Base;
                    if BasePos <> -1
                       then ObjSize := IndRec(DBIndex^.At(BasePos)^).Size
                 end  { if }
      end;  { ObjSize }

   { ----- Count ---------------------------------------------- }

   function TBase.Count: Integer;

   { Returns the number of objects in the database }

      begin
         Count := DBIndex^.Count
      end;  { Count }

   { ----- IdlePack ---------------------------------------------- }

   procedure TBase.IdlePack;

   { Makes a single step of database packing.
     Method (just now) - simple sequential relocation.
     Before object is relocated, old index is gotten
     from the stream and then put back with proper amendments. }

      var
          P         : PObject;           { Relocated object }
          OldLoc,                        { Old location of relocated object }
          NewLoc,                        { New location of relocated object }
          IndLoc    : Longint;           { Location of old DBIndex }
          OldIndex  : PIndexCollection;  { Old DBIndex }
          Pos       : Integer;           { Posititon of relocated object
                                           in the index }

      begin

         with HolesIndex^ do
           with BaseStream^ do
             begin

               if Count = 0
                  then Exit;
               OldLoc := IndRec(At(0)^).StartPos + IndRec(At(0)^).Size;
               NewLoc := IndRec(At(0)^).StartPos;
               Seek (OldLoc); P := Get;
               if P = Nil
                  then begin
                          Reset;
                          Seek (NewLoc); Truncate;
                          AtDelete (0);
                          Exit
                       end;
               Seek (IndexPointerLocation); Read (IndLoc,4);
               Seek (IndLoc); OldIndex := PIndexCollection (Get);

               if IndexFound (OldIndex, OldLoc, Pos, False)
                  then begin
                          IndRec(OldIndex^.At(Pos)^).StartPos := NewLoc;
                          if not IndexFound (DBIndex,
                                             IndRec(OldIndex^.At(Pos)^).ID,
                                             Pos, True)
                             then Halt (1)
                       end
                  else begin
                          Pos := 0;
                          while (IndRec(DBIndex^.At(Pos)^).StartPos <>
                                 OldLoc) do
                                Pos := Pos + 1
                        end;
               IndRec(DBIndex^.At(Pos)^).StartPos := NewLoc;

               if OldLoc = IndLoc
                  then IndLoc := NewLoc;
               Seek (NewLoc); Put (P);
               Seek (IndexPointerLocation); Write (IndLoc,4);
               Seek (IndLoc); Put (OldIndex);
               Dispose (P,Done); Dispose (OldIndex, Done);

               IndRec(At(0)^).StartPos :=
                      NewLoc + IndRec(DBIndex^.At(Pos)^).Size;
               if Count > 1
                  then if ( IndRec(At(0)^).StartPos + IndRec(At(0)^).Size =
                            IndRec(At(1)^).StartPos )
                          then begin
                                 IndRec(At(0)^).Size :=
                                 IndRec(At(0)^).Size + IndRec(At(1)^).Size;
                                 AtDelete (1)
                               end

             end  { With }
      end;  { IdlePack }

    { -- End of TBase implementation -- }

   const
      RIndexCollection: TStreamRec =
         ( ObjType : 10000;
           VMTLink : Ofs(TypeOf(TIndexCollection)^);
           Load    : @TIndexCollection.Load;
           Store   : @TIndexCollection.Store );

begin

  { Unit body }

  RegisterType (RIndexCollection)

end.