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

Pascal/Delphi Source File | 1991-10-27 | 7KB | 237 lines

PROGRAM TVTEST;
{ This is a simple Turbo Vision TSR. The OPINT and OPTSR units
  are from TurboPower Software's Object Professional or TSRs
  Made Easy libraries, which are commercial libraries and may
  not be distributed. This file, the TVSCREEN unit, and associated
  text may be distributed freely.}
{$M 8192, 0, 655360}
{$S-,R-,I-,V-,X+}

USES
  Dos,
  TvScreen,                                 { Refer to Listing 2}
  Objects, Drivers, Memory, Views, Menus, Dialogs, MsgBox, App,
  OpInt, OpTsr;           {From TurboPower's Object Professional}

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;

CONST GoneResident : Boolean = False;              { Flag for TSR}

CONSTRUCTOR TMyApp.Init;
CONST
  TvTestStr = ^C'TVTEST 1.0'^M + ^C'Installing as a 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 TVTEST',
                 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                       {== Changes for making a TSR below ==}
  HotKey = $080F;                                        {Alt-Tab}
  ExtraHeapParas = (48 * 1024) div 16;    {48K extra heap for TSR}
  OurModuleName : String[8] = 'TVTEST10';

PROCEDURE ShutTVDownForUnload;
BEGIN                                       { Reinit Turbo Vision}
  InitVideo;
  InitMemory;
  InitEvents;
  MyApp.Redraw;
  DRIVERS.ShowMouse;
  MyApp.Done;
END;

PROCEDURE CmdEntryPoint(BP : Word); Interrupt;
VAR
  Regs : IntRegisters absolute BP;
  SavePSP : Word;

BEGIN
  SavePSP := GetPSP;
  SetPSP(PrefixSeg);
  Regs.AL := 0;
  IF SafeToDisable THEN BEGIN
    ShutTVDownForUnload;
    IF DisableTSR THEN Regs.AL := 1;
  END;
  SetPSP(SavePSP);
END;

PROCEDURE UnloadFromCommandLine;
VAR
  Regs : IntRegisters;
  P : IfcPtr;
BEGIN
  P := ModulePtrByName(OurModuleName);
  IF (P <> Nil) and (P^.CmdEntryPtr <> Nil) THEN BEGIN
    RestoreAllVectors;
    EmulateInt(Regs, P^.CmdEntryPtr);
    IF Boolean(Regs.AL) THEN
      WriteLn('TVTEST successfully unloaded')
    ELSE
      WriteLn('Unable to unload TVTEST');
  END;
END;

PROCEDURE PopupEntryPoint(VAR Regs : Registers); far;
VAR
  Covers : pointer;
  MSP : MouseStatePtr;
  MStateSize : Word;
  XY : Word;
  ScanLines : Word;
BEGIN               { Reset video VARs in case video mode changed}
  ReinitVideo;
  IN NOT InTextMode THEN Exit;        { Can't popup over graphics}
  IF MouseInstalled THEN BEGIN
    MStateSize := MouseStateBufferSize;
    IF (MStateSize = 0) or (MStateSize > MaxAvail) THEN Exit;
    SaveMouseState(MSP); { Save mouse, cursor and screen state...}
  END;                             {...for underlying application}
  GetCursorState(XY, ScanLines);
  IN NOT SaveScreen(Covers) THEN BEGIN
    RestoreMouseState(MSP);        { Done here to release heap...}
    Exit;                                      { ...space for MSP}
  END;
  InitVideo;                                { Reinit Turbo Vision}
  InitMemory;
  InitEvents;
  (* InitSysError; *)          {!! DO NOT CALL THIS IN A POPUP !!}
  MyApp.Redraw;
  DRIVERS.ShowMouse;
  MyApp.Run;
  DRIVERS.HideMouse;
  DoneVideo;                            { Shut down Turbo Vision }
  DoneEvents;
  DoneMemory;
  RestoreScreen(Covers);                     { Restore screen,...}
  RestoreCursorState(XY, ScanLines);               {...cursor,...}
  IF MouseInstalled THEN RestoreMouseState(MSP);    {...and mouse}
END;
{========================== MAIN ================================}
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('TVTEST already loaded.');
    Halt;
  END;
  InstallModule(OurModuleName, @CmdEntryPoint);
  IN NOT DefinePop(HotKey, PopupEntryPoint, Ptr(SSeg, SPtr), True)
  THEN BEGIN
    WriteLn('unable to define popup');
    Halt;
  END;
  MyApp.Init;                        { Initialize the application}
  DoneSysError;                           { Shutdown Turbo Vision}
  DoneEvents;
  DoneVideo;
  DoneMemory;
  PopupsOn;
  GoneResident := True;
  StayRes(ParagraphsToKeep+ExtraHeapParas, 0);
  WriteLn('unable to go resident');
END.