home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / OPBONUS.ZIP / TESTREPL.LZH / REPLMAIN.PAS next >
Encoding:
Pascal/Delphi Source File  |  1990-05-23  |  4.6 KB  |  172 lines
  1. {$S-,R-,V-,I-,A-,O-,F-}
  2.  
  3. unit ReplMain;
  4.   {-Main unit for TESTREPL.PAS, to test OpReplay and OpSwap}
  5.  
  6. interface
  7.  
  8. uses
  9.   Dos,
  10.   OpString,
  11.   OpCrt,
  12.   OpSwap1;
  13.   {DON'T USE OPREPLAY ANYWHERE IN THIS USES STATEMENT}
  14.  
  15. var
  16.   {Pointers to OpReplay procedures and data}
  17.   CallStartMacro : procedure(P : Pointer);
  18.   CallStringToScrapMacro : procedure(S : String);
  19.   MacPtr : Pointer; {Address of macro to play back}
  20.  
  21. var
  22.   SaveInt16 : Pointer;
  23.  
  24. procedure InitializeTest;
  25.   {-Initialize the test TSR and go resident}
  26.  
  27.   {=========================================================================}
  28.  
  29. implementation
  30.  
  31. const
  32.   HotKey = $0844;                 {<Alt><F10>}
  33.   ProgName : String[9] = 'TESTREPL';
  34.   SwapFile1 : String[15] = 'C:\TESTSWP1.$$$';
  35.   SwapFile2 : String[15] = 'C:\TESTSWP2.$$$';
  36.  
  37.   UnloadTSR = 1;
  38.   UnloadSuccessful = 2;
  39.   UnloadFailed = 3;
  40.  
  41.   procedure Abort(Msg : String; Code : Byte);
  42.     {-Write a message and halt}
  43.   begin
  44.     WriteLn(Msg);
  45.     Halt(Code);
  46.   end;
  47.  
  48.   {$F+}
  49.   procedure MainPop;
  50.     {-The routine called when the hotkey is pressed}
  51.   begin
  52.     CallStringToScrapMacro('OpReplay will replay up to 127 characters');
  53.     CallStartMacro(MacPtr);
  54.   end;
  55.   {$F-}
  56.  
  57.   {$F+}
  58.   procedure ExternalIfc;
  59.     {-Dispatches external requests}
  60.   var
  61.     TempSaveInt16 : Pointer;
  62.     CurInt16 : Pointer;
  63.   begin
  64.     with CSSwapData^.ThisIFC do
  65.       case LongInt(UserData) of
  66.         UnloadTSR :
  67.           begin
  68.             {Make Vectors reflect the original Int16 handler}
  69.             TempSaveInt16 := CSSwapData^.Vectors[$16];
  70.             SetVecOnReturn($16, SaveInt16);
  71.  
  72.             if not CSSwapData^.SwapEnabled then begin {!!}
  73.               GetIntVec($16, CurInt16);               {!!}
  74.               SetIntVec($16, SaveInt16);              {!!}
  75.             end;                                      {!!}
  76.  
  77.             {Try to remove the TSR}
  78.             if DisableTSR then
  79.               LongInt(UserData) := UnloadSuccessful
  80.             else begin
  81.               if not CSSwapData^.SwapEnabled then     {!!}
  82.                 SetIntVec($16, CurInt16);             {!!}
  83.               SetVecOnReturn($16, TempSaveInt16);
  84.               LongInt(UserData) := UnloadFailed;
  85.             end;
  86.           end;
  87.       else
  88.         Write('Unknown external interface request');
  89.       end;
  90.   end;
  91.   {$F-}
  92.  
  93.   procedure DisableResidentCopy(IFC : IfcPtr);
  94.     {-Using the IfcPtr, disable the known resident copy of ourself}
  95.   var
  96.     Save : Boolean;
  97.   begin
  98.     with IFC^ do begin
  99.       RestoreAllVectors;
  100.       Save := CSDataPtr^.SwapMsgOn;   {Save state of swap messages}
  101.       CSDataPtr^.SwapMsgOn := False;  {Disable swap messages}
  102.       LongInt(UserData) := UnloadTSR; {UserData = UnLoadTSR command}
  103.       CmdEntryPtr;                    {Call the CmdEntryPtr}
  104.  
  105.       {Check status of Unload attempt}
  106.       if LongInt(UserData) = UnloadSuccessful then begin
  107.         WriteLn(ProgName, ' removed from memory');
  108.         Halt;
  109.       end else begin
  110.         {Restore state of swap messages}
  111.         CSDataPtr^.SwapMsgOn := Save;
  112.         Abort('Unable to remove '+ProgName+' from memory', 1);
  113.       end;
  114.     end;
  115.   end;
  116.  
  117.   function UnloadRequest : Boolean;
  118.     {-Return True if user requested unload at the DOS command line}
  119.   begin
  120.     UnloadRequest := (ParamCount > 0) and (StUpcase(ParamStr(1)) = '/U');
  121.   end;
  122.  
  123.   procedure InstallCheck;
  124.     {-Are we installed? Unload if requested}
  125.   var
  126.     IFC : IfcPtr;
  127.     Regs : IntRegisters;
  128.   begin
  129.     {Check to see if we're already installed}
  130.     IFC := ModulePtrByName(ProgName);
  131.  
  132.     if IFC <> nil then
  133.       {We are already installed}
  134.       if UnloadRequest then
  135.         {Try to unload}
  136.         DisableResidentCopy(IFC)
  137.       else
  138.         Abort(ProgName+' already installed', 1)
  139.     else if UnloadRequest then
  140.       Abort(ProgName+' not currently installed', 1);
  141.   end;
  142.  
  143.   procedure InitializeTest;
  144.     {-Main initialization routine}
  145.   begin
  146.     {Check for previous installation, unload if requested}
  147.     InstallCheck;
  148.  
  149.     {Install main hotkey}
  150.     if not DefinePop(HotKey, MainPop, Ptr(SSeg, SPtr)) then begin
  151.       WriteLn('Error defining popup procedure');
  152.       Halt;
  153.     end;
  154.  
  155.     {Mark installation and define external interface routine}
  156.     InstallModule(ProgName, ExternalIfc);
  157.  
  158.     {Don't show the swap message if swapping to EMS}
  159.     if WillSwapUseEms(ParagraphsToKeep) then
  160.       SetSwapMsgOn(False);
  161.  
  162.     {Enable popups}
  163.     PopupsOn;
  164.  
  165.     {Go resident}
  166.     WriteLn('Going resident, <Alt><F10> to stuff string');
  167.     StayResSwap(ParagraphsToKeep, 0, SwapFile1, SwapFile2, True);
  168.     WriteLn('Error going resident');
  169.   end;
  170.  
  171. end.
  172.