Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PACKSCR.ZIP/PSCREEN.PAS

Pascal/Delphi Source File | 1988-08-21 | 5.8 KB | 227 lines

{$S-,R-,V-,I-,B-,F-}
{$M 4096,0,10000}

{*********************************************************}
{*                  PSCREEN.PAS 5.00                     *}
{*        Copyright (c) TurboPower Software 1988.        *}
{*                 All rights reserved.                  *}
{*********************************************************}

program PackedScreenUtility;
  {-Utility for saving and displaying packed screens}

uses
  Dos, TpCrt, TpString, TpEdit, TpTsr;

type
  String64 = string[64];
const
  ModuleName : string[7] = 'PSCREEN'; {module name for standard interface}
  OurHotKey : Word = $0619;  {Ctrl + LeftShift, 'P'}
  ProgName : string[64] = 'PSCREEN 5.00: A Utility for Saving and Displaying Packed Screens';
  Copyright : string[41] = 'Copyright (c) 1988 by TurboPower Software';
  LoadError : string[25] = 'Unable to install PSCREEN';
  Disable   : Boolean = False;
var
  PWP : PackedWindowPtr;
  Bright,                    {video attributes}
  Dim,
  Border,
  Reverse : Byte;
  MaxRows : Word;
  MaxCols : Word;
  MaxParas : Word;           {maximum space needed for saving the screen}

  procedure SetAttributes;
    {-Set the attributes to be used based on the current video mode}
  begin
    case CurrentMode of
     0,                      {BW40}
     2,                      {BW80}
     7 :                     {monochrome}
       begin
         Bright := $F;
         Border := $F;
         Dim := $7;
         Reverse := $70;
        end;
    else                     {color}
     begin
      Bright := $1F;
      Border := $1A;
      Dim := $1B;
      Reverse := $21;
     end;
    end;
    TextAttr := Dim;
  end;

  {$F+}
  function GetKey : Word;
    {-}
  var
    ChWord : Word;
  begin
    ChWord := ReadKeyWord;
    {check for Alt-U}
    if ChWord = $1600 then begin
      {translate to ESC and set flag to disable the TSR}
      ChWord := $001B;
      Disable := True;
    end;
    GetKey := ChWord;
  end;
  {$F-}

  function GetFileName(var FName : String64) : Boolean;
    {-Prompt for a file name}
  const
    Prompt = 'File to write: ';
  var
    Escaped : Boolean;
  begin
    ForceUpper := True;
    EditSize := CurrentWidth-(Length(Prompt)+4);
    ReadString(Prompt, 2, 3, 64, Bright, Dim, Dim, Escaped, FName);

    GetFileName := (Length(FName) <> 0) and not Escaped;
  end;

  procedure ErrorMessage(Msg : String);
    {-Display an error message and wait for a keypress}
  const
    PressAnyKey = '. Press any key...';
  begin
    if Length(Msg)+Length(PressAnyKey)+4 <= CurrentWidth then
      Msg := Msg+PressAnyKey;
    FastWrite(Pad(Msg, CurrentWidth-4), 2, 3, Bright);
    if ReadKeyWord = 0 then {};
  end;

  {$F+}
  procedure PopupEntryPoint(var Regs : Registers);
    {-This is the entry point for the popup}
  const
    FName : String64 = '';
  var
    SaveXY, SaveSL : Word;   {for saving cursor position and shape}
  begin
    {reinitialize CRT}
    ReInitCrt;

    {exit if not in text mode}
    if InTextMode then begin
      {save the screen}
      PWP := PackWindow(1, 1, CurrentWidth, CurrentHeight+1);
      if PWP = nil then
        Exit;

      {initialize screen stuff}
      SetAttributes;
      GetCursorState(SaveXY, SaveSL);

      {draw our window}
      Window(1, 1, CurrentWidth, 3);
      ClrScr;
      FrameWindow(1, 1, CurrentWidth, 3, Border, Reverse, ' PSCREEN 5.00 ');

      {get name of file to save screen in}
      if GetFileName(FName) then begin
        {save the screen}
        WritePackedWindow(PWP, FName);
        if CrtError <> 0 then
          ErrorMessage('Error while writing screen to disk');
      end
      else if Disable then
        Disable := DisableTSR;

      {restore cursor and screen}
      RestoreCursorState(SaveXY, SaveSL);
      DisplayPackedWindow(PWP);
      DisposePackedWindow(PWP);
    end;
  end;
  {$F-}

  procedure Abort(Msg : string);
    {-Display an error message and halt}
  begin
    WriteLn(Msg);
    Halt(1);
  end;

  procedure Initialize;
    {-Initialize and check for command line parameters}
  var
    PWP : PackedWindowPtr;
    FName : String64;
  begin
    {initialize}
    RSgetKeyPtr := @GetKey;

    {resident mode if no parameters specified}
    if ParamCount = 0 then
      Exit;

    {get the filename and display it}
    FName := ParamStr(1);
    PWP := ReadPackedWindow(FName);
    if PWP = nil then
      Abort('Error reading '+FName);
    DisplayPackedWindow(PWP);
    Halt;
  end;

begin
  {see if there is a file to display}
  Initialize;

  {signon message}
  HighVideo;
  WriteLn(ProgName, ^M^J, Copyright, ^M^J);
  LowVideo;

  {check to see if SideKick is loaded}
  if SideKickLoaded then
    Abort('Can''t be loaded after SideKick!');

  {check to see if we're already installed}
  if ModuleInstalled(ModuleName) then
    Abort('PSCREEN is already loaded. Aborting...');

  {install the module}
  InstallModule(ModuleName, nil);

  {go resident}
  if DefinePop(OurHotKey, @PopupEntryPoint, Ptr(SSeg, SPtr), True) then begin
    WriteLn('PSCREEN loaded. Press Ctrl-LeftShift-P to activate.');

    {Enable popups}
    PopupsOn;

    {$IFDEF Ver40}
    {restore INT $1B, captured by TPCRT}
    SetIntVec($1B, SaveInt1B);
    {$ENDIF}

    {calculate amount of heap space to set aside}
    case EnhancedDisplay of
      EGA : MaxRows := 43;
      VGA : MaxRows := 50;
      else MaxRows := 25;
    end;
    if CurrentWidth > 80 then
      MaxCols := CurrentWidth
    else
      MaxCols := 80;
    MaxParas := (MaxRows*MaxCols*2)+(SizeOf(PackedWindow)-SizeOf(PackedScreen));
    MaxParas := (MaxParas+$F) div 16;

    {terminate and stay resident}
    if not TerminateAndStayResident(ParagraphsToKeep+MaxParas, 0) then {} ;
  end;

  {if we get here we failed}
  Abort(LoadError);
end.