Category : Pascal Source Code
Archive   : SHELLOUT.ZIP
Filename : SHELLOUT.PAS

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

Harvey Arkawy
Rabbitsoft
10123 Hanna Ave.
Chatsworth, Ca. 91311
(818) 341-6104

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.