Liren Large Software Subsidy 16/16.iso/w/w048/2.ddi/MSSRC.ARC/INVOKE.PAS

Pascal/Delphi Source File | 1987-12-21 | 6.6 KB | 250 lines

{                            INVOKE.PAS
                               MS 4.0
                Copyright (c) 1985, 87 by Borland International, Inc.         }

{$I-}
{$R-}
{$V-}
{$S-}
{$D-}

unit Invoke;
  {-Compress the Turbo heap and run a DOS command}

interface

uses
  Crt,
  Dos;

function ExecShrink(Command : string) : Integer;
  {-Run any DOS command. Call with command='' for a new shell}
  { Return codes:
           0 : Success
          -1 : Insufficient memory to store free list
          -2 : DOS setblock error before EXEC call
          -3 : DOS setblock error after EXEC call  -- critical error
          -4 : Insufficient memory to run DOS command
        else   a DOS error code
    }

  {==========================================================================}

implementation

const
  MinDOSspace = 20000;       {Minimum bytes for DOS shell to run}

var
  PathName, CommandTail : string[127];
  TopOfHeap : Pointer;       {value of HeapEnd when program began}

  function HeapEnd : Pointer;
    {-Return the last available location for the heap}

  begin                      {HeapEnd}
    if Ofs(FreePtr^) = 0 then
      {Free list is empty}
      HeapEnd := Ptr(Seg(FreePtr^)+$1000, 0)
    else
      HeapEnd := Ptr(Seg(FreePtr^)+Ofs(FreePtr^) shr 4, Ofs(FreePtr^) and $F);
  end;                       {HeapEnd}

  function PtrDiff(HighPt, LowPt : Pointer) : LongInt;
    {-Return the number of bytes between point A^ and point B^}
  type
    SegOfs = record
               O, S : Word;
             end;
  var
    High : SegOfs absolute HighPt;
    Low : SegOfs absolute LowPt;
    HighVal, LowVal : LongInt;

  begin                      {PtrDiff}
    HighVal := LongInt(High.S) shl 4+LongInt(High.O);
    LowVal := LongInt(Low.S) shl 4+LongInt(Low.O);
    PtrDiff := HighVal-LowVal;
  end;                       {PtrDiff}

  function SetBlock(Paras : Integer) : Boolean;
    {-Free up some memory above this program for a DOS shell}
  var
    regs : registers;

  begin                      {SetBlock}
    with regs do begin
      Ah := $4A;
      ES := PrefixSeg;
      Bx := Paras;
      MsDos(regs);
      SetBlock := not Odd(Flags);
    end;
  end;                       {SetBlock}

  function GetEnvStr(SearchString : string) : string;
    {-Return the environment variable value}
  type
    Env = array[0..32767] of Char;
  var
    EPtr : ^Env;
    EStr : string[255];
    Done : Boolean;
    SearchLen, I : Integer;

  begin                      {GetEnvStr}
    GetEnvStr := '';
    if SearchString = '' then
      Exit;

    EPtr := Ptr(MemW[PrefixSeg:$2C], 0);
    I := 0;
    SearchString := SearchString+'=';
    SearchLen := Length(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];
              Inc(I);
            end;
            GetEnvStr := EStr;
          end;
        end;
        if Copy(EStr, 1, SearchLen) = SearchString then begin
          GetEnvStr := Copy(EStr, Succ(SearchLen), 255);
          Done := True;
        end;
        EStr := '';
      end
      else
        EStr := EStr+EPtr^[I];
      Inc(I);
    until Done;
  end;                       {GetEnvStr}

  function ExecShrink(Command : string) : Integer;
    {-Run any DOS command. Call with command='' for a new shell}
  label
    ExitPoint;
  var
    C : Char;
    OldHeapEnd,
    NewHeapEnd : Pointer;
    BytesAllocated,
    FreeListSize,
    ParasToKeep,
    ParasWeHave,
    ParasForDos : Word;

  begin                      {ExecShrink}

    {Calculate number of bytes to save}
    FreeListSize := PtrDiff(TopOfHeap, HeapEnd);
    BytesAllocated := 0;

    {If enough space available, use stack to store the free list}
    if FreeListSize+1000 < SPtr then
      NewHeapEnd := Ptr(SSeg, 0)

    else begin

      {Check for sufficient memory}
      if MaxAvail < FreeListSize then begin
        {Insufficient memory to store free list}
        ExecShrink := -1;
        Exit;
      end;

      {Allocate memory for copy of free list}
      BytesAllocated := FreeListSize;
      if BytesAllocated > 0 then
        GetMem(NewHeapEnd, BytesAllocated);

      {Recalculate the size of the free list}
      FreeListSize := Word(PtrDiff(TopOfHeap, HeapEnd));
    end;

    {Save the current pointer to the end of the free list}
    OldHeapEnd := HeapEnd;

    {Current DOS memory allocation read from memory control block}
    ParasWeHave := MemW[Pred(PrefixSeg):3];

    {Calculate amount of memory to give up}
    ParasForDos := Pred(PtrDiff(TopOfHeap, HeapPtr) shr 4);

    {Calculate amount of memory to keep while in shell}
    ParasToKeep := ParasWeHave-ParasForDos;

    {See if enough memory to run DOS}
    if (ParasForDos > 0) and (ParasForDos < (MinDOSspace shr 4)) then begin
      ExecShrink := -4;
      goto ExitPoint;
    end;

    {Copy the free list to a safe location}
    Move(OldHeapEnd^, NewHeapEnd^, FreeListSize);

    {Deallocate memory for DOS}
    if not SetBlock(ParasToKeep) then begin
      ExecShrink := -2;
      goto ExitPoint;
    end;

    {get parameters for Execute}
    PathName := GetEnvStr('COMSPEC');
    if Command = '' then
      CommandTail := ''
    else
      CommandTail := '/C '+Command;

    {Clear physical screen}
    ClrScr;

    {Show status info if entering DOS shell}
    if Command = '' then begin
      WriteLn('Approximate memory available: ', (ParasForDos-240) shr 6, 'K');
      WriteLn('Type EXIT to return to program...');
    end;

    {Call Turbo's EXEC function}
    Exec(PathName, CommandTail);

    {Reallocate memory from DOS}
    if not SetBlock(ParasWeHave) then begin
      ExecShrink := -3;
      goto ExitPoint;
    end;

    {Put free list back where it was}
    Move(NewHeapEnd^, OldHeapEnd^, FreeListSize);

    {If not in shell allow time to see result}
    if (Command <> '') or (doserror <> 0) then begin
      Write(^M^J'Press any key to continue...');
      C := ReadKey;
    end;

    {If we get to here, our function result is in DosError}
    ExecShrink := doserror;

ExitPoint:

    {Deallocate any dynamic memory used}
    if BytesAllocated <> 0 then
      FreeMem(NewHeapEnd, BytesAllocated);

  end;                       {ExecShrink}

begin
  {Save top of heap for later}
  TopOfHeap := HeapEnd;
end.