Monster Media 1994 #1/monster.zip/monster/PROG_GEN/TCYBER.ZIP/CYBASE.PAS

Pascal/Delphi Source File | 1994-01-15 | 17KB | 732 lines

{
Turbo Vision CyberTools 1.0
(C) 1994 Steve Goldsmith
All Rights Reserved

CyberBase Application using PX Browse unit to edit multiple Paradox tables
on single user or network systems.  Table passwords, encryption, decryption,
delete and empty are supported.  Status bar on status lines reports what
the app is doing during table operations.

Borland Pascal 7.x or Turbo Pascal 7.x, Turbo Vision 2.x and Paradox
Engine 3.x Database Framework are required to compile.

Set IDE directories to

\BP\UNITS;
\BP\EXAMPLES\DOS\TVDEMO;
\BP\EXAMPLES\DOS\TVFM;
\BP\PXENGINE\PASCAL\SOURCE;
\BP\PXENGINE\PASCAL;

I used \BP\PXENGINE when I installed Paradox Engine 3.0.  The rest of the
path names use BP 7.x defaults.  If you changed any of these then use the
correct paths in Options|Directories...  See APP.INC for global compiler
switches.
}

{$I APP.INC}
{$X+}

program CyberBase;

uses

  Dos,                           {system units}
  OOPXEng, PXEngine,             {paradox engine 3.0 and framework units}
  Memory, Drivers, Objects,      {tv units}
  Views, Menus, Dialogs,
  App, MsgBox, StdDlg,
  Gadgets, Calendar, Calc,       {tv demo units}
  ViewText,                      {tvfm units}
  CBCmds, PXBrowse;              {cybertools units}

type

  TCyberBase = object(TApplication)
    appEnv : TEnv;
    appEngine : TEngine;
    appDatabase : TDatabase;
    appStatus : PInputLine;
    Clock : PClockView;
    Heap : PHeapView;
    constructor Init;
    destructor Done; virtual;
    procedure UpdateStatus (S : string);
    function ErrorBox (ErrCode : integer) : boolean;
    procedure AboutBox;
    procedure Idle; virtual;
    procedure ClearDeskTop;
    function SelectFile (Title : string; WildCard : PathStr; ReadFlag : boolean) : PathStr;
    procedure SaveConfig;
    procedure LoadConfig;
    procedure AddPassword;
    procedure NewBrowser;
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure InitMenuBar; virtual;
    procedure InitStatusLine; virtual;
    procedure OutOfMemory; virtual;
  end;

const

  appRecords = 4;            {use 4 record browser}
  appIndex = 0;              {open tables on primary index}
  appViewDocBuf = 8192;      {buffer size for viewing doc file}
  appDocName  = 'CYBER.DOC'; {doc file name}
  appCfgName = 'CYBASE.CFG'; {config file name}
  appReadyMsg = 'READY';     {ready status}

{
Init app, engine and database.
}

constructor TCyberBase.Init;

var

  R : TRect;

begin
  LowMemSize := 2048; {32768 byte safety pool}
  inherited Init;

  R.Assign (64,0,70,1);
  Heap := New (PHeapView,Init(R));
  Insert (Heap);

  R.Assign (71,0,79,1);
  Clock := New (PClockView,Init (R)); {gadgets included with tvdemo}
  Insert (Clock);

  R.Assign (70,24,80,25);
  appStatus := New (PInputLine,Init (R,10));
  appStatus^.Options := appStatus^.Options and not ofSelectable;
  appStatus^.GrowMode := gfGrowAll;
  Insert (appStatus);

  LoadConfig;                         {load engine config}
  appEngine.Init (@appEnv);           {init engine}
  ErrorBox (appEngine.lastError);
  appDatabase.Init (@appEngine);      {init database}
  ErrorBox (appDataBase.lastError)
end;

{
Close database and engine if open before calling inherited done.
}

destructor TCyberBase.Done;

begin
  if appDataBase.isOpen then
    appDatabase.Done;
  if appEngine.isOpen then
    appEngine.Done;
  inherited Done
end;

{
Update dialog status line.
}

procedure TCyberBase.UpdateStatus (S : string);

begin
  appStatus^.SetData (S)
end;

{
Display error and return true if error <> PXSUCCESS.  If error = PXSUCCESS
then no error is diaplayed and false is returned.
}

function TCyberBase.ErrorBox (ErrCode : integer) : boolean;

begin
  if ErrCode <> PxSuccess then
  begin
    MessageBox (appEngine.getErrorMessage (ErrCode),nil, mfError or mfOKButton);
    ErrorBox := true
  end
  else
    ErrorBox := false
end;

{
Tells what the app is about and what mode it is running in.
}

procedure TCyberBase.AboutBox;

begin
  MessageBox(
    #3'Turbo Vision CyberTools 1.0'#13+
    #3'(C) 1994 Steve Goldsmith'#13+
{$IFDEF DPMI}
    #3'CyberBase »> PROTECTED <«',
{$ELSE}
    #3'CyberBase »> REAL <«',
{$ENDIF}
    nil, mfInformation or mfOKButton)
end;

{
Update status line and gadgets during idle processing.
}

procedure TCyberBase.Idle;

function IsTileable (P : PView) : Boolean; far;

begin
  IsTileable := (P^.Options and ofTileable <> 0) and
  (P^.State and sfVisible <> 0)
end;

function IsThere (P : PView) : Boolean; far;

begin
  IsThere := (P^.State and sfActive = sfActive)
end;

function IsModal (P : PView) : Boolean; far;

begin
  IsModal := (P^.State and sfModal = sfModal)
end;

begin
  inherited Idle;
  Clock^.Update;                               {update tvdemo gadgets}
  Heap^.Update;
  if Desktop^.FirstThat (@IsThere) <> nil then {see if anything is}
  begin                                        {on the desk top}
    EnableCommands ([cmCloseAll]);
    if Desktop^.FirstThat (@IsTileable) <> nil then {see if any tileable}
      EnableCommands ([cmTile,cmCascade])           {windows are on the}
    else                                            {desk top}
      DisableCommands ([cmTile,cmCascade]);
  end
  else
    DisableCommands ([cmCloseAll,cmTile,cmCascade]);
  if (Desktop^.FirstThat (@IsModal) <> nil) then    {see if modal view}
    DisableCommands ([cmQuit,cmOpenTable])          {is on the desk top}
  else
  begin
    if appStatus^.Data^ <> appReadyMsg then
      UpdateStatus (appReadyMsg);
    EnableCommands ([cmQuit,cmOpenTable])
  end
end;

{
Close all windows on desk top.
}

procedure TCyberBase.ClearDeskTop;

procedure CloseDlg (P : PView); far;

begin
  Message (P,evCommand,cmClose,nil)
end;

begin
  UpdateStatus ('CLOSE');
  Desktop^.ForEach (@CloseDlg)
end;

{
Select file from wild card with overwrite warning.
}

function TCyberBase.SelectFile (Title : string; WildCard : PathStr; ReadFlag : boolean) : PathStr;

var

  F : file;

begin
  if ExecuteDialog (New (PFileDialog,Init (WildCard,Title,
    '~N~ame',fdOkButton,100)),@WildCard) <> cmCancel then
  begin
    if ReadFlag then
      SelectFile := WildCard
    else
    begin
      Assign (F,WildCard);
      {$I-} Reset (F); {$I+}
      if IoResult = 0 then {see if file exists before writes}
      begin
        {$I-} Close (F); {$I+}
        if MessageBox (WildCard+' already exists.  Erase and continue?',
        nil,mfConfirmation or mfYesNoCancel) = cmYes then
          SelectFile := WildCard
        else
          SelectFile := ''
      end
      else
        SelectFile := WildCard
    end
  end
  else
    SelectFile := ''
end;

{
Save engine config.
}

procedure TCyberBase.SaveConfig;

var

  CfgFile : file of TEnv;

begin
  UpdateStatus ('SAVE');
  Assign (CfgFile,appCfgName);
  {$I-} Rewrite (CfgFile); {$I+}
  if IoResult = 0 then
  begin
    Write (CfgFile,appEnv);
    Close (CfgFile)
  end
end;

{
Load engine config.
}

procedure TCyberBase.LoadConfig;

var

  CfgFile : file of TEnv;

begin
  UpdateStatus ('LOAD');
  Assign (CfgFile,appCfgName);
  {$I-} Reset (CfgFile); {$I+}
  if IoResult = 0 then
  begin
    Read (CfgFile,appEnv);
    Close (CfgFile)
  end
end;

{
Add master password to engine.
}

procedure TCyberBase.AddPassword;

var

  Password : string;

begin
  Password := '';
  if InputBox ('','Password',Password,15) <> cmCancel then
    ErrorBox (appEngine.addPassword (Password))
end;

{
Open new table browser on primary index.  Any existing index can be used
though.  Handles encrypted tables too.
}

procedure TCyberBase.NewBrowser;

var

  FileName : PathStr;
  BrowseCur : PCursor;

begin
  FileName := SelectFile ('Open Table','*.DB',true);
  if FileName <> '' then
  begin
    UpdateStatus ('OPEN');
    BrowseCur := New (PCursor,InitAndOpen (@appDataBase,FileName,appIndex,true));
    if BrowseCur^.lastError = PXERR_INSUFRIGHTS then
    begin
      AddPassword;
      BrowseCur^.Open (@appDataBase,FileName,appIndex,true)
    end;
    if not ErrorBox (BrowseCur^.lastError) then
      InsertWindow (New (PpxbDialog,Init (appRecords,
      FileName,@appEngine,@appDataBase,BrowseCur,appIndex)))
    else
      Dispose (BrowseCur,Done)
  end
end;

procedure TCyberBase.HandleEvent(var Event: TEvent);

{
Configure and save engine setup.  Be careful when modifing engine values,
since incorrect values can crash the engine with a internal error!
}

procedure EngineConfig;

var

  D : PpxbEngineCfg;
  CfgRec : TpxbEngineCfgRec;

begin
  EngCfgToDlgCfg (appEnv,CfgRec);
  D := New (PpxbEngineCfg,Init);
  if ExecuteDialog (D,@CfgRec) <> cmCancel then
  begin
    DlgCfgToEngCfg (CfgRec,appEnv);
    SaveConfig;
    MessageBox(#3'Changes will not take effect until you reload program.',
    nil, mfInformation or mfOKButton)
  end
end;

{
Lock, delete and unlock table.
}

procedure DeleteTable;

var

  FileName : PathStr;

begin
  FileName := SelectFile ('Delete Table','*.DB',true);
  if FileName <> '' then
  begin
    UpdateStatus ('DELETE');
    if appEngine.engineType <> pxLocal then
    begin
      if not ErrorBox (appDataBase.lockNetFile (FileName,pxFL)) then
      begin
        if appDataBase.deleteTable (FileName) = PXERR_INSUFRIGHTS then
        begin
          AddPassword;
          ErrorBox (appDataBase.deleteTable (FileName))
        end
        else
          ErrorBox (appDataBase.lastError);
        ErrorBox (appDataBase.unlockNetFile (FileName,pxFL))
      end
    end
    else
      if appDataBase.emptyTable (FileName) = PXERR_INSUFRIGHTS then
      begin
        AddPassword;
        ErrorBox (appDataBase.deleteTable (FileName))
      end
      else
        ErrorBox (appDataBase.lastError)
  end
end;

{
Lock, empty and unlock table.
}

procedure EmptyTable;

var

  FileName : PathStr;

begin
  FileName := SelectFile ('Empty Table','*.DB',true);
  if FileName <> '' then
  begin
    UpdateStatus ('EMPTY');
    if appEngine.engineType <> pxLocal then
    begin
      if not ErrorBox (appDataBase.lockNetFile (FileName,pxFL)) then
      begin
        if appDataBase.emptyTable (FileName) = PXERR_INSUFRIGHTS then
        begin
          AddPassword;
          ErrorBox (appDataBase.emptyTable (FileName))
        end
        else
          ErrorBox (appDataBase.lastError);
        ErrorBox (appDataBase.unlockNetFile (FileName,pxFL))
      end
    end
    else
      if appDataBase.emptyTable (FileName) = PXERR_INSUFRIGHTS then
      begin
        AddPassword;
        ErrorBox (appDataBase.emptyTable (FileName))
      end
      else
        ErrorBox (appDataBase.lastError)
  end
end;

{
Get password, lock, encrypt and unlock table.
}

procedure EncryptTable;

var

  FileName : PathStr;
  Password : string;

begin
  FileName := SelectFile ('Encrypt Table','*.DB',true);
  if FileName <> '' then
  begin
    Password := '';
    if InputBox ('Encrypt','Password',Password,15) <> cmCancel then
    begin
      UpdateStatus ('ENCRYPT');
      if appEngine.engineType <> pxLocal then
      begin
        if not ErrorBox (appDataBase.lockNetFile (FileName,pxFL)) then
        begin
          if appDataBase.encryptTable (FileName,Password) = PXERR_INSUFRIGHTS then
          begin
            AddPassword;
            ErrorBox (appDataBase.encryptTable (FileName,Password))
          end
          else
            ErrorBox (appDataBase.lastError);
          ErrorBox (appDataBase.unlockNetFile (FileName,pxFL))
        end
      end
      else
        if appDataBase.encryptTable (FileName,Password) = PXERR_INSUFRIGHTS then
        begin
          AddPassword;
          ErrorBox (appDataBase.encryptTable (FileName,Password))
        end
        else
          ErrorBox (appDataBase.lastError)
      end
    end
end;

{
Lock, decrypt and unlock table.  Password must be in effect for decrypt to
work.
}

procedure DecryptTable;

var

  FileName : PathStr;

begin
  FileName := SelectFile ('Decrypt Table','*.DB',true);
  if FileName <> '' then
  begin
    UpdateStatus ('DECRYPT');
    if appEngine.engineType <> pxLocal then
    begin
      if not ErrorBox (appDataBase.lockNetFile (FileName,pxFL)) then
      begin
        if appDataBase.decryptTable (FileName) = PXERR_INSUFRIGHTS then
        begin
          AddPassword;
          ErrorBox (appDataBase.decryptTable (FileName))
        end
        else
          ErrorBox (appDataBase.lastError);
        ErrorBox (appDataBase.unlockNetFile (FileName,pxFL))
      end
    end
    else
      if appDataBase.decryptTable (FileName) = PXERR_INSUFRIGHTS then
      begin
        AddPassword;
        ErrorBox (appDataBase.decryptTable (FileName))
      end
      else
        ErrorBox (appDataBase.lastError)
  end
end;

{
Switch between 25 and 43/50 line mode.
}

procedure ToggleVideo;

var

  NewMode : word;
  R : TRect;

begin
  NewMode := ScreenMode xor smFont8x8;
  if NewMode and smFont8x8 <> 0 then
    ShadowSize.X := 1
  else
    ShadowSize.X := 2;
  SetScreenMode (NewMode);
  Desktop^.GetExtent (R)
end;

{
TV Demo calendar.
}

procedure Calendar;

var

  P : PCalendarWindow;

begin
  P := New(PCalendarWindow, Init);
  InsertWindow(P)
end;

{
TV Demo calculator.
}

procedure Calculator;

var

  P : PCalculator;
begin
  P := New(PCalculator, Init);
  InsertWindow(P)
end;

{
View doc file.
}

procedure ViewTextFile (FileName : PathStr);

var

  T : PTextWindow;
  R : TRect;

begin
  GetExtent (R);
  R.Grow (-5,-4);
  T := New(PTextWindow, Init(R, FileName));
  T^.Options := T^.Options or ofCentered;
  InsertWindow (T)
end;

begin
  if (Event.What = evCommand) and
  (Event.Command = cmQuit) then
    ClearDeskTop;
  inherited HandleEvent (Event);
  case Event.What of
    evCommand:
    case Event.Command of             {process commands}
      cmOpenTable    : NewBrowser;
      cmDeleteTable  : DeleteTable;
      cmEmptyTable   : EmptyTable;
      cmEncryptTable : EncryptTable;
      cmDecryptTable : DecryptTable;
      cmAddPassword  : AddPassword;
      cmEngineConfig : EngineConfig;
      cmToggleVideo  : ToggleVideo;
      cmViewDoc      : ViewTextFile (appDocName);
      cmCalendar     : Calendar;
      cmCalculator   : Calculator;
      cmAbout        : AboutBox;
      cmCloseAll     : ClearDeskTop
    end
    else
      Exit;
    ClearEvent (Event)
  end
end;

procedure TCyberBase.InitMenuBar;

var

  R : TRect;

begin
  GetExtent (R);
  R.B.Y := R.A.Y+1;
  MenuBar := New (PMenuBar,Init (R,NewMenu (
    NewSubMenu ('~F~ile',hcNoContext,NewMenu (
    NewSubMenu ('~T~able',hcNoContext,NewMenu (
      NewItem ('~O~pen','F3',kbF3,cmOpenTable,hcNoContext,
      NewItem ('~D~elete','',kbNoKey,cmDeleteTable,hcNoContext,
      NewItem ('~E~mpty','',kbNoKey,cmEmptyTable,hcNoContext,
      nil)))),
    NewSubMenu ('~S~ecurity',hcNoContext,NewMenu (
      NewItem ('~A~dd password','',kbNoKey,cmAddPassword,hcNoContext,
      NewItem ('~E~ncrypt','',kbNoKey,cmEncryptTable,hcNoContext,
      NewItem ('~D~ecrypt','',kbNoKey,cmDecryptTable,hcNoContext,
      nil)))),
      NewLine (
      NewItem ('~C~alendar','',kbNoKey,cmCalendar,hcNoContext,
      NewItem ('Ca~l~culator','',kbNoKey,cmCalculator,hcNoContext,
      NewItem ('~V~iew doc','',kbNoKey,cmViewDoc,hcNoContext,
      NewItem ('~A~bout','',kbNoKey,cmAbout,hcNoContext,
      NewLine (
      NewItem ('E~x~it','Alt-X',kbAltX,cmQuit,hcExit,
      nil)))))))))),
    NewSubMenu ('~O~ptions',hcNoContext,NewMenu (
      NewItem ('~E~ngine','',kbNoKey,cmEngineConfig,hcNoContext,
      NewItem ('~T~oggle video','',kbNoKey,cmToggleVideo,hcNoContext,
      nil))),
    NewSubMenu ('~W~indow',hcNoContext,NewMenu(
      StdWindowMenuItems (
      nil)),nil))))))
end;

procedure TCyberBase.InitStatusLine;

var

  R : TRect;

begin
  GetExtent (R);
  R.A.Y := R.B.Y-1;
  StatusLine := New (PStatusLine,Init(R,
    NewStatusDef (0,$FFFF,
      NewStatusKey ('~F3~ Open',kbF3,cmOpenTable,
      NewStatusKey ('~Alt-F3~ Close',kbAltF3,cmClose,
      NewStatusKey ('~Alt-X~ Exit',kbAltX,cmQuit,
      NewStatusKey ('',kbCtrlF5,cmResize,
      NewStatusKey ('',kbF10,cmMenu,
      nil))))),nil)))
end;

{
Let user know if heap allocation cuts into the safety pool.
}

procedure TCyberBase.OutOfMemory;

begin
  MessageBox ('Not enough memory available to complete operation.  Try closing some windows!',
  nil,mfError+mfOkButton);
end;

var

  CBApp : TCyberBase;

begin
  CBApp.Init;
  CBApp.Run;
  CBApp.Done
end.