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

* fixes for Exec - execution of different application types, fixed memory leak and avoided queue name collisions

Browse Source 
git-svn-id: trunk@19324 -
This commit is contained in:
Tomas Hajny 2011-10-02 01:43:18 +00:00
parent f13c5fae05
commit 67612af07d
1 changed files with 96 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

156
rtl/os2/dos.pas
View File

@ -79,6 +79,7 @@ implementation
threadvar threadvar
LastDosErrorModuleName: string; LastDosErrorModuleName: string;
ExecCounter: cardinal;
const FindResvdMask = $00003737; {Allowed bits in attribute const FindResvdMask = $00003737; {Allowed bits in attribute
@ -143,24 +144,38 @@ end;
procedure Exec (const Path: PathStr; const ComLine: ComStr); procedure Exec (const Path: PathStr; const ComLine: ComStr);
{Execute a program.} {Execute a program.}
var Args0, Args: PByteArray; var
ArgSize: word; Args0, Args: PByteArray;
Res: TResultCodes; ArgSize: word;
ObjName: string; Res: TResultCodes;
RC: longint; ObjName: string;
HQ: THandle; RC: cardinal;
SPID, STID, QName: string; ExecAppType: cardinal;
SD: TStartData; HQ: THandle;
SID, PID: cardinal; SPID, STID, SCtr, QName: string;
RD: TRequestData; SID, PID: cardinal;
PCI: PChildInfo; SD: TStartData;
CISize: cardinal; RD: TRequestData;
Prio: byte; PCI: PChildInfo;
CISize: cardinal;
Prio: byte;
DSS: boolean;
SR: SearchRec;
const const
MaxArgsSize = 3072; (* Amount of memory reserved for arguments in bytes. *) MaxArgsSize = 3072; (* Amount of memory reserved for arguments in bytes. *)
begin begin
{ LastDosExitCode := Exec (Path, ExecRunFlags (ExecFlags), efDefault, ComLine);} { LastDosExitCode := Exec (Path, ExecRunFlags (ExecFlags), efDefault, ComLine);}
QName := FExpand (Path); ObjName := '';
(* FExpand should be used only for the DosStartSession part
and only if the executable is in the current directory. *)
FindFirst (Path, AnyFile, SR);
if DosError = 0 then
QName := FExpand (Path)
else
QName := Path;
FindClose (SR);
if ComLine = '' then if ComLine = '' then
begin begin
Args0 := nil; Args0 := nil;
@ -186,57 +201,77 @@ begin
Inc (ArgSize); Inc (ArgSize);
Args^ [ArgSize] := 0; Args^ [ArgSize] := 0;
end; end;
RC := DosExecPgm (ObjName, cardinal (ExecFlags), Args, nil, Res, Path);
if RC = 0 then if (DosQueryAppType (PChar (Args), ExecAppType) = 0) and
(ApplicationType and 3 = ExecAppType and 3) then
(* DosExecPgm should work... *)
begin begin
LastDosExitCode := Res.ExitCode; DSS := false;
LastDosErrorModuleName := ''; Res.ExitCode := $FFFFFFFF;
RC := DosExecPgm (ObjName, cardinal (ExecFlags), Args, nil, Res, Path);
if RC = 0 then
begin
LastDosExitCode := Res.ExitCode;
LastDosErrorModuleName := '';
end
else
if (RC = 190) or (RC = 191) then
DSS := true;
end end
else else
if (RC = 190) or (RC = 191) then DSS := true;
begin if DSS then
FillChar (SD, SizeOf (SD), 0); begin
SD.Length := 24; FillChar (SD, SizeOf (SD), 0);
SD.Related := ssf_Related_Child; SD.Length := SizeOf (SD);
if Args = nil then SD.Related := ssf_Related_Child;
if Args = nil then
(* No parameters passed, Args not allocated for DosExecPgm, so allocate now. *) (* No parameters passed, Args not allocated for DosExecPgm, so allocate now. *)
begin begin
GetMem (Args, MaxArgsSize); GetMem (Args0, MaxArgsSize);
Move (QName [1], Args^ [0], Length (QName)); Args := Args0;
Args^ [Length (QName)] := 0; Move (QName [1], Args^ [0], Length (QName));
end Args^ [Length (QName)] := 0;
else end
SD.PgmInputs := PChar (@Args^ [Length (QName) + 1]); else
SD.PgmName := PChar (Args); SD.PgmInputs := PChar (@Args^ [Length (QName) + 1]);
SD.InheritOpt := ssf_InhertOpt_Parent; SD.PgmName := PChar (Args);
Str (GetProcessID, SPID); SD.InheritOpt := ssf_InhertOpt_Parent;
Str (ThreadID, STID); Str (GetProcessID, SPID);
QName := '\QUEUES\FPC_Dos_Exec_p' + SPID + 't' + STID + '.QUE'#0; Str (ThreadID, STID);
SD.TermQ := @QName [1]; Str (ExecCounter, SCtr);
RC := DosCreateQueue (HQ, quFIFO or quConvert_Address, @QName [1]); Inc (ExecCounter);
if RC = 0 then QName := '\QUEUES\FPC_Dos_Exec_p' + SPID + 't' + STID + '.QUE'#0;
begin SD.TermQ := @QName [1];
RC := DosStartSession (SD, SID, PID); SD.ObjectBuffer := @ObjName [1];
if (RC = 0) or (RC = 457) then SD.ObjectBuffLen := SizeOf (ObjName) - 1;
begin RC := DosCreateQueue (HQ, quFIFO or quConvert_Address, @QName [1]);
RC := DosReadQueue (HQ, RD, CISize, PCI, 0, 0, Prio, 0); if RC <> 0 then
if RC = 0 then ObjName := Copy (QName, 1, Pred (Length (QName)))
begin else
LastDosExitCode := PCI^.Return; begin
DosCloseQueue (HQ); RC := DosStartSession (SD, SID, PID);
DosFreeMem (PCI); if (RC = 0) or (RC = 457) then
end begin
else RC := DosReadQueue (HQ, RD, CISize, PCI, 0, 0, Prio, 0);
if RC = 0 then
begin
LastDosExitCode := PCI^.Return;
DosCloseQueue (HQ); DosCloseQueue (HQ);
end DosFreeMem (PCI);
else end
DosCloseQueue (HQ); else
end; DosCloseQueue (HQ);
end end
else else
LastDosErrorModuleName := ObjName; DosCloseQueue (HQ);
end;
end;
if RC <> 0 then if RC <> 0 then
LastDosExitCode := 0; (* Needed for TP/BP compatibility *) begin
LastDosErrorModuleName := ObjName;
LastDosExitCode := 0; (* Needed for TP/BP compatibility *)
end;
DosError := RC; DosError := RC;
if Args0 <> nil then if Args0 <> nil then
FreeMem (Args0, MaxArgsSize); FreeMem (Args0, MaxArgsSize);
@ -529,4 +564,5 @@ begin
LastDosExitCode := 0; LastDosExitCode := 0;
LastDosErrorModuleName := ''; LastDosErrorModuleName := '';
ExecFlags := 0; ExecFlags := 0;
ExecCounter := 0;
end. end.