program command_launcher;
uses
Classes, sysutils, process, BaseUnix;
type
TChildException = class(Exception)
end;
TPipeException = class(Exception)
end;
procedure RaiseChildException(isignal: LongInt; pinfo: PSigInfo; pcontext: PSigContext); cdecl;
const
SMETHOD = 'RaiseChildException';
CLD_EXITED = 1;
var
ichldpid, ichlduid, ichldstt: LongInt;
begin
WriteLn(SMETHOD, ': go ...');
ichldpid := -1;
ichlduid := -1;
ichldstt := -1;
WriteLn('got signal: ', chr(39), isignal, chr(39));
if pinfo <> Nil then
begin
WriteLn('signal info: no: ', chr(39), pinfo^.si_signo, chr(39)
, '; cd: ', chr(39), pinfo^.si_code, chr(39)
, '; err: ', chr(39), pinfo^.si_errno, chr(39));
if pinfo^.si_code = CLD_EXITED then
begin
ichldpid := LongInt(pinfo^._sifields._sigchld._pid);
ichlduid := LongInt(pinfo^._sifields._sigchld._uid);
ichldstt := pinfo^._sifields._sigchld._status;
WriteLn('signal info: pid: ', chr(39), ichldpid, chr(39)
, '; uid: ', chr(39), ichlduid, chr(39)
, '; stt: ', chr(39), ichldstt, chr(39));
end; //if pinfo^.si_code = CLD_EXITED then
end; //if pinfo <> Nil then
if pcontext <> Nil then
begin
WriteLn('signal context: set.');
end;
raise TChildException.CreateHelp('Child [' + IntToStr(ichldpid)
+ ']: User (uid: ' + chr(39) + IntToStr(ichlduid) + chr(39)
+ '): Launch failed with [' + IntToStr(ichldstt) + ']', ichldstt);
end;
procedure RaisePipeException(isignal: LongInt; pinfo: PSigInfo; pcontext: PSigContext); cdecl;
const
SMETHOD = 'RaisePipeException';
SI_USER = 0;
var
ipppid, ippuid: LongInt;
begin
WriteLn(SMETHOD, ': go ...');
ipppid := -1;
ippuid := -1;
WriteLn('got signal: ', chr(39), isignal, chr(39));
if pinfo <> Nil then
begin
WriteLn('signal info: no: ', chr(39), pinfo^.si_signo, chr(39)
, '; cd: ', chr(39), pinfo^.si_code, chr(39)
, '; err: ', chr(39), pinfo^.si_errno, chr(39));
if pinfo^.si_code = SI_USER then
begin
ipppid := LongInt(pinfo^._sifields._kill._pid);
ippuid := LongInt(pinfo^._sifields._kill._uid);
WriteLn('signal info: pid: ', chr(39), ipppid, chr(39)
, '; uid: ', chr(39), ippuid, chr(39));
end; //if pinfo^.si_code = SI_USER then
end; //if pinfo <> Nil then
if pcontext <> Nil then
begin
WriteLn('signal context: set.');
end;
raise TPipeException.CreateHelp('Process [' + IntToStr(ipppid)
+ ']: User (uid: ' + chr(39) + IntToStr(ippuid) + chr(39)
+ '): Pipe failed', isignal);
end;
function InstallSignalHandler: Integer;
const
SMETHOD = 'InstallSignalHandler';
var
nchldrec, ochldrec, npprec, opprec: SigActionRec;
begin
Result := 0;
nchldrec.sa_handler := sigactionhandler(@RaiseChildException);
FillChar(nchldrec.sa_mask, SizeOf(nchldrec.sa_mask), #0);
nchldrec.sa_flags := 0 or SA_SIGINFO;
{$ifdef Linux} // Linux specific
nchldrec.sa_restorer := Nil;
{$endif}
if FPSigAction(SIGCHLD, @nchldrec, @ochldrec) <> 0 then
begin
WriteLn(SMETHOD, ': FPSigAction(SIGCHLD): failed with [', fpgeterrno, '].');
//Self.brun := False;
Result := 1;
end;
npprec.sa_handler := sigactionhandler(@RaisePipeException);
FillChar(npprec.sa_mask, SizeOf(npprec.sa_mask), #0);
npprec.sa_flags := 0 or SA_SIGINFO;
{$ifdef Linux} // Linux specific
npprec.sa_restorer := Nil;
{$endif}
if FPSigAction(SIGPIPE, @npprec, @opprec) <> 0 then
begin
WriteLn(SMETHOD, ': FPSigAction(SIGPIPE): failed with [', fpgeterrno, '].');
//Self.brun := False;
Result := 1;
end;
end;
var
command: TProcess;
messagestream: TStringStream;
smessage: String;
sbuffer: String;
ReadSize: Integer;
bwait: Boolean;
begin
command := TProcess.Create(nil);
messagestream := TStringStream.Create('');
InstallSignalHandler;
try
try
smessage := 'test input';
messagestream.WriteString(smessage);
command.Options := [poUsePipes, poStderrToOutPut];
command.Executable := 'noexec_script.pl';
command.Execute;
WriteLn('Command Input: Writing ...');
WriteLn('Command Input (Length ', chr(39), messagestream.Size, chr(39), '):');
WriteLn(chr(39), messagestream.DataString, chr(39));
command.Input.Write(messagestream.DataString[1], messagestream.Size);
// Close the input on the SecondProcess
// so it finishes processing it's data
command.CloseInput;
// and wait for it to complete
bwait := command.WaitOnExit;
WriteLn('Command WaitOnExit: ', chr(39), bwait, chr(39));
// that's it! the rest of the program is just so the example
// is a little 'useful'
WriteLn('Command Output: Reading ...');
sbuffer := '';
ReadSize := command.Output.NumBytesAvailable;
WriteLn('Command Report (Length ', chr(39), ReadSize, chr(39), '):');
SetLength(sbuffer, ReadSize);
if ReadSize > 0 then
begin
command.Output.Read(sbuffer[1], ReadSize);
WriteLn(chr(39), sbuffer, chr(39));
end;
WriteLn('Command finished with [', command.ExitStatus, ']');
except
//------------------------
//Report Exception
on e : Exception do
begin
WriteLn('Command - failed with Exception [', e.HelpContext, ']: '
, chr(39), e.Message, chr(39));
end //on E : Exception do
else
begin
WriteLn('Command - failed with Unknown Exception: '
, chr(39), 'unknown error', chr(39));
end; //on e : Exception do
end;
finally
// free our process objects
messagestream.Free;
command.Free;
end;
end.