Thread Process //Pascal class (See related posts)

   1  
   2  unit Process;
   3  
   4  interface
   5  
   6  uses
   7    SysUtils, Windows, Classes, TLHelp32;
   8  
   9  const
  10    INITIALIZATION_TIMEOUT = 10000;
  11  
  12  type
  13    TStringArray = array of string;
  14    TProcessArray = array of Cardinal;
  15    TExceptionEvent = procedure(Sender: TObject; Exception: Exception) of object;
  16    EProcessError = class(Exception);
  17  
  18    TProcessThread = class(TThread)
  19    private
  20      FException: Exception;
  21      FWatching, FStarted, FSuspended: Boolean;
  22      FDirectory, FPath, FCommandLine, FEnvironment: PChar;
  23      FData: string;
  24      FOnProcessTerminated, FOnDataAvailable: TNotifyEvent;
  25      InputRead, InputWrite, OutputRead, OutputWrite: THandle;
  26      FMainProcess: PROCESS_INFORMATION;
  27      FOnException: TExceptionEvent;
  28      FOnProcessStarted: TNotifyEvent;
  29      function GetPriority: TThreadPriority;
  30      procedure SetPriority(const Value: TThreadPriority);
  31      procedure FreeResources;
  32    protected
  33      procedure CallDataAvailable; virtual;
  34      procedure CallProcessTerminated; virtual;
  35      procedure CallProcessOpened; virtual;
  36      procedure CallException; virtual;
  37      procedure Execute; override;
  38    public
  39      constructor Create(Path, CommandLine, Directory: string; Environment: TStrings = nil; Watch: Boolean = True);
  40      destructor Destroy; override;
  41  
  42      function IsProcessAlive: Boolean;
  43      procedure Resume;
  44      procedure Suspend;
  45      property OnDataAvailable: TNotifyEvent read FOnDataAvailable write FOnDataAvailable;
  46      property OnProcessTerminated: TNotifyEvent read FOnProcessTerminated write FOnProcessTerminated;
  47      property OnProcessStarted: TNotifyEvent read FOnProcessStarted write FOnProcessStarted;
  48      property OnException: TExceptionEvent read FOnException write FOnException;
  49      property Data: string read FData;
  50      property Process: PROCESS_INFORMATION read FMainProcess;
  51      property Priority: TThreadPriority read GetPriority write SetPriority;
  52  
  53    end;
  54  
  55    TProcessLineThread = class;
  56    TOnNewLineEvent = procedure(ProcessLine:  TProcessLineThread; const Line: string) of object;
  57    TProcessLineThread = class(TProcessThread)
  58    private
  59      FCurrentLine: string;
  60      FOnNewLine: TOnNewLineEvent;
  61      procedure DataAvailable(Sender: TObject);
  62      procedure Finished(Sender: TObject);
  63    public
  64      constructor Create(Path, CommandLine, Directory: string; Environment: TStrings = nil);
  65      property OnNewLine: TOnNewLineEvent read FOnNewLine write FOnNewLine;
  66    end;
  67  
  68  function KillProcess(const Process: Cardinal): Boolean;
  69  function GetChildrenProcesses(const Process: Cardinal; const IncludeParent: Boolean = True): TProcessArray;
  70  
  71  implementation
  72  
  73  const
  74    Priorities: array [TThreadPriority] of Integer =
  75     (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
  76      THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
  77      THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);
  78  
  79  function GetChildrenProcesses(const Process: Cardinal; const IncludeParent: Boolean): TProcessArray;
  80  var
  81    Snapshot: Cardinal;
  82    ProcessList: PROCESSENTRY32;
  83    Current: Integer;
  84  begin
  85    Current := 0;
  86    SetLength(Result, 1);
  87    Result[0] := Process;
  88    repeat
  89      ProcessList.dwSize := SizeOf(PROCESSENTRY32);
  90      Snapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  91      if (Snapshot = INVALID_HANDLE_VALUE) or not Process32First(Snapshot, ProcessList) then
  92        Continue;
  93      repeat
  94        if ProcessList.th32ParentProcessID = Result[Current] then
  95        begin
  96          SetLength(Result, Length(Result) + 1);
  97          Result[Length(Result) - 1] := ProcessList.th32ProcessID;
  98        end;
  99      until Process32Next(Snapshot, ProcessList) = False;
 100      Inc(Current);
 101    until Current >= Length(Result);
 102    if not IncludeParent then
 103      Result := Copy(Result, 2, Length(Result));
 104  end;
 105  
 106  function KillProcess(const Process: Cardinal): Boolean;
 107  var
 108    Handle: Cardinal;
 109    List: TProcessArray;
 110    I: Integer;
 111  begin
 112    Result := True;
 113    List := GetChildrenProcesses(Process);
 114    for I := Length(List) - 1 downto 0 do
 115      if Result then
 116      begin
 117        Handle := OpenProcess(PROCESS_TERMINATE, false, List[I]);
 118        Result := (Handle <> 0) and TerminateProcess(Handle, 0) and CloseHandle(Handle);
 119      end;
 120  end;
 121  
 122  { TProcessThread }
 123  
 124  procedure TProcessThread.CallDataAvailable;
 125  begin
 126    if Assigned(FOnDataAvailable) then
 127      FOnDataAvailable(Self);
 128  end;
 129  
 130  procedure TProcessThread.Resume;
 131  var
 132    SuspendCount: Integer;
 133  begin
 134    if FStarted then
 135    begin
 136      FStarted := True;
 137      SuspendCount := ResumeThread(FMainProcess.hThread);
 138      CheckThreadError(SuspendCount >= 0);
 139      if SuspendCount = 1 then
 140        FSuspended := False;
 141    end;
 142    inherited Resume;
 143  end;
 144  
 145  function TProcessThread.GetPriority: TThreadPriority;
 146  begin
 147    if FStarted then
 148    begin
 149      CheckThreadError(GetThreadPriority(FMainProcess.hThread) <> THREAD_PRIORITY_ERROR_RETURN);
 150    end;
 151    Result := inherited Priority;
 152  end;
 153  
 154  function TProcessThread.IsProcessAlive: Boolean;
 155  var
 156    Status: Cardinal;
 157  begin
 158    GetExitCodeProcess(FMainProcess.hProcess, Status);
 159    Result := Status = STILL_ACTIVE;
 160  end;
 161  
 162  procedure TProcessThread.SetPriority(const Value: TThreadPriority);
 163  begin
 164    if FStarted then
 165      CheckThreadError(SetThreadPriority(FMainProcess.hThread, Priorities[Value]));
 166    inherited Priority := Value;
 167  end;
 168  
 169  procedure TProcessThread.Suspend;
 170  var
 171    OldSuspend: Boolean;
 172  begin
 173    if FStarted then
 174    begin
 175      OldSuspend := FSuspended;
 176      try
 177        FSuspended := True;
 178        CheckThreadError(Integer(SuspendThread(FMainProcess.hThread)) >= 0);
 179      except
 180        FSuspended := OldSuspend;
 181        raise;
 182      end;
 183    end;
 184    inherited Suspend;
 185  end;
 186  
 187  
 188  procedure TProcessThread.CallException;
 189  begin
 190    if Assigned(FOnException) then
 191      FOnException(Self, FException);
 192  end;
 193  
 194  procedure TProcessThread.CallProcessOpened;
 195  begin
 196    if Assigned(FOnProcessStarted) then
 197      FOnProcessStarted(Self);
 198  end;
 199  
 200  procedure TProcessThread.CallProcessTerminated;
 201  begin
 202    if Assigned(FOnProcessTerminated) then
 203      FOnProcessTerminated(Self);
 204  end;
 205  
 206  constructor TProcessThread.Create(Path, CommandLine, Directory: string; Environment: TStrings; Watch: Boolean);
 207  var
 208    Len, I: Integer;
 209  begin
 210    inherited Create(True);
 211  
 212    if (Length(CommandLine) > 0) and (Length(Path) > 0) then
 213      CommandLine := ' ' + CommandLine;
 214  
 215    if Length(Path) > 0 then
 216    begin
 217      GetMem(FPath, Length(Path) + 1);
 218      StrCopy(FPath, PChar(Path));
 219    end;
 220    if Length(CommandLine) > 0 then
 221    begin
 222      GetMem(FCommandLine, Length(CommandLine) + 1);
 223      StrCopy(FCommandLine, PChar(CommandLine));
 224    end;
 225  
 226    if Length(Directory) > 0 then
 227    begin
 228      GetMem(FDirectory, Length(Directory) + 1);
 229      StrCopy(FDirectory, PChar(Directory));
 230    end;
 231  
 232    FWatching := Watch;
 233  
 234    if Assigned(Environment) then
 235    begin
 236      GetMem(FEnvironment, 1);
 237      Len := 1;
 238      for I := 0 to Environment.Count - 1 do
 239      begin
 240        Inc(Len, Length(Environment[I]) + 1);
 241        ReallocMem(FEnvironment, Len);
 242        SetEnvironmentVariable(PChar(Environment.Names[I]), PChar(Environment.ValueFromIndex[I]));
 243        StrCopy(FEnvironment + Len - Length(Environment[I]) - 2, PChar(Environment[I]));
 244      end;
 245      (FEnvironment + Len - 1)^ := #0;
 246      FreeMem(FEnvironment);
 247      FEnvironment := nil;
 248    end;
 249  end;
 250  
 251  destructor TProcessThread.Destroy;
 252  begin
 253    FreeMem(FPath);
 254    FreeMem(FCommandLine);
 255    FreeMem(FDirectory);
 256    FreeResources;
 257    if Assigned(FEnvironment) then
 258      FreeMem(FEnvironment);
 259    inherited;
 260  end;
 261  
 262  procedure TProcessThread.Execute;
 263  const
 264    MAX_BUFFER = 512 * 1024;
 265  var
 266    MaxBytes, Available, BytesRead: Cardinal;
 267    Buffer: array[0..MAX_BUFFER] of Char;
 268  
 269    function Read: Boolean;
 270    begin
 271      Result := True;
 272      FillChar(Buffer, MAX_BUFFER, #0);
 273      PeekNamedPipe(OutputRead, @Buffer, MAX_BUFFER, @BytesRead, @Available, nil);
 274  
 275      if BytesRead < MAX_BUFFER then
 276      begin
 277        MaxBytes := BytesRead;
 278      end
 279      else
 280        MaxBytes := MAX_BUFFER;
 281  
 282      if MaxBytes > 0 then
 283        if ReadFile(OutputRead, Buffer, MaxBytes, BytesRead, nil) then
 284        begin
 285          if BytesRead > 0 then
 286          begin
 287            FData := StrPas(Buffer);
 288            Synchronize(CallDataAvailable);
 289          end;
 290        end
 291        else
 292          Result := False;
 293    end;
 294  
 295  var
 296    Startup: STARTUPINFO;
 297    SecurityDescriptor: SECURITY_DESCRIPTOR;
 298    SecurityAttributes: SECURITY_ATTRIBUTES;
 299  begin
 300    try
 301      ZeroMemory(@Startup, SizeOf(STARTUPINFO));
 302      Startup.cb := SizeOf(STARTUPINFO);
 303      ZeroMemory(@SecurityDescriptor, SizeOf(SECURITY_DESCRIPTOR));
 304      ZeroMemory(@SecurityAttributes, SizeOf(SECURITY_ATTRIBUTES));
 305      InputRead := 0;
 306      InputWrite := 0;
 307      OutputRead := 0;
 308      OutputWrite := 0;
 309  
 310      if Win32Platform = VER_PLATFORM_WIN32_NT then
 311      begin
 312        InitializeSecurityDescriptor(@SecurityDescriptor, SECURITY_DESCRIPTOR_REVISION);
 313        SetSecurityDescriptorDacl(@SecurityDescriptor, True, nil, False);
 314        SecurityAttributes.lpSecurityDescriptor := @SecurityDescriptor;
 315      end
 316      else
 317        SecurityAttributes.lpSecurityDescriptor := nil;
 318      SecurityAttributes.nLength := SizeOf(SECURITY_ATTRIBUTES);
 319      SecurityAttributes.bInheritHandle := True;
 320      if not CreatePipe(OutputRead, OutputWrite, @SecurityAttributes, 0)
 321      or not CreatePipe(InputRead, InputWrite, @SecurityAttributes, 0) then
 322        raise EProcessError.Create('Error while opening pipes');
 323  
 324      SetHandleInformation(OutputRead, HANDLE_FLAG_INHERIT, 0);
 325      SetHandleInformation(InputWrite, HANDLE_FLAG_INHERIT, 0);
 326  
 327      GetStartupInfo(Startup);
 328      Startup.dwFlags := STARTF_USESHOWWINDOW OR STARTF_USESTDHANDLES;
 329  
 330      Startup.hStdOutput := OutputWrite;
 331      Startup.hStdError := OutputWrite;
 332      Startup.hStdInput := InputRead;
 333  
 334      FlushFileBuffers(OutputWrite);
 335      FlushFileBuffers(OutputRead);
 336      FlushFileBuffers(InputRead);
 337      FlushFileBuffers(InputWrite);
 338  
 339      Startup.wShowWindow := SW_HIDE;
 340  
 341      if not CreateProcess(FPath, FCommandLine, nil, nil, True, CREATE_NEW_CONSOLE OR NORMAL_PRIORITY_CLASS, FEnvironment, FDirectory, Startup, FMainProcess) then
 342        raise EProcessError.Create('Error while starting Process: ' + SysErrorMessage(GetLastError) + ':' + FPath + ':' + FCommandLine + ':' + FDirectory);
 343      WaitForInputIdle(FMainProcess.hProcess, INITIALIZATION_TIMEOUT);
 344      FStarted := True;
 345      SetPriority(GetPriority);
 346      Synchronize(CallProcessOpened);
 347      
 348      if not FWatching then
 349        Exit;
 350  
 351      repeat
 352        if not Read then
 353          Break;
 354      until not IsProcessAlive or Terminated;
 355      Read;
 356  
 357      if not IsProcessAlive then
 358        Synchronize(CallProcessTerminated);
 359        
 360    except
 361      on E: Exception do
 362      begin
 363        FException := E;
 364        Synchronize(CallException);
 365      end;
 366    end;
 367  end;
 368  
 369  procedure TProcessThread.FreeResources;
 370  begin
 371    KillProcess(FMainProcess.dwProcessId);
 372  
 373    if OutputRead <> 0 then
 374    begin
 375      CloseHandle(OutputRead);
 376      OutputRead := 0;
 377    end;
 378    if OutputWrite <> 0 then
 379    begin
 380      CloseHandle(OutputWrite);
 381      OutputWrite := 0;
 382    end;
 383    if InputWrite <> 0 then
 384    begin
 385      CloseHandle(InputWrite);
 386      InputWrite := 0;
 387    end;
 388    if InputRead <> 0 then
 389    begin
 390      CloseHandle(InputRead);
 391      InputRead := 0;
 392    end;
 393  end;
 394  
 395  {  TProcessLineThread }
 396  
 397  constructor  TProcessLineThread.Create(Path, CommandLine, Directory: string; Environment: TStrings);
 398  begin
 399    inherited Create(Path, CommandLine, Directory, Environment);
 400    OnDataAvailable := DataAvailable;
 401    OnTerminate := Finished;
 402  end;
 403  
 404  procedure  TProcessLineThread.DataAvailable(Sender: TObject);
 405  var
 406    I, L: Integer;
 407  begin
 408    I := 0;
 409    L := Length(Data);
 410    while I < L do
 411    begin
 412      Inc(I);
 413      if Data[I] in [#13, #10] then
 414      begin
 415        if (I < L) and (Data[I+1] in [#13, #10]) then
 416          Inc(I);
 417        if Assigned(FOnNewLine) then
 418          FOnNewLine(Self, FCurrentLine);
 419        FCurrentLine := '';
 420      end
 421      else
 422        FCurrentLine := FCurrentLine + Data[I];
 423    end;
 424  end;
 425  
 426  procedure  TProcessLineThread.Finished(Sender: TObject);
 427  begin
 428    if (FCurrentLine <> '') and Assigned(FOnNewLine) then
 429      FOnNewLine(Self, FCurrentLine);
 430  end;
 431  
 432  end.