fpc/fcl/unix/process.inc
2006-03-31 21:29:36 +00:00

384 lines
7.8 KiB
PHP

{
Unix Process .inc.
}
uses
Unix,
Baseunix;
Const
PriorityConstants : Array [TProcessPriority] of Integer =
(20,20,0,-20);
Const
GeometryOption : String = '-geometry';
TitleOption : String ='-title';
procedure TProcess.CloseProcessHandles;
begin
// Do nothing. Win32 call.
end;
Function TProcess.PeekExitStatus : Boolean;
begin
Result:=fpWaitPid(Handle,@FExitCode,WNOHANG)=Handle;
If Result then
FExitCode:=wexitstatus(FExitCode)
else
FexitCode:=0;
end;
Type
TPCharArray = Array[Word] of pchar;
PPCharArray = ^TPcharArray;
Function StringsToPCharList(List : TStrings) : PPChar;
Var
I : Integer;
S : String;
begin
I:=(List.Count)+1;
GetMem(Result,I*sizeOf(PChar));
PPCharArray(Result)^[List.Count]:=Nil;
For I:=0 to List.Count-1 do
begin
S:=List[i];
Result[i]:=StrNew(PChar(S));
end;
end;
Procedure FreePCharList(List : PPChar);
Var
I : integer;
begin
I:=0;
While List[i]<>Nil do
begin
StrDispose(List[i]);
Inc(I);
end;
FreeMem(List);
end;
Procedure CommandToList(S : String; List : TStrings);
Function GetNextWord : String;
Const
WhiteSpace = [' ',#8,#10];
Literals = ['"',''''];
Var
Wstart,wend : Integer;
InLiteral : Boolean;
LastLiteral : char;
begin
WStart:=1;
While (WStart<=Length(S)) and (S[WStart] in WhiteSpace) do
Inc(WStart);
WEnd:=WStart;
InLiteral:=False;
LastLiteral:=#0;
While (Wend<=Length(S)) and (Not (S[Wend] in WhiteSpace) or InLiteral) do
begin
if S[Wend] in Literals then
If InLiteral then
InLiteral:=Not (S[Wend]=LastLiteral)
else
begin
InLiteral:=True;
LastLiteral:=S[Wend];
end;
inc(wend);
end;
Result:=Copy(S,WStart,WEnd-WStart);
Result:=StringReplace(Result,'"','',[rfReplaceAll]);
Result:=StringReplace(Result,'''','',[rfReplaceAll]);
While (WEnd<=Length(S)) and (S[Wend] in WhiteSpace) do
inc(Wend);
Delete(S,1,WEnd-1);
end;
Var
W : String;
begin
While Length(S)>0 do
begin
W:=GetNextWord;
If (W<>'') then
List.Add(W);
end;
end;
Function MakeCommand(P : TProcess) : PPchar;
Const
SNoCommandLine = 'Cannot execute empty command-line';
Var
Cmd : String;
S : TStringList;
G : String;
begin
if (P.ApplicationName='') then
begin
If (P.CommandLine='') then
Raise EProcess.Create(SNoCommandline);
Cmd:=P.CommandLine;
end
else
begin
If (P.CommandLine='') then
Cmd:=P.ApplicationName
else
Cmd:=P.CommandLine;
end;
S:=TStringList.Create;
try
CommandToList(Cmd,S);
if poNewConsole in P.Options then
begin
S.Insert(0,'-e');
If (P.ApplicationName<>'') then
begin
S.Insert(0,P.ApplicationName);
S.Insert(0,'-title');
end;
if suoUseCountChars in P.StartupOptions then
begin
S.Insert(0,Format('%dx%d',[P.dwXCountChars,P.dwYCountChars]));
S.Insert(0,'-geometry');
end;
S.Insert(0,'xterm');
end;
if (P.ApplicationName<>'') then
begin
S.Add(TitleOption);
S.Add(P.ApplicationName);
end;
G:='';
if (suoUseSize in P.StartupOptions) then
g:=format('%dx%d',[P.dwXSize,P.dwYsize]);
if (suoUsePosition in P.StartupOptions) then
g:=g+Format('+%d+%d',[P.dwX,P.dwY]);
if G<>'' then
begin
S.Add(GeometryOption);
S.Add(g);
end;
Result:=StringsToPcharList(S);
Finally
S.free;
end;
end;
Function GetLastError : Integer;
begin
Result:=-1;
end;
Type
TPipeEnd = (peRead,peWrite);
TPipePair = Array[TPipeEnd] of cint;
Procedure CreatePipes(Var HI,HO,HE : TPipePair; CE : Boolean);
Procedure CreatePair(Var P : TPipePair);
begin
If not CreatePipeHandles(P[peRead],P[peWrite]) then
Raise EProcess.Create('Failed to create pipes');
end;
Procedure ClosePair(Var P : TPipePair);
begin
if (P[peRead]<>-1) then
FileClose(P[peRead]);
if (P[peWrite]<>-1) then
FileClose(P[peWrite]);
end;
begin
HO[peRead]:=-1;HO[peWrite]:=-1;
HI[peRead]:=-1;HI[peWrite]:=-1;
HE[peRead]:=-1;HE[peWrite]:=-1;
Try
CreatePair(HO);
CreatePair(HI);
If CE then
CreatePair(HE);
except
ClosePair(HO);
ClosePair(HI);
If CE then
ClosePair(HE);
Raise;
end;
end;
Procedure TProcess.Execute;
Var
HI,HO,HE : TPipePair;
PID : Longint;
FEnv : PPChar;
Argv : PPChar;
fd : Integer;
PName : String;
begin
If (poUsePipes in FProcessOptions) then
CreatePipes(HI,HO,HE,Not (poStdErrToOutPut in FProcessOptions));
Try
if FEnvironment.Count<>0 then
FEnv:=StringsToPcharList(FEnvironment)
else
FEnv:=Nil;
Try
Argv:=MakeCommand(Self);
Try
If (Argv<>Nil) and (ArgV[0]<>Nil) then
PName:=StrPas(Argv[0])
else
begin
// This should never happen, actually.
PName:=ApplicationName;
If (PName='') then
PName:=CommandLine;
end;
if (pos('/',PName)<>1) then
PName:=FileSearch(Pname,fpgetenv('PATH'));
Pid:=fpfork;
if Pid<0 then
Raise EProcess.Create('Failed to Fork process');
if (PID>0) then
begin
// Parent process. Copy process information.
FProcessHandle:=PID;
FThreadHandle:=PID;
FProcessId:=PID;
//FThreadId:=PID;
end
else
begin
{ We're in the child }
if (FCurrentDirectory<>'') then
ChDir(FCurrentDirectory);
if PoUsePipes in Options then
begin
fpclose(HI[peWrite]);
fpdup2(HI[peRead],0);
fpclose(HO[peRead]);
fpdup2(HO[peWrite],1);
if (poStdErrToOutPut in Options) then
fpdup2(HO[peWrite],2)
else
begin
fpclose(HE[peRead]);
fpdup2(HE[peWrite],2);
end
end
else if poNoConsole in Options then
begin
fd:=FileOpen('/dev/null',fmOpenReadWrite);
fpdup2(fd,0);
fpdup2(fd,1);
fpdup2(fd,2);
end;
if (poRunSuspended in Options) then
sigraise(SIGSTOP);
if FEnv<>Nil then
fpexecve(PName,Argv,Fenv)
else
fpexecv(PName,argv);
Halt(127);
end
Finally
FreePcharList(Argv);
end;
Finally
If (FEnv<>Nil) then
FreePCharList(FEnv);
end;
Finally
if POUsePipes in FProcessOptions then
begin
FileClose(HO[peWrite]);
FileClose(HI[peRead]);
if Not (poStdErrToOutPut in FProcessOptions) then
FileClose(HE[peWrite]);
CreateStreams(HI[peWrite],HO[peRead],HE[peRead]);
end;
end;
FRunning:=True;
if not (csDesigning in ComponentState) and // This would hang the IDE !
(poWaitOnExit in FProcessOptions) and
not (poRunSuspended in FProcessOptions) then
WaitOnExit;
end;
Function TProcess.WaitOnExit : Dword;
begin
Result:=fpWaitPid(Handle,@FExitCode,0);
If Result=Handle then
FExitCode:=WexitStatus(FExitCode);
FRunning:=False;
end;
Function TProcess.Suspend : Longint;
begin
If fpkill(Handle,SIGSTOP)<>0 then
Result:=-1
else
Result:=1;
end;
Function TProcess.Resume : LongInt;
begin
If fpKill(Handle,SIGCONT)<>0 then
Result:=-1
else
Result:=0;
end;
Function TProcess.Terminate(AExitCode : Integer) : Boolean;
begin
Result:=False;
Result:=fpkill(Handle,SIGTERM)=0;
If Result then
begin
If Running then
Result:=fpkill(Handle,SIGKILL)=0;
end;
GetExitStatus;
end;
Procedure TProcess.SetShowWindow (Value : TShowWindowOptions);
begin
FShowWindow:=Value;
end;