mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-20 12:49:08 +02:00
* fixes for Exec - execution of different application types, fixed memory leak and avoided queue name collisions
git-svn-id: trunk@19324 -
This commit is contained in:
parent
f13c5fae05
commit
67612af07d
156
rtl/os2/dos.pas
156
rtl/os2/dos.pas
@ -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.
|
||||||
|
Loading…
Reference in New Issue
Block a user