paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-14 14:09:20 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Exec cleanup

Browse Source
This commit is contained in:
Tomas Hajny 2004-03-21 20:22:20 +00:00
parent b0c948a143
commit db94578ce6
1 changed files with 79 additions and 130 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

209
rtl/os2/dos.pas
View File

@ -62,49 +62,39 @@ Type
{Flags for the exec procedure: {Flags for the exec procedure:
Starting the program: }
efwait: Wait until program terminates.
efno_wait: Don't wait until the program terminates. Does not work
in dos, as DOS cannot multitask.
efoverlay: Terminate this program, then execute the requested
program. WARNING: Exit-procedures are not called!
efdebug: Debug program. Details are unknown.
efsession: Do not execute as child of this program. Use a seperate
session instead.
efdetach: Detached. Function unknown. Info wanted!
efpm: Run as presentation manager program.
Not found info about execwinflags {$ifdef HASTHREADVAR}
threadvar
Determining the window state of the program: {$else HASTHREADVAR}
efdefault: Run the pm program in it's default situation. var
efminimize: Run the pm program minimized. {$endif HASTHREADVAR}
efmaximize: Run the pm program maximized.
effullscreen: Run the non-pm program fullscreen.
efwindowed: Run the non-pm program in a window.
}
type execrunflags=(efwait,efno_wait,efoverlay,efdebug,efsession,
efdetach,efpm);
execwinflags=(efdefault,efminimize,efmaximize,effullscreen,
efwindowed);
const
(* For compatibility with VP/2, used for runflags in Exec procedure. *) (* For compatibility with VP/2, used for runflags in Exec procedure. *)
ExecFlags: cardinal = ord (efwait); ExecFlags: cardinal;
{$i dosh.inc} {$i dosh.inc}
{OS/2 specific functions} {OS/2 specific functions}
function exec(path:pathstr;runflags:execrunflags;winflags:execwinflags;
const comline:comstr):longint;
function GetEnvPChar (EnvVar: string): PChar; function GetEnvPChar (EnvVar: string): PChar;
function DosErrorModuleName: string;
(* In case of an error in Dos.Exec returns the name of the module *)
(* causing the problem - e.g. name of a missing or corrupted DLL. *)
implementation implementation
var LastSR: SearchRec;
{$ifdef HASTHREADVAR}
threadvar
{$else HASTHREADVAR}
var
{$endif HASTHREADVAR}
LastDosExitCode: longint;
LastDosErrorModuleName: string;
type TBA = array [1..SizeOf (SearchRec)] of byte; type TBA = array [1..SizeOf (SearchRec)] of byte;
PBA = ^TBA; PBA = ^TBA;
@ -113,6 +103,7 @@ const FindResvdMask = $00003737; {Allowed bits in attribute
specification for DosFindFirst call.} specification for DosFindFirst call.}
function fsearch(path:pathstr;dirlist:string):pathstr; function fsearch(path:pathstr;dirlist:string):pathstr;
Var Var
A: array [0..255] of char; A: array [0..255] of char;
@ -124,6 +115,7 @@ begin
fsearch := StrPas (@A); fsearch := StrPas (@A);
end; end;
procedure getftime(var f;var time:longint); procedure getftime(var f;var time:longint);
var var
FStat: TFileStatus3; FStat: TFileStatus3;
@ -139,6 +131,7 @@ begin
Time:=0; Time:=0;
end; end;
procedure SetFTime (var F; Time: longint); procedure SetFTime (var F; Time: longint);
var FStat: TFileStatus3; var FStat: TFileStatus3;
RC: cardinal; RC: cardinal;
@ -157,108 +150,41 @@ begin
DosError := integer (RC); DosError := integer (RC);
end; end;
{$ifdef HASTHREADVAR}
threadvar
{$else HASTHREADVAR}
var
{$endif HASTHREADVAR}
LastDosExitCode: longint;
procedure exec (const path:pathstr;const comline:comstr); procedure Exec (const Path: PathStr; const ComLine: ComStr);
{Execute a program.} {Execute a program.}
begin var Args: PByteArray;
LastDosExitCode := Exec (Path, ExecRunFlags (ExecFlags), efDefault, ComLine); ArgSize: word;
end; Res: TResultCodes;
ObjName: string;
function Exec (path:pathstr;runflags:execrunflags;winflags:execwinflags;
const comline:comstr): longint;
{Execute a program. More suitable for OS/2 than the exec above.}
var args:Pbytearray;
env:Pbytearray;
i,argsize:word;
esadr:pointer;
d:dirstr;
n:namestr;
e:extstr;
p : ppchar;
j : integer;
res: TResultCodes;
ObjName: String;
const const
ArgsSize = 2048; (* Amount of memory reserved for arguments in bytes. *) MaxArgsSize = 2048; (* Amount of memory reserved for arguments in bytes. *)
begin begin
getmem(args,ArgsSize); { LastDosExitCode := Exec (Path, ExecRunFlags (ExecFlags), efDefault, ComLine);}
GetMem(env, envc*sizeof(pchar)+16384); GetMem (Args, MaxArgsSize);
{Now setup the arguments. The first argument should be the program ArgSize := 0;
name without directory and extension.} Move (Path [1], Args^ [ArgSize], Length (Path));
fsplit(path,d,n,e); Inc (ArgSize, Length (Path));
// args^[0]:=$80; Args^ [ArgSize] := 0;
argsize:=0; Inc (ArgSize);
for i:=1 to length(n) do
begin
args^[argsize]:=byte(n[i]);
inc(argsize);
end;
args^[argsize]:=0;
inc(argsize);
{Now do the real arguments.} {Now do the real arguments.}
i:=1; Move (ComLine [1], Args^ [ArgSize], Length (ComLine));
while i<=length(comline) do Inc (ArgSize, Length (ComLine));
begin Args^ [ArgSize] := 0;
if comline[i]<>' ' then Inc (ArgSize);
begin Args^ [ArgSize] := 0;
{Commandline argument found. Copy it.} DosError := DosExecPgm (ObjName, cardinal (ExecFlags), Args, nil, Res, Path);
// args^[argsize]:=$80; if DosError = 0 then
// inc(argsize); begin
while (i<=length(comline)) and (comline[i]<>' ') do LastDosExitCode := Res.ExitCode;
begin LastDosErrorModuleName := '';
args^[argsize]:=byte(comline[i]); end
inc(argsize); else
inc(i); begin
end; LastDosErrorModuleName := ObjName;
args^[argsize]:=32;//0; LastDosExitCode := 0; (* Needed for TP/BP compatibility *)
inc(argsize); end;
end; FreeMem (Args, MaxArgsSize);
inc(i);
end;
args^[argsize]:=0;
inc(argsize);
{Commandline ready, now build the environment.
Oh boy, I always had the opinion that executing a program under Dos
was a hard job!}
asm
movl env,%edi {Setup destination pointer.}
movl envc,%ecx {Load number of arguments in edx.}
movl envp,%esi {Load env. strings.}
xorl %edx,%edx {Count environment size.}
.Lexa1:
lodsl {Load a Pchar.}
xchgl %eax,%ebx
.Lexa2:
movb (%ebx),%al {Load a byte.}
incl %ebx {Point to next byte.}
stosb {Store it.}
incl %edx {Increase counter.}
cmpb $0,%al {Ready ?.}
jne .Lexa2
loop .Lexa1 {Next argument.}
stosb {Store an extra 0 to finish. (AL is now 0).}
incl %edx
// movw %dx,ES.SizeEnv {Store environment size.}
end ['eax','ebx','ecx','edx','esi','edi'];
//Not clear how to use
DosError:=DosExecPgm(ObjName, cardinal (RunFlags), Args, Env, Res, Path);
exec:=Res.ExitCode;
freemem(args,ArgsSize);
FreeMem(env, envc*sizeof(pchar)+16384);
{Phew! That's it. This was the most sophisticated procedure to call
a system function I ever wrote!}
end; end;
@ -268,6 +194,12 @@ begin
end; end;
function DosErrorModuleName: string;
begin
DosErrorModuleName := LastDosErrorModuleName;
end;
function dosversion:word; function dosversion:word;
{Returns OS/2 version} {Returns OS/2 version}
var var
@ -278,6 +210,7 @@ begin
DosVersion:=Major or Minor shl 8; DosVersion:=Major or Minor shl 8;
end; end;
procedure GetDate (var Year, Month, MDay, WDay: word); procedure GetDate (var Year, Month, MDay, WDay: word);
Var Var
dt: TDateTime; dt: TDateTime;
@ -289,6 +222,7 @@ begin
WDay:=dt.Weekday; WDay:=dt.Weekday;
end; end;
procedure SetDate (Year, Month, Day: word); procedure SetDate (Year, Month, Day: word);
var var
DT: TDateTime; DT: TDateTime;
@ -300,6 +234,7 @@ begin
DosSetDateTime (DT); DosSetDateTime (DT);
end; end;
procedure GetTime (var Hour, Minute, Second, Sec100: word); procedure GetTime (var Hour, Minute, Second, Sec100: word);
var var
dt: TDateTime; dt: TDateTime;
@ -311,6 +246,7 @@ begin
Sec100:=dt.Hundredths; Sec100:=dt.Hundredths;
end; end;
procedure SetTime (Hour, Minute, Second, Sec100: word); procedure SetTime (Hour, Minute, Second, Sec100: word);
var var
DT: TDateTime; DT: TDateTime;
@ -323,20 +259,24 @@ begin
DosSetDateTime (DT); DosSetDateTime (DT);
end; end;
procedure getcbreak(var breakvalue:boolean); procedure getcbreak(var breakvalue:boolean);
begin begin
breakvalue := True; breakvalue := True;
end; end;
procedure setcbreak(breakvalue:boolean); procedure setcbreak(breakvalue:boolean);
begin begin
end; end;
procedure getverify(var verify:boolean); procedure getverify(var verify:boolean);
begin begin
verify := true; verify := true;
end; end;
procedure setverify(verify:boolean); procedure setverify(verify:boolean);
begin begin
end; end;
@ -355,6 +295,7 @@ begin
DiskFree := -1; DiskFree := -1;
end; end;
function DiskSize (Drive: byte): int64; function DiskSize (Drive: byte): int64;
var FI: TFSinfo; var FI: TFSinfo;
RC: cardinal; RC: cardinal;
@ -372,6 +313,7 @@ procedure SearchRec2DosSearchRec (var F: SearchRec);
begin begin
end; end;
procedure DosSearchRec2SearchRec (var F: SearchRec); procedure DosSearchRec2SearchRec (var F: SearchRec);
type type
TRec = record TRec = record
@ -388,6 +330,7 @@ begin
end; end;
end; end;
procedure FindFirst (const Path: PathStr; Attr: word; var F: SearchRec); procedure FindFirst (const Path: PathStr; Attr: word; var F: SearchRec);
@ -682,10 +625,16 @@ end;
begin begin
LastDosExitCode := 0; LastDosExitCode := 0;
LastDosErrorModuleName := '';
ExecFlags := 0;
end. end.
{ {
$Log$ $Log$
Revision 1.39 2004-02-22 15:01:49 hajny Revision 1.40 2004-03-21 20:22:20 hajny
* Exec cleanup
Revision 1.39 2004/02/22 15:01:49 hajny
* lots of fixes (regcall, THandle, string operations in sysutils, longint2cardinal according to OS/2 docs, dosh.inc, ...) * lots of fixes (regcall, THandle, string operations in sysutils, longint2cardinal according to OS/2 docs, dosh.inc, ...)
Revision 1.38 2004/02/17 17:37:26 daniel Revision 1.38 2004/02/17 17:37:26 daniel