Power-Programmierung/CD1.mdf/magazine/pctchnqs/1991/number5/tvtsr/tvstestm.pas

Pascal/Delphi Source File | 1991-04-12 | 7KB | 272 lines

{
  This is a very simple Turbo Vision TSR. It uses the unit TVSCREEN provided
  by TurboPower Software, and the OPINT and OPTSR units from TurboPower's
  Object Professional or TSRs Made Easy libraries. Object Professional and
  TSRs Made Easy are commercial libraries and may not be distributed. This
  file, the TVSCREEN unit, and associated text may be distributed freely.
}
{$S-,R-,I-,V-,X+}
unit TVSTESTM;
interface
uses
  Dos,
  TvScreen,
  Objects, Drivers, Memory, Views, Menus, MsgBox, App,
  OpSwap1;

procedure InitTvTest;

implementation

const
  WinCount: Integer =   0;
  cmFileOpen        = 100;
  cmNewWin          = 101;

type
  TMyApp = object(TApplication)
    constructor Init;                    {added for TSR}
    destructor Done; Virtual;            {added for TSR}
    procedure HandleEvent(var Event: TEvent); virtual;
    procedure InitMenuBar; virtual;
    procedure InitStatusLine; virtual;
    procedure NewWindow;
  end;

  PDemoWindow = ^TDemoWindow;
  TDemoWindow = object(TWindow)
  end;

{Added for TSR. Flag indicating whether program has gone resident yet}
const
  GoneResident      : Boolean = False;

{ TMyApp }
constructor TMyApp.Init;
const
  TvTestStr = ^C'TVSTEST 1.0'^M +
              ^C'Installing as a swappable TSR'^M +
              ^C'Press Alt-TAB to popup';
var
  Control : Word;
begin
  TApplication.Init;

  {dialog box added for TSR}
  Control := MessageBox(TvTestStr, Nil, mfInformation + mfOKCancel);
  if Control = cmCancel then begin
    Done;
    Halt;
  end;
end;

destructor TMyApp.Done;
var
  Control : Word;
begin
  {dialog box added for TSR}
  if GoneResident then
    Control := MessageBox(^C'Unloading resident copy of TVSTEST', Nil,
                          mfInformation + mfOKButton);
  TApplication.Done;
end;

procedure TMyApp.HandleEvent(var Event: TEvent);
begin
  TApplication.HandleEvent(Event);
  if Event.What = evCommand then
  begin
    case Event.Command of
      cmNewWin: NewWindow;
    else
      Exit;
    end;
    ClearEvent(Event);
  end;
end;

procedure TMyApp.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(
      NewItem('~O~pen', 'F3', kbF3, cmFileOpen, hcNoContext,
      NewItem('~N~ew', 'F4', kbF4, cmNewWin, hcNoContext,
      NewLine(
      NewItem('E~x~it', 'Alt-X', kbAltX, cmQuit, hcNoContext,
      nil))))),
    NewSubMenu('~W~indow', hcNoContext, NewMenu(
      NewItem('~N~ext', 'F6', kbF6, cmNext, hcNoContext,
      NewItem('~Z~oom', 'F5', kbF5, cmZoom, hcNoContext,
      nil))),
    nil))
  )));
end;

procedure TMyApp.InitStatusLine;
var R: TRect;
begin
  GetExtent(R);
  R.A.Y := R.B.Y - 1;
  StatusLine := New(PStatusLine, Init(R,
    NewStatusDef(0, $FFFF,
      NewStatusKey('', kbF10, cmMenu,
      NewStatusKey('~Alt-X~ Exit', kbAltX, cmQuit,
      NewStatusKey('~F4~ New', kbF4, cmNewWin,
      NewStatusKey('~Alt-F3~ Close', kbAltF3, cmClose,
      nil)))),
    nil)
  ));
end;

procedure TMyApp.NewWindow;
var
  Window: PDemoWindow;
  R: TRect;
begin
  Inc(WinCount);
  R.Assign(0, 0, 26, 7);
  R.Move(Random(58), Random(16));
  Window := New(PDemoWindow, Init(R, 'Demo Window', WinCount));
  DeskTop^.Insert(Window);
end;

var
  MyApp: TMyApp;

{=========================================================================}

const
  HotKey = $080F; {alt-tab}
  ExtraHeapParas = (48 * 1024) div 16;    {48K of extra heap for TSR}
  OurModuleName : String[8] = 'TVSTEST1';

procedure ShutTVDownForUnload;
begin
  {reinit Turbo Vision}
  InitVideo;
  InitMemory;
  InitEvents;

  MyApp.Redraw;
  DRIVERS.ShowMouse;
  MyApp.Done;
end;

procedure CmdEntryPoint; Far;

begin
  if SafeToDisable then begin
    ShutTVDownForUnload;
    LongInt(CSSwapData^.ThisIFC.UserData) := LongInt(Ord(DisableTSR));
  end;
end;

procedure UnloadFromCommandLine;
var
  P : IfcPtr;
begin
  P := ModulePtrByName(OurModuleName);
  if (P <> Nil) then begin
    RestoreAllVectors;
    P^.CmdEntryPtr;
    if Boolean(P^.UserData) then
      WriteLn('TVSTEST successfully unloaded')
    else
      WriteLn('Unable to unload TVSTEST');
  end;
end;

procedure PopupEntryPoint; far;
var
  Covers : pointer;
  MSP : MouseStatePtr;
  MStateSize : Word;
  XY : Word;
  ScanLines : Word;
begin
  ReinitVideo;                    {reset video vars in case video mode changed}
  if not InTextMode then          {can't popup over graphics}
    Exit;
  if MouseInstalled then begin
    MStateSize := MouseStateBufferSize;
    {check to see if mouse driver supports mouse state calls, and enough mem}
    if (MStateSize = 0) or (MStateSize > MaxAvail) then
      Exit;
    {save mouse, cursor and screen state for underlying application}
    SaveMouseState(MSP);
  end;
  GetCursorState(XY, ScanLines);
  if not SaveScreen(Covers) then begin
    RestoreMouseState(MSP);       {done here to release heap space for MSP}
    Exit;
  end;


  {reinit Turbo Vision}
  InitVideo;
  InitMemory;
  InitEvents;
  (* InitSysError; *)  {!! do not call this in a popup !!}

  MyApp.Redraw;
  DRIVERS.ShowMouse;
  MyApp.Run;
  DRIVERS.HideMouse;

  {shut down Turbo Vision}
  DoneVideo;
  DoneEvents;
  DoneMemory;

  {restore screen, cursor, and mouse states}
  RestoreScreen(Covers);
  RestoreCursorState(XY, ScanLines);
  if MouseInstalled then
    RestoreMouseState(MSP);
end;

procedure InitTvTest;

var
  Parameter : String[128];

begin
  if ParamCount > 0 then begin
    Parameter := ParamStr(1);
    if (Length(Parameter) = 2) and (Parameter[1] in ['/','-']) then
      if UpCase(Parameter[2]) = 'U' then begin
        UnloadFromCommandLine;
        Halt;
      end;
  end;
  if ModuleInstalled(OurModuleName) then begin
    WriteLn('TVSTEST already loaded.');
    Halt;
  end;
  InstallModule(OurModuleName, CmdEntryPoint);

  if not DefinePop(HotKey, PopupEntryPoint, Ptr(SSeg, SPtr)) then begin
    WriteLn('Unable to define popup');
    Halt;
  end;

  MyApp.Init;

  {Shutdown Turbo Vision}
  DoneSysError;
  DoneEvents;
  DoneVideo;
  DoneMemory;

  PopupsOn;
  GoneResident := True;
  StayResSwap(ParagraphsToKeep+ExtraHeapParas, 0, 'c:\tvstest1.$$$',
              'c:\tvstest2.$$$', True);
  WriteLn('unable to go resident');
end;

end.