home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS - Coast to Coast / simteldosarchivecoasttocoast.iso / pcmag / vol6n20.zip / PROFIL.ZIP / INVOKE.PRF < prev    next >
Text File  |  1987-01-11  |  8KB  |  220 lines
  1. { This is Kim Kokonnen's INVOKE.PAS, stripped of features not needed here.    }
  2. { If you really want to know how it works, download the full version from DL4.}
  3.  
  4. const
  5.   NewStackSize = 1700;        {Turbo Stack size (bytes) to keep while in DOS shell (>700)}
  6.   StackBufferSize = 512;      {Bytes in DOS stack buffer}
  7.  
  8. var
  9.   TopOfStack     : Integer;      { used by INVOKE }
  10.   StackBuffer    : array[1..StackBufferSize] of Byte;
  11.   StackSeg       : Integer;
  12.   StackPtr       : Integer;
  13.   NewStackSeg    : Integer;
  14.   NewStackPtr    : Integer;
  15.   ParasToKeep    : Integer;
  16.   ParasWeHave    : Integer;
  17.   ParasForDos    : Integer;
  18.   ExecStatus     : Integer;
  19.   CommandStr     : string255 ;
  20.   I              : integer ;
  21.  
  22.   function StackPointer : Integer;
  23.     {-Return the stack pointer at the point of the call}
  24.   begin
  25.     inline(
  26.       $89/$E0/                {MOV     AX,SP}
  27.       $05/$08/$00/            {ADD     AX,0008}
  28.       $89/$EC/                {MOV     SP,BP}
  29.       $5D/                    {POP     BP}
  30.       $C2/$02/$00             {RET     0002}
  31.       );
  32.   end;                        {StackPointer}
  33.  
  34.   procedure Error(error_num : integer );
  35.   const
  36.   { this array defines the error messages given in response to various
  37.     DOS errors.  The messages that just indicate the error number shouldn't
  38.     occur.  The text is included because it's space is free.  (In fact,
  39.     errors 10 and 11 shouldn't occur either.) }
  40.     ErrorMsg : array[1..11] of string[30] =
  41.       ( 'Error 1.',
  42.         'Can''t find file ',                { 2 }
  43.         'Error 3.',
  44.         'Error 4.',
  45.         'Error 5.',
  46.         'Error 6.',
  47.         'Memory control blocks damaged.',  { 7 }
  48.         'Not enough memory to load ',      { 8 }
  49.         'Error 9.',
  50.         'Bad environment.',                { 10 }
  51.         'Improper format for EXEC.' ) ;    { 11 }
  52.   begin
  53.     if ((error_num >= 1) and (error_num <= 11)) then
  54.     begin
  55.       FastWrite( ErrorMsg[error_num], 23, 1, EmphAttr ) ;
  56.       if ((error_num = 2) or (error_num = 8)) then
  57.         FastWrite( CommandStr, 23, Length(ErrorMsg[error_num])+2, EmphAttr ) ;
  58.     end
  59.     else FastWrite( 'Error in Invoke.', 23, 1, EmphAttr ) ;
  60.   end;                        {Error}
  61.  
  62.   procedure SetBlock(paras : Integer);
  63.     {-Free up some memory above this program for a DOS shell}
  64.   var
  65.     regs : Registers;
  66.   begin                       {SetBlock}
  67.     with regs do begin
  68.       Ah := $4A;
  69.       Es := CSeg;
  70.       Bx := paras;
  71.       MsDos(regs);
  72.       if Odd(Flags) then
  73.         Error(ax);
  74.     end;
  75.   end;                        {SetBlock}
  76.  
  77.   procedure Invoke(command : String255);
  78.  
  79.     function SubProcess(CommandLine : String255) : Integer;
  80.       {-From Bela Lubkin's EXEC.PAS}
  81.     const
  82.       SSSave : Integer = 0;
  83.       SPSave : Integer = 0;
  84.  
  85.     var
  86.       regs : Registers;
  87.       FCB1, FCB2 : array[0..36] of Byte;
  88.       PathName : String255;
  89.       CommandTail : String255;
  90.       ParmTable : record
  91.                     EnvSeg : Integer;
  92.                     ComLin : ^Integer;
  93.                     FCB1Pr : ^Integer;
  94.                     FCB2Pr : ^Integer;
  95.                   end;
  96.       RegsFlags : Integer;
  97.  
  98.     begin
  99.       if Pos(' ', CommandLine) = 0 then begin
  100.         PathName := CommandLine+#0;
  101.         CommandTail := ^M;
  102.       end else begin
  103.         PathName := Copy(CommandLine, 1, Pred(Pos(' ', CommandLine)))+#0;
  104.         CommandTail := Copy(CommandLine, Pos(' ', CommandLine), 255)+^M;
  105.       end;
  106.       CommandTail[0] := Pred(CommandTail[0]);
  107.       with regs do begin
  108.         FillChar(FCB1, SizeOf(FCB1), 0);
  109.         Ax := $2901;
  110.         Ds := Seg(CommandTail[1]);
  111.         Si := Ofs(CommandTail[1]);
  112.         Es := Seg(FCB1);
  113.         Di := Ofs(FCB1);
  114.         MsDos(regs);          { Create FCB 1 }
  115.         FillChar(FCB2, SizeOf(FCB2), 0);
  116.         Ax := $2901;
  117.         Es := Seg(FCB2);
  118.         Di := Ofs(FCB2);
  119.         MsDos(regs);          { Create FCB 2 }
  120.         with ParmTable do begin
  121.           EnvSeg := Seg( EnvStr^ );
  122.           ComLin := Addr(CommandTail);
  123.           FCB1Pr := Addr(FCB1);
  124.           FCB2Pr := Addr(FCB2);
  125.         end;
  126.         inline(
  127.           $8D/$96/PathName/$42/ { <DX>:=Ofs(PathName[1]); }
  128.           $8D/$9E/ParmTable/  { <BX>:=Ofs(ParmTable);   }
  129.           $B8/$00/$4B/        { <AX>:=$4B00;            }
  130.           $1E/$55/            { Save <DS>, <BP>         }
  131.           $16/$1F/            { <DS>:=Seg(PathName[1]); }
  132.           $16/$07/            { <ES>:=Seg(ParmTable);   }
  133.           $2E/$8C/$16/SSSave/ { Save <SS> in SSSave     }
  134.           $2E/$89/$26/SPSave/ { Save <SP> in SPSave     }
  135.           $FC/                { CLD}
  136.           $FA/                { Disable interrupts      }
  137.           $CD/$21/            { Call MS-DOS             }
  138.           $FA/                { Disable interrupts      }
  139.           $2E/$8B/$26/SPSave/ { Restore <SP>            }
  140.           $2E/$8E/$16/SSSave/ { Restore <SS>            }
  141.           $FB/                { Enable interrupts       }
  142.           $5D/$1F/            { Restore <BP>,<DS>       }
  143.           $9C/$8F/$86/RegsFlags/ { RegsFlags:=<CPU flags>}
  144.           $89/$86/regs);      { Regs.AX:=<AX>;          }
  145.         if Odd(RegsFlags) then
  146.           SubProcess := Ax
  147.         else
  148.           SubProcess := 0;
  149.       end;
  150.     end;                      {SubProcess}
  151.  
  152.   begin                       {Invoke}
  153.  
  154.     {Save current stack seg and ptr}
  155.     inline(
  156.       $8C/$D0/                {MOV    AX,SS}
  157.       $A3/StackSeg/           {MOV    stackseg,AX}
  158.       $89/$26/StackPtr        {MOV    stackptr,SP}
  159.       );
  160.  
  161.     {The new lower stack goes above the "high water mark" of the heap }
  162.     {Heap fragmentation may cause HeapPtr to be higher than you expect}
  163.     NewStackSeg := Succ(Seg(HeapPtr^));
  164.     NewStackPtr := NewStackSize;
  165.  
  166.     {Current DOS memory allocation read from memory control block}
  167.     ParasWeHave := MemW[Pred(CSeg):3];
  168.     ParasToKeep := Succ(NewStackSeg-CSeg)+Succ(NewStackSize shr 4);
  169.     ParasForDos := ParasWeHave-ParasToKeep;
  170.  
  171.     {See if enough stack buffer to store current Turbo stack}
  172.     if succ(TopOfStack-StackPtr) > StackBufferSize then
  173.       begin
  174.         FastWrite( 'Insufficient memory for internal stack buffer.', 23, 1, EmphAttr ) ;
  175.         exit ;
  176.       end;
  177.  
  178.     {Build the command string}
  179.       Commandstr := command ;
  180.  
  181.     ClrScr;
  182.  
  183.     {Copy the top of the stack to a buffer}
  184.     Move(Mem[StackSeg:StackPtr], StackBuffer, succ(TopOfStack-StackPtr));
  185.  
  186.     {Lower stack}
  187.     inline(
  188.       $FA/                    {CLI    }
  189.       $A1/NewStackSeg/        {MOV    AX,newstackseg}
  190.       $8E/$D0/                {MOV    SS,AX}
  191.       $8B/$26/NewStackPtr/    {MOV    SP,newstackptr}
  192.       $FB                     {STI    }
  193.       );
  194.  
  195.     {Deallocate memory}
  196.     SetBlock(ParasToKeep);
  197.  
  198.     {Run the program}
  199.     ExecStatus := SubProcess(Commandstr);
  200.  
  201.     {Reallocate memory}
  202.     SetBlock(ParasWeHave);
  203.  
  204.     {Restore stack seg and ptr to original values}
  205.     inline(
  206.       $FA/                    {CLI    }
  207.       $A1/StackSeg/           {MOV    AX,stackseg}
  208.       $8E/$D0/                {MOV    SS,AX}
  209.       $8B/$26/StackPtr/       {MOV    SP,stackptr}
  210.       $FB                     {STI    }
  211.       );
  212.  
  213.     {Put stack buffer back on stack}
  214.     Move(StackBuffer, Mem[StackSeg:StackPtr], succ(TopOfStack-StackPtr));
  215.  
  216.     if ExecStatus <> 0 then
  217.       Error( ExecStatus );
  218.  
  219.   end;                        {Invoke}
  220.