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

Pascal/Delphi Source File | 1992-04-29 | 17.9 KB | 597 lines

uses Objects, Drivers, Views, Menus, Dialogs, App, Layout, OODB;

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.