Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/NEWSHELL.ZIP/SHELLOUT.PAS

Pascal/Delphi Source File | 1990-10-11 | 6.3 KB | 249 lines

(*********************************************************************)
(*********************************************************************)
{This source code was written by:

       Harvey Arkawy
       Rabbitsoft
       10123 Hanna Ave.
       Chatsworth, Ca. 91311
       [phone]

and is released through Shareware!

The author makes no guarantee whatsoever other than it functions on
his Hyundai Turbo 16.

It was compiled using Dos 3.2, 4dos 3.02 and Turbo Pascal Version 5.0
and was tested using Dos 3.3 and 4.01 with 4dos 3.02.

If the procedure known as 'ShellOut' from this Pascal file or the setup
routines within the test program are of any use or assistance to you,
any donation of (U.S.) funds would be greatly appreciated.}

(*********************************************************************)
(*********************************************************************)

Program Test;
USES CRT,Dos;
Var
    S,
    CommandCom,
    OriginalDirectory  : PathStr;
    ThisProgram        : NameStr;
    ThisExt            : ExtStr;
    OriginalDrive      : String[2];
    CommandLineOptions : ComStr;
    Counter            : integer;
    R                  : Registers;
    Ch                 : char;
    Done               : Boolean;


(**                     The procedure starts here.                      **)

PROCEDURE ShellOut(WhoAmI : PathStr);
Const Null : Char = #0;
Var
    PSP_Seg,
    NewPSP_Seg,
    Environment_Seg,
    NewEnvironment_Seg : word;
    I,
    J,
    II,
    JJ,
    Item_Counter,
    Total_Items              : Integer;
    Entry                    : String[128];
    Foundit                  : Boolean;
    MemLocation              : Pointer;

  Function Get_PSP : Word;
    Begin
      R.AX := $6200;
      MSDos(R);
      Get_PSP := R.BX;
    End;

  Procedure Release_Mem(NewEnvironment_Seg : Word);
    Begin
      R.AX := $4900;
      R.ES := NewEnvironment_Seg;
      MSDos(R);
      If R.Flags and FCarry <> 0 then
        Begin
          Write(#7);
          Writeln('Memory release failed.  Error # ',R.AX);
          Halt;
        End;
    End;

  Function Allocate_Mem (Total_Items: Integer) : Word;
    Begin
      R.AX := $4800;
      R.BX := ((Total_Items * 128) div 16) + 1;
      MSDos(R);
      If R.Flags and FCarry <> 0 then
        Begin
          Write(#7);
          Write('Dos Call to Allocate memory failed');
          Write('The largest available block is ',R.BX);
          halt;
        End
      Else
    Allocate_Mem := R.Ax;
  End;


Begin
  {Determine if the 'Prompt=' is part of the environment. If not then
   increase the environment quantity.}

  Foundit := False;
  I := 1;
  Total_Items := EnvCount;
  While I <= EnvCount do
    Begin
      Entry := EnvStr(I);
      If Pos('PROMPT=',Entry) = 1 THEN
        Begin
          Foundit := True;
          Inc(I,EnvCount + 1);
        end;
      Inc(I);
    End;
  If Not Foundit then Inc(Total_Items);

{Get the location of the Program_Segment_Prefix and Store it in PSP_Seg.}

  PSP_Seg := Get_PSP;

{Get the pointer to the Environment's AsciiZ Strings.}

  Environment_Seg := MemW[PSP_Seg: $2C];

{Allocate Memory for the new AsciiZ strings.}

  NewEnvironment_Seg := Allocate_Mem (Total_Items);

{Set Original Environment Segment Pointer to point to the New Location.
 This is required so the new PSP will have the correct location of
 the new environment AsciiZ strings and therefore the child process will
 use this environment information when it is executed.}

  MemW[PsP_Seg:$2C] := NewEnvironment_Seg;


{Read in the old Environment into Entry and test for 'PROMPT='.}

  Clrscr;
  I := 0;
  II := 0;
  Item_Counter := 0;
  Repeat
    J := 0;
    Entry := '';
    Repeat
      Inc(J);
      Entry[J] := Chr(Mem[Environment_Seg: I]);
      Inc(I);
    Until (Entry[J] = Null);
    Entry[0] := Chr(J-1);
    If Length(Entry) > 0 then
      Begin
        If Pos('PROMPT=',Entry) > 0 then
          Entry := 'PROMPT=Type ''EXIT'' to return to ' + WhoAmI +
              '...$_$_$P$g';

{Relocate Entry to the New Environment string location.}

        For JJ := 1 to Length(Entry) do
          Begin
            Mem[NewEnvironment_Seg: II ] := Ord(Entry[JJ]);
            Inc(II);
          End;
        Mem[NewEnvironment_Seg: II ] := Ord(#0);
        Inc(II);
      End;
  Until (Mem[Environment_Seg: I + 1] = 0);

{If no prompt in the environment, put one there.}

  If Not Foundit then
    Begin
      Entry := 'PROMPT=Type ''EXIT'' to return to ' + WhoAmI +
         '...$_$_$P$g';
      For JJ := 1 to Length(Entry) do
        Begin
          Mem[NewEnvironment_Seg: II ] := Ord(Entry[JJ]);
          Inc(II);
        End;
    End;

{Clean the back end of the environment.}
  For JJ := 0 to 4 do Mem[NewEnvironment_Seg: II + JJ ] := Ord(#0);

{CommandCom is equal to what Comspec equals.
 Some computers don't use 'COMMAND.COM', they might use 4dos.}

  Clrscr;
  SwapVectors;
  Exec(CommandCom,'');
  SwapVectors;


{Restore the original PSP's environment pointer.}

  MemW[PSP_Seg:$2C] := Environment_Seg;

{Release memory (dump the new AsciiZ strings).}

  Release_Mem(NewEnvironment_Seg);

END;

(**                     The procedure ends here.                      **)


{The test program starts here.}

Begin
  FSplit(FExpand(ParamStr(0)),OriginalDirectory,ThisProgram,ThisExt);
  CommandLineOptions := ParamStr(1);
  OriginalDrive := copy(OriginalDirectory,1,2);
  If OriginalDirectory[Length(OriginalDirectory)] = '\' then
    OriginalDirectory := Copy(OriginalDirectory,1,
      Length(OriginalDirectory)-1);
  Counter := 0;
  While Counter <= EnvCount do
    Begin
      S := EnvStr(Counter);
      If Pos('COMSPEC=',S) = 1 THEN
        Begin
          Delete(S,1,8);
          Counter := EnvCount + 1;
        end;
      Inc(Counter);
    End;
  CommandCom := FExpand(S);
  SwapVectors;
  exec(CommandCom,' /C '+ OriginalDrive);
  SwapVectors;
  ChDir(OriginalDirectory);
  Repeat
    Done := False;
    Clrscr;
    GotoXy(30,5);
    Writeln('S] Shell to DOS');
    Gotoxy(30,6);
    Writeln('Q] Quit');
    Gotoxy(30,8);
    Write('Enter ''S'' or ''Q''');
    Ch := Upcase(ReadKey);
    Case Ch of
      'S': ShellOut(ThisProgram);
      'Q': Halt;
    End;
  Until Done;
End.