mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-20 07:39:25 +02:00
* fix DosExitCode for sessions of other types, consider ExecFlags for other session types
git-svn-id: trunk@19398 -
This commit is contained in:
Tomas Hajny
parent
9edae25cae
commit
af03a73af2
147
rtl/os2/dos.pas
147
rtl/os2/dos.pas
@ -54,6 +54,14 @@ Type
|
||||
threadvar
|
||||
(* For compatibility with VP/2, used for runflags in Exec procedure. *)
|
||||
ExecFlags: cardinal;
|
||||
(* Note that the TP/BP compatible method for retrieval of exit codes *)
|
||||
(* is limited to only one (the last) execution! Including the following *)
|
||||
(* two variables in the interface part allows querying the status of *)
|
||||
(* of asynchronously started programs using DosWaitChild with dtNoWait *)
|
||||
(* parameter, i.e. without waiting for the final program result (as *)
|
||||
(* opposed to calling DosExitCode which would wait for the exit code). *)
|
||||
LastExecRes: TResultCodes;
|
||||
LastExecFlags: cardinal;
|
||||
|
||||
{$i dosh.inc}
|
||||
|
||||
@ -64,12 +72,15 @@ 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. *)
|
||||
(* It may also contain a queue name in case of a failed attempt *)
|
||||
(* to create queue for reading results of started sessions. *)
|
||||
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
{$DEFINE HAS_GETMSCOUNT}
|
||||
{$DEFINE HAS_DOSEXITCODE}
|
||||
|
||||
{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
|
||||
{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
|
||||
@ -79,7 +90,6 @@ implementation
|
||||
|
||||
threadvar
|
||||
LastDosErrorModuleName: string;
|
||||
ExecCounter: cardinal;
|
||||
|
||||
|
||||
const FindResvdMask = $00003737; {Allowed bits in attribute
|
||||
@ -142,13 +152,40 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
function DosExitCode: word;
|
||||
var
|
||||
Res: TResultCodes;
|
||||
PPID: cardinal;
|
||||
RC: cardinal;
|
||||
begin
|
||||
if (LastExecFlags = deAsyncResult) or (LastExecFlags = deAsyncResultDb) then
|
||||
begin
|
||||
RC := DosWaitChild (DCWA_PROCESS, dtWait, Res, PPID, LastExecRes.PID);
|
||||
if RC = 0 then
|
||||
(* If we succeeded, the process is finished - possible future querying
|
||||
of DosExitCode shall return the result immediately as with synchronous
|
||||
execution. *)
|
||||
begin
|
||||
LastExecFlags := deSync;
|
||||
LastExecRes := Res;
|
||||
end
|
||||
else
|
||||
LastExecRes.ExitCode := RC shl 16;
|
||||
end;
|
||||
if LastExecRes.ExitCode > high (word) then
|
||||
DosExitCode := high (word)
|
||||
else
|
||||
DosExitCode := LastExecRes.ExitCode and $FFFF;
|
||||
end;
|
||||
|
||||
|
||||
procedure Exec (const Path: PathStr; const ComLine: ComStr);
|
||||
{Execute a program.}
|
||||
var
|
||||
Args0, Args: PByteArray;
|
||||
ArgSize: word;
|
||||
Res: TResultCodes;
|
||||
ObjName: string;
|
||||
Res: TResultCodes;
|
||||
RC: cardinal;
|
||||
ExecAppType: cardinal;
|
||||
HQ: THandle;
|
||||
@ -186,7 +223,7 @@ begin
|
||||
GetMem (Args0, MaxArgsSize);
|
||||
Args := Args0;
|
||||
(* Work around a bug in OS/2 - argument to DosExecPgm *)
|
||||
(* should not cross 64K boundary. *)
|
||||
(* should not cross a 64K boundary. *)
|
||||
if ((PtrUInt (Args) + 1024) and $FFFF) < 1024 then
|
||||
Inc (pointer (Args), 1024);
|
||||
ArgSize := 0;
|
||||
@ -211,7 +248,8 @@ begin
|
||||
RC := DosExecPgm (ObjName, cardinal (ExecFlags), Args, nil, Res, Path);
|
||||
if RC = 0 then
|
||||
begin
|
||||
LastDosExitCode := Res.ExitCode;
|
||||
LastExecFlags := ExecFlags;
|
||||
LastExecRes := Res;
|
||||
LastDosErrorModuleName := '';
|
||||
end
|
||||
else
|
||||
@ -222,55 +260,90 @@ begin
|
||||
DSS := true;
|
||||
if DSS then
|
||||
begin
|
||||
FillChar (SD, SizeOf (SD), 0);
|
||||
SD.Length := SizeOf (SD);
|
||||
SD.Related := ssf_Related_Child;
|
||||
if Args = nil then
|
||||
(* No parameters passed, Args not allocated for DosExecPgm, so allocate now. *)
|
||||
begin
|
||||
GetMem (Args0, MaxArgsSize);
|
||||
Args := Args0;
|
||||
Move (QName [1], Args^ [0], Length (QName));
|
||||
Args^ [Length (QName)] := 0;
|
||||
end
|
||||
else
|
||||
SD.PgmInputs := PChar (@Args^ [Length (QName) + 1]);
|
||||
SD.PgmName := PChar (Args);
|
||||
SD.InheritOpt := ssf_InhertOpt_Parent;
|
||||
Str (GetProcessID, SPID);
|
||||
Str (ThreadID, STID);
|
||||
Str (ExecCounter, SCtr);
|
||||
Inc (ExecCounter);
|
||||
QName := '\QUEUES\FPC_Dos_Exec_p' + SPID + 't' + STID + '.QUE'#0;
|
||||
SD.TermQ := @QName [1];
|
||||
SD.ObjectBuffer := @ObjName [1];
|
||||
SD.ObjectBuffLen := SizeOf (ObjName) - 1;
|
||||
RC := DosCreateQueue (HQ, quFIFO or quConvert_Address, @QName [1]);
|
||||
FillChar (SD, SizeOf (SD), 0);
|
||||
SD.Length := SizeOf (SD);
|
||||
RC := 0;
|
||||
case ExecFlags of
|
||||
deSync:
|
||||
begin
|
||||
SD.Related := ssf_Related_Child;
|
||||
LastExecFlags := ExecFlags;
|
||||
SD.TermQ := @QName [1];
|
||||
RC := DosCreateQueue (HQ, quFIFO or quConvert_Address, @QName [1]);
|
||||
end;
|
||||
deAsync,
|
||||
deAsyncResult:
|
||||
begin
|
||||
(* Current implementation of DosExitCode does not support retrieval *)
|
||||
(* of result codes for other session types started asynchronously. *)
|
||||
LastExecFlags := deAsync;
|
||||
SD.Related := ssf_Related_Independent;
|
||||
end;
|
||||
deBackground:
|
||||
begin
|
||||
(* Current implementation of DosExitCode does not support retrieval *)
|
||||
(* of result codes for other session types started asynchronously. *)
|
||||
LastExecFlags := ExecFlags;
|
||||
SD.Related := ssf_Related_Independent;
|
||||
SD.FgBg := ssf_FgBg_Back;
|
||||
end;
|
||||
deAsyncResultDB:
|
||||
begin
|
||||
(* Current implementation of DosExitCode does not support retrieval *)
|
||||
(* of result codes for other session types started asynchronously. *)
|
||||
LastExecFlags := ExecFlags;
|
||||
SD.Related := ssf_Related_Child;
|
||||
SD.TraceOpt := ssf_TraceOpt_Trace;
|
||||
end;
|
||||
end;
|
||||
if RC <> 0 then
|
||||
ObjName := Copy (QName, 1, Pred (Length (QName)))
|
||||
else
|
||||
begin
|
||||
if Args = nil then
|
||||
(* No parameters passed, Args not allocated for DosExecPgm, so allocate now. *)
|
||||
begin
|
||||
GetMem (Args0, MaxArgsSize);
|
||||
Args := Args0;
|
||||
Move (QName [1], Args^ [0], Length (QName));
|
||||
Args^ [Length (QName)] := 0;
|
||||
end
|
||||
else
|
||||
SD.PgmInputs := PChar (@Args^ [Length (QName) + 1]);
|
||||
SD.PgmName := PChar (Args);
|
||||
SD.InheritOpt := ssf_InhertOpt_Parent;
|
||||
SD.ObjectBuffer := @ObjName [1];
|
||||
SD.ObjectBuffLen := SizeOf (ObjName) - 1;
|
||||
RC := DosStartSession (SD, SID, PID);
|
||||
if (RC = 0) or (RC = 457) then
|
||||
begin
|
||||
RC := DosReadQueue (HQ, RD, CISize, PCI, 0, 0, Prio, 0);
|
||||
if RC = 0 then
|
||||
LastExecRes.PID := PID;
|
||||
if ExecFlags = deSync then
|
||||
begin
|
||||
LastDosExitCode := PCI^.Return;
|
||||
DosCloseQueue (HQ);
|
||||
DosFreeMem (PCI);
|
||||
end
|
||||
else
|
||||
DosCloseQueue (HQ);
|
||||
RC := DosReadQueue (HQ, RD, CISize, PCI, 0, 0, Prio, 0);
|
||||
if (RC = 0) and (PCI^.SessionID = SID) then
|
||||
begin
|
||||
LastExecRes.ExitCode := PCI^.Return;
|
||||
DosCloseQueue (HQ);
|
||||
DosFreeMem (PCI);
|
||||
end
|
||||
else
|
||||
DosCloseQueue (HQ);
|
||||
end;
|
||||
end
|
||||
else
|
||||
else if ExecFlags = deSync then
|
||||
DosCloseQueue (HQ);
|
||||
end;
|
||||
end;
|
||||
if RC <> 0 then
|
||||
begin
|
||||
LastDosErrorModuleName := ObjName;
|
||||
LastDosExitCode := 0; (* Needed for TP/BP compatibility *)
|
||||
LastExecFlags := deSync;
|
||||
LastExecRes.ExitCode := 0; (* Needed for TP/BP compatibility *)
|
||||
LastExecRes.TerminateReason := $FFFFFFFF;
|
||||
end;
|
||||
DosError := RC;
|
||||
if Args0 <> nil then
|
||||
@ -561,8 +634,8 @@ begin
|
||||
|
||||
|
||||
begin
|
||||
LastDosExitCode := 0;
|
||||
FillChar (LastExecRes, SizeOf (LastExecRes), 0);
|
||||
LastDosErrorModuleName := '';
|
||||
ExecFlags := 0;
|
||||
ExecCounter := 0;
|
||||
LastExecFlags := deSync;
|
||||
end.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user