[Back to OOP SWAG index] [Back to Main SWAG index] [Original]
uses Objects, Drivers, Views, Menus, Dialogs, App, Layout, OODB;
{ layout and OODB are at the end !!}
const
DBFileName = 'dbdemo.dat';
MaxLen = 25;
CollLimit = $7F; CollDelta = 4;
InvPID = 1;
cmInfo = 100;
cmOpen = 101;
cmShut = 102;
cmStat = 103;
cmCreate = 105;
cmGet = 106;
cmDelete = 107;
cmCommit = 108;
cmAbort = 109;
type
NameString = String [MaxLen];
ModDialData =
record
NameData : NameString
end;
TInvCard =
record
Name : NameString;
ID : Word
end;
PInvCard = ^TInvCard;
{ ----- TCatCollection ----- }
TCatCollection =
object (TSortedCollection)
procedure FreeItem (Item: Pointer); virtual;
function GetItem (var S: TStream): Pointer; virtual;
procedure PutItem (var S: TStream; Item: Pointer); virtual;
function Compare (Key1, Key2 : Pointer): Integer; virtual;
end;
PCatCollection = ^TCatCollection;
{ ----- TDemoApplication class ----- }
TDemoApplication =
object (TApplication)
DB : PBase;
DBFile : PDosStream;
constructor Init;
destructor Done; virtual;
procedure InitMenuBar; virtual;
procedure InitStatusLine; virtual;
procedure HandleEvent (var Event: TEvent); virtual;
procedure Idle; virtual;
function NameDialog (Title: TTitleStr):
PDialog; virtual;
procedure About; virtual;
procedure OpenDB; virtual;
procedure ShutDB; virtual;
procedure StatInfo; virtual;
procedure CreateMod; virtual;
procedure GetMod; virtual;
procedure DeleteMod; virtual;
procedure Commit; virtual;
procedure Rollback; virtual;
end;
PDemoApplication = ^TDemoApplication;
{ -- Implementation of TCatCollection -- }
procedure TCatCollection.FreeItem (Item: Pointer);
begin
Dispose (Item)
end; { FreeItem }
function TCatCollection.GetItem (var S: TStream): Pointer;
var Item : PInvCard;
begin
New (Item);
with S do
with Item^ do
begin
Read (Name, SizeOf(Name));
Read (ID, SizeOf(ID))
end;
GetItem := Item
end; { GetItem }
procedure TCatCollection.PutItem (var S: TStream; Item: Pointer);
begin
with S do
with TInvCard(Item^) do
begin
Write (Name, SizeOf(Name));
Write (ID, SizeOf(ID))
end
end; { PutItem }
function TCatCollection.Compare (Key1, Key2 : Pointer): Integer;
var
N1, N2 : NameString;
begin
N1 := TInvCard(Key1^).Name; N2 := TInvCard(Key2^).Name;
if N1 > N2
then Compare := 1
else if N1 < N2
then Compare := -1
else Compare := 0
end; { Compare }
{ -- End of TCatCollection implementation -- }
{ ----- TDemoApplication implementation ----- }
{ ----- Init ----- }
constructor TDemoApplication.Init;
begin
TApplication.Init;
DB := nil
end;
{ ----- Done ----- }
destructor TDemoApplication.Done;
begin
if DB <> nil
then begin
Dispose (DB, Done);
Dispose (DBFile, Done)
end;
TApplication.Done
end;
{ ----- InitMenuBar ----- }
procedure TDemoApplication.InitMenuBar;
var
MenuRect: TRect;
begin
GetExtent (MenuRect);
MenuRect.B.Y := MenuRect.A.Y + 1;
MenuBar := New (PMenuBar, Init (MenuRect, NewMenu (
NewItem ( '~I~nfo', '', kbNoKey, cmInfo, hcNoContext,
NewSubMenu ( '~D~atabase', hcNoContext, NewMenu (
NewItem ( '~O~pen', 'F3', kbF3, cmOpen, hcNoContext,
NewItem ( '~S~hut', 'F4', kbF4, cmShut, hcNoContext,
NewItem ( 'S~t~atistics', '', kbNoKey, cmStat, hcNoContext,
NewLine (
NewItem ( '~E~xit', 'Alt-X', kbAltX, cmQuit, hcNoContext,
nil )))))),
NewSubMenu ( '~M~odules', hcNoContext, NewMenu (
NewItem ( '~C~reate', 'F5', kbF5, cmCreate, hcNoContext,
NewItem ( '~G~et', 'F6', kbF6, cmGet, hcNoContext,
NewItem ( '~D~elete', '', kbNoKey, cmDelete, hcNoContext,
nil )))),
NewSubMenu ( '~T~ransaction', hcNoContext, NewMenu (
NewItem ( '~C~ommit', '', kbNoKey, cmCommit, hcNoContext,
NewItem ( '~R~ollback', '', kbNoKey, cmAbort, hcNoContext,
nil ))),
nil )))))))
end;
{ ----- InitStatusLine ----- }
procedure TDemoApplication.InitStatusLine;
var
StatusRect: TRect;
begin
GetExtent (StatusRect);
StatusRect.A.Y := StatusRect.B.Y - 1;
StatusLine := New (PStatusLine, Init (StatusRect,
NewStatusDef (0, $FFFF,
NewStatusKey ('~Alt-X~ - Exit', kbAltX, cmQuit,
NewStatusKey ('~F3~ - Open database', kbF3, cmOpen,
NewStatusKey ('~F10~ - Menu', kbF10, cmMenu,
nil ))),
nil )))
end;
{ ----- HandleEvent ----- }
procedure TDemoApplication.HandleEvent (var Event: TEvent);
begin
TApplication.HandleEvent (Event);
with Event do
if What = evCommand
then begin
case Command of
cmInfo : About;
cmOpen : OpenDB;
cmShut : ShutDB;
cmStat : StatInfo;
cmCreate : CreateMod;
cmGet : GetMod;
cmDelete : DeleteMod;
cmCommit : Commit;
cmAbort : Rollback;
else
Exit
end;
ClearEvent (Event)
end
end;
{ ----- Idle ----- }
procedure TDemoApplication.Idle;
begin
TApplication.Idle;
if DB <> nil
then DB^.IdlePack
end;
{ ----- NameDialog ----- }
function TDemoApplication.NameDialog (Title: TTitleStr): PDialog;
var
X, Y : Word;
R : TRect;
Dial : PDialog;
Bruce : PView;
begin
if DB = nil
then begin
HandleError ( ^C'Open database at first !' );
NameDialog := nil;
Exit
end;
Randomize;
X := 2 + Random (50); Y := 2 + Random (12);
R.Assign (X,Y,X+28,Y+9);
New (Dial, Init (R, Title));
with Dial^ do
begin
R.Assign (2,6,12,8);
Insert (New (PButton, Init (R, '~O~k', cmOK, bfDefault)));
R.Assign (14,6,24,8);
Insert (New (PButton,
Init (R, '~C~ancel', cmCancel, bfNormal)));
R.Assign (3,3,25,4);
Bruce := New (PInputLine, Init (R, MaxLen));
Insert (Bruce);
R.Assign (2,2,20,3);
Insert (New (PLabel, Init (R, 'Module name:', Bruce)))
end;
NameDialog := Dial
end;
{ ----- About ----- }
procedure TDemoApplication.About;
var
R: TRect;
begin
R.Assign (15,3,65,16);
Inform
( R,
^C'This program is intended to demonstrate'^M +
^C'some features of OODBMS'^M +
^C'(object-oriented database management system).'^M +
^C'OODBMS as well as this demo'^M +
^C'is developed independently by Shmatikov V.'^M^M +
^C'Spring 1992',
nil )
end;
{ ----- OpenDB ----- }
procedure TDemoApplication.OpenDB;
var
Dial : PDialog;
C : Word;
DBIsNew : Boolean;
Invent : PCatCollection;
begin
DBIsNew := False;
if DB = nil
then begin
if Confirm ( ^C'You are to open database.'^M +
^C'Choose Ok to proceed ...' ) =
cmCancel
then Exit;
New (DBFile, Init (DBFileName, stOpen));
if DBFile^.Status <> stOk
then begin
Dispose (DBFile, Done);
New (DBFile, Init (DBFileName, stCreate));
DBIsNew := True;
end;
New (DB, Init (DBFile));
if DBIsNew
then begin
New (Invent, Init (CollLimit, CollDelta));
DB^.Put (InvPID, Invent);
Inc (DB^.PIDCurrent);
Dispose (Invent, Done)
end;
DB^.Commit
end
else HandleError ( ^C'Database is in use already !' )
end;
{ ----- ShutDB ----- }
procedure TDemoApplication.ShutDB;
var
Dial : PDialog;
C : Word;
begin
if DB <> nil
then begin
if Confirm ( ^C'You are about to close database'^M +
^C'Choose Ok to do it !' ) =
cmCancel
then Exit;
Dispose (DB, Done); DB := nil;
Dispose (DBFile, Done); DBFile := nil
end
else HandleError ( ^C'No database is in use now !' )
end;
{ ----- StatInfo ----- }
procedure TDemoApplication.StatInfo;
type
InfoRec =
record
FileName : PString;
NumObj, SizeObj,
NumHoles, SizeHoles,
SizeAnc, TotalSize : Longint
end;
var
R : TRect;
DataRec : InfoRec;
i : Integer;
begin
if DB = nil
then begin
HandleError ( ^C'Open database at first !' );
Exit
end;
with DB^ do
with DataRec do
begin
FileName^ := DBFileName;
NumObj := 0; SizeObj := 0;
For i := 2 to DBIndex^.Count - 1 do
if (IndRec(DBIndex^.At(i)^).Base = i) and
(IndRec(DBIndex^.At(1)^).Base <> i)
then begin
Inc (NumObj);
SizeObj := SizeObj +
IndRec(DBIndex^.At(i)^).Size
end;
NumHoles := HolesIndex^.Count; SizeHoles := 0;
For i := 0 to NumHoles-1 do
SizeHoles := SizeHoles +
IndRec(HolesIndex^.At(i)^).Size;
SizeAnc := DBFile^.GetSize - SizeObj - SizeHoles;
TotalSize := DBFile^.GetSize
end;
R.Assign (10,2,70,15);
Inform
( R,
'Database file "%s" is in use'^M^M +
' - %d user object(s) hold(s) %d byte(s) in file'^M +
' - %d hole(s) hold(s) %d byte(s) in file'^M +
' - Ancillary information holds %d byte(s)'^M +
' - Total size of database is %d byte(s)',
@DataRec )
end;
{ ----- CreateMod ----- }
procedure TDemoApplication.CreateMod;
var
NewDial : PDialog;
C : Word;
DialData : ModDialData;
Card : PInvCard;
Invent : PCatCollection;
PID : Word;
begin
NewDial := NameDialog ('New module');
if NewDial = nil
then Exit;
C := DeskTop^.ExecView (NewDial);
if C <> CmCancel
then begin
NewDial^.GetData (DialData);
if DialData.NameData <> ''
then begin
Invent := PCatCollection (DB^.Get (InvPID));
New (Card);
PID := DB^.Create;
Card^.Name := DialData.NameData;
Card^.ID := PID;
Invent^.Insert (Card);
DB^.Put (PID, NewDial);
DB^.Destroy (InvPID);
DB^.Put (InvPID, Invent);
Dispose (Invent, Done)
end
end;
Dispose (NewDial, Done)
end;
{ ----- GetMod ----- }
procedure TDemoApplication.GetMod;
var
Dial,
DialFromDB : PDialog;
C : Word;
DialData : ModDialData;
Card : PInvCard;
Invent : PCatCollection;
Ind : Integer;
begin
Dial := NameDialog ('Get');
if Dial = nil
then Exit;
C := DeskTop^.ExecView (Dial);
if C <> CmCancel
then begin
Dial^.GetData (DialData);
New (Card);
Card^.Name := DialData.NameData;
Invent := PCatCollection (DB^.Get (InvPID));
if Invent^.Search (Card, Ind)
then begin
DialFromDB :=
PDialog (DB^.Get
(TInvCard(Invent^.At(Ind)^).ID));
C := ExecView (DialFromDB);
Dispose (DialFromDB, Done)
end;
Dispose (Invent, Done)
end;
Dispose (Dial, Done)
end;
{ ----- DeleteMod ----- }
procedure TDemoApplication.DeleteMod;
var
Dial : PDialog;
C : Word;
DialData : ModDialData;
Card : PInvCard;
Invent : PCatCollection;
Ind : Integer;
begin
Dial := NameDialog ('Delete');
if Dial = nil
then Exit;
C := DeskTop^.ExecView (Dial);
if C <> CmCancel
then begin
Dial^.GetData (DialData);
New (Card);
Card^.Name := DialData.NameData;
Invent := PCatCollection (DB^.Get (InvPID));
if Invent^.Search (Card, Ind)
then begin
DB^.Destroy (TInvCard(Invent^.At(Ind)^).ID);
Invent^.AtDelete (Ind);
DB^.Destroy (InvPID);
DB^.Put (InvPID, Invent)
end;
Dispose (Invent, Done)
end;
Dispose (Dial, Done)
end;
{ ----- Commit ----- }
procedure TDemoApplication.Commit;
var
Dial : PDialog;
C : Word;
begin
if DB <> nil
then begin
if Confirm
( ^C'All changes you''ve made since last Commit '^M +
^C'will be placed into the database forever !' ) =
cmCancel
then Exit;
DB^.Commit
end
else HandleError ( ^C'No database is in use now !' )
end;
{ ----- Rollback ----- }
procedure TDemoApplication.Rollback;
var
Dial : PDialog;
C : Word;
begin
if DB <> nil
then begin
if Confirm
( ^C'You are restoring database to its old state.'^M +
^C'Changes since last Commit will be lost !' ) =
cmCancel
then Exit;
DB^.Abort;
end
else HandleError ( ^C'No database is in use now !' )
end;
procedure RegisterAll;
const
RCatCollection: TStreamRec =
( ObjType : 10001;
VMTLink : Ofs(TypeOf(TCatCollection)^);
Load : @TCatCollection.Load;
Store : @TCatCollection.Store );
begin
RegisterObjects;
RegisterViews;
RegisterDialogs;
RegisterType (RCatCollection)
end;
{ ----- Program body ----- }
var
DA : TDemoApplication;
begin
RegisterAll;
DA.Init;
DA.Run;
DA.Done
end.
{ --------------------- LAYOUT.PAS ---------------------- }
{ CUT }
unit Layout;
interface
uses Objects, MsgBox;
procedure HandleError ( Mess: String );
procedure Inform ( R: TRect; Mess: String; Params: Pointer );
function Confirm ( Mess: String ): Word;
implementation
procedure HandleError ( Mess: String );
var C: Word;
begin
C := MessageBox ( Mess, nil, mfError + mfOKButton )
end;
procedure Inform ( R: TRect; Mess: String; Params: Pointer );
var C: Word;
begin
C := MessageBoxRect ( R, Mess, Params,
mfInformation + mfOKButton )
end;
function Confirm ( Mess: String ): Word;
var R: TRect;
begin
R.Assign (10,4,60,12);
Confirm := MessageBoxRect ( R, Mess, nil,
mfConfirmation + mfOKCancel )
end;
end.
{ --------------------- OODB.PAS ---------------------- }
{ CUT }
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.
[Back to OOP SWAG index] [Back to Main SWAG index] [Original]