home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DP Tool Club 31
/
CDASC_31_1996_juillet_aout.iso
/
internet
/
rnr214.zip
/
EXEC23P.ZIP
/
EXEC.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-08-03
|
15KB
|
579 lines
Unit exec;
{
EXEC function with memory swap.
Needs Assembler file 'spawn.asm'.
Public domain software by
Thomas Wagner
Ferrari electronic GmbH
Beusselstrasse 27
D-1000 Berlin 21
West Germany
BIXname: twagner
}
Interface
Uses
Dos;
type
filename = pathstr;
string128 = string [128];
function do_exec (xfn: filename; pars: string128; spwn: integer;
needed: word; newenv: boolean): integer;
{ The EXEC function.
Parameters: xfn is a string containing the name of the file
to be executed. If the string is empty,
the COMSPEC environment variable is used to
load a copy of COMMAND.COM or its equivalent.
If the filename does not include a path, the
current PATH is searched after the default.
If the filename does not include an extension,
the path is scanned for a COM or EXE file in
that order.
pars The program parameters.
spwn If 1, the function will return, if necessary
after swapping the memory image.
If -1, EMS will not be used during swapping.
If 0, the function will terminate after the
EXECed program returns.
NOTE: If the program file is
not found, the function will always return
with the appropriate error code, even if
'spwn' is 0.
needed The memory needed for the program in
paragraphs. If not enough memory is free, the
program will be swapped out. Use 0 to never
swap, $ffff to always swap. If 'spwn' is false,
this parameter is irrelevant.
newenv If this parameter is FALSE, the environment
of the spawned program is a copy of the parent's
environment. If it is TRUE, a new environment
is created which includes the modifications from
previous 'putenv' calls.
Return value:
$0000..00FF: The EXECed Program's return code
(0..255 decimal)
$0100: Error writing swap file
(256 decimal)
$0200: Program file not found
(512 decimal)
$03xx: DOS-error-code xx calling EXEC
(768..1023 decimal)
$0400: Error allocating environment buffer
(1024 decimal)
}
procedure putenv (envvar: string);
{ Adds a string to the environment. Note that the change to the
environment is valid for an exec'ed process only, and only if you
set the 'newenv' parameter in do_exec to TRUE. }
function envcount: integer;
function envstr (index: integer): string;
function getenv (envvar: string): string;
{ Replacement functions for the environment handling functions in the
DOS unit. All three functions work exactly like their DOS-unit
counterparts, except that they recognize the changes to the child
environment produced by 'putenv'. }
{===========================================================================}
Implementation
const
swap_filename = '$$AAAAAA.AAA';
m_swapping = $01;
m_use_ems = $02;
m_creat_temp = $04;
m_exec = $80;
type
stringptr = ^string;
stringarray = array [0..10000] of stringptr;
stringarrptr = ^stringarray;
bytearray = array [0..30000] of byte;
bytearrayptr = ^bytearray;
var
envptr: stringarrptr; { Pointer to the changed environment }
envcnt: integer; { Count of environment strings }
function do_spawn (method: byte;
var swapfn; var xeqfn; var cmdtail; envlen: word;
var env): integer; external;
{$L spawn}
{ Environment routines }
function envcount: integer;
{ Returns count of strings in environment. }
var
cnt: integer;
begin
if envptr = nil { If not yet changed }
then envcount := dos.envcount
else envcount := envcnt;
end;
function envstr (index: integer): string;
{ Returns environment string 'index' }
begin
if envptr = nil { If not yet changed }
then envstr := dos.envstr (index)
else if (index <= 0) or (index >= envcnt)
then envstr := ''
else if envptr^ [index - 1] = nil
then envstr := ''
else envstr := envptr^ [index - 1]^;
end;
function name_eq (var n1, n2: string): boolean;
{ Compares search string 'n1' with environment string 'n2'.
Case is insignificant. }
var
i: integer;
eq: boolean;
begin
i := 1;
eq := false;
while (i <= length (n1)) and (i <= length (n2)) and
(upcase (n1 [i]) = upcase (n2 [i])) do
i := i + 1;
name_eq := (i > length (n1)) and (i <= length (n2)) and (n2 [i] = '=');
end;
function searchenv (var str: string): integer;
{ Search for environment string, returns index in 'envptr' array.
Assumes 'envptr' is not NIL. }
var
idx: integer;
found: boolean;
begin
idx := 0;
found := false;
while (idx < envcnt) and not found do
begin
if envptr^ [idx] <> nil
then found := name_eq (str, envptr^ [idx]^);
idx := idx + 1;
end;
if not found
then searchenv := -1
else searchenv := idx - 1;
end;
function getenv (envvar: string): string;
{ Returns value of environment string specified by name. }
var
strp: stringptr;
eq: integer;
begin
if envptr = nil { If not yet changed }
then getenv := dos.getenv (envvar)
else begin
eq := searchenv (envvar);
if eq < 0
then getenv := ''
else begin
strp := envptr^ [eq];
eq := pos ('=', strp^);
getenv := copy (strp^, eq + 1, length (strp^) - eq);
end;
end;
end;
procedure init_envptr;
{ Initialise 'envptr' array. Called when 'putenv' is used for the
first time. Copies all environment strings into heap storage,
and builds an array of pointers to this strings. }
var
i: integer;
str: string [255];
begin
envcnt := dos.envcount;
getmem (envptr, envcnt * sizeof (stringptr));
if envptr = nil
then exit;
for i := 0 to envcnt - 1 do
begin
str := dos.envstr (i + 1);
getmem (envptr^ [i], length (str) + 1);
if envptr^ [i] <> nil
then envptr^ [i]^ := str;
end;
end;
procedure putenv (envvar: string);
{ Adds the string 'envvar' to the environment, or changes the
environment string if the name is already present. }
var
idx, eq: integer;
help: stringarrptr;
begin
if envptr = nil
then init_envptr;
if envptr = nil
then exit;
eq := pos ('=', envvar);
if eq = 0
then exit;
for idx := 1 to eq do
envvar [idx] := upcase (envvar [idx]);
idx := searchenv (envvar);
if idx >= 0
then begin
freemem (envptr^ [idx], length (envptr^ [idx]^) + 1);
if eq >= length (envvar)
then envptr^ [idx] := nil
else begin
getmem (envptr^ [idx], length (envvar) + 1);
if envptr^ [idx] <> nil
then envptr^ [idx]^ := envvar;
end;
end
else if eq < length (envvar)
then begin
getmem (help, (envcnt + 1) * sizeof (stringptr));
if help = nil
then exit;
move (envptr^, help^, envcnt * sizeof (stringptr));
freemem (envptr, envcnt * sizeof (stringptr));
envptr := help;
getmem (envptr^ [envcnt], length (envvar) + 1);
if envptr^ [envcnt] <> nil
then envptr^ [envcnt]^ := envvar;
envcnt := envcnt + 1;
end;
end;
{ Routines to search for files }
function exists (fn: filename): boolean;
{ Returns TRUE if a file with name 'fn' exists. }
var
s: searchrec;
begin
findfirst (fn, readonly or hidden or sysfile or archive, s);
exists := doserror = 0;
end { exists };
function tryext (var fn: filename): boolean;
{ Try '.COM' and '.EXE' on current filename, modify filename if found. }
var
found: boolean;
begin
found := exists (fn + '.COM');
if found
then fn := fn + '.COM'
else begin
found := exists (fn + '.EXE');
if found
then fn := fn + '.EXE'
end;
tryext := found;
end;
function findfile (var fn: filename): boolean;
{ Try to find the file 'fn' in the current path. Modifies the filename
accordingly. }
var
path: string [255];
prfx: filename;
i, j: integer;
ext, found: boolean;
begin
if fn = ''
then fn := getenv ('COMSPEC');
i := pos ('\', fn);
j := pos ('.', fn);
if (j < i) and (j > 0)
then begin
j := i;
while (j <= length (fn)) and (fn [j] <> '.') do
j := j + 1;
end;
if (j > 0) and (j = length (fn))
then fn [0] := pred (fn [0]);
ext := (j > 0) and (j < length (fn));
if (ext)
then found := exists (fn)
else found := tryext (fn);
if not found and (i = 0)
then begin
path := getenv ('PATH');
i := 1;
while i <= length (path) do
begin
j := 0;
while (path [i] <> ';') and (i <= length (path)) do
begin
j := j + 1;
prfx [j] := path [i];
i := i + 1;
end;
i := i + 1;
if (j > 0)
then begin
j := j + 1;
prfx [j] := '\';
prfx [0] := chr (j);
prfx := prfx + fn;
if ext
then found := exists (prfx)
else found := tryext (prfx);
if found
then begin
fn := prfx;
i := 999;
end;
end;
end;
end;
findfile := found;
end; { findfile }
procedure tempdir (var outfn: filename);
{ Set temporary file path.
Read "TMP/TEMP" environment. If empty or invalid, clear path.
If TEMP is drive or drive+backslash only, return TEMP.
Otherwise check if given path is a valid directory.
If so, add a backslash, else clear path.
}
var
drive: string [2];
dir: dirstr;
name: namestr;
ext: extstr;
f: file;
attr: word;
regs: registers;
begin
outfn := getenv ('TMP');
if outfn = ''
then outfn := getenv ('TEMP');
if outfn = ''
then exit;
if outfn [length (outfn)] in ['\', '/']
then dec (outfn [0]);
fsplit (outfn, dir, name, ext);
drive := '';
if length (dir) > 1
then if dir [2] = ':'
then begin
drive := dir [1] + ':';
delete (dir, 1, 2);
end;
if drive <> ''
then begin
regs.ah := $1c;
regs.dl := ord (upcase (drive [1])) - ord ('A') + 1;
msdos (regs);
if regs.al = $ff
then begin
outfn := '';
exit;
end;
end;
if name = ''
then begin
if dir <> ''
then outfn := ''
else outfn := drive + '\';
exit;
end;
assign (f, outfn);
getfattr (f, attr);
if (doserror <> 0) or
((attr and directory) = 0) or
((attr and readonly) <> 0)
then outfn := ''
else outfn := outfn + '\';
end;
function do_exec (xfn: filename; pars: string128; spwn: integer;
needed: word; newenv: boolean): integer;
var
swapfn: filename;
avail: word;
regs: registers;
envlen, einx: word;
idx, len: integer;
envp: bytearrayptr;
method: byte;
begin
{ First, check if the file to execute exists. }
if not findfile (xfn)
then begin
do_exec := $200;
exit;
end;
{ Now create a copy of the environment if the user wants it, and
if the environment has been changed. }
envlen := 0;
if newenv and (envptr <> nil)
then begin
for idx := 0 to envcnt - 1 do
envlen := envlen + length (envptr^ [idx]^) + 1;
if envlen > 0
then begin
envlen := envlen + 1;
getmem (envp, envlen);
if envp = nil
then begin
do_exec := $400;
exit;
end;
einx := 0;
for idx := 0 to envcnt - 1 do
begin
len := length (envptr^ [idx]^);
move (envptr^ [idx]^ [1], envp^ [einx], len);
envp^ [einx + len] := 0;
einx := einx + len + 1;
end;
envp^ [einx] := 0;
end;
end;
if spwn = 0
then method := m_exec { Mark 'EXEC' function }
else begin
{ Determine amount of free memory }
with regs do
begin
ax := $4800;
bx := $ffff;
msdos (regs);
avail := regs.bx;
end;
{ No swapping if available memory > needed }
if needed < avail
then method := 0
else begin
{ Swapping necessary, use 'TMP' or 'TEMP' environment variable
to determine swap file path if defined. }
if spwn < 0
then method := m_swapping
else method := m_swapping or m_use_ems;
tempdir (swapfn);
if (dosversion and $ff) >= 3
then method := method or m_creat_temp
else begin
swapfn := swapfn + swap_filename;
len := length (swapfn);
while exists (swapfn) do
begin
if (swapfn [len] >= 'Z')
then len := len - 1;
if (swapfn [len] = '.')
then len := len - 1;
swapfn [len] := succ (swapfn [len]);
end;
end;
swapfn [length (swapfn) + 1] := #0;
end;
end;
{ All set up, ready to go. }
swapvectors;
do_exec := do_spawn (method, swapfn, xfn, pars, envlen, envp^);
swapvectors;
{ Free the environment buffer if it was allocated. }
if envlen > 0
then freemem (envp, envlen);
end;
{ Initialisation for environment processing }
Begin
envptr := nil;
envcnt := 0;
End.