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.

   1  
   2  unit PathParser;
   3  
   4  interface
   5  
   6  uses
   7    Classes, SysUtils, TypInfo, SysUtils2, ShlObj, ShellApi, Registry, Windows;
   8  
   9  type
  10    TSpecialFolder = ( sfDesktop, sfAppData, sfTemplates, sfPrograms,
  11      sfPersonal, sfFavorites, sfStartup, sfRecent, sfSendTo, sfStartMenu,
  12      sfFonts, sfHistory, sfCookies, sfInternetCache, sfCommonFavorites,
  13      sfCommonDesktop, sfCommonStartup, sfCommonPrograms, sfCommonStartMenu,
  14      sfProgramFiles, sfTemporary, sfWindows, sfSystem );
  15  
  16    TSpecialFolderSet = set of TSpecialFolder;
  17  
  18    TPathParser = class( TStringList )
  19    public
  20      constructor Create( const UseDefaultMap: Boolean = True );
  21      class function GetSpecialFolder( const Name: TSpecialFolder ): string;
  22      function Parse( Path: string ): string;
  23    end;
  24  
  25  
  26  implementation
  27  
  28  { TPathParser }
  29  
  30  uses Dialogs;
  31  
  32  constructor TPathParser.Create(const UseDefaultMap: Boolean);
  33  var
  34    I: TSpecialFolder;
  35  begin
  36    CaseSensitive := False;
  37    if UseDefaultMap then begin
  38      for I := Low( TSpecialFolder ) to High( TSpecialFolder ) do
  39        Add( RemoveSlash( LowerCase( Copy( GetEnumName( TypeInfo( TSpecialFolder ),
  40          Ord( I ) ), 3, MAX_PATH ) ) + '=' + GetSpecialFolder( I ) ) );
  41      Add( RemoveSlash( Format( 'windowsvolume=%s', [ GetSpecialFolder( sfWindows )[1] ] ) ) );
  42    end;
  43  end;
  44  
  45  class function TPathParser.GetSpecialFolder(
  46    const Name: TSpecialFolder): string;
  47  const
  48    FoldersMap: array[TSpecialFolder] of Cardinal = ( CSIDL_DESKTOP,
  49      CSIDL_APPDATA, CSIDL_TEMPLATES, CSIDL_PROGRAMS, CSIDL_PERSONAL,
  50      CSIDL_FAVORITES, CSIDL_STARTUP, CSIDL_RECENT, CSIDL_SENDTO, CSIDL_STARTMENU,
  51      CSIDL_FONTS, CSIDL_HISTORY, CSIDL_COOKIES, CSIDL_INTERNET_CACHE,
  52      CSIDL_COMMON_FAVORITES, CSIDL_COMMON_DESKTOPDIRECTORY, CSIDL_COMMON_STARTUP,
  53      CSIDL_COMMON_PROGRAMS, CSIDL_COMMON_STARTMENU, 0, 0, 0, 0 );
  54  var
  55    Res: Bool;
  56    Path: array[0..MAX_PATH-1] of Char;
  57    Reg: TRegistry;
  58  begin
  59    Result := '';
  60    case Name of
  61      sfWindows: GetWindowsDirectory( Path, MAX_PATH );
  62      sfTemporary: GetTempPath( MAX_PATH, Path );
  63      sfSystem: GetSystemDirectory( Path, MAX_PATH );
  64      sfProgramFiles:
  65      begin
  66        Reg := TRegistry.Create( KEY_READ );
  67        try
  68          Reg.RootKey := HKEY_LOCAL_MACHINE;
  69          Reg.OpenKey( 'SOFTWARE\Microsoft\Windows\CurrentVersion', False );
  70          Result := AddSlash( Reg.ReadString( 'ProgramFilesDir' ) );
  71        finally
  72          Reg.Free;
  73        end;
  74        Exit;
  75      end;
  76    else
  77      Res := ShGetSpecialFolderPath( 0, Path, FoldersMap[ Name ], False );
  78      if not Res then
  79        raise Exception.Create( ClassName + '.GetSpecialFolder: Error on ShGetSpecialFolderPath' );
  80    end;
  81    Result := AddSlash( Path );
  82  end;
  83  
  84  function TPathParser.Parse(Path: string): string;
  85  var
  86    S: string;
  87    I, I2, Pos: Integer;
  88  begin
  89    I := 1;
  90    while I <= Length( Path )-3 do
  91    begin
  92      if ( Path[I] = '$' ) and ( Path[I+1] = '(' ) then
  93      begin
  94        I2 := I + 2;
  95        while ( I2 <= Length( Path ) ) and ( Path[I2] <> ')' ) do
  96          Inc( I2 );
  97        if I2 > Length( Path ) then
  98          Break;
  99        S := Copy( Path, I + 2, I2 - ( I + 2 ) );
 100        System.Delete( Path, I, I2 - I + 1 );
 101        Pos := IndexOfName( S );
 102        if Pos > -1 then
 103        begin
 104          System.Insert( ValueFromIndex[Pos], Path, I );
 105          Inc( I, Length( ValueFromIndex[Pos] ) );
 106        end
 107        else
 108          raise Exception.CreateFmt( '%s.Parse: Variável "%s" inexistente', [ ClassName, S ] ); //I := I2 + 1;
 109      end
 110      else
 111        Inc( I );
 112    end;
 113    Result := Path;
 114  end;
 115  
 116  end.