From af03a73af2509319d2d074a102090d017c7ddcaf Mon Sep 17 00:00:00 2001 From: Tomas Hajny Date: Thu, 6 Oct 2011 23:57:59 +0000 Subject: [PATCH] * fix DosExitCode for sessions of other types, consider ExecFlags for other session types git-svn-id: trunk@19398 - --- rtl/os2/dos.pas | 147 ++++++++++++++++++++++++++++++++++++------------ 1 file changed, 110 insertions(+), 37 deletions(-) diff --git a/rtl/os2/dos.pas b/rtl/os2/dos.pas index b8a52035b0..0adbd9f930 100644 --- a/rtl/os2/dos.pas +++ b/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.