interface
uses
Windows, Classes, SysUtils;
type
TAppLauncherProgressEvent =
procedure(Sender: TObject; ProcessInfo: PROCESS_INFORMATION; Position: Int64)
of object;
TAppLauncher =
class(TComponent)
private
FCreateNoWindow: Boolean;
FOnProgress: TAppLauncherProgressEvent;
FSecurityAttributes: SECURITY_ATTRIBUTES;
FSecurityDescriptor: SECURITY_DESCRIPTOR;
function CentralLoop(
const ProcessInfo: PROCESS_INFORMATION;
const ReadHandle: THandle;
const OutputStream: TStream): DWord;
inline;
protected
procedure DoProgress(ProcessInfo: PROCESS_INFORMATION; Position: Int64);
virtual;
procedure PreparePipe(
out ReadHandle, WriteHandle: THandle);
virtual;
function PrepareStartupInfoA(
const StdOutput: THandle): STARTUPINFOA;
virtual;
function PrepareStartupInfoW(
const StdOutput: THandle): STARTUPINFOW;
virtual;
property SecurityAttributes: SECURITY_ATTRIBUTES
read FSecurityAttributes;
property SecurityDescriptor: SECURITY_DESCRIPTOR
read FSecurityDescriptor;
public
constructor Create(AOwner: TComponent);
override;
function ExecuteA(
const Path, CmdLine: AnsiString;
out Output: TBytes): DWORD;
function ExecuteW(
const Path, CmdLine: WideString;
out Output: TBytes): DWORD;
published
property CreateNoWindow: Boolean
read FCreateNoWindow
write FCreateNoWindow
default false;
property OnProgress: TAppLauncherProgressEvent
read FOnProgress
write FOnProgress;
end;
implementation
uses
TeCanvas, Forms;
{ TAppLauncher }
constructor TAppLauncher.Create(AOwner: TComponent);
begin
inherited;
FCreateNoWindow := false;
ZeroMemory(@FSecurityAttributes, SizeOf(FSecurityAttributes));
if IsWindowsNT
then
begin
InitializeSecurityDescriptor(@FSecurityDescriptor, SECURITY_DESCRIPTOR_REVISION);
SetSecurityDescriptorDacl(@FSecurityDescriptor, True,
nil, False);
FSecurityAttributes.lpSecurityDescriptor := @FSecurityDescriptor;
end else
FSecurityAttributes.lpSecurityDescriptor :=
nil;
FSecurityAttributes.nLength := SizeOf(SECURITY_ATTRIBUTES);
FSecurityAttributes.bInheritHandle := True;
end;
procedure TAppLauncher.DoProgress(ProcessInfo: PROCESS_INFORMATION; Position: Int64);
begin
if Assigned(FOnProgress)
then
FOnProgress(Self, ProcessInfo, Position);
end;
procedure TAppLauncher.PreparePipe(
out ReadHandle,
WriteHandle: THandle);
var
PipeName:
string;
begin
PipeName := '
\\.\pipe\' + IntToHex(Random(MaxInt), 8) + IntToHex(GetCurrentProcessId, 8) + IntToHex(Random(MaxInt), 8);
ReadHandle := CreateNamedPipe(PChar(PipeName), PIPE_ACCESS_INBOUND
or FILE_FLAG_OVERLAPPED, 0, 1, 1024, 1024, 0,
nil);
if ReadHandle = INVALID_HANDLE_VALUE
then
RaiseLastOSError;
try
WriteHandle := CreateFile(PChar(PipeName), GENERIC_WRITE, FILE_SHARE_READ, @SecurityAttributes, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if WriteHandle = INVALID_HANDLE_VALUE
then
RaiseLastOSError;
except
CloseHandle(ReadHandle);
end;
end;
function TAppLauncher.PrepareStartupInfoA(
const StdOutput: THandle): STARTUPINFOA;
begin
ZeroMemory(@Result, SizeOf(Result));
Result.cb := SizeOf(Result);
Result.dwFlags := STARTF_USESTDHANDLES;
Result.hStdInput := GetStdHandle(STD_INPUT_HANDLE);
Result.hStdOutput := StdOutput;
Result.hStdError := StdOutput;
end;
function TAppLauncher.PrepareStartupInfoW(
const StdOutput: THandle): STARTUPINFOW;
begin
ZeroMemory(@Result, SizeOf(Result));
Result.cb := SizeOf(Result);
Result.dwFlags := STARTF_USESTDHANDLES;
Result.hStdInput := GetStdHandle(STD_INPUT_HANDLE);
Result.hStdOutput := StdOutput;
Result.hStdError := StdOutput;
end;
function TAppLauncher.CentralLoop(
const ProcessInfo: PROCESS_INFORMATION;
const ReadHandle: THandle;
const OutputStream: TStream): DWord;
const
BUFFER_SIZE = 512;
var
OvLapped: OVERLAPPED;
BytesRead: Cardinal;
Buffer:
array[0..BUFFER_SIZE - 1]
of Byte;
HandleArray:
array[0..1]
of THandle;
begin
ZeroMemory(@OvLapped, SizeOf(OvLapped));
OvLapped.hEvent := CreateEvent(
nil, True, False,
nil);
try
HandleArray[0] := ProcessInfo.hProcess;
HandleArray[1] := OvLapped.hEvent;
if not ReadFile(ReadHandle, Buffer, BUFFER_SIZE, BytesRead, @OvLapped)
and (GetLastError <> ERROR_IO_PENDING)
then
RaiseLastOSError;
while WaitForMultipleObjects(2, @HandleArray, False, INFINITE) = WAIT_OBJECT_0 + 1
do
begin
if not GetOverlappedResult(ReadHandle, OvLapped, BytesRead, False)
then
RaiseLastOSError;
OutputStream.
Write(Buffer, BytesRead);
ResetEvent(OvLapped.hEvent);
if not ReadFile(ReadHandle, Buffer, BUFFER_SIZE, BytesRead, @OvLapped)
and (GetLastError <> ERROR_IO_PENDING)
then
RaiseLastOSError;
DoProgress(ProcessInfo, OutputStream.Position);
end;
GetExitCodeProcess(ProcessInfo.hProcess, Result);
finally
CloseHandle(OvLapped.hEvent);
end;
end;
function TAppLauncher.ExecuteA(
const Path, CmdLine: AnsiString;
out Output: TBytes): DWORD;
var
lpPath, lpCmdLine: PAnsiChar;
StartupInf: STARTUPINFOA;
ProcessInfo: PROCESS_INFORMATION;
WriteHandle, ReadHandle: THandle;
dwCreationFlags: Cardinal;
BytesStream: TBytesStream;
begin
PreparePipe(ReadHandle, WriteHandle);
try
try
StartupInf := PrepareStartupInfoA(WriteHandle);
if CreateNoWindow
then
dwCreationFlags := CREATE_NO_WINDOW
else
dwCreationFlags := 0;
if Path = '
'
then
lpPath :=
nil
else
lpPath := PAnsiChar(Path);
if CmdLine = '
'
then
lpCmdLine :=
nil
else begin
lpCmdLine := PAnsiChar(CmdLine);
end;
if not CreateProcessA(lpPath, lpCmdLine,
nil,
nil, True, dwCreationFlags,
nil,
nil, StartupInf, ProcessInfo)
then
RaiseLastOSError;
try
CloseHandle(ProcessInfo.hThread);
BytesStream := TBytesStream.Create(
nil);
try
Result := CentralLoop(ProcessInfo, ReadHandle, BytesStream);
Output := BytesStream.Bytes;
finally
BytesStream.Free;
end;
finally
CloseHandle(ProcessInfo.hProcess);
end;
finally
CloseHandle(WriteHandle);
end;
finally
CloseHandle(ReadHandle);
end;
end;
function TAppLauncher.ExecuteW(
const Path, CmdLine: WideString;
out Output: TBytes): DWORD;
var
lpPath, lpCmdLine: PWideChar;
StartupInf: STARTUPINFOW;
ProcessInfo: PROCESS_INFORMATION;
WriteHandle, ReadHandle: THandle;
dwCreationFlags: Cardinal;
BytesStream: TBytesStream;
CmdLineCopy: WideString;
begin
PreparePipe(ReadHandle, WriteHandle);
try
try
StartupInf := PrepareStartupInfoW(WriteHandle);
if CreateNoWindow
then
dwCreationFlags := CREATE_NO_WINDOW
else
dwCreationFlags := 0;
if Path = '
'
then
lpPath :=
nil
else
lpPath := PWideChar(Path);
if CmdLine = '
'
then
lpCmdLine :=
nil
else begin
// We need to work with a copy of CmdLine. Cf. the Microsoft
// documentation on the CreateProcess method: "The Unicode version of
// this function, CreateProcessW, can modify the contents of this
// string. Therefore, this parameter cannot be a pointer to read-only
// memory (such as a const variable or a literal string). If this
// parameter is a constant string, the function may cause an access
// violation.
CmdLineCopy := CmdLine;
UniqueString(CmdLineCopy);
lpCmdLine := PWideChar(CmdLineCopy);
end;
if not CreateProcessW(lpPath, lpCmdLine,
nil,
nil, True, dwCreationFlags,
nil,
nil, StartupInf, ProcessInfo)
then
RaiseLastOSError;
try
CloseHandle(ProcessInfo.hThread);
BytesStream := TBytesStream.Create(
nil);
try
Result := CentralLoop(ProcessInfo, ReadHandle, BytesStream);
Output := BytesStream.Bytes;
finally
BytesStream.Free;
end;
finally
CloseHandle(ProcessInfo.hProcess);
end;
finally
CloseHandle(WriteHandle);
end;
finally
CloseHandle(ReadHandle);
end;
end;