home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / BONUS507.ZIP / CHAIN.ARC / CHAIN.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-10-31  |  3.5 KB  |  129 lines
  1. {$S-,R-,I-,V-,F-,B-}
  2.  
  3.   {*********************************************************}
  4.   {*                    CHAIN.PAS 5.00                     *}
  5.   {*        Copyright (c) TurboPower Software 1987.        *}
  6.   {*                 All rights reserved.                  *}
  7.   {*********************************************************}
  8.  
  9. unit Chain;
  10.   {-Chaining facility for Turbo 4 or 5}
  11.  
  12. interface
  13.  
  14. const
  15.   CloseFilesBeforeChaining : Boolean = True;
  16.   {If False: no files are closed before chaining,
  17.        True: all files but StdIn, StdOut, StdErr, StdPrn are closed}
  18.  
  19. function Chain4(Path, CmdLine : string) : Word;
  20.   {-Chain to file named in Path
  21.     CmdLine must be no longer than 82 characters
  22.     If Chain4 returns, a DOS error code is in the result}
  23.  
  24. procedure ChainHalt(Path, CmdLine : string);
  25.   {-Execute all exit handlers after the CHAIN unit, then chain as specified}
  26.  
  27. procedure SetMaxHeap(Bytes : LongInt);
  28.   {-Set maximum heap and adjust DOS memory allocation block}
  29.  
  30. procedure GetMemDos(var P : Pointer; Bytes : LongInt);
  31.   {-Allocate memory from DOS, returning a pointer to the new block
  32.     Shrink Turbo allocation and relocate free list if forced to
  33.     Returns P = nil if unable to allocate space}
  34.  
  35. function Pointer2String(P : Pointer) : string;
  36.   {-Convert a pointer to a string suitable for passing on command line}
  37.  
  38. function String2Pointer(S : string) : Pointer;
  39.   {-Convert a string formatted by Pointer2String to a pointer
  40.     Returns nil if S is an invalid string}
  41.  
  42.   {==========================================================================}
  43.  
  44. implementation
  45.  
  46. var
  47.   SaveExit : pointer;
  48.   ChainPath : string[79];
  49.   ChainCmdLine : string[83];
  50.  
  51.   {$L CHAIN}
  52.   {$L GETMEM}
  53.  
  54.   function Chain4(Path, CmdLine : string) : Word;
  55.     external {CHAIN} ;
  56.  
  57.   procedure SetIntVec(Num : Byte; Vec : Pointer);
  58.     external {CHAIN} ;
  59.  
  60.   procedure SetMaxHeap(Bytes : LongInt);
  61.     external {GETMEM} ;
  62.  
  63.   procedure GetMemDos(var P : Pointer; Bytes : LongInt);
  64.     external {GETMEM} ;
  65.  
  66.   function Pointer2String(P : Pointer) : string;
  67.     external {GETMEM} ;
  68.  
  69.   function String2Pointer(S : string) : Pointer;
  70.     external {GETMEM} ;
  71.  
  72.   procedure RestoreVectors;
  73.     {-Restore SYSTEM interrupt vectors}
  74.   begin
  75.     SetIntVec($00, SaveInt00);
  76.     SetIntVec($02, SaveInt02);
  77.     {$IFNDEF Ver40}
  78.     SetIntVec($1B, SaveInt1B);
  79.     {$ENDIF}
  80.     SetIntVec($23, SaveInt23);
  81.     SetIntVec($24, SaveInt24);
  82.     {$IFNDEF Ver40}
  83.     SetIntVec($34, SaveInt34);
  84.     SetIntVec($35, SaveInt35);
  85.     SetIntVec($36, SaveInt36);
  86.     SetIntVec($37, SaveInt37);
  87.     SetIntVec($38, SaveInt38);
  88.     SetIntVec($39, SaveInt39);
  89.     SetIntVec($3A, SaveInt3A);
  90.     SetIntVec($3B, SaveInt3B);
  91.     SetIntVec($3C, SaveInt3C);
  92.     SetIntVec($3D, SaveInt3D);
  93.     SetIntVec($3E, SaveInt3E);
  94.     SetIntVec($3F, SaveInt3F);
  95.     {$ENDIF}
  96.     SetIntVec($75, SaveInt75);
  97.   end;
  98.  
  99.   {$F+}
  100.   procedure ChainExit;
  101.     {-Trap on exit, chain if requested}
  102.   var
  103.     Status : Word;
  104.   begin
  105.     ExitProc := SaveExit;
  106.     if Length(ChainPath) <> 0 then begin
  107.       Status := Chain4(ChainPath, ChainCmdLine);
  108.       if Status <> 0 then
  109.         Halt(Status);
  110.     end;
  111.   end;
  112.   {$F-}
  113.  
  114.   procedure ChainHalt(Path, CmdLine : string);
  115.     {-Execute all exit handlers after the CHAIN unit, then chain as specified}
  116.   begin
  117.     {Save the path and command line to chain to}
  118.     ChainPath := Path;
  119.     ChainCmdLine := CmdLine;
  120.     {Loop through exit chain}
  121.     Halt(0);
  122.   end;
  123.  
  124. begin
  125.   SaveExit := ExitProc;
  126.   ExitProc := @ChainExit;
  127.   ChainPath := '';
  128. end.
  129.