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

+ working (although very limited) generic TProcess implementation based on SysUtils.CreteProcess for use with GO32v2, etc.

Browse Source 
git-svn-id: trunk@19378 -
This commit is contained in:
Tomas Hajny 2011-10-05 00:32:12 +00:00
parent 4a8b37016a
commit a3813ce176
1 changed files with 108 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

125
packages/fcl-process/src/dummy/process.inc
View File

@ -1,21 +1,13 @@
{
Dummy process.inc
Dummy process.inc - the simplest version based on SysUtils.ExecuteProcess
}
{
prevent compilation error for the versions mentioned below
}
{$if defined (go32v2) and defined(VER2_7_1)}
{$define WARN_ONLY}
{$endif}
{$if defined(VER2_4) or defined(VER2_5_1)}
{$define WARN_ONLY}
{$endif}
{$ifdef WARN_ONLY}
{$warning Temporary workaround - unit does nothing}
{$else}
{$fatal Proper implementation of TProcess for version of this target needed}
{$endif}
Resourcestring
SNoCommandLine = 'Cannot execute empty command-line';
SErrCannotExecute = 'Failed to execute %s : %d';
SErrNoSuchProgram = 'Executable not found: "%s"';
procedure TProcess.CloseProcessHandles;
begin
@ -23,15 +15,115 @@ end;
Function TProcess.PeekExitStatus : Boolean;
begin
Result := true; (* Dummy version assumes always synchronous execution *)
end;
function GetNextWordPos (const S: string): integer;
const
WhiteSpace = [' ', #9, #10, #13];
Literals = ['"', ''''];
var
WStart: integer;
InLiteral: boolean;
LastLiteral: char;
begin
WStart := 1;
(* Skip whitespaces at the beginning *)
while (WStart <= Length (S)) and (S [WStart] in WhiteSpace) do
Inc (WStart);
InLiteral := false;
LastLiteral := #0;
while (WStart <= Length (S)) and
(not (S [WStart] in WhiteSpace) or InLiteral) do
begin
if S [WStart] in Literals then
if InLiteral then
InLiteral := not (S [WStart] = LastLiteral)
else
begin
InLiteral := true;
LastLiteral := S [WStart];
end;
Inc (WStart);
end;
(* Skip whitespaces at the end *)
while (WStart <= Length (S)) and (S [WStart] in WhiteSpace) do
Inc (WStart);
Result := WStart;
end;
function MaybeQuote (const S: string): string;
begin
if (Pos (' ', S) <> 0) then
Result := '"' + S + '"'
else
Result := S;
end;
Procedure TProcess.Execute;
var
I: integer;
ExecName, FoundName: string;
E2: EProcess;
OrigDir: string;
Params: string;
begin
if (ApplicationName = '') and (CommandLine = '') and (Executable = '') then
raise EProcess.Create (SNoCommandline);
if (FApplicationName <> '') then
ExecName := FApplicationName;
if (FCommandLine <> '') then
begin
Params := FCommandLine;
if ExecName = '' then
begin
I := GetNextWordPos (Params);
ExecName := Copy (Params, 1, Pred (I));
Trim (ExecName);
Delete (Params, 1, Pred (I));
end
else if Copy (FCommandLine, 1, Length (ExecName)) = ExecName then
Delete (Params, 1, Succ (Length (ExecName)))
else
Delete (Params, 1, Pred (GetNextWordPos (Params)));
Trim (Params);
end
else
for I := 1 to Pred (Parameters.Count) do
Params := Params + ' ' + MaybeQuote (Parameters [I]);
if (FExecutable <> '') and (ExecName = '') then
ExecName := Executable;
if not FileExists (ExecName) then
begin
FoundName := ExeSearch (ExecName, '');
if FoundName <> '' then
ExecName := FoundName
else
raise EProcess.CreateFmt (SErrNoSuchProgram, [ExecName]);
end;
if (FCurrentDirectory <> '') then
begin
GetDir (0, OrigDir);
ChDir (FCurrentDirectory);
end;
try
FExitCode := ExecuteProcess (ExecName, Params);
except
(* Normalize the raised exception so that it is aligned to other platforms. *)
On E: EOSError do
begin
raise EProcess.CreateFmt (SErrCannotExecute, [FCommandLine, E.ErrorCode]);
if (FCurrentDirectory <> '') then
ChDir (OrigDir);
end;
end;
if (FCurrentDirectory <> '') then
ChDir (OrigDir);
end;
Function TProcess.WaitOnExit : Boolean;
begin
Result:=False;
Result:=True;
end;
Function TProcess.Suspend : Longint;
@ -40,7 +132,6 @@ begin
end;
Function TProcess.Resume : LongInt;
begin
Result:=0;
end;