jvqcreateprocess.pas

East make Tray Icon in delphi

{******************************************************************************}
{* WARNING:  JEDI VCL To CLX Converter generated unit.                        *}
{*           Manual modifications will be lost on next release.               *}
{******************************************************************************}

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvSysComp.PAS, released Dec 26, 1999.

The Initial Developer of the Original Code is Petr Vones (petr dott v att mujmail dott cz)
Portions created by Petr Vones are Copyright (C) 1999 Petr Vones.
Portions created by Microsoft are Copyright (C) 1998, 1999 Microsoft Corp.
All Rights Reserved.

Contributor(s):
  Marcel van Brakel <brakelm att bart dott nl>.
  Remko Bonte <remkobonte att myrealbox dott com> (redirect console output)

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

Known Issues:
-----------------------------------------------------------------------------}
// $Id: JvQCreateProcess.pas,v 1.15 2004/11/06 22:08:16 asnepvangers Exp $

unit JvQCreateProcess;

{$I jvcl.inc}
{$I windowsonly.inc}

interface

uses
  Windows, SysUtils, Classes, 
  ShellAPI, SyncObjs,
  JvQComponent, 
  JvQTypes,
  Messages; // (asn) Messges after Jv(Q)Component for VisualCLX

const
  CCPS_BufferSize = 1024;
  CCPS_MaxBufferSize = 65536;

type
  EJvProcessError = EJVCLException;

  TJvProcessPriority = (ppIdle, ppNormal, ppHigh, ppRealTime);

  TJvConsoleOption = (coOwnerData, coRedirect);
  TJvConsoleOptions = set of TJvConsoleOption;

  TJvCPSRawReadEvent = procedure(Sender: TObject; const S: string) of object;
  TJvCPSReadEvent = procedure(Sender: TObject; const S: string; const StartsOnNewLine: Boolean) of object;
  TJvCPSTerminateEvent = procedure(Sender: TObject; ExitCode: DWORD) of object;

  TJvRWHandles = record
    Read: THandle;
    Write: THandle;
  end;

  TJvRWEHandles = record
    Read: THandle;
    Write: THandle;
    Error: THandle;
  end;

  TJvProcessEntry = class(TObject)
  private
    FFileName: TFileName;
    FProcessID: DWORD;
    FProcessName: string;
    function GetSystemIconIndex(IconType: Integer): Integer;
    function GetPriority: TJvProcessPriority;
    procedure SetPriority(const Value: TJvProcessPriority);
  public
    constructor Create(AProcessID: DWORD; const AFileName: TFileName;
      const AProcessName: string);
    function Close(UseQuit: Boolean = False): Boolean;
    class function PriorityText(Priority: TJvProcessPriority): string;
    function Terminate: Boolean;
    property FileName: TFileName read FFileName;
    property LargeIconIndex: Integer index SHGFI_LARGEICON read
      GetSystemIconIndex;
    property Priority: TJvProcessPriority read GetPriority write SetPriority;
    property ProcessID: DWORD read FProcessID;
    property ProcessName: string read FProcessName;
    property SmallIconIndex: Integer index SHGFI_SMALLICON read
      GetSystemIconIndex;
  end;

  TJvCPSBuffer = array [0..CCPS_BufferSize - 1] of Char;
  TJvCPSState = (psReady, psRunning, psWaiting);
  TJvCPSFlag = (cfDefaultErrorMode, cfNewConsole, cfNewProcGroup, cfSeparateWdm,
    cfSharedWdm, cfSuspended, cfUnicode, cfDetached);
  TJvCPSFlags = set of TJvCPSFlag;
  TJvCPSShowWindow = (swHide, swMinimize, swMaximize, swNormal);

  TJvCPSStartupInfo = class(TPersistent)
  private
    FDesktop: string;
    FTitle: string;
    FDefaultPosition: Boolean;
    FDefaultWindowState: Boolean;
    FDefaultSize: Boolean;
    FHeight: Integer;
    FLeft: Integer;
    FWidth: Integer;
    FShowWindow: TJvCPSShowWindow;
    FTop: Integer;
    FForceOnFeedback: Boolean;
    FForceOffFeedback: Boolean;
    function GetStartupInfo: TStartupInfo;
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create;
    property StartupInfo: TStartupInfo read GetStartupInfo;
  published
    property Desktop: string read FDesktop write FDesktop;
    property Title: string read FTitle write FTitle;
    property Left: Integer read FLeft write FLeft default 0;
    property Top: Integer read FTop write FTop default 0;
    property DefaultPosition: Boolean read FDefaultPosition write
      FDefaultPosition default True;
    property Width: Integer read FWidth write FWidth default 0;
    property Height: Integer read FHeight write FHeight default 0;
    property DefaultSize: Boolean read FDefaultSize write FDefaultSize default True;
    property ShowWindow: TJvCPSShowWindow read FShowWindow write FShowWindow
      default swNormal;
    property DefaultWindowState: Boolean read FDefaultWindowState write
      FDefaultWindowState default True;
    property ForceOnFeedback: Boolean read FForceOnFeedback write
      FForceOnFeedback default False;
    property ForceOffFeedback: Boolean read FForceOffFeedback write
      FForceOffFeedback default False;
  end;

  TJvCreateProcess = class(TJvComponent)
  private
    FApplicationName: string;
    FCommandLine: string;
    FCreationFlags: TJvCPSFlags;
    FCurrentDirectory: string;
    FEnvironment: TStringList;
    FState: TJvCPSState;
    FStartupInfo: TJvCPSStartupInfo;
    FPriority: TJvProcessPriority;
    FProcessInfo: TProcessInformation;
    FWaitForTerminate: Boolean;
    FConsoleOptions: TJvConsoleOptions;
    FOnTerminate: TJvCPSTerminateEvent;
    FOnRead: TJvCPSReadEvent;
    FOnRawRead: TJvCPSRawReadEvent;
    FWaitThread: TThread;
    FReadThread: TThread;
    FHandle: THandle;
    FCurrentLine: string; // Last output of the console with no #10 char.
    FCursorPosition: Integer; // Position of the cursor on FCurrentLine
    FConsoleOutput: TStringList;
    FParseBuffer: TJvCPSBuffer;
    FExitCode: Cardinal;
    FEndLock: TCriticalSection; // lock to synchronize ending of the threads
    FStartsOnNewLine: Boolean;
    function GetConsoleOutput: TStrings;
    function GetEnvironment: TStrings;
    procedure SetWaitForTerminate(const Value: Boolean);
    procedure WaitThreadTerminated(Sender: TObject);
    procedure ConsoleWaitThreadTerminated(Sender: TObject);
    procedure ReadThreadTerminated(Sender: TObject);
    procedure SetEnvironment(const Value: TStrings);
    function GetHandle: THandle;

    procedure StartConsoleEnding;
    procedure EndConsoleEnding;
  protected
    procedure CheckRunning;
    procedure CheckNotWaiting;
    procedure CloseProcessHandles;
    procedure TerminateWaitThread;
    procedure HandleReadEvent;
    procedure ParseConsoleOutput(Data: PChar; ASize: Cardinal);
    procedure DoReadEvent(const EndsWithNewLine: Boolean);
    procedure DoRawReadEvent(Data: PChar; const ASize: Cardinal);
    procedure DoTerminateEvent;
    procedure WndProc(var Msg: TMessage);
    property Handle: THandle read GetHandle;
    procedure CloseRead;
    procedure CloseWrite;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function CloseApplication(SendQuit: Boolean = False): Boolean;
    procedure Run;
    procedure StopWaiting;
    procedure Terminate;
    function Write(const S: string): Boolean;
    function WriteLn(const S: string): Boolean;
    property ProcessInfo: TProcessInformation read FProcessInfo;
    property State: TJvCPSState read FState;
    property ConsoleOutput: TStrings read GetConsoleOutput;
  published
    property ApplicationName: string read FApplicationName write FApplicationName;
    property CommandLine: string read FCommandLine write FCommandLine;
    property CreationFlags: TJvCPSFlags read FCreationFlags write FCreationFlags
      default [];
    property CurrentDirectory: string read FCurrentDirectory write
      FCurrentDirectory;
    property Environment: TStrings read GetEnvironment write SetEnvironment;
    property Priority: TJvProcessPriority read FPriority write FPriority default
      ppNormal;
    property StartupInfo: TJvCPSStartupInfo read FStartupInfo write
      FStartupInfo;
    property WaitForTerminate: Boolean read FWaitForTerminate write
      SetWaitForTerminate default True;
    property ConsoleOptions: TJvConsoleOptions read FConsoleOptions write
      FConsoleOptions default [coOwnerData];
    property OnTerminate: TJvCPSTerminateEvent read FOnTerminate write
      FOnTerminate;
    property OnRead: TJvCPSReadEvent read FOnRead write FOnRead;
    property OnRawRead: TJvCPSRawReadEvent read FOnRawRead write FOnRawRead;
  end;

implementation

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  Math,
  JclStrings,
  JvQJCLUtils, JvQJVCLUtils, JvQConsts, JvQResources;

const
  CM_READ = WM_USER + 1;

  //MaxProcessCount = 4096;
  ProcessPriorities: array [TJvProcessPriority] of DWORD =
    (IDLE_PRIORITY_CLASS, NORMAL_PRIORITY_CLASS, HIGH_PRIORITY_CLASS,
     REALTIME_PRIORITY_CLASS);

type
  { Threads which monitor the created process }

  TJvWaitForProcessThread = class(TThread)
  private
    FExitCode: DWORD;
    FCloseEvent: THandle;
    FProcessHandle: THandle;
  protected
    procedure Execute; override;
  public
    constructor Create(ProcessHandle: DWORD);
    destructor Destroy; override;
    procedure TerminateThread;
  end;

  TJvConsoleThread = class(TJvWaitForProcessThread)
  private
    // Write end of the pipe
    FWriteHandle: THandle;
    FWriteEvent: THandle;
    // Critical sections to synchronize access to the buffers
    FWriteLock: TCriticalSection;
    // Fixed size buffer; maybe change to sizeable
    FOutputBuffer: TJvCPSBuffer;
    FOutputBufferEnd: Cardinal;
  protected
    procedure Execute; override;
    function TryWrite: Boolean;
  public
    constructor Create(ProcessHandle: DWORD; AWriteHandle: THandle);
    destructor Destroy; override;
    function Write(const S: string): Boolean;
    procedure CloseWrite;
  end;

  TJvReadThread = class(TThread)
  private
    // Read end of the pipe
    FReadHandle: THandle;
    // Critical sections to synchronize access to the buffers
    FReadLock: TCriticalSection;
    // Handle to the TJvCreateProcess
    FDestHandle: THandle;
    FPreBuffer: PChar;
    FInputBuffer: PChar;
    FInputBufferSize: Cardinal;
    FInputBufferEnd: Cardinal;
  protected
    FLoopEntered: Boolean;
    FTerminateAfterLoopEntered: Boolean;
    procedure CopyToBuffer(Buffer: PChar; ASize: Cardinal);
    procedure Execute; override;
  public
    constructor Create(AReadHandle, ADestHandle: THandle);
    destructor Destroy; override;
    procedure CloseRead;
    function ReadBuffer(var ABuffer: TJvCPSBuffer; out ABufferSize: Cardinal): Boolean;
    procedure TerminateThread;
  end;

//=== Local procedures =======================================================

function InternalCloseApp(ProcessID: DWORD; UseQuit: Boolean): Boolean;
type
  PEnumWinRec = ^TEnumWinRec;
  TEnumWinRec = record
    ProcessID: DWORD;
    PostQuit: Boolean;
    FoundWin: Boolean;
  end;
var
  EnumWinRec: TEnumWinRec;

  function EnumWinProc(Wnd: HWND; Param: PEnumWinRec): BOOL; stdcall;
  var
    PID, TID: DWORD;
  begin
    TID := GetWindowThreadProcessId(Wnd, @PID);
    if PID = Param.ProcessID then
    begin
      if Param.PostQuit then
        PostThreadMessage(TID, WM_QUIT, 0, 0)
      else
      if IsWindowVisible(Wnd) then
        PostMessage(Wnd, WM_CLOSE, 0, 0);
      Param.FoundWin := True;
    end;
    Result := True;
  end;

begin
  EnumWinRec.ProcessID := ProcessID;
  EnumWinRec.PostQuit := UseQuit;
  EnumWinRec.FoundWin := False;
  EnumWindows(@EnumWinProc, Integer(@EnumWinRec));
  Result := EnumWinRec.FoundWin;
end;

function InternalTerminateProcess(ProcessID: DWORD): Boolean;
var
  ProcessHandle: THandle;
begin
  ProcessHandle := OpenProcess(PROCESS_TERMINATE, False, ProcessID);
  OSCheck(ProcessHandle <> 0);
  Result := TerminateProcess(ProcessHandle, 0);
  CloseHandle(ProcessHandle);
end;

function SafeCloseHandle(var H: THandle): Boolean;
begin
  if H <> 0 then
  begin
    Result := CloseHandle(H);
    if Result then
      H := 0;
  end
  else
    Result := True;
end;

function ConstructPipe(var ConsoleHandles: TJvRWEHandles; var LocalHandles: TJvRWHandles): Boolean;
var
  LHandles: TJvRWHandles;
  LSecurityAttr: TSecurityAttributes;
  LSecurityDesc: TSecurityDescriptor;

  procedure CloseAllHandles;
  begin
    // Some error occurred; close all possibly created handles
    SafeCloseHandle(ConsoleHandles.Read);
    SafeCloseHandle(ConsoleHandles.Write);
    SafeCloseHandle(ConsoleHandles.Error);
    SafeCloseHandle(LocalHandles.Read);
    SafeCloseHandle(LocalHandles.Write);
    SafeCloseHandle(LHandles.Read);
    SafeCloseHandle(LHandles.Write);
  end;

begin
  { http://support.microsoft.com/default.aspx?scid=KB;EN-US;q190351& }
  { http://community.borland.com/article/0,1410,10387,00.html }
  FillChar(LSecurityAttr, SizeOf(TSecurityAttributes), 0);
  FillChar(ConsoleHandles, SizeOf(TJvRWEHandles), 0);
  FillChar(LocalHandles, SizeOf(TJvRWHandles), 0);
  FillChar(LHandles, SizeOf(TJvRWHandles), 0);

  // Set up the security attributes struct.
  LSecurityAttr.nLength := SizeOf(TSecurityAttributes);
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    // Initialize security descriptor (Windows NT)
    InitializeSecurityDescriptor(@LSecurityDesc, SECURITY_DESCRIPTOR_REVISION);
    SetSecurityDescriptorDacl(@LSecurityDesc, True, nil, False);
    LSecurityAttr.lpSecurityDescriptor := @LSecurityDesc;
  end
  else
    LSecurityAttr.lpSecurityDescriptor := nil;
  LSecurityAttr.bInheritHandle := True;

  // Create the child output pipe.
  Result := CreatePipe(LHandles.Read, ConsoleHandles.Write, @LSecurityAttr, 0);
  if not Result then
  begin
    CloseAllHandles;
    Exit;
  end;

  { Create a duplicate of the output write handle for the std error
    write handle. This is necessary in case the child application
    closes one of its std output handles.
  }
  Result := DuplicateHandle(GetCurrentProcess, ConsoleHandles.Write,
    GetCurrentProcess,
    @ConsoleHandles.Error, // Address of new handle.
    0, True, // Make it inheritable.
    DUPLICATE_SAME_ACCESS);
  if not Result then
  begin
    CloseAllHandles;
    Exit;
  end;

  // Create the child input pipe.
  Result := CreatePipe(ConsoleHandles.Read, LHandles.Write, @LSecurityAttr, 0);
  if not Result then
  begin
    CloseAllHandles;
    Exit;
  end;

  { Create new output read handle and the input write handles. Set
    the Properties to FALSE. Otherwise, the child inherits the
    properties and, as a result, non-closeable handles to the pipes
    are created.
  }
  Result := DuplicateHandle(GetCurrentProcess, LHandles.Read,
    GetCurrentProcess,
    @LocalHandles.Read, // Address of new handle.
    0, False, // Make it uninheritable.
    DUPLICATE_SAME_ACCESS);
  if not Result then
  begin
    CloseAllHandles;
    Exit;
  end;

  Result := DuplicateHandle(GetCurrentProcess, LHandles.Write,
    GetCurrentProcess,
    @LocalHandles.Write, // Address of new handle.
    0, False, // Make it uninheritable.
    DUPLICATE_SAME_ACCESS);
  if not Result then
  begin
    CloseAllHandles;
    Exit;
  end;

  { Okay, everything went as expected; now close inheritable copies of the
    handles you do not want to be inherited.
  }
  SafeCloseHandle(LHandles.Read);
  SafeCloseHandle(LHandles.Write);
end;

//=== { TJvProcessEntry } ====================================================

constructor TJvProcessEntry.Create(AProcessID: DWORD;
  const AFileName: TFileName; const AProcessName: string);
begin
  inherited Create;
  FFileName := AFileName;
  FProcessID := AProcessID;
  FProcessName := AProcessName;
end;

function TJvProcessEntry.Close(UseQuit: Boolean): Boolean;
begin
  Result := InternalCloseApp(ProcessID, UseQuit);
end;

function TJvProcessEntry.GetPriority: TJvProcessPriority;
var
  ProcessHandle: THandle;
  PriorityClass: DWORD;
begin
  if ProcessID = 0 then
    Result := ppNormal