Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/INVOKE.ZIP/INVOKE.PAS

Pascal/Delphi Source File | 1986-11-08 | 11.5 KB | 366 lines

{
This program demonstrates a dynamically sized DOS shell from
within a Turbo Program. The program may be compiled to use all
available memory. When the DOS shell is invoked, the program
will automatically release all memory above the "high water"
mark of the heap, saving the Turbo stack for later recovery.
As a result, the DOS shell can get up to several hundred K of
RAM. When the DOS shell returns, Turbo regains the memory and
restores its stack.

This concept is particularly useful for programs that use
Turbo EXTENDER, since code modules there can be loaded and
unloaded from the heap, and the space reused by INVOKE.

The Invoke procedure can be called from anywhere in a program,
even from nested procedures.

The EXEC function used here is Bela Lubkin's. The stack and
memory allocation code was written by Kim Kokkonen.

Compile with mAx heap set to A000 or larger.
Cannot be run within the compiler, compile to COM file.

Version 1.1, changes NewStackSize to avoid problem on some systems, 11/4/86.
}

program TestInvoke;

const                         {DO NOT REDUCE}
  NewStackSize = 1700;        {Turbo Stack size (bytes) to keep while in DOS shell (>700)}
  MinDOSspace = 20000;        {Minimum bytes for DOS shell to run}
  StackBufferSize = 512;      {Bytes in DOS stack buffer}

type
  String255 = string[255];
  Registers =
  record
    case Integer of
      1 : (Ax, Bx, Cx, Dx, Bp, Si, Di, Ds, Es, Flags : Integer);
      2 : (Al, Ah, Bl, Bh, Cl, Ch, Dl, Dh : Byte);
  end;

var
  {Following variables are required for the shell}
  TopOfStack : Integer;
  StackBuffer : array[1..StackBufferSize] of Byte;
  StackSeg : Integer;
  StackPtr : Integer;
  NewStackSeg : Integer;
  NewStackPtr : Integer;
  ParasToKeep : Integer;
  ParasWeHave : Integer;
  ParasForDos : Integer;
  ExecStatus : Integer;

  Screenadr : Integer;
  Screenstore : array[1..4000] of Char;
  Screenx, Screeny : Integer;
  Commandstr : String255;

  {Following variable is for demonstration only}
  P : ^Integer;
  DOScommandLine : String255 absolute CSeg : $80;

  function ScreenAddress : Integer;
    {-Return the segment of the screen memory}
  var
    retracemode : Boolean;
    regs : Registers;
  begin
    regs.Ax := $0F00;
    {BIOS INT 10H call to get screen type}
    Intr($10, regs);
    retracemode := regs.Al <> 7;
    if retracemode then
      {Color card}
      ScreenAddress := $B800
    else
      ScreenAddress := $B000;
  end;                        {ScreenAddress}

  function StackPointer : Integer;
    {-Return the stack pointer at the point of the call}
  begin
    inline(
      $89/$E0/                {MOV     AX,SP}
      $05/$08/$00/            {ADD     AX,0008}
      $89/$EC/                {MOV     SP,BP}
      $5D/                    {POP     BP}
      $C2/$02/$00             {RET     0002}
      );
  end;                        {StackPointer}

  procedure Error(message : String255);
    {-Demonstration error handler}
  begin
    WriteLn(message);
    Halt(1);
  end;                        {Error}

  procedure SetBlock(paras : Integer);
    {-Free up some memory above this program for a DOS shell}
  var
    regs : Registers;
  begin                       {SetBlock}
    with regs do begin
      Ah := $4A;
      Es := CSeg;
      Bx := paras;
      MsDos(regs);
      if Odd(Flags) then
        Error('setblock error');
    end;
  end;                        {SetBlock}

  procedure StoreScreen;
    {-Demonstration StoreScreen, causes snow on CGA}
  begin
    Move(Mem[Screenadr:0], Screenstore, SizeOf(Screenstore));
    Screenx := WhereX;
    Screeny := WhereY;
  end;                        {Storescreen}

  procedure RestoreScreen;
    {-Demonstration RestoreScreen, causes snow on CGA}
  begin
    Move(Screenstore, Mem[Screenadr:0], SizeOf(Screenstore));
    GoToXY(Screenx, Screeny);
  end;                        {RestoreScreen}

  procedure Invoke(command : String255);
    {-Run any DOS command. Call with command='' for a new shell}
  var
    m : Integer;
    Ch : Char;

    function SubProcess(CommandLine : String255) : Integer;
      {-From Bela Lubkin's EXEC.PAS}
    const
      SSSave : Integer = 0;
      SPSave : Integer = 0;

    var
      regs : Registers;
      FCB1, FCB2 : array[0..36] of Byte;
      PathName : String255;
      CommandTail : String255;
      ParmTable : record
                    EnvSeg : Integer;
                    ComLin : ^Integer;
                    FCB1Pr : ^Integer;
                    FCB2Pr : ^Integer;
                  end;
      RegsFlags : Integer;

    begin
      if Pos(' ', CommandLine) = 0 then begin
        PathName := CommandLine+#0;
        CommandTail := ^M;
      end else begin
        PathName := Copy(CommandLine, 1, Pred(Pos(' ', CommandLine)))+#0;
        CommandTail := Copy(CommandLine, Pos(' ', CommandLine), 255)+^M;
      end;
      CommandTail[0] := Pred(CommandTail[0]);
      with regs do begin
        FillChar(FCB1, SizeOf(FCB1), 0);
        Ax := $2901;
        Ds := Seg(CommandTail[1]);
        Si := Ofs(CommandTail[1]);
        Es := Seg(FCB1);
        Di := Ofs(FCB1);
        MsDos(regs);          { Create FCB 1 }
        FillChar(FCB2, SizeOf(FCB2), 0);
        Ax := $2901;
        Es := Seg(FCB2);
        Di := Ofs(FCB2);
        MsDos(regs);          { Create FCB 2 }
        with ParmTable do begin
          EnvSeg := MemW[CSeg:$002C];
          ComLin := Addr(CommandTail);
          FCB1Pr := Addr(FCB1);
          FCB2Pr := Addr(FCB2);
        end;
        inline(
          $8D/$96/PathName/$42/ { <DX>:=Ofs(PathName[1]); }
          $8D/$9E/ParmTable/  { <BX>:=Ofs(ParmTable);   }
          $B8/$00/$4B/        { <AX>:=$4B00;            }
          $1E/$55/            { Save <DS>, <BP>         }
          $16/$1F/            { <DS>:=Seg(PathName[1]); }
          $16/$07/            { <ES>:=Seg(ParmTable);   }
          $2E/$8C/$16/SSSave/ { Save <SS> in SSSave     }
          $2E/$89/$26/SPSave/ { Save <SP> in SPSave     }
          $FC/                { CLD}
          $FA/                { Disable interrupts      }
          $CD/$21/            { Call MS-DOS             }
          $FA/                { Disable interrupts      }
          $2E/$8B/$26/SPSave/ { Restore <SP>            }
          $2E/$8E/$16/SSSave/ { Restore <SS>            }
          $FB/                { Enable interrupts       }
          $5D/$1F/            { Restore <BP>,<DS>       }
          $9C/$8F/$86/RegsFlags/ { RegsFlags:=<CPU flags>}
          $89/$86/regs);      { Regs.AX:=<AX>;          }
        if Odd(RegsFlags) then
          SubProcess := Ax
        else
          SubProcess := 0;
      end;
    end;                      {SubProcess}

    function GetEnvStr(SearchString : String255) : String255;
      {-Return the environment variable value}
    type
      env = array[0..32767] of Char;
    var
      eptr : ^env;
      estr : String255;
      done : Boolean;
      i : Integer;

    begin
      GetEnvStr := '';
      if SearchString <> '' then begin
        eptr := Ptr(MemW[CSeg:$002C], 0);
        i := 0;
        SearchString := SearchString+'=';
        done := False;
        estr := '';
        repeat
          if eptr^[i] = #0 then begin
            if eptr^[Succ(i)] = #0 then begin
              done := True;
              if SearchString = '==' then begin
                estr := '';
                i := i+4;
                while eptr^[i] <> #0 do begin
                  estr := estr+eptr^[i];
                  i := Succ(i);
                end;
                GetEnvStr := estr;
              end;
            end;
            if Copy(estr, 1, Length(SearchString)) = SearchString then begin
              GetEnvStr := Copy(estr, Succ(Length(SearchString)), 255);
              done := True;
            end;
            estr := '';
          end
          else estr := estr+eptr^[i];
          i := Succ(i);
        until done;
      end;
    end;                      {GetEnvStr}

  begin                       {Invoke}

    {Save current stack seg and ptr}
    inline(
      $8C/$D0/                {MOV    AX,SS}
      $A3/StackSeg/           {MOV    stackseg,AX}
      $89/$26/StackPtr        {MOV    stackptr,SP}
      );

    {The new lower stack goes above the "high water mark" of the heap }
    {Heap fragmentation may cause HeapPtr to be higher than you expect}
    NewStackSeg := Succ(Seg(HeapPtr^));
    NewStackPtr := NewStackSize;

    {Current DOS memory allocation read from memory control block}
    ParasWeHave := MemW[Pred(CSeg):3];
    ParasToKeep := Succ(NewStackSeg-CSeg)+Succ(NewStackSize shr 4);
    ParasForDos := ParasWeHave-ParasToKeep;

    {See if enough memory to run DOS}
    if (ParasForDos > 0) and (ParasForDos < (MinDOSspace shr 4)) then
      Error('Insufficient memory to run command');

    {See if enough stack buffer to store current Turbo stack}
    if succ(TopOfStack-StackPtr) > StackBufferSize then
      Error('Insufficient memory for internal stack buffer');

    {Build the command string}
    Commandstr := GetEnvStr('COMSPEC');
    if command <> '' then
      Commandstr := Commandstr+' /C '+command;

    {Store and Clear physical screen}
    StoreScreen;
    ClrScr;
    WriteLn('Type EXIT to return to program...');
    m := (ParasForDos-240) shr 6;
    WriteLn('Approximate memory available: ', m, 'K');

    {Copy the top of the stack to a buffer}
    Move(Mem[StackSeg:StackPtr], StackBuffer, succ(TopOfStack-StackPtr));

    {Lower stack}
    inline(
      $FA/                    {CLI    }
      $A1/NewStackSeg/        {MOV    AX,newstackseg}
      $8E/$D0/                {MOV    SS,AX}
      $8B/$26/NewStackPtr/    {MOV    SP,newstackptr}
      $FB                     {STI    }
      );

    {Deallocate memory for DOS}
    SetBlock(ParasToKeep);

    {Run the DOS command}
    ExecStatus := SubProcess(Commandstr);

    {Reallocate memory from DOS}
    SetBlock(ParasWeHave);

    {Restore stack seg and ptr to original values}
    inline(
      $FA/                    {CLI    }
      $A1/StackSeg/           {MOV    AX,stackseg}
      $8E/$D0/                {MOV    SS,AX}
      $8B/$26/StackPtr/       {MOV    SP,stackptr}
      $FB                     {STI    }
      );

    {Put stack buffer back on stack}
    Move(StackBuffer, Mem[StackSeg:StackPtr], succ(TopOfStack-StackPtr));

    {Allow time to see result}
    if command <> '' then begin
      Write('Press a key to continue ');
      Read(Kbd, Ch);
    end;

    {Restore screen}
    RestoreScreen;

    if ExecStatus <> 0 then
      Error('Error while invoking DOS');

  end;                        {Invoke}

begin                         {TestInvoke}

  {Store stack size for use in DOS shell invocation later}
  TopOfStack := StackPointer;

  {Get Screen address for later}
  Screenadr := ScreenAddress;

  {*****************************************************
  Do any desired heap allocation and deallocation here.
  WARNING: a fragmented heap will not be usable by DOS.
  For Dispose or Freemem to be effective, the objects
  deallocated must be at the top of the heap. Mark and
  Release may also be used.
  ******************************************************}
  GetMem(P, 4096);
  FreeMem(P, 4096);

  {Example call}
  if ParamCount > 0 then
    Invoke(DOScommandLine)
  else
    {A general command shell}
    Invoke('');

end.                          {TestInvoke}