////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2023 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// Task (i.e. process, application, program) execution control routines.      //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20040725 - Creation                                                        //
// 20040729 - First tested release                                            //
// 20040801 - KillProcess,KillProcessTree,TRunningProcessList                 //
// 20052102 - GetExeByFile,ShellExecuteOpen                                   //
// 20050514 - Account,CreateProcessWithLogon etc.                             //
// 20050516 - Bug fixed: Account fail in W2k.                                 //
// 20050812 - Priority                                                        //
// 20051226 - Inherit handles only if stdio redirected, SmartExecute.         //
// 20060326 - Fixed bug (possible deadlock) in Detach.                        //
// 20070220 - StdInpPipeFifoClear,StdOutPipeFifoClear                         //
// 20090103 - TTask.Run modified                                              //
// 20101225 - FindParentProcessId,FindParentProcessExe,GetProcessHandleCount  //
// 20120518 - GetConsoleWindow,GetWindowClassName,GetWindowProcessId,         //
//            FindWindowByPidAndClassName,                                    //
//            WM_COPYDATA_SendToWindowByPidAndClassName                       //
// 20170413 - EnumThreads, EnumProcesses                                      //
// 20170818 - PidAffinity, cpu_count                                          //
// 20180619 - TTask.Decrypt(aBuff,aSize),TaskShuttleEncode,TaskShuttleDecode  //
// 20200614 - EnumModules,GetListOfModules,GetListOfModulesAsText             //
// 20200924 - AssocQueryString,GetExeByExtension,GetSystemAssoc,              //
//            GetSystemFType,...                                              //
// 20210405 - GetListOfWindows                                                //
// 20210421 - task_ref_min,task_ref_max                                       //
// 20210626 - ConsoleWnd, Terminate (correct wm_close to console).            //
// 20211013 - WScriptShellRun,GetRegAppPath,GetAppPath                        //
// 20230913 - Modified for FPC (A.K.). Unit _task was splitted to _crw_task,  //
//            _crw_sysid, _crw_proc, _crw_wmctrl, etc                         //
////////////////////////////////////////////////////////////////////////////////

unit _crw_task; // Task, i.e. process control

{$I _crw_sysdef}

{$IFDEF FPC}{$mode Delphi}{$ENDIF}{$H+}

interface

uses
 _crw_sharemem, // NB: THIS UNIT MUST BE FIRST !!!
 {$IFDEF UNIX} cthreads, dl, {$ENDIF}
 {$IFDEF WINDOWS} windows, {$ENDIF}
 {$IFDEF WINDOWS} jwatlhelp32, shellapi, comobj, registry, {$ENDIF}
 sysutils, classes, math, variants, lmessages, lcltype, lclintf, process,
 _crw_alloc, _crw_str, _crw_fifo, _crw_fio, _crw_rtc, _crw_dynar, _crw_crypt,
 _crw_base64, _crw_polling, _crw_proc, _crw_assoc, _crw_wmctrl, _crw_sysid;

 //////////////////////////
 // TTask.Options features.
 //////////////////////////
type
 TTaskOption  = (
  poTermOnDetach,            // Terminate process on TTask.Detach
  poTermStdInpPipeOnDetach,  // Terminate process on TTask.Detach if StdInp redirected to pipe
  poTermStdOutPipeOnDetach,  // Terminate process on TTask.Detach if StdOut redirected to pipe
  poTermStdInpFileOnDetach,  // Terminate process on TTask.Detach if StdInp redirected to file
  poTermStdOutFileOnDetach,  // Terminate process on TTask.Detach if StdOut redirected to file
  poEraseStdInpOnDetach,     // Erase StdInp file on TTask.Detach
  poEraseStdOutOnDetach      // Erase StdOut file on TTask.Detach
                 );
 TTaskOptions = set of TTaskOption;
const
 DefTaskTermHow = 0;         // Default termination code "How"
 DefTaskDisplay = 1;         // Default TTask.Display
 DefTaskOptions = [          // Default TTask.Options
  poTermStdInpPipeOnDetach,  // Terminate process on TTask.Detach if StdInp redirected to pipe
  poTermStdOutPipeOnDetach,  // Terminate process on TTask.Detach if StdOut redirected to pipe
  poTermStdInpFileOnDetach,  // Terminate process on TTask.Detach if StdInp redirected to file
  poTermStdOutFileOnDetach   // Terminate process on TTask.Detach if StdOut redirected to file
                  ];

 ////////////////////////////////////
 // Exception raised on TTask errors.
 ////////////////////////////////////
type
 ETask = class(EEchoException);

 ///////////////////////////////////////////////////////////////////////////////
 // Task (process,application,program) control class.
 // Uses to run applications/commands, standard I/O redirection ect.
 // Methods:
 //  Run       - If process attached, i.e Pid<>0, return false.
 //              Otherwise call CreateProcess to create new process.
 //              Process defined by AppName,CmdLine,Environment,DisplayMode,etc.
 //              If StdInpPipeSize>0 or StdInpFileName<>'', redirect StdIn.
 //              If StdOutPipeSize>0 or StdOutFileName<>'', redirect StdOut.
 //              If Run return true, new process attached, i.e. Pid<>0.
 //              Use Running to check if process still running or not.
 //  Running   - return true if process attached and still running.
 //              Running or Running(0) return process state immediately.
 //              Running(timeout) may be used to wait normal task termination.
 //  Detach    - Detach process, if one running, close process & file handles.
 //              If poTerminateOnDetach in Options, process will be terminated.
 //              If process still running, it will now live with it's own life.
 //              Be care, if uses standard i/o redirection: all file/pipe handles
 //              will be closed.
 //              If process still running, it may cause process file i/o errors.
 //              So you should not use Detach with file/pipe redirection.
 //  Terminate - process termination with given exit code.
 //              Maybe some timeout needed to be sure that process really killed.
 //              Even if process killed, all handles opened until Detach call.
 //  AppName   - Application name. May be empty, if CmdLine is not empty.
 //  CmdLine   - Application command line parameters. May be empty.
 //  HomeDir   - Start directory when task started. Empty mean current directory.
 //  Account   - Encrypted account (user,domain,password) to logon as another user.
 //  Encrypt   - Find encrypted account by user+CRLF+domain+CRLF+password.
 //  Environment - Enwironment strings for task. Empty means current environment.
 //  StdInpFileName - if present, standard input  redirected to this file.
 //  StdOutFileName - if present, standard output redirected to this file.
 //  StdInpPipeSize - if >0, standart input  redirected to pipe.
 //  StdOutPipeSize - if >0, standart output redirected to pipe.
 //  StdInpPipeFifo - FIFO to write to  StdIn  pipe if redirected.
 //  StdOutPipeFifo - FIFO to read from StdOut pipe if redirected.
 //  StdInpPriority - StdIn  I/O thread priority.
 //  StdOutPriority - StdOut I/O thread priority.
 //  ExitCode       - Result of execution or STILL_ACTIVE if Running
 //  Display        - usually SW_SHOWNORMAL or SW_HIDE
 //  Options        - miscallenious options
 //  ThreadPriority - main process thread priority.
 //  ProcessPriority- process priority class level, see GetPriorityClassLevel.
 //  Info           - general process information
 //  Pid            - process identifier or 0 if task was not Run or was Detach.
 //  Wnd            - handle of main window of main process thread or 0.
 // Notes:
 // 1) Use "Pid<>0" to test if prosess attached or not.
 //    If process is not attached, we have no any information or access to it.
 //    If process attached, USER COULD NOT CHANGE properties, like AppName,
 //    CmdLine,HomeDir,Account,Environment,StdInpXXXX,StdOutXXX,Options.
 //    All changes will be ignored while Pid<>0.
 // 2) If process attached, use "Running" to check if process still running.
 ///////////////////////////////////////////////////////////////////////////////
type
 TTaskPipeWriter=class(TThread) // For internal use only
 private
  myFifo : TFifo;
  myPipe : THandle;
  myPoll : TPolling;
  myBuff : packed array[0..255] of Char;
 public
  constructor Create(aSize:Integer; aPipe:THandle; aPid:Integer);
  destructor  Destroy; override;
  procedure   Execute; override;
 end;
type
 TTaskPipeReader=class(TThread) // For internal use only
 private
  myFifo : TFifo;
  myPipe : THandle;
  myPoll : TPolling;
  myBuff : packed array[0..255] of Char;
 public
  constructor Create(aSize:Integer; aPipe:THandle; aPid:Integer);
  destructor  Destroy; override;
  procedure   Execute; override;
 end;
 //
 // General Task class for process control
 //
 TTask = class(TLatch)
 private
  myAppName          : LongString;
  myCmdLine          : LongString;
  myHomeDir          : LongString;
  myAccount          : packed record
   Key               : LongString;
   User              : LongString;
   Domain            : LongString;
   Password          : LongString;
  end;
  myEnvironment      : LongString;
  myProcessInfo      : TProcessInformation;
  myStdInp           : packed record
   tempName          : LongString;
   tempFile          : THandle;
   pipeRead          : THandle;
   pipeWrite         : THandle;
   pipeFifoSize      : Integer;
   pipeThread        : TTaskPipeWriter;
   pipePriority      : TThreadPriority;
  end;
  myStdOut           : packed record
   tempName          : LongString;
   tempFile          : THandle;
   pipeRead          : THandle;
   pipeWrite         : THandle;
   pipeFifoSize      : Integer;
   pipeThread        : TTaskPipeReader;
   pipePriority      : TThreadPriority;
  end;
  myDisplay          : Integer;
  myOptions          : TTaskOptions;
  myThreadPriority   : TThreadPriority;
  myProcessPriority  : Integer;
 private
  function    GetAppName:LongString;
  procedure   SetAppName(aAppName:LongString);
  function    GetCmdLine:LongString;
  procedure   SetCmdLine(aCmdLine:LongString);
  function    GetHomeDir:LongString;
  procedure   SetHomeDir(aHomeDir:LongString);
  function    GetAccount:LongString;
  procedure   SetAccount(aAccount:LongString);
  function    GetEnvironment:LongString;
  procedure   SetEnvironment(aEnvironment:LongString);
  function    GetStdInpFileName:LongString;
  procedure   SetStdInpFileName(aFileName:LongString);
  function    GetStdInpPipeSize:Integer;
  procedure   SetStdInpPipeSize(aPipeSize:Integer);
  function    GetStdInpPipeFifoCount:Integer;
  function    GetStdInpPipeFifoSpace:Integer;
  function    GetStdInpPriority:TThreadPriority;
  procedure   SetStdInpPriority(aPriority:TThreadPriority);
  function    GetStdOutFileName:LongString;
  procedure   SetStdOutFileName(aFileName:LongString);
  function    GetStdOutPipeSize:Integer;
  procedure   SetStdOutPipeSize(aPipeSize:Integer);
  function    GetStdOutPipeFifoCount:Integer;
  function    GetStdOutPipeFifoSpace:Integer;
  function    GetStdOutPriority:TThreadPriority;
  procedure   SetStdOutPriority(aPriority:TThreadPriority);
  function    GetDisplay:Integer;
  procedure   SetDisplay(aDisplay:Integer);
  function    GetExitCode:Cardinal;
  function    GetOptions:TTaskOptions;
  procedure   SetOptions(aOptions:TTaskOptions);
  function    GetThreadPriority:TThreadPriority;
  procedure   SetThreadPriority(aPriority:TThreadPriority);
  function    GetProcessPriority:Integer;
  procedure   SetProcessPriority(aPriority:Integer);
  function    GetInfo:TProcessInformation;
  function    GetPid:Cardinal;
  function    GetMainWnd:hWnd;
  function    GetConsoleWnd:hWnd;
  function    GetExeName:LongString;
 protected
  procedure   ErrorFound(E:Exception; const Note:LongString=''); override;
 public
  constructor Create;
  destructor  Destroy; override;
  procedure   AfterConstruction; override;
  procedure   BeforeDestruction; override;
 public
  function    Run:BOOL;
  function    Running(aTimeOut:Integer=0):BOOL;
  procedure   Detach(aHow:Integer=DefTaskTermHow;aExitCode:Integer=0;aTimeOut:Integer=0);
  function    Terminate(aHow:Integer=DefTaskTermHow;aExitCode:Integer=0;aTimeOut:Integer=0):BOOL;
  function    Encrypt(const UserCrlfDomainCrlfPassword:LongString):LongString;
  function    Decrypt(aBuff:PChar=nil; aSize:Integer=0):Boolean;
  procedure   StdInpPipeFifoClear;
  procedure   StdOutPipeFifoClear;
  procedure   Burn;
 public
  property AppName             : LongString          read GetAppName         write SetAppName;
  property CmdLine             : LongString          read GetCmdLine         write SetCmdLine;
  property HomeDir             : LongString          read GetHomeDir         write SetHomeDir;
  property ExeName             : LongString          read GetExeName;
  property Account             : LongString          read GetAccount         write SetAccount;
  property Environment         : LongString          read GetEnvironment     write SetEnvironment;
  property StdInpFileName      : LongString          read GetStdInpFileName  write SetStdInpFileName;
  property StdInpPipeSize      : Integer             read GetStdInpPipeSize  write SetStdInpPipeSize;
  property StdInpPipeFifoCount : Integer             read GetStdInpPipeFifoCount;
  property StdInpPipeFifoSpace : Integer             read GetStdInpPipeFifoSpace;
  function StdInpPipeFifoPutText(const aText:LongString):Boolean;
  property StdInpPriority      : TThreadPriority     read GetStdInpPriority  write SetStdInpPriority;
  property StdOutFileName      : LongString          read GetStdOutFileName  write SetStdOutFileName;
  property StdOutPipeSize      : Integer             read GetStdOutPipeSize  write SetStdOutPipeSize;
  property StdOutPipeFifoCount : Integer             read GetStdOutPipeFifoCount;
  property StdOutPipeFifoSpace : Integer             read GetStdOutPipeFifoSpace;
  function StdOutPipeFifoGetText(aSize:Integer=MaxInt):LongString;
  property StdOutPriority      : TThreadPriority     read GetStdOutPriority  write SetStdOutPriority;
  property ExitCode            : Cardinal            read GetExitCode;
  property Display             : Integer             read GetDisplay         write SetDisplay;
  property Options             : TTaskOptions        read GetOptions         write SetOptions;
  property ThreadPriority      : TThreadPriority     read GetThreadPriority  write SetThreadPriority;
  property ProcessPriority     : Integer             read GetProcessPriority write SetProcessPriority;
  property Info                : TProcessInformation read GetInfo;
  property Pid                 : Cardinal            read GetPid;
  property MainWnd             : hWnd                read GetMainWnd;
  property ConsoleWnd          : hWnd                read GetConsoleWnd;
 end;

 ////////////////////////////////////////////
 // Full list of all existing TTask instances
 ////////////////////////////////////////////
function  FullTaskList:TObjectStorage;

 ////////////////////////////////
 // Task construction/destruction
 ////////////////////////////////
function  NewTask(const aAppName     : LongString      = '';
                  const aCmdLine     : LongString      = '';
                  const aHomeDir     : LongString      = '';
                  const aAccount     : LongString      = '';
                  const aEnvironment : LongString      = '';
                  const aDisplay     : Cardinal        = DefTaskDisplay;
                  const aStdInpFile  : LongString      = '';
                  const aStdOutFile  : LongString      = '';
                  const aStdInpPipe  : Integer         = 0;
                  const aStdOutPipe  : Integer         = 0;
                  const aOptions     : TTaskOptions    = DefTaskOptions;
                  const aRunning     : BOOL            = false):TTask;
procedure Kill(var TheObject:TTask); overload;

 // Simple (shuttle) protection for TTask.Decrypt data
function TaskShuttleEncode(Str:LongString):LongString;
function TaskShuttleDecode(Str:LongString):LongString;

 //////////////////////////////////////////////////
 // Handle file associations
 //////////////////////////////////////////////////
function  GetSystemAssoc(const Ext:LongString):LongString;
function  GetSystemFType(const FType:LongString):LongString;
function  GetSystemAssocExe(const Ext:LongString):LongString;
function  GetSystemFTypeExe(const FType:LongString):LongString;
function  HasSystemAssocExe(const Ext:LongString):Boolean;
function  HasSystemFTypeExe(const FType:LongString):Boolean;

function GetExeByExtension(const Extension:LongString):LongString;

 ///////////////////////////////////////////////////////////////////////////////////
 // Get registered application path by application short exe name (like firefox.exe)
 // Read path from HKCU or HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths.
 // Run test: REG QUERY "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths"
 // See https://docs.microsoft.com/en-us/windows/win32/shell/app-registration
 ///////////////////////////////////////////////////////////////////////////////////
function GetRegAppPath(const app:LongString):LongString;

 ///////////////////////////////////////////////////////////////////////////////////
 // Get application path by short name (like firefox) or EXE name (like firefox.exe)
 // or full file name (like %windir%\notepad.exe) or file extension type association
 // (like .html) or file type identifier (like htmlfile); many specifications may be
 // user in list of arguments (args); also options supported: (-f,-e,-b,-r,-a,-t,-c)
 // to specify type of next argument; see GetAppPath.vbs utility to get more details
 ///////////////////////////////////////////////////////////////////////////////////
function GetAppPath(args:LongString; AllowRun:Boolean=false; AllowWait:Boolean=false;
                    pExitCode:PInteger=nil; StdOut:TEchoProcedure=nil; StdErr:TEchoProcedure=nil;
                    EnvPath:LongString=''; EnvPathExt:LongString=''):LongString;

 // See https://docs.microsoft.com/en-us/windows/win32/api/shlwapi/nf-shlwapi-assocquerystringa
 //////////////////////////////////////////////////////////////////////////////////////////////
function AssocQueryString(Flags: Integer; Str: Integer; pszAssoc, pszExtra, pszOut: PChar;
  var pcchOut: DWORD): HRESULT; stdcall; external 'shlwapi.dll' name 'AssocQueryStringA';

const
  ASSOCSTR_COMMAND                 = 1;
  ASSOCSTR_EXECUTABLE              = 2;
  ASSOCSTR_FRIENDLYDOCNAME         = 3;
  ASSOCSTR_FRIENDLYAPPNAME         = 4;
  ASSOCSTR_NOOPEN                  = 5;
  ASSOCSTR_SHELLNEWVALUE           = 6;
  ASSOCSTR_DDECOMMAND              = 7;
  ASSOCSTR_DDEIFEXEC               = 8;
  ASSOCSTR_DDEAPPLICATION          = 9;
  ASSOCSTR_DDETOPIC                = 10;
  ASSOCSTR_INFOTIP                 = 11;
  ASSOCSTR_QUICKTIP                = 12;
  ASSOCSTR_TILEINFO                = 13;
  ASSOCSTR_CONTENTTYPE             = 14;
  ASSOCSTR_DEFAULTICON             = 15;
  ASSOCSTR_SHELLEXTENSION          = 16;
  ASSOCSTR_DROPTARGET              = 17;
  ASSOCSTR_DELEGATEEXECUTE         = 18;
  ASSOCSTR_SUPPORTED_URI_PROTOCOLS = 19;
  ASSOCSTR_PROGID                  = 20;
  ASSOCSTR_APPID                   = 21;
  ASSOCSTR_APPPUBLISHER            = 22;
  ASSOCSTR_APPICONREFERENCE        = 23;
const
  ASSOCF_NONE                  = $00000000;
  ASSOCF_INIT_NOREMAPCLSID     = $00000001;
  ASSOCF_INIT_BYEXENAME        = $00000002;
  ASSOCF_OPEN_BYEXENAME        = $00000002;
  ASSOCF_INIT_DEFAULTTOSTAR    = $00000004;
  ASSOCF_INIT_DEFAULTTOFOLDER  = $00000008;
  ASSOCF_NOUSERSETTINGS        = $00000010;
  ASSOCF_NOTRUNCATE            = $00000020;
  ASSOCF_VERIFY                = $00000040;
  ASSOCF_REMAPRUNDLL           = $00000080;
  ASSOCF_NOFIXUPS              = $00000100;
  ASSOCF_IGNOREBASECLASS       = $00000200;
  ASSOCF_INIT_IGNOREUNKNOWN    = $00000400;
  ASSOCF_INIT_FIXED_PROGID     = $00000800;
  ASSOCF_IS_PROTOCOL           = $00001000;
  ASSOCF_INIT_FOR_FILE         = $00002000;

 /////////////////////////////////////////////////
 // Get executable file name by document file name
 /////////////////////////////////////////////////
function GetExeByFile(const FileName:ShortString):ShortString;

 ///////////////////////////////////////////
 // Открыть документ при помощи ShellExecute
 ///////////////////////////////////////////
function ShellExecuteOpen(const FileName:ShortString; const Cmd:ShortString=''):Boolean;

 ///////////////////////////////////////////////////////////////////////////////
 // Выполнить командную строку CmdLine.
 // Если ShellCm='Open','Print','Explore', вызвать через ShellExecute
 ///////////////////////////////////////////////////////////////////////////////
function SmartExecute(const CmdLine:LongString;
                            Display:Integer=SW_SHOWNORMAL;
                            ShellCm:LongString=''):Boolean;

 ////////////////////////////////////////////////////
 //  Run application via WScript.Shell.Run COM object
 ////////////////////////////////////////////////////
function WScriptShellRun(const CmdLine:LongString; Show:Integer=SW_SHOWNORMAL; Wait:Boolean=false):Integer;

 ///////////////////////////////////////////////////////
 // Get console window handle, for console applications.
 // Requires Windows version >= Windows 2000 Pro.
 ///////////////////////////////////////////////////////
function GetConsoleWindow:HWND;

 ///////////////////////////////////
 // Get window class name by handle.
 ///////////////////////////////////
function GetWindowClassName(hWnd:HWND):LongString;

 /////////////////////////////////////////
 // Get window owner process ID by handle.
 /////////////////////////////////////////
function GetWindowProcessId(hWnd:HWND):DWORD;

 ///////////////////////////////////////////////////////
 // Find window handle by PID and ClassName or return 0.
 ///////////////////////////////////////////////////////
function FindWindowByPidAndClassName(aPid:DWORD; const aClassName:LongString):HWND;

 ///////////////////////////////////////////////////////////////////////////////
 // Send WM_COPYDATA message to process with ID aPid, to window with aClassName.
 ///////////////////////////////////////////////////////////////////////////////
function WM_COPYDATA_SendToWindowByPidAndClassName(hSender:HWND; aPid:DWORD; const aClassName,aData:LongString):LRESULT;

 ///////////////////////////////////////////////////////////////////////////////
 // TRunningProcessList encapsulate Win32 ToolHelp information about processes
 // currently running in the system. Win-NT3/NT4 is not supported.
 // Win-95/98/2K/XP is supported.
 // Count         - Number of running processes.
 // Pid           - Process identifier array. Index in range 0..Count-1.
 // ParentPid     - Parent process PID array.
 // FileName      - File name of process.
 // Usage         - Usage count of process.
 // Threads       - How many threads running in process.
 // PriorityClass - Process priority class.
 ///////////////////////////////////////////////////////////////////////////////
type
 TRunningProcessList=class(TMasterObject)
 private
  myList : TObjectStorage;
  function GetCount:Integer;
  function GetPid(i:Integer):DWORD;
  function GetParentPid(i:Integer):DWORD;
  function GetFileName(i:Integer):LongString;
  function GetUsage(i:Integer):DWORD;
  function GetThreads(i:Integer):DWORD;
  function GetPriorityClass(i:Integer):Integer;
 public
  constructor Create;
  destructor  Destroy; override;
 public
  property Count                    : Integer    read GetCount;
  property Pid[i:Integer]           : DWORD      read GetPid; default;
  property ParentPid[i:Integer]     : DWORD      read GetParentPid;
  property FileName[i:Integer]      : LongString read GetFileName;
  property Usage[i:Integer]         : DWORD      read GetUsage;
  property Threads[i:Integer]       : DWORD      read GetThreads;
  property PriorityClass[i:Integer] : Integer    read GetPriorityClass;
 end;

function  NewRunningProcessList:TRunningProcessList;
procedure Kill(var TheObject:TRunningProcessList); overload;

 ///////////////////////////////////////////////////////////////////////////////
 // KillProcess     - Terminate process by given PID.
 // KillProcessTree - Terminate process with all descendants (child proceses).
 ///////////////////////////////////////////////////////////////////////////////
function KillProcess(aPid:DWORD; aExitCode:Integer):BOOL;
function KillProcessTree(aPid:DWORD; aExitCode:Integer; MaxLevel:Integer=1000):Integer;

 ///////////////////////////////////////////////////////////////////////////////
 // Easy task routines, to be use in DAQ PASCAL
 // tid          - Task index, integer value > 0 to identify task.
 //                Zero value of tid uses to indicate error or null task.
 // task_init    - Create empty task, initialize CmdLine, return task index.
 //                After task_init, task_ref<>nil,task_pid=0,task_wait=false.
 //                Task not attached to process, you need task_run call to do it.
 //                Return 0 if free task index not found, if task table overflow.
 // task_free    - Destroy task instance and free task index for future use.
 // task_ref     - Return task instance by task index or nil if not exists.
 //                Existing reference means that task_init call was done.
 // task_pid     - Process identifier (pid) or 0 if process not attached.
 //                task_pid will return pid<>0 after task_run call.
 // task_run     - Create and run process, return true if success.
 //                After task_run call, task_pid<>0, task_wait=true.
 //                Task now will be attached to process, even if one terminated.
 //                If process already attached, return false.
 //                So you don't call task_run two times.
 // task_wait    - Wait timeout while process running.
 //                Return true if process still running.
 //                Use task_wait(tid,0) to check immediately if process running.
 // task_send    - Send data string to process standard stdin stream.
 //                Works if only stdin was redirected to pipe.
 // task_recv    - Receive data string from process standard stdout stream.
 //                Works if only stdout was redirected to pipe.
 // task_txcount - Data count in stdin  pipe.
 // task_rxcount - Data count in stdout pipe.
 // task_txspace - Data space in stdin  pipe.
 // task_rxspace - Data space in stdout pipe.
 // task_result  - Return exit code of terminated process.
 //                If process still running, return 259=STILL_ACTIVE.
 // task_kill    - Terminate process. Argument how means how to kill.
 //                0 - TerminateProcess
 //                1 - Post WM_CLOSE to window
 //                2 - Post WM_CLOSE to thread
 //                3 - Post WM_QUIT  to window
 //                4 - Post WM_QUIT  to thread
 // task_ctrl    - Task control, set parameters.
 //                task_ctrl('name=value') - assign parameter value
 //                task_ctrl('name')       - return parameter value
 //                AppName, CmdLine, HomeDir, Account, Display,
 //                StdInPipeSize=StdInpPipeSize=TxPipeSize,StdOutPipeSize=RxPipeSize
 //                StdInFileName=StdInpFileName,StdOutFileName
 ///////////////////////////////////////////////////////////////////////////////
function task_init(const cmd_line:LongString):Integer;
function task_free(tid:Integer):Boolean;
function task_ref(tid:Integer):TTask;
function task_pid(tid:Integer):Integer;
function task_run(tid:Integer):Boolean;
function task_wait(tid,timeout:Integer):Boolean;
function task_send(tid:Integer; const data:LongString):Integer;
function task_recv(tid,maxlen:Integer):LongString;
function task_txcount(tid:Integer):Integer;
function task_rxcount(tid:Integer):Integer;
function task_txspace(tid:Integer):Integer;
function task_rxspace(tid:Integer):Integer;
function task_result(tid:Integer):Integer;
function task_kill(tid,how,exit_code,timeout:Integer):Boolean;
function task_ctrl(tid:Integer; const param:LongString):LongString;

const                // Task reference range
 task_ref_min = 1;   // Minimal task reference
 task_ref_max = 255; // Maximal task reference

 ///////////////////////////////////////////////////////////////////////////////
 // Special Win32 system call which are not presents in Windows.pas
 // This call needs W2K or higher.
 ///////////////////////////////////////////////////////////////////////////////
const
 LOGON_WITH_PROFILE        = $00000001;
 LOGON_NETCREDENTIALS_ONLY = $00000002;

 // Create process to run with another user account.
 // See http://msdn.microsoft.com/library/default.asp?
 //          url=/library/en-us/dllproc/base/createprocesswithlogonw.asp
function CreateProcessWithLogon(lpUsername,lpDomain,lpPassword:PChar;
          dwLogonFlags:DWORD; lpApplicationName,lpCommandLine:PChar;
          dwCreationFlags:DWORD; lpEnvironment:Pointer;
          lpCurrentDirectory:PChar; const lpStartupInfo:TStartupInfo;
          var lpProcessInformation:TProcessInformation):BOOL stdcall;

function PidAffinity(pid,mask:Integer):Integer;

 //////////////////////////////
 // Test routine to check TTask
 //////////////////////////////
{$IFDEF Poligon}
procedure TestTask1;
procedure TestTask2;
{$ENDIF Poligon}

implementation

 /////////////////////////////
 // Internal utility functions
 /////////////////////////////
function KillHandle(var Handle:THandle; Default:THandle):BOOL;
begin
 Result:=true;
 if Handle<>Default then begin
  Result:=CloseHandle(Handle);
  Handle:=Default;
 end;
end;

function GetThreadMainWindowHandle(aThreadID:THandle): hWnd;
 function CheckThreadWindows(Wnd: HWND; Data:LPARAM): BOOL; stdcall;
 var
  ParentWnd : hWnd;
  ExStyle   : DWORD;
  Caption   : array [0..255] of Char;
 begin
  Result:=True;
  if Wnd<>0 then
  if Data<>0 then
  if IsWindow(Wnd) then begin
   ExStyle:=GetWindowLong(Wnd,GWL_EXSTYLE);
   ParentWnd:=GetWindowLong(Wnd,GWL_HWNDPARENT);
   if (ParentWnd=0) or (ParentWnd=GetDesktopWindow) then
   if (ExStyle and WS_EX_TOOLWINDOW=0) or (ExStyle and WS_EX_APPWINDOW<>0) then
   if GetWindowText(Wnd,Caption,SizeOf(Caption))>0 then begin
    hWnd(Pointer(Data)^):=Wnd;
    Result:=false;
   end;
  end;
 end;
begin
 Result:=0;
 try
  EnumThreadWindows(aThreadID, @CheckThreadWindows, LPARAM(@Result));
 except
  on E:Exception do BugReport(E);
 end;
end;

 ///////////////////////////////////////////////////////////////////////////////
 // Some special Win32 calls which are not presents in Windows.pas
 ///////////////////////////////////////////////////////////////////////////////
function CreateProcessWithLogon(lpUsername,lpDomain,lpPassword:PChar;
          dwLogonFlags:DWORD; lpApplicationName,lpCommandLine:PChar;
          dwCreationFlags:DWORD; lpEnvironment:Pointer;
          lpCurrentDirectory:PChar; const lpStartupInfo:TStartupInfo;
          var lpProcessInformation:TProcessInformation):BOOL stdcall;
const
 CreateProcessWithLogonW : function(lpUsername,lpDomain,lpPassword:PWideChar;
          dwLogonFlags:DWORD; lpApplicationName,lpCommandLine:PWideChar;
          dwCreationFlags:DWORD; lpEnvironment:Pointer;
          lpCurrentDirectory:PWideChar; const lpStartupInfo:TStartupInfo;
          var lpProcessInformation:TProcessInformation):BOOL stdcall = nil;
var
 hModule:THandle;
 LastError:DWORD;
 // We need wrapper procedure because function frame code resets GetLastError
 function WrapCreateProcessWithLogonW:BOOL;
 var
  wsUsername,wsDomain,wsPassword,wsApplicationName,wsCommandLine,wsCurrentDirectory:WideString;
  function ArgWChar(const Str:WideString):PWideChar;
  begin
   if Length(Str)>0 then Result:=PWideChar(Str) else Result:=nil;
  end;
 begin
  wsUsername:=SysUtils.StrPas(lpUsername);
  wsDomain:=SysUtils.StrPas(lpDomain);
  wsPassword:=SysUtils.StrPas(lpPassword);
  wsApplicationName:=SysUtils.StrPas(lpApplicationName);
  wsCommandLine:=SysUtils.StrPas(lpCommandLine);
  wsCurrentDirectory:=SysUtils.StrPas(lpCurrentDirectory);
  Result:=CreateProcessWithLogonW(ArgWChar(wsUsername),ArgWChar(wsDomain),
            ArgWChar(wsPassword),dwLogonFlags,ArgWChar(wsApplicationName),
            ArgWChar(wsCommandLine),dwCreationFlags,lpEnvironment,
            ArgWChar(wsCurrentDirectory),lpStartupInfo,lpProcessInformation);
  LastError:=GetLastError;
 end;
begin
 Result:=false;
 if not Assigned(CreateProcessWithLogonW) then begin
  hModule:=GetModuleHandle('advapi32.dll');
  if hModule<>0 then @CreateProcessWithLogonW:=GetProcAddress(hModule,'CreateProcessWithLogonW');
 end;
 if Assigned(CreateProcessWithLogonW) then begin
  Result:=WrapCreateProcessWithLogonW;
  SetLastError(LastError);
 end else SetLastError(ERROR_CALL_NOT_IMPLEMENTED);
end;

function PidAffinity(pid,mask:Integer):Integer;
var h:THandle; m1,m2:DWORD;
begin
 Result:=0;
 try
  if (pid=0) or (pid=-1)
  then h:=GetCurrentProcess
  else h:=OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_SET_INFORMATION,False,pid);
  if h<>0 then
  try
   if (mask<>0) and (pid<>-1) then SetProcessAffinityMask(h,DWORD(mask));
   if Windows.GetProcessAffinityMask(h,m1,m2) then
   if pid=-1 then Result:=m2 else Result:=m1;
  finally
   if (h<>0) and (h<>GetCurrentProcess) then CloseHandle(h);
  end;
 except
  on E:Exception do BugReport(E);
 end;
end;

 ///////////////////////////////////////////////
 // Thread to write data to child process StdIn.
 ///////////////////////////////////////////////
constructor TTaskPipeWriter.Create(aSize:Integer; aPipe:THandle; aPid:Integer);
begin
 inherited Create(true);
 myFifo:=NewFifo(aSize);
 myFifo.Master:=@myFifo;
 myPoll:=NewPolling(nil,1000,tpNormal,true,Format('StdIn#%u',[aPid]));
 myPoll.Master:=@myPoll;
 myPipe:=aPipe;
end;

destructor TTaskPipeWriter.Destroy;
begin
 Kill(myFifo);
 Kill(myPoll);
 inherited;
end;

procedure  TTaskPipeWriter.Execute;
var pipe:THandle; Len,Index,Count:Integer;
begin
 try
  if not DuplicateHandle(GetCurrentProcess,myPipe,
                         GetCurrentProcess,@pipe,0,False,DUPLICATE_SAME_ACCESS)
  then RAISE ETask.Create(Format('%s: %s',[myPoll.Name,SysErrorMessage(GetLastError)]));
  try
   while not Terminated do begin
    Index:=0;
    Count:=myFifo.Get(@myBuff,SizeOf(myBuff));
    while not Terminated and (Count>0) do begin
     if WriteFile(pipe,myBuff[Index],Count,DWORD(Len),nil) then begin
      inc(Index,Len);
      dec(Count,Len);
      if Count<=0 then begin
       Index:=0;
       Count:=myFifo.Get(@myBuff,SizeOf(myBuff));
      end;
     end else begin
      if not Terminated then begin
       Echo(Format('%s: %s',[myPoll.Name,SysErrorMessage(GetLastError)]));
       Terminate;
      end;
     end;
     myPoll.Awake;
    end;
    if not Terminated then Sleep(1);
   end;
  finally
   KillHandle(pipe,0);
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

 //////////////////////////////////////////
 // Thread to read data from process StdOut
 //////////////////////////////////////////
constructor TTaskPipeReader.Create(aSize:Integer; aPipe:THandle; aPid:Integer);
begin
 inherited Create(true);
 myFifo:=NewFifo(aSize);
 myFifo.Master:=@myFifo;
 myPoll:=NewPolling(nil,1000,tpNormal,true,Format('StdOut#%u',[aPid]));
 myPoll.Master:=@myPoll;
 myPipe:=aPipe;
end;

destructor TTaskPipeReader.Destroy;
begin
 Kill(myFifo);
 Kill(myPoll);
 inherited;
end;

procedure  TTaskPipeReader.Execute;
var pipe:THandle; Len:Integer;
begin
 try
  if not DuplicateHandle(GetCurrentProcess,myPipe,
                         GetCurrentProcess,@pipe,0,False,DUPLICATE_SAME_ACCESS)
  then RAISE ETask.Create(Format('%s: %s',[myPoll.Name,SysErrorMessage(GetLastError)]));
  try
   while not Terminated do begin
    while not Terminated and (myFifo.Space>=SizeOf(myBuff)) do begin
     if ReadFile(pipe,myBuff,SizeOf(myBuff),DWORD(Len),nil) then begin
      if Len>0 then
      if myFifo.Put(@myBuff,Len)<>Len
      then Echo(Format('%s: %d byte(s) lost due to FIFO overflow',[myPoll.Name,Len]));
     end else begin
      if not Terminated then begin
       Echo(Format('%s: %s',[myPoll.Name,SysErrorMessage(GetLastError)]));
       Terminate;
      end;
     end;
     myPoll.Awake;
    end;
    if not Terminated then Sleep(1);
   end;
  finally
   KillHandle(pipe,0);
  end
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

 ////////////////////////
 // TTask implementation.
 ////////////////////////
constructor TTask.Create;
begin
 inherited Create;
 Exceptions:=false;
 myAppName:='';
 myCmdLine:='';
 myHomeDir:='';
 with myAccount do begin
  Key:='';
  User:='';
  Domain:='';
  Password:='';
 end;
 myEnvironment:='';
 with myProcessInfo do begin
  hProcess:=0;
  hThread:=0;
  dwProcessId:=0;
  dwThreadId:=0;
 end;
 with myStdInp do begin
  tempName:='';
  tempFile:=INVALID_HANDLE_VALUE;
  pipeRead:=0;
  pipeWrite:=0;
  pipeFifoSize:=0;
  pipeThread:=nil;
  pipePriority:=tpNormal;
 end;
 with myStdOut do begin
  tempName:='';
  tempFile:=INVALID_HANDLE_VALUE;
  pipeRead:=0;
  pipeWrite:=0;
  pipeFifoSize:=0;
  pipeThread:=nil;
  pipePriority:=tpNormal;
 end;
 myDisplay:=DefTaskDisplay;
 myOptions:=DefTaskOptions;
 myThreadPriority:=tpNormal;
 myProcessPriority:=GetPriorityClassLevel(NORMAL_PRIORITY_CLASS);
end;

destructor  TTask.Destroy;
begin
 Burn;
 Detach;
 myAppName:='';
 myCmdLine:='';
 myHomeDir:='';
 myAccount.Key:='';
 myEnvironment:='';
 myStdInp.tempName:='';
 myStdOut.tempName:='';
 inherited Destroy;
end;

procedure TTask.AfterConstruction;
begin
 inherited AfterConstruction;
 FullTaskList.Add(Self);
end;

procedure TTask.BeforeDestruction;
begin
 FullTaskList.Remove(Self);
 inherited BeforeDestruction;
end;

function  TTask.GetAppName:LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myAppName;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TTask.SetAppName(aAppName:LongString);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if Pid=0 then myAppName:=SysUtils.Trim(aAppName);
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetCmdLine:LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myCmdLine;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TTask.SetCmdLine(aCmdLine:LongString);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if Pid=0 then myCmdLine:=SysUtils.Trim(aCmdLine);
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetHomeDir:LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myHomeDir;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TTask.SetHomeDir(aHomeDir:LongString);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if Pid=0 then myHomeDir:=SysUtils.Trim(aHomeDir);
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetAccount:LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myAccount.Key;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TTask.SetAccount(aAccount:LongString);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   Burn;
   if Pid=0 then myAccount.Key:=SysUtils.Trim(aAccount);
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetEnvironment:LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myEnvironment;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TTask.SetEnvironment(aEnvironment:LongString);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if Pid=0 then myEnvironment:=aEnvironment;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetStdInpFileName:LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myStdInp.tempName;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TTask.SetStdInpFileName(aFileName:LongString);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if Pid=0 then
   with myStdInp do begin
    tempName:=SysUtils.Trim(aFileName);
    if Length(tempName)>0 then pipeFifoSize:=0;
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetStdInpPipeSize:Integer;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myStdInp.pipeFifoSize;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TTask.SetStdInpPipeSize(aPipeSize:Integer);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if Pid=0 then
   with myStdInp do begin
    if aPipeSize>0
    then pipeFifoSize:=AdjustBufferSize(aPipeSize,1024)
    else pipeFifoSize:=0;
    if pipeFifoSize>0 then tempName:='';
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetStdInpPipeFifoCount:Integer;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   with myStdInp do
   if Assigned(pipeThread) then
   Result:=pipeThread.myFifo.Count;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetStdInpPipeFifoSpace:Integer;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   with myStdInp do
   if Assigned(pipeThread) then
   Result:=pipeThread.myFifo.Space;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.StdInpPipeFifoPutText(const aText:LongString):Boolean;
begin
 Result:=false;
 if Assigned(Self) then
 try
  Lock;
  try
   with myStdInp do
   if Assigned(pipeThread) then
   Result:=pipeThread.myFifo.PutText(aText);
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TTask.StdInpPipeFifoClear;
begin
 if Assigned(Self) then
 try
  Lock;
  try
   with myStdInp do
   if Assigned(pipeThread) then pipeThread.myFifo.Clear;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetStdInpPriority:TThreadPriority;
begin
 Result:=tpNormal;
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myStdInp.pipePriority;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure  TTask.SetStdInpPriority(aPriority:TThreadPriority);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   with myStdInp do begin
    pipePriority:=aPriority;
    if Assigned(pipeThread) then pipeThread.Priority:=pipePriority;
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetStdOutFileName:LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myStdOut.tempName;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TTask.SetStdOutFileName(aFileName:LongString);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if Pid=0 then
   with myStdOut do begin
    tempName:=SysUtils.Trim(aFileName);
    if Length(tempName)>0 then pipeFifoSize:=0;
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetStdOutPipeSize:Integer;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myStdOut.pipeFifoSize;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TTask.SetStdOutPipeSize(aPipeSize:Integer);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if Pid=0 then
   with myStdOut do begin
    if aPipeSize>0
    then pipeFifoSize:=AdjustBufferSize(aPipeSize,1024)
    else pipeFifoSize:=0;
    if pipeFifoSize>0 then tempName:='';
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetStdOutPipeFifoCount:Integer;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   with myStdOut do
   if Assigned(pipeThread) then
   Result:=pipeThread.myFifo.Count;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetStdOutPipeFifoSpace:Integer;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   with myStdOut do
   if Assigned(pipeThread) then
   Result:=pipeThread.myFifo.Space;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.StdOutPipeFifoGetText(aSize:Integer):LongString;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lock;
  try
   with myStdOut do
   if Assigned(pipeThread) then
   Result:=pipeThread.myFifo.GetText(aSize);
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TTask.StdOutPipeFifoClear;
begin
 if Assigned(Self) then
 try
  Lock;
  try
   with myStdOut do
   if Assigned(pipeThread) then pipeThread.myFifo.Clear;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetStdOutPriority:TThreadPriority;
begin
 Result:=tpNormal;
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myStdOut.pipePriority;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure  TTask.SetStdOutPriority(aPriority:TThreadPriority);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   with myStdOut do begin
    pipePriority:=aPriority;
    if Assigned(pipeThread) then pipeThread.Priority:=pipePriority;
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetDisplay:Integer;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myDisplay;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TTask.SetDisplay(aDisplay:Integer);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if Pid=0 then myDisplay:=aDisplay;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetOptions:TTaskOptions;
begin
 Result:=[];
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myOptions;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TTask.SetOptions(aOptions:TTaskOptions);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if Pid=0 then myOptions:=aOptions;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetThreadPriority:TThreadPriority;
begin
 Result:=tpNormal;
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myThreadPriority;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure  TTask.SetThreadPriority(aPriority:TThreadPriority);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   myThreadPriority:=aPriority;
   with myProcessInfo do
   if hThread<>0 then
   case myThreadPriority of
    tpIdle         : windows.SetThreadPriority(hThread,THREAD_PRIORITY_IDLE);
    tpLowest       : windows.SetThreadPriority(hThread,THREAD_PRIORITY_LOWEST);
    tpLower        : windows.SetThreadPriority(hThread,THREAD_PRIORITY_BELOW_NORMAL);
    tpNormal       : windows.SetThreadPriority(hThread,THREAD_PRIORITY_NORMAL);
    tpHigher       : windows.SetThreadPriority(hThread,THREAD_PRIORITY_ABOVE_NORMAL);
    tpHighest      : windows.SetThreadPriority(hThread,THREAD_PRIORITY_HIGHEST);
    tpTimeCritical : windows.SetThreadPriority(hThread,THREAD_PRIORITY_TIME_CRITICAL);
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function  TTask.GetProcessPriority:Integer;
begin
 Result:=GetPriorityClassLevel(NORMAL_PRIORITY_CLASS);
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myProcessPriority;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure  TTask.SetProcessPriority(aPriority:Integer);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   myProcessPriority:=GetPriorityClassLevel(GetPriorityClassByLevel(aPriority));
   with myProcessInfo do
   if hProcess<>0 then windows.SetPriorityClass(hProcess,GetPriorityClassByLevel(myProcessPriority));
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function TTask.GetExitCode:Cardinal;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   with myProcessInfo do
   if hProcess<>0 then GetExitCodeProcess(hProcess,Result);
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function TTask.GetInfo:TProcessInformation;
begin
 Result.hProcess:=0;
 Result.hThread:=0;
 Result.dwProcessId:=0;
 Result.dwThreadId:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myProcessInfo;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function TTask.GetPid:Cardinal;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   Result:=myProcessInfo.dwProcessId;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function TTask.GetMainWnd:hWnd;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   with myProcessInfo do
   if dwProcessId<>0 then Result:=GetThreadMainWindowHandle(dwThreadId);
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function TTask.GetConsoleWnd:hWnd;
begin
 Result:=0;
 if Assigned(Self) then
 try
  Lock;
  try
   with myProcessInfo do
   if dwProcessId<>0 then Result:=FindWindowByPidAndClassName(dwProcessId,'ConsoleWindowClass');
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function TTask.GetExeName:LongString;
var
 i     : Integer;
 FName : ShortString;
 Quote : Char;
begin
 Result:='';
 if Assigned(Self) then
 try
  Lock;
  try
   FName:=SysUtils.Trim(myAppName);
   if IsEmptyStr(FName) then begin
    FName:=SysUtils.Trim(myCmdLine);
    if not IsEmptyStr(FName) then begin
     Quote:=FName[1];
     if Quote='"' then Delete(FName,1,1);
     for i:=1 to Length(FName) do begin
      if (FName[i] in [' ',ASCII_TAB,ASCII_CR,ASCII_LF]) and (Quote<>QuoteMark) then begin
       Delete(FName,i,Length(FName));
       Break;
      end;
      if (FName[i]='"') and (Quote='"') then begin
       Delete(FName,i,Length(FName));
       Break;
      end;
     end;
    end;
   end;
   Result:=RemoveBrackets(SysUtils.Trim(FName),'""');
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function TTask.Encrypt(const UserCrlfDomainCrlfPassword:LongString):LongString;
var
 t     : Int64;
 i     : Integer;
 IV    : ShortString;
 Temp  : ShortString;
 FName : ShortString;
begin
 Result:='';
 if Assigned(Self) then
 if Length(UserCrlfDomainCrlfPassword)>0 then
 try
  Lock;
  try
   FName:=ExeName;
   if IsEmptyStr(FName)
   then RAISE ETask.Create('TTask.Run: executable file is not specified.');
   if not HasExtension(FName,i)
   then RAISE ETask.Create('TTask.Run: executable file must include extension.');
   if IsRelativePath(FName)
   then RAISE ETask.Create('TTask.Run: executable file must include full path.');
   if not FileExists(FName)
   then RAISE ETask.Create('TTask.Run: executable file not found: '+FName);
   t:=IntMSecNow;
   IV:=Dump(Int64(t),SizeOf(Int64));
   Temp:=LeftPad(UserCrlfDomainCrlfPassword,40);
   Temp:=EncryptText(Temp,GetFileSign(FName),IV,FSign_EK,FSign_EM,df_Bin,df_Bin);
   if Length(Temp)>0
   then Result:=StringReplace(Mime_Encode(IV+Temp),'=','',[rfReplaceAll]);
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function TTask.Decrypt(aBuff:PChar=nil; aSize:Integer=0):Boolean;
var
 T     : TText;
 i     : Integer;
 IV    : ShortString;
 Temp  : ShortString;
 FName : ShortString;
begin
 Result:=false;
 if Assigned(Self) then
 try
  T:=NewText;
  Lock;
  try
   Burn;
   FName:=ExeName;
   if IsEmptyStr(FName)
   then RAISE ETask.Create('TTask.Run: executable file is not specified.');
   if not HasExtension(FName,i)
   then RAISE ETask.Create('TTask.Run: executable file must include extension.');
   if IsRelativePath(FName)
   then RAISE ETask.Create('TTask.Run: executable file must include full path.');
   if not FileExists(FName)
   then RAISE ETask.Create('TTask.Run: executable file not found: '+FName);
   Temp:=Mime_Decode(myAccount.Key);
   if Length(Temp)>SizeOf(Int64) then begin
    IV:=Copy(Temp,1,SizeOf(Int64));
    Delete(Temp,1,SizeOf(Int64));
    T.Text:=DecryptText(Temp,GetFileSign(FName),IV,FSign_EK,FSign_EM,df_Bin,df_Bin);
    if T.Count>2 then begin
     myAccount.User:=TrimLeadChars(T[0],[' ']);
     myAccount.Domain:=T[1];
     myAccount.Password:=T[2];
     // Copy account with simple (shuttle) protection
     // Uses TaskShuttleDecode to decode account data
     if Assigned(aBuff) and (aSize>1) then begin
      Temp:=TaskShuttleEncode(myAccount.User+CRLF+myAccount.Domain+CRLF+myAccount.Password);
      StrPCopy(aBuff,Copy(Temp,1,aSize-1));
     end;
    end;
   end;
   Result:=not IsEmptyStr(myAccount.User);
  finally
   Unlock;
   Kill(T);
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TTask.Burn;
begin
 if Assigned(Self) then
 try
  Lock;
  try
   SafeFillChar(myAccount.User[1],Length(myAccount.User),0);
   SafeFillChar(myAccount.Domain[1],Length(myAccount.Domain),0);
   SafeFillChar(myAccount.Password[1],Length(myAccount.Password),0);
   myAccount.User:='';
   myAccount.Domain:='';
   myAccount.Password:='';
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TTask.ErrorFound(E:Exception; const Note:LongString);
begin
 if Exceptions then begin
  if E is Exception
  then RAISE ETask.Create(E.Message)
  else RAISE ETask.Create(Note);
 end else ErrorReport(E,Note);
end;

function TTask.Terminate(aHow:Integer=DefTaskTermHow;aExitCode:Integer=0;aTimeOut:Integer=0):BOOL;
var hWin:hWnd;
begin
 Result:=false;
 if Assigned(Self) then
 try
  Lock;
  try
   with myProcessInfo do
   if hProcess<>0 then begin
    if WaitForSingleObject(hProcess,0)=WAIT_TIMEOUT then begin
     case aHow of
      0:   Result:=TerminateProcess(hProcess,aExitCode);
      1:   begin
            hWin:=MainWnd;
            if (hWin=0) then hWin:=ConsoleWnd;
            if (hWin<>0) and IsWindow(hWin) then begin
             if IsWindowVisible(hWin) then SetForegroundWindow(hWin);
             Result:=PostMessage(hWin, WM_CLOSE, aExitCode, 0);
            end;
           end;
      2:   begin
            hWin:=MainWnd;
            if (hWin=0) then hWin:=ConsoleWnd;
            if (hWin<>0) and IsWindow(hWin) then begin
             if IsWindowVisible(hWin) then SetForegroundWindow(hWin);
             Result:=PostMessage(hWin, WM_QUIT, aExitCode, 0);
            end;
           end;
      3:   Result:=KillProcessTree(dwProcessId,aExitCode)>0;
      else Result:=TerminateProcess(hProcess,aExitCode);
     end;
     if Result then WaitForSingleObject(hProcess,aTimeOut);
    end;
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

procedure TTask.Detach(aHow:Integer=DefTaskTermHow;aExitCode:Integer=0;aTimeOut:Integer=0);
begin
 if Assigned(Self) then
 try
  Lock;
  try
   Burn;
   if (poTermOnDetach in myOptions) or
     ((poTermStdInpPipeOnDetach in myOptions) and (StdInpPipeSize>0)) or
     ((poTermStdOutPipeOnDetach in myOptions) and (StdOutPipeSize>0)) or
     ((poTermStdInpFileOnDetach in myOptions) and (StdInpFileName<>'')) or
     ((poTermStdOutFileOnDetach in myOptions) and (StdOutFileName<>''))
   then if Running then Terminate(aHow,aExitCode,aTimeOut);
   with myProcessInfo do begin
    KillHandle(hProcess,0);
    KillHandle(hThread,0);
    dwProcessId:=0;
    dwThreadId:=0;
   end;
   with myStdInp do begin
    KillHandle(tempFile,INVALID_HANDLE_VALUE);
    if poEraseStdInpOnDetach in myOptions then FileErase(tempName);
    if Assigned(pipeThread) then begin
     if WaitForSingleObject(pipeThread.Handle,0)=WAIT_TIMEOUT then begin
      pipeThread.FreeOnTerminate:=true;
      pipeThread.Terminate;
      pipeThread:=nil;
     end;
    end;
    KillHandle(pipeRead,0);
    KillHandle(pipeWrite,0);
    Kill(TObject(pipeThread));
   end;
   with myStdOut do begin
    KillHandle(tempFile,INVALID_HANDLE_VALUE);
    if poEraseStdOutOnDetach in myOptions then FileErase(tempName);
    if Assigned(pipeThread) then begin
     if WaitForSingleObject(pipeThread.Handle,0)=WAIT_TIMEOUT then begin
      pipeThread.FreeOnTerminate:=true;
      pipeThread.Terminate;
      pipeThread:=nil;
     end;
    end;
    KillHandle(pipeRead,0);
    KillHandle(pipeWrite,0);
    Kill(TObject(pipeThread));
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function TTask.Running(aTimeOut:Integer=0):BOOL;
begin
 Result:=false;
 if Assigned(Self) then
 try
  Lock;
  try
   with myProcessInfo do
   if hProcess<>0 then Result:=(WaitForSingleObject(hProcess,aTimeOut)=WAIT_TIMEOUT);
  finally
   Unlock;
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

function TTask.Run:BOOL;
var
 myInheritance : BOOL;
 myCreateFlags : Cardinal;
 myStartupInfo : TStartupInfo;
 function IsLocalHost(const Domain:LongString):Boolean;
 begin
  Result:=IsSameText(Trim(Domain),'.') or IsSameText(Trim(Domain),'localhost');
 end;
 function SmartDomain(const Domain:LongString):LongString;
 begin
  if IsLocalHost(Domain) then Result:=ComputerName else Result:=Domain;
 end;
begin
 Result:=false;
 if Assigned(Self) and (Pid=0) then
 try
  Lock;
  try
   //
   // Close all previouse handles if one exists
   //
   Detach;
   //
   // Check arguments...
   //
   if Length(AppName)+Length(CmdLine)=0
   then RAISE ETask.Create('TTask.Run: command line is not specified.');
   //
   // Create files or pipes for redirection
   // Use DuplicateHandle to enable inheritance if one needed
   //
   with myStdInp do
   if pipeFifoSize>0 then begin
    if not CreatePipe(pipeRead,pipeWrite,nil,pipeFifoSize)
    then RAISE ETask.Create(Format('TTask.Run: %s',[SysErrorMessage(GetLastError)]));
    if not DuplicateHandle(GetCurrentProcess,pipeRead,
                           GetCurrentProcess,@pipeRead,0,True,
                           DUPLICATE_CLOSE_SOURCE OR DUPLICATE_SAME_ACCESS)
    then RAISE ETask.Create(Format('TTask.Run: %s',[SysErrorMessage(GetLastError)]));
   end else
   if Length(tempName)>0 then begin
    tempFile:=CreateFile(ArgChar(tempName), GENERIC_READ, 0, nil,
                         OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
    if tempFile = INVALID_HANDLE_VALUE
    then RAISE ETask.Create(Format('TTask.Run: %s',[SysErrorMessage(GetLastError)]));
    if not DuplicateHandle(GetCurrentProcess,tempFile,
                           GetCurrentProcess,@tempFile,0,True,
                           DUPLICATE_CLOSE_SOURCE OR DUPLICATE_SAME_ACCESS)
    then RAISE ETask.Create(Format('TTask.Run: %s',[SysErrorMessage(GetLastError)]));
   end;
   with myStdOut do
   if pipeFifoSize>0 then begin
    if not CreatePipe(pipeRead,pipeWrite,nil,pipeFifoSize)
    then RAISE ETask.Create(Format('TTask.Run: %s',[SysErrorMessage(GetLastError)]));
    if not DuplicateHandle(GetCurrentProcess,pipeWrite,
                           GetCurrentProcess,@pipeWrite,0,True,
                           DUPLICATE_CLOSE_SOURCE OR DUPLICATE_SAME_ACCESS)
    then RAISE ETask.Create(Format('TTask.Run: %s',[SysErrorMessage(GetLastError)]));
   end else
   if Length(tempName)>0 then begin
    tempFile := CreateFile(ArgChar(tempName), GENERIC_WRITE, 0, nil,
                           CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
    if tempFile = INVALID_HANDLE_VALUE
    then RAISE ETask.Create(Format('TTask.Run: %s',[SysErrorMessage(GetLastError)]));
    if not DuplicateHandle(GetCurrentProcess,tempFile,
                           GetCurrentProcess,@tempFile,0,True,
                           DUPLICATE_CLOSE_SOURCE OR DUPLICATE_SAME_ACCESS)
    then RAISE ETask.Create(Format('TTask.Run: %s',[SysErrorMessage(GetLastError)]));
   end;
   //
   // Fill process startup information: show flags, handle inheritance etc.
   //
   ZeroMemory(@myStartupInfo, SizeOf(myStartupInfo));
   myStartupInfo.cb           := SizeOf(myStartupInfo);
   if myDisplay <> -1 then begin
    myStartupInfo.dwFlags     := myStartupInfo.dwFlags or STARTF_USESHOWWINDOW;
    myStartupInfo.wShowWindow := myDisplay;
   end;
   with myStdInp do
   if pipeRead <> 0 then begin
    myStartupInfo.dwFlags    := myStartupInfo.dwFlags or STARTF_USESTDHANDLES;
    myStartupInfo.hStdInput  := pipeRead;
   end else
   if tempFile <> INVALID_HANDLE_VALUE then begin
    myStartupInfo.dwFlags    := myStartupInfo.dwFlags or STARTF_USESTDHANDLES;
    myStartupInfo.hStdInput  := tempFile;
   end;
   with myStdOut do
   if pipeWrite <> 0 then begin
    myStartupInfo.dwFlags    := myStartupInfo.dwFlags or STARTF_USESTDHANDLES;
    myStartupInfo.hStdOutput := pipeWrite;
    myStartupInfo.hStdError  := pipeWrite;
   end else
   if tempFile <> INVALID_HANDLE_VALUE then begin
    myStartupInfo.dwFlags    := myStartupInfo.dwFlags or STARTF_USESTDHANDLES;
    myStartupInfo.hStdOutput := tempFile;
    myStartupInfo.hStdError  := tempFile;
   end;
   //
   // Allow inheritance only if StdIO redirected
   //
   if myStartupInfo.dwFlags and STARTF_USESTDHANDLES <> 0 then begin
    myInheritance:=TRUE;
    myCreateFlags:=0;
   end else begin
    myInheritance:=FALSE;
    myCreateFlags:=CREATE_NEW_CONSOLE;
   end;
   //
   // Create process with given parameters
   //
   if IsEmptyStr(myAccount.Key) then begin
    if not CreateProcess(ArgChar(myAppName),     // pointer to name of executable module
                         ArgChar(myCmdLine),     // pointer to command line string
                         nil,                    // pointer to process security attributes
                         nil,                    // pointer to thread security attributes
                         myInheritance,          // handle inheritance flag
                         myCreateFlags,          // creation flags
                         ArgChar(myEnvironment), // pointer to new environment block
                         ArgChar(myHomeDir),     // pointer to current directory name
                         myStartupInfo,          // pointer to STARTUPINFO
                         myProcessInfo)          // pointer to PROCESS_INFORMATION
    then RAISE ETask.Create(Format('TTask.Run: %s',[SysErrorMessage(GetLastError)]));
   end else begin
    if not Decrypt
    then RAISE ETask.Create('TTask.Run: could not decrypt account.');
    if not CreateProcessWithLogon(
                         ArgChar(myAccount.User),
                         ArgChar(myAccount.Domain),
                         ArgChar(myAccount.Password),
                         LOGON_WITH_PROFILE,     // Logon flags
                         ArgChar(myAppName),     // pointer to name of executable module
                         ArgChar(myCmdLine),     // pointer to command line string
                         CREATE_DEFAULT_ERROR_MODE or CREATE_NEW_CONSOLE or CREATE_NEW_PROCESS_GROUP,
                         ArgChar(myEnvironment), // pointer to new environment block
                         ArgChar(myHomeDir),     // pointer to current directory name
                         myStartupInfo,          // pointer to STARTUPINFO
                         myProcessInfo)          // pointer to PROCESS_INFORMATION
    then
    if IsLocalHost(myAccount.Domain) and not CreateProcessWithLogon(
                         ArgChar(myAccount.User),
                         ArgChar(SmartDomain(myAccount.Domain)),
                         ArgChar(myAccount.Password),
                         LOGON_WITH_PROFILE,     // Logon flags
                         ArgChar(myAppName),     // pointer to name of executable module
                         ArgChar(myCmdLine),     // pointer to command line string
                         CREATE_DEFAULT_ERROR_MODE or CREATE_NEW_CONSOLE or CREATE_NEW_PROCESS_GROUP,
                         ArgChar(myEnvironment), // pointer to new environment block
                         ArgChar(myHomeDir),     // pointer to current directory name
                         myStartupInfo,          // pointer to STARTUPINFO
                         myProcessInfo)          // pointer to PROCESS_INFORMATION
    then RAISE ETask.Create(Format('TTask.Run: %s',[SysErrorMessage(GetLastError)]));
   end;
   //
   // Set process & thread priority if one started
   //
   with myProcessInfo do begin
    if hThread<>0 then SetThreadPriority(ThreadPriority);
    if hProcess<>0 then SetProcessPriority(ProcessPriority);
   end;
   //
   // Create I/O threads, if uses pipes
   //
   with myStdInp do
   if pipeFifoSize>0 then begin
    pipeThread:=TTaskPipeWriter.Create(pipeFifoSize,pipeWrite,Pid);
    pipeThread.Priority:=StdInpPriority;
    pipeThread.Resume;
   end;
   with myStdOut do
   if pipeFifoSize>0 then begin
    pipeThread:=TTaskPipeReader.Create(pipeFifoSize,pipeRead,Pid);
    pipeThread.Priority:=StdOutPriority;
    pipeThread.Resume;
   end;
   //
   // Now it's Ok
   //
   Result:=true;
  finally
   Unlock;
   Burn;
  end;
 except
  on E:Exception do begin
   ErrorFound(E);
   Detach;
  end;
 end;
end;

{$IFDEF Poligon}////////////////////////////////////////////////////////////////

type
 TTestTask1Thread=class(Tthread)
 public
  procedure Execute;override;
 end;

procedure TTestTask1Thread.Execute;
var p:TTask; t,i,n:cardinal; cmd:LongString;
begin
 cmd:='d:\paslib\_research\catw\cat';
 //cmd:=ExtractFilePath(getcomspec)+'\notepad.exe';
 //cmd:=GetComSpec+' /c dir';
 //cmd:='d:\crw32exe\crw32.exe';
 try
  n:=0;
  p:=NewTask('',cmd,'','','',sw_shownormal,'','',1000,1000);
  try
   p.run;
   t:=gettickcount;
   while p.running and (gettickcount-t<30000) do begin
    for i:=1 to 100 do begin
     if p.StdInpPipeFifo.Space>100 then begin
      p.StdInpPipeFifo.PutText(Format('%d %d%s',[n,gettickcount-t,crlf]));
      inc(n);
     end;
    end;
    if p.StdOutPipeFifo.Count>0 then write(p.StdOutPipeFifo.GetText);
    Sleep(5);
   end;
   for i:=0 to 9 do begin
    Echo(Format('Terminate %d',[i]));
    Echo(Format('Result %d',[ord(p.Terminate(i,4,10000))]));
   end;
   Echo(Format('Task exit code = %d',[p.ExitCode]));
  finally
   Kill(p);
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

procedure TestTask1;
begin
 TTestTask1Thread.Create(false).FreeOnTerminate:=true;
end;

type
 TTestTask2Thread=class(Tthread)
 public
  procedure Execute;override;
 end;

procedure TTestTask2Thread.Execute;
var p:integer; t,i,n:cardinal; cmd:LongString;
begin
 //cmd:='d:\paslib\_research\catw\cat';
 //cmd:='d:\paslib\_research\catd\cat';
 //cmd:=GetComSpec+' /c d:\paslib\_research\catd\cat';
 //cmd:='command.com /c d:\paslib\_research\catd\cat';
 //cmd:=ExtractFilePath(getcomspec)+'\notepad.exe';
 //cmd:=GetComSpec+' /c dir';
 cmd:=GetComSpec+' /c d:\paslib\_research\catw\test.bat';
 //cmd:='d:\crw32exe\crw32.exe';
 try
  n:=0;
  p:=task_init('');
  task_ctrl(p,'AppName=');
  task_ctrl(p,'CmdLine='+cmd);
  task_ctrl(p,'HomeDir='+GetCurrDir);
  //task_ctrl(p,'StdInPipeSize=1000');
  task_ctrl(p,'StdOutPipeSize=2000');
  //task_ctrl(p,'StdInFileName=crw32.map');
  //task_ctrl(p,'StdOutFileName=a.x');
  task_ctrl(p,'Display=1');
  echo('AppName='+          task_ctrl(p,'AppName'));
  echo('CmdLine='+          task_ctrl(p,'CmdLine'));
  echo('HomeDir='+          task_ctrl(p,'HomeDir'));
  echo('StdInPipeSize='+    task_ctrl(p,'StdInPipeSize'));
  echo('StdOutPipeSize='+   task_ctrl(p,'StdOutPipeSize'));
  echo('StdInFileName='+    task_ctrl(p,'StdInFileName'));
  echo('StdOutFileName='+   task_ctrl(p,'StdOutFileName'));
  echo('Display='+          task_ctrl(p,'Display'));
  Sleep(1000);
  try
   task_run(p);
   Echo(Format('Task index %d, ref %d, pid %d',[p, Integer(task_ref(p)), task_pid(p)]));
   Sleep(1000);
   t:=gettickcount;
   while task_wait(p,0) and (gettickcount-t<30000) do begin
    for i:=1 to 100 do begin
     if task_txspace(p)>100 then begin
      task_send(p,Format('%d %d%s',[n,gettickcount-t,crlf]));
      inc(n);
     end;
    end;
    if task_rxcount(p)>0 then write(task_recv(p,maxint));
    Sleep(5);
   end;
   echo('Send ^C'); task_send(p,#3#13#10); Sleep(2000);
   for i:=0 to 9 do begin
    Echo(Format('Terminate %d',[i]));
    Echo(Format('Result %d',[ord(task_kill(p,i,111,10000))]));
   end;
   Echo(Format('Task exit code = %d',[task_result(p)]));
  finally
   echo('TaskFree='+d2s(ord(task_free(p))));
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

procedure TestTask2;
begin
 TTestTask2Thread.Create(false).FreeOnTerminate:=true;
end;

{$ENDIF Poligon}////////////////////////////////////////////////////////////////

 ////////////////////
 // Utility functions
 ////////////////////
function NewTask(const aAppName     : LongString      = '';
                 const aCmdLine     : LongString      = '';
                 const aHomeDir     : LongString      = '';
                 const aAccount     : LongString      = '';
                 const aEnvironment : LongString      = '';
                 const aDisplay     : Cardinal        = DefTaskDisplay;
                 const aStdInpFile  : LongString      = '';
                 const aStdOutFile  : LongString      = '';
                 const aStdInpPipe  : Integer         = 0;
                 const aStdOutPipe  : Integer         = 0;
                 const aOptions     : TTaskOptions    = DefTaskOptions;
                 const aRunning     : BOOL            = false):TTask;
begin
 Result:=nil;
 try
  Result:=TTask.Create;
  Result.AppName:=aAppName;
  Result.CmdLine:=aCmdLine;
  Result.HomeDir:=aHomeDir;
  Result.Account:=aAccount;
  Result.Environment:=aEnvironment;
  Result.Display:=aDisplay;
  Result.StdInpFileName:=aStdInpFile;
  Result.StdOutFileName:=aStdOutFile;
  Result.StdInpPipeSize:=aStdInpPipe;
  Result.StdOutPipeSize:=aStdOutPipe;
  Result.Options:=aOptions;
  if aRunning then Result.Run;
 except
  on E:Exception do begin
   BugReport(E);
   Kill(Result);
  end;
 end;
end;

procedure Kill(var TheObject:TTask); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end;
end;

function TaskShuttleEncode(Str:LongString):LongString;
begin
 Result:=Mime_Encode(BitReverseText(Str));
end;

function TaskShuttleDecode(Str:LongString):LongString;
begin
 Result:=BitReverseText(Mime_Decode(Str));
end;

type EGetAppPathAbort = class(ESoftException);

function GetAppPath(args:LongString; AllowRun:Boolean=false; AllowWait:Boolean=false;
                    pExitCode:PInteger=nil; StdOut:TEchoProcedure=nil; StdErr:TEchoProcedure=nil;
                    EnvPath:LongString=''; EnvPathExt:LongString=''):LongString;
 const DefFilter='febrat'; MaxIters=100; NameOfProg='GetAppPath';
 var argnum,optShow,i,ExitCode,argc:Integer; optRun,optWait,optTest,isopt:Boolean;
 var optFilter,AppPath,Params,arg,opt,cmdline,argv:LongString;
 function Trim(const s:LongString):LongString;
 begin
  Result:=SysUtils.Trim(s);
 end;
 function TrimLeft(const s:LongString):LongString;
 begin
  Result:=SysUtils.TrimLeft(s);
 end;
 function IsEmptyStr(const s:LongString):Boolean;
 begin
  Result:=not(trim(s)<>'');
 end;
 function ShellRun(const cmdline:LongString; show:Integer; wait:Boolean):Integer;
 begin
  Result:=WScriptShellRun(cmdline,show,wait);
 end;
 procedure PrintLn(const msg:LongString);
 begin
  if Assigned(StdOut) then StdOut(msg+LineEnding);
 end;
 procedure ErrorLn(const msg:LongString);
 begin
  if Assigned(StdErr) then StdErr(msg+LineEnding);
 end;
 procedure SetExitCode(code:Integer);
 begin
  ExitCode:=code;
  if (pExitCode<>nil) then pExitCode^:=code;
 end;
 procedure Abort(code:Integer; msg:LongString);
 begin
  ErrorLn(msg);
  SetExitCode(code);
  raise EGetAppPathAbort.Create(Msg);
 end;
 function ucase(const s:LongString):LongString;
 begin
  Result:=UpperCase(s);
 end;
 procedure PrintVersion(const name:LongString);
 begin
  if not Assigned(StdOut) then Exit;
  PrintLn(ucase(name)+' version 1.0');
 end;
 procedure PrintHelp(name:LongString);
 begin
  if not Assigned(StdOut) then Exit;
  PrintVersion(name);
  PrintLn('Find registered application, print path or run it.');
  PrintLn('Copyright (c) 2021 Alexey Kuryakin kouriakine@mail.ru');
  PrintLn('Under MIT License, see https://opensource.org/licenses/MIT');
  PrintLn('Help on '+ucase(name)+':');
  PrintLn(' =================> Syntax:');
  PrintLn('  '+ucase(name)+' [Options] [Arguments] [--run] [Options] [Params]');
  PrintLn(' =================> Options:');
  PrintLn('   --            => options ended, next is params');
  PrintLn('   --version     => print program version and exit');
  PrintLn('   -h,--help     => print this help screen and exit');
  PrintLn('   -f,--full     => next argument expect to be full path\name.ext');
  PrintLn('   -e,--exe      => next is short file name.exe to search in PATH');
  PrintLn('   -b,--base     => next is base name to search with PATH/PATHEXT');
  PrintLn('   -r,--reg      => next is name.exe to search registry App Paths');
  PrintLn('   -a,--assoc    => next argument expect to be association (.ext)');
  PrintLn('   -t,--ftype    => next argument expect to be filetype specifier');
  PrintLn('   -c,--cmd      => set --filter feb (full+exe+base) for commands');
  PrintLn('   --filter f    => set filter f (check types)  for next argument');
  PrintLn('   -        f    => by default f=febrat & filter reset to default');
  PrintLn('   -             => after following argument processed by filter.');
  PrintLn('   -             => for example --filter feb equals to -c option.');
  PrintLn('   --run,--start => run (start) application with following Params');
  PrintLn('   --wait        => with --run option wait application until ends');
  PrintLn('   --test        => with --run option don`t run but print cmdline');
  PrintLn('   --show n      => with --run option set application show mode n');
  PrintLn('          n = 0  => SW_HIDE to run application with hidden window');
  PrintLn('              1  => SW_SHOWNORMAL  to activate and display window');
  PrintLn('              2  => SW_SHOWMINIMIZED  activate and show minimized');
  PrintLn('              3  => SW_SHOWMAXIMIZED  activate and show maximized');
  PrintLn('              4  => SW_SHOWNOACTIVATE display it but not activate');
  PrintLn('              5  => SW_SHOW activate, display in current position');
  PrintLn('              6  => SW_MINIMIZE minimize, activate another window');
  PrintLn('              7  => SW_SHOWMINNOACTIVE run minimized, keeps focus');
  PrintLn('              8  => SW_SHOWNA show in normal pos, do not activate');
  PrintLn('              9  => SW_RESTORE activate and display normal window');
  PrintLn('              10 => SW_SHOWDEFAULT display it in default position');
  PrintLn(' =================> Arguments:');
  PrintLn('   file.exe      => find application by EXE file  like firefox.exe');
  PrintLn('   file          => find application by base name like firefox');
  PrintLn('   ftype         => find application by file type like htmlfile');
  PrintLn('   .ext          => find application by extension like .html');
  PrintLn('   Params        => parameters to pass for application on --run');
  PrintLn(' =================> Exit Code:');
  PrintLn('   0             => specified application found');
  PrintLn('   1             => specified application is not found ');
  PrintLn('   2             => some error found (bad arguments/options)');
  PrintLn('   else          => some error found (internal script error)');
  PrintLn('   with --run --wait options return application`s exit code.');
  PrintLn(' =================> Note:');
  PrintLn('   Search application full path\name.ext registered in system');
  PrintLn('   and specified by argument EXE file name (like firefox.exe)');
  PrintLn('   or file type (like htmlfile) or file extension (like .htm)');
  PrintLn('   The list of argument(s) can be passed to find application.');
  PrintLn('   If any specified applications found, return first of them.');
  PrintLn('   By default just print found applicaton full path\name.ext.');
  PrintLn('   Option --run or --start  will run application with Params.');
  PrintLn('   Option --show uses to specify application showwindow mode.');
  PrintLn('   Option --wait uses to run application and wait until ends.');
  PrintLn('   Option --test uses to print a cmd line to run application.');
  PrintLn('   By default try to detect argument by type (febrat), where:');
  PrintLn('   f = full path\name.ext (like c:\windows\system32\cmd.exe);');
  PrintLn('   e = exe  file name.ext to search with PATH (like cmd.exe);');
  PrintLn('   b = base file name to search with PATH/PATHEXT (like cmd);');
  PrintLn('   r = reg  name.ext in registry App Paths (like chrome.exe);');
  PrintLn('   a = assoc is file extension name association (like .html);');
  PrintLn('   t = ftype is registry file type specifier (like htmlfile);');
  PrintLn('   c = cmd is feb (full+exe+base) for command (like cmd.exe).');
  PrintLn('   By default all argument types checking but you can specify');
  PrintLn('   following argument type by options (-f,-e,-b,-r,-a,-t,-c).');
  PrintLn('   You can specify types by --filter option (default=febrat).');
  PrintLn(' =================> Examples:');
  PrintLn('  call '+name+' --help');
  PrintLn('  call '+name+' --version');
  PrintLn('  echo FIND APPLICATION AND PRINT HIS PATH:');
  PrintLn('  call '+name+' -e akelpad.exe -r notepad++.exe -t txtfile -a .txt');
  PrintLn('  call '+name+' firefox.exe chrome.exe opera.exe iexplore.exe .html');
  PrintLn('  call '+name+' -t htmlfile .html .htm -t shtmlfile .shtml -t urlfile .url');
  PrintLn('  echo FIND APPLICATION AND RUN (START) WITH PARAMETERS:');
  PrintLn('  call '+name+' .txt --run --test c:\Crw32exe\Crw32.ini');
  PrintLn('  call '+name+' -t textfile --run --test c:\Crw32exe\Crw32.ini');
  PrintLn('  call '+name+' -c %ComSpec% -c cmd -c cmd.exe --run /k echo Run CMD is OK');
  PrintLn('  call '+name+' notepad.exe .txt --run --wait --show 3 c:\Crw32exe\Crw32.ini');
  PrintLn('  call '+name+' firefox.exe .html --start c:\Crw32exe\Resource\Manual\crw-daq.htm');
  PrintLn('  call '+name+' SumatraPDF.exe -t SumatraPDF AcroRd32.exe Acrobat.exe -t acrobat .pdf --run');
 end;
 function BuildPath(const dir,name:LongString):LongString;
 begin
  Result:=IncludeTrailingBackslash(Trim(dir))+Trim(name);
 end;
 function GetAbsolutePathName(const path:LongString):LongString;
 begin
  Result:=Trim(ExpandFileName(path));
 end;
 function GetParentFolderName(const path:LongString):LongString;
 begin
  Result:=Trim(SysUtils.ExtractFilePath(path));
 end;
 function GetExtensionName(path:LongString):LongString;
 begin
  Result:=Trim(SysUtils.ExtractFileExt(path));
  if (StrFetch(Result,1)='.') then Delete(Result,1,1);
 end;
 function HasExtensionName(const path:LongString):Boolean;
 begin
  Result:=not IsEmptyStr(path) and not IsEmptyStr(GetExtensionName(path));
 end;
 function IsExtension(const path:LongString):Boolean; //*** is arg looks like extension i.e. ".html"?
 begin
  Result:=not IsEmptyStr(arg) and HasExtensionName(arg) and (SameText(arg,'.'+GetExtensionName(arg)));
 end;
 function HasParentFolderName(const path:LongString):Boolean;
 begin
  Result:=not IsEmptyStr(path) and not IsEmptyStr(GetParentFolderName(path));
 end;
 function SearchFile(name,dirlist,extlist:LongString; sep:Char):LongString;
 var idir,iext:Integer; dirs,exts:TStringList; dir,ext,fqn:LongString;
 begin
  Result:=''; dirs:=nil; exts:=nil;
  try
   name:=Trim(name);
   if (name<>'') and (sep<>#0) then begin
    dirs:=TStringList.Create; dirs.Text:=StringReplace(sep+dirlist,sep,LineEnding,[rfReplaceAll]);
    exts:=TStringList.Create; exts.Text:=StringReplace(sep+extlist,sep,LineEnding,[rfReplaceAll]);
    for iext:=0 to exts.Count-1 do begin
     ext:=Trim(exts[iext]); ext:=GetExtensionName(ext);
     for idir:=0 to dirs.Count-1 do begin
      dir:=Trim(dirs[idir]); dir:=GetAbsolutePathName(dir);
      fqn:=BuildPath(dir,name); if (ext<>'') then fqn:=fqn+'.'+ext;
      if (fqn<>'') and FileExists(fqn) then Result:=GetRealFilePathName(Trim(fqn));
      if (Result<>'') then break;
     end;
     if (Result<>'') then break;
    end;
   end;
  finally
   FreeAndNil(dirs);
   FreeAndNil(exts);
  end;
 end;
 function GetEnvPATH:LongString;
 const fallbackPATH='%SystemRoot%;%SystemRoot%\System32';
 begin
  if IsEmptyStr(EnvPath) then Result:=Trim(GetEnv('PATH')) else Result:=Trim(EnvPath);
  if IsEmptyStr(Result) then Result:=ExpEnv(fallbackPATH);
 end;
 function GetEnvPATHEXT:LongString;
 const fallbackPATHEXT='.COM;.EXE;.BAT;.CMD';
 begin
  if IsEmptyStr(EnvPathExt) then Result:=Trim(GetEnv('PATHEXT')) else Result:=Trim(EnvPathExt);
  if IsEmptyStr(Result) then Result:=fallbackPATHEXT;
 end;
 function IsTypeExe(const arg:LongString):Boolean; //*** is arg looks like executable? i.e. "name.exe" or "name.cmd", see PATHEXT
begin
  Result:=HasListedExtension(arg,GetEnvPATHEXT);
 end;
 function IsCmdName(const arg:LongString):Boolean;   //*** is arg looks like command (just a simple word) i.e. "name"?
 begin
  Result:=not IsEmptyStr(arg) and not HasParentFolderName(arg) and not HasExtensionName(arg);
 end;
 function IsFullExe(const arg:LongString):Boolean;   //*** is arg looks like full EXE name i.e. "path\name.exe"?
 begin
  Result:=not IsEmptyStr(arg) and HasParentFolderName(arg) and IsTypeExe(arg);
 end;
 function IsExeName(const arg:LongString):Boolean;   //*** is arg looks like short EXE name i.e. "name.exe"?
 begin
  Result:=not IsEmptyStr(arg) and not HasParentFolderName(arg) and IsTypeExe(arg);
 end;
 function IsItAssoc(const arg:LongString):Boolean;   //*** is arg looks like association by extension i.e. ".html"?
 begin
  Result:=not IsEmptyStr(arg) and not HasParentFolderName(arg) and IsExtension(arg);
 end;
 function IsItFType(const arg:LongString):Boolean;   //*** is arg looks like file type i.e. "htmlfile" or "TIFImage.Document"?
 begin
  Result:=not IsEmptyStr(arg) and not HasParentFolderName(arg) and not IsItAssoc(arg) and not IsExeName(arg);
 end;
 procedure SetOptRun(opt:Boolean);
 begin
  optRun:=opt;
  if optRun then begin
   optWait:=false;
   optTest:=false;
   optShow:=SW_SHOWNORMAL;
  end;
 end;
 procedure SetOptWait(opt:Boolean);
 begin
  if AllowWait then optWait:=opt;
 end;
 procedure SetOptTest(opt:Boolean);
 begin
  optTest:=opt;
 end;
 procedure SetOptShow(opt:Integer);
 begin
  if (opt in [SW_HIDE..SW_MAX]) then optShow:=opt else Abort(2,'Error: invalid option --show '+d2s(opt)+'. Valid option is --show n, where n=0..10.');
 end;
 procedure SetOptFilter(const opt:LongString);
 begin
  optFilter:=LowerCase(opt);
 end;
 procedure AddParams(const arg:LongString);
 begin
  if optRun and not IsEmptyStr(arg) then Params:=Params+' '+AnsiQuotedIfNeed(arg);
 end;
 procedure HandleArgs(arg:LongString);
 begin
  argnum:=argnum+1;
  arg:=Trim(ExpEnv(arg));
  if not optRun then begin
   if (arg<>'') then begin
    if IsEmptyStr(AppPath) and (Pos('f',optFilter)>0) and IsFullExe(arg) then begin
     AppPath:=Trim(arg);
     if not IsEmptyStr(AppPath) and not FileExists(AppPath) then AppPath:='';
    end;
    if IsEmptyStr(AppPath) and (Pos('e',optFilter)>0) and IsExeName(arg) then begin
     AppPath:=SearchFile(arg,GetEnvPATH,'',';');
     if not IsEmptyStr(AppPath) and not FileExists(AppPath) then AppPath:='';
    end;
    if IsEmptyStr(AppPath) and (Pos('b',optFilter)>0) and IsCmdName(arg) then begin
     AppPath:=SearchFile(arg,GetEnvPATH,GetEnvPATHEXT,';');
     if not IsEmptyStr(AppPath) and not FileExists(AppPath) then AppPath:='';
    end;
    if IsEmptyStr(AppPath) and (Pos('r',optFilter)>0) and IsExeName(arg) then begin
     AppPath:=ExpEnv(GetRegAppPath(arg));
     if not IsEmptyStr(AppPath) and not FileExists(AppPath) then AppPath:='';
    end;
    if IsEmptyStr(AppPath) and (Pos('a',optFilter)>0) and IsItAssoc(arg) then begin
     AppPath:=ExpEnv(GetSystemAssocExe(arg));
     if not IsEmptyStr(AppPath) and not FileExists(AppPath) then AppPath:='';
    end;
    if IsEmptyStr(AppPath) and (Pos('t',optFilter)>0) and IsItFType(arg) then begin
     AppPath:=ExpEnv(GetSystemFTypeExe(arg));
     if not IsEmptyStr(AppPath) and not FileExists(AppPath) then AppPath:='';
    end;
   end; 
   optFilter:=DefFilter;
  end;
  if optRun and (arg<>'') then begin
   AddParams(arg);
  end;
 end;
begin
 Result:='';
 try
  SetExitCode(0); cmdline:=''; argc:=0; argv:=args;
  argnum:=0; AppPath:=''; Params:=''; SetOptFilter(DefFilter);
  optRun:=false; optWait:=false; optTest:=false; optShow:=SW_SHOWNORMAL;
  arg:=''; opt:=''; isopt:=true;
  for i:=0 to MaxIters-1 do begin
   arg:=ExtractFirstParam(argv); argv:=SkipFirstParam(argv);
   if (StrFetch(arg,1)='-') and isopt and (opt='') then begin
    if SameText(arg,'--')                               then begin isopt:=false;                     end else
    if SameText(arg,'--version')                        then begin PrintVersion(NameOfProg);   Exit; end else
    if SameText(arg,'-h') or SameText(arg,'--help')     then begin PrintHelp(NameOfProg);      Exit; end else
    if SameText(arg,'--run') or SameText(arg,'--start') then begin SetOptRun(true);                  end else
    if SameText(arg,'--wait')                           then begin SetOptWait(true);                 end else
    if SameText(arg,'--test')                           then begin SetOptTest(true);                 end else
    if SameText(arg,'-f') or SameText(arg,'--full')     then begin SetOptFilter('f');                end else
    if SameText(arg,'-e') or SameText(arg,'--exe')      then begin SetOptFilter('e');                end else
    if SameText(arg,'-b') or SameText(arg,'--base')     then begin SetOptFilter('b');                end else
    if SameText(arg,'-r') or SameText(arg,'--reg')      then begin SetOptFilter('r');                end else
    if SameText(arg,'-a') or SameText(arg,'--assoc')    then begin SetOptFilter('a');                end else
    if SameText(arg,'-t') or SameText(arg,'--ftype')    then begin SetOptFilter('t')                 end else
    if SameText(arg,'-c') or SameText(arg,'--cmd')      then begin SetOptFilter('feb');              end else
    if SameText(arg,'--filter')                         then begin opt:=arg;                         end else
    if SameText(arg,'--show')                           then begin opt:=arg;                         end else
    Abort(2,'Error: unknown option '+arg+'. See --help.');
   end else begin
    if SameText(opt,'')                                 then begin HandleArgs(arg);                  end else
    if SameText(opt,'--show')                           then begin SetOptShow(StrToIntDef(arg,-1));  end else
    if SameText(opt,'--filter')                         then begin SetOptFilter(arg);                end else
    Abort(2,'Error: unknown option '+opt+'. See --help.');
    opt:='';
   end;
   if (arg<>'') then inc(argc);
   if IsEmptyStr(argv) then break;
  end;
  if IsEmptyStr(args) or (argc=0) then begin
   PrintHelp(NameOfProg);
   Exit;
  end;
  if not IsEmptyStr(AppPath) and not FileExists(AppPath) then AppPath:='';
  if IsEmptyStr(AppPath) then Abort(1,'Error: specified application is not found.');
  if optRun then begin
   cmdline:=AnsiQuotedIfNeed(AppPath)+Params; PrintLn(cmdline); Result:=cmdline;
   if AllowRun and not optTest then begin
    SetExitCode(ShellRun(cmdline,optShow,optWait and AllowWait));
   end;
  end else begin
   PrintLn(AppPath); Result:=AppPath;
  end;
 except
  on E:EGetAppPathAbort do Exit;
  on E:Exception do BugReport(E,nil,NameOfProg);
 end;
end;

function GetRegAppPath(const app:LongString):LongString;
const keyAppPaths='SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\';
begin
 Result:='';
 if not IsEmptyStr(app) then begin
  if (Result='') then Result:=ReadRegistryString(HKEY_CURRENT_USER,keyAppPaths+app,'');
  if (Result='') then Result:=ReadRegistryString(HKEY_LOCAL_MACHINE,keyAppPaths+app,'');
 end;
end;

function GetSystemAssoc(const Ext:LongString):LongString;
begin
 Result:='';
 if (Length(Ext)>1) and (Pos('.',Ext)=1) then begin
  if (Result='') then Result:=ReadRegistryString(HKEY_CLASSES_ROOT,Ext,'');
  if (Result='') then Result:=ReadRegistryString(HKEY_CURRENT_USER,'SOFTWARE\Classes\'+Ext,'');
  if (Result='') then Result:=ReadRegistryString(HKEY_LOCAL_MACHINE,'SOFTWARE\Classes\'+Ext,'');
 end;
 Result:=SysUtils.Trim(Result);
end;

function GetSystemFType(const FType:LongString):LongString;
begin
 Result:='';
 if (Length(FType)>0) then begin
  if (Result='') then Result:=ReadRegistryString(HKEY_CLASSES_ROOT,AddBackSlash(FType)+'Shell\Open\Command','');
  if (Result='') then Result:=ReadRegistryString(HKEY_CURRENT_USER,'SOFTWARE\Classes\'+AddBackSlash(FType)+'Shell\Open\Command','');
  if (Result='') then Result:=ReadRegistryString(HKEY_LOCAL_MACHINE,'SOFTWARE\Classes\'+AddBackSlash(FType)+'Shell\Open\Command','');
 end;
 Result:=SysUtils.Trim(Result);
end;

function GetSystemFTypeExe(const FType:LongString):LongString;
begin
 Result:=SysUtils.Trim(GetSystemFType(FType)); if (Result='') then Exit;
 Result:=ExtractFirstParam(Result);
 Result:=SysUtils.Trim(Result);
end;

function GetSystemAssocExe(const Ext:LongString):LongString;
begin
 Result:=GetSystemFTypeExe(GetSystemAssoc(Ext));
end;

function HasSystemAssocExe(const Ext:LongString):Boolean;
var S:LongString;
begin
 Result:=false;
 S:=GetSystemAssocExe(Ext);
 if (S<>'') and FileExists(S) then Result:=true;
end;

function HasSystemFTypeExe(const FType:LongString):Boolean;
var S:LongString;
begin
 Result:=false;
 S:=GetSystemFTypeExe(FType);
 if (S<>'') and FileExists(S) then Result:=true;
end;

function GetExeByExtension(const Extension:LongString):LongString;
var BufSize: DWORD;
begin
 Result:=''; if (Extension='') then Exit;
 BufSize:=MAX_PATH; SetLength(Result,BufSize);
 if AssocQueryString(ASSOCF_OPEN_BYEXENAME,ASSOCSTR_EXECUTABLE,PChar(Extension),nil,PChar(Result),BufSize)=S_OK
 then SetLength(Result,BufSize-1) else Result := '';
 if (Result='') then Result:=GetSystemAssocExe(Extension);
end;

function GetExeByFile(const FileName:ShortString):ShortString;
var
 lpFile      : packed array[0..MAX_PATH] of Char;
 lpDirectory : packed array[0..MAX_PATH] of Char;
 lpResult    : packed array[0..MAX_PATH] of Char;
begin
 Result:='';
 try
  StrPCopy(lpFile,SysUtils.Trim(FileName));
  StrPCopy(lpDirectory,ExtractFilePath(SysUtils.Trim(FileName)));
  StrPCopy(lpResult,'');
  if FindExecutable(lpFile,lpDirectory,lpResult)>32 then Result:=StrPas(lpResult);
  if (Result='') and HasExtension(FileName) then Result:=GetSystemAssocExe(ExtractFileExt(FileName));
 except
  on E:Exception do BugReport(E);
 end;
end;

function ShellExecuteOpen(const FileName:ShortString; const Cmd:ShortString=''):Boolean;
var
 lpExe : packed array[0..MAX_PATH] of Char;
 lpCmd : packed array[0..MAX_PATH] of Char;
 lpDir : packed array[0..MAX_PATH] of Char;
begin
 Result:=false;
 try
  StrPCopy(lpExe,GetExeByFile(FileName));
  if IsEmptyStr(Cmd)
  then StrPCopy(lpCmd,SysUtils.Trim(FileName))
  else StrPCopy(lpCmd,SysUtils.Trim(Cmd));
  StrPCopy(lpDir,AddBackSlash(ExtractFilePath(FileName)));
  Result:=ShellExecute(0,'open',lpExe,lpCmd,lpDir,SW_SHOWNORMAL)>32;
 except
  on E:Exception do BugReport(E);
 end;
end;

function SmartExecute(const CmdLine:LongString; Display:Integer; ShellCm:LongString):Boolean;
var
 task : TTask;
 path : packed array[0..MAX_PATH] of Char;
begin
 Result:=false;
 try
  if Length(ShellCm)>0 then begin
   if StrLen(StrPCopy(path,CmdLine))>0 then
   Result:=(ShellExecute(0,PChar(ShellCm),path,nil,nil,Display)>32);
  end else begin
   task:=NewTask;
   try
    task.CmdLine:=CmdLine;
    task.Display:=Display;
    Result:=task.Run;
   finally
    task.Free;
   end;
  end; 
 except
  on E:Exception do BugReport(E);
 end;
end;

function WScriptShellRun(const CmdLine:LongString; Show:Integer=SW_SHOWNORMAL; Wait:Boolean=false):Integer;
var Shell:Variant;
begin
 Result:=-1;
 if not IsEmptyStr(CmdLine) then
 try
  Shell:=Unassigned;
  try
   Shell:=CreateOleObject('WScript.Shell');
   if VarIsNull(Shell) or VarIsEmpty(Shell) then Exit;
   Result:=Shell.Run(CmdLine,Show,Wait);
  finally
   Shell:=Unassigned;
  end;
 except
  on E:EOleException do begin BugReport(E,nil,FormatHarmlessBug(EEchoException,'WScriptShellRun')); Exit; end;
  on E:Exception do BugReport(E,nil,'ShellRun');
 end;
end;

function GetConsoleWindow:HWND;
const _GetConsoleWindow:function:HWND; stdcall = nil;
begin
 if not Assigned(_GetConsoleWindow)
 then @_GetConsoleWindow:=GetProcAddress(GetModuleHandle('kernel32.dll'),'GetConsoleWindow');
 if Assigned(_GetConsoleWindow) then Result:=_GetConsoleWindow else Result:=0;
 if (Result<>0) then if not IsWindow(Result) then Result:=0;
end;

function GetWindowClassName(hWnd:HWND):LongString;
var Buffer:packed array[0..1024-1] of Char; Len:Integer;
begin
 Len:=GetClassName(hWnd,@Buffer,SizeOf(Buffer));
 SetString(Result,Buffer,Len);
end;

function GetWindowProcessId(hWnd:HWND):DWORD;
begin
 Result:=0;
 if IsWindow(hWnd) then
 GetWindowThreadProcessId(hWnd,@Result);
end;

 // Types uses to find window by PID and ClassName.
type TPidClassWndRec=packed record dwPid:DWORD; lpClassName:PChar; hWnd:HWND; end;
type PPidClassWndRec=^TPidClassWndRec;

 // Callback function uses to find window by PID and ClassName.
function EnumWindowsProc(hWnd:HWND; lParam:LPARAM):BOOL; stdcall;
var wPid:DWORD; Rec:PPidClassWndRec;
begin
 Result:=True;
 if lParam<>0 then begin
  wPid:=GetWindowProcessId(hWnd);
  if wPid<>0 then begin
   Rec:=Pointer(lParam);
   if (wPid = Rec.dwPid) then
   if IsSameText(Rec.lpClassName,GetWindowClassName(hWnd)) then begin
    Rec.hWnd:=hWnd;
    Result:=False;
   end;
  end;
 end;
end;

function FindWindowByPidAndClassName(aPid:DWORD; const aClassName:LongString):HWND;
var Rec:TPidClassWndRec;
begin
 Rec.dwPid:=aPid; Rec.hWnd:=0;
 Rec.lpClassName:=PChar(aClassName);
 EnumWindows(@EnumWindowsProc,LPARAM(@Rec));
 Result:=Rec.hWnd;
end;

function WM_COPYDATA_SendToWindowByPidAndClassName(hSender:HWND; aPid:DWORD; const aClassName,aData:LongString):LRESULT;
var hWin:HWND; DataRec:TCopyDataStruct;
begin
 Result:=0;
 if Length(aData)>0 then
 try
  if (aPid<>0) then begin
   hWin:=FindWindowByPidAndClassName(aPid,aClassName);
   if hWin<>0 then begin
    DataRec.dwData:=aPid;
    DataRec.cbData:=Length(aData);
    DataRec.lpData:=PChar(aData);
    Result:=SendMessage(hWin,WM_COPYDATA,hSender,LPARAM(@DataRec));
   end;
  end;
 except
  on E:Exception do BugReport(E);
 end;
end;

 ///////////////////////////////////////////////////////////////////////////////
 // TProcessEntry is internally uses class needed for TRunningProcessList
 ///////////////////////////////////////////////////////////////////////////////
type
 TProcessEntry=class(TMasterObject)
 private
  myEntry : TProcessEntry32;
 public
  constructor Create(const aEntry:TProcessEntry32);
  function    Entry:TProcessEntry32;
 end;

constructor TProcessEntry.Create(const aEntry:TProcessEntry32);
begin
 inherited Create;
 myEntry:=aEntry;
end;

function TProcessEntry.Entry:TProcessEntry32;
begin
 if Assigned(Self) then Result:=myEntry else FillChar(Result,sizeof(Result),0);
end;

 ///////////////////////////////////////////////////////////////////////////////
 // TRunningProcessList implementation
 ///////////////////////////////////////////////////////////////////////////////
constructor TRunningProcessList.Create;
var
 SnapHandle : THandle;
 ProcEntry  : TProcessEntry32;
 NextProc   : BOOL;
begin
 inherited Create;
 myList:=NewObjectStorage;
 try
  SnapHandle:=CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0);
  if SnapHandle<>0 then
  if SnapHandle<>INVALID_HANDLE_VALUE then
  try
   ProcEntry.dwSize:=SizeOf(ProcEntry);
   NextProc:=Process32First(SnapHandle,ProcEntry);
   while NextProc do begin
    myList.Add(TProcessEntry.Create(ProcEntry));
    NextProc:=Process32Next(SnapHandle,ProcEntry);
   end;
  finally
   CloseHandle(SnapHandle);
  end;
 except
  on E:Exception do ErrorFound(E);
 end;
end;

destructor TRunningProcessList.Destroy;
begin
 Kill(myList);
 inherited Destroy;
end;

function TRunningProcessList.GetCount:Integer;
begin
 if Assigned(Self)
 then Result:=myList.Count
 else Result:=0;
end;

function TRunningProcessList.GetPid(i:Integer):DWORD;
begin
 if Assigned(Self)
 then Result:=TProcessEntry(myList[i]).Entry.th32ProcessID
 else Result:=0;
end;

function TRunningProcessList.GetParentPid(i:Integer):DWORD;
begin
 if Assigned(Self)
 then Result:=TProcessEntry(myList[i]).Entry.th32ParentProcessID
 else Result:=0;
end;

function TRunningProcessList.GetFileName(i:Integer):LongString;
begin
 if Assigned(Self)
 then Result:=TProcessEntry(myList[i]).Entry.szExeFile
 else Result:='';
end;

function TRunningProcessList.GetUsage(i:Integer):DWORD;
begin
 if Assigned(Self)
 then Result:=TProcessEntry(myList[i]).Entry.cntUsage
 else Result:=0;
end;

function TRunningProcessList.GetThreads(i:Integer):DWORD;
begin
 if Assigned(Self)
 then Result:=TProcessEntry(myList[i]).Entry.cntThreads
 else Result:=0;
end;

function TRunningProcessList.GetPriorityClass(i:Integer):Integer;
begin
 if Assigned(Self)
 then Result:=TProcessEntry(myList[i]).Entry.pcPriClassBase
 else Result:=0;
end;

function NewRunningProcessList:TRunningProcessList;
begin
 Result:=nil;
 try
  Result:=TRunningProcessList.Create;
 except
  on E:Exception do BugReport(E);
 end;
end;

procedure Kill(var TheObject:TRunningProcessList); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end;
end;

function KillProcess(aPid:DWORD; aExitCode:Integer):BOOL;
var
 hProcess : THandle;
begin
 Result:=false;
 if aPid<>0 then
 if aPid<>GetCurrentProcessId then
 try
  hProcess:=OpenProcess(PROCESS_TERMINATE,False,aPid);
  if hProcess<>0 then
  try
   Result:=TerminateProcess(hProcess,aExitCode);
  finally
   CloseHandle(hProcess);
  end;
 except
  on E:Exception do BugReport(E);
 end;
end;

function KillProcessTree(aPid:DWORD; aExitCode:Integer; MaxLevel:Integer):Integer;
var
 List : TRunningProcessList;
 procedure KillPid(aPid:DWORD;aLevel:Integer); // To be called recursively
 var i:Integer;
 begin
  if aPid<>0 then
  if aPid<>GetCurrentProcessId then begin
   if aLevel<MaxLevel then
   for i:=0 to List.Count-1 do
   if List.ParentPid[i]=aPid then KillPid(List.Pid[i],aLevel+1);
   if KillProcess(aPid,aExitCode) then Inc(Result);
  end;
 end;
begin
 Result:=0;
 if aPid<>0 then
 if aPid<>GetCurrentProcessId then
 try
  List:=TRunningProcessList.Create;
  if Assigned(List) then
  try
   KillPid(aPid,0);
  finally
   Kill(List);
  end;
 except
  on E:Exception do BugReport(E);
 end;
end;

 //////////////////////////////////////////////
 // Easy task routines, to be use in DAQ PASCAL
 //////////////////////////////////////////////
const
 task_latch : TLatch = nil;
var
 task_array : packed array[task_ref_min..task_ref_max] of TTask;

procedure task_initialize;
begin
 task_latch:=NewLatch;
 task_latch.Master:=@task_latch;
 ZeroMemory(@task_array,sizeof(task_array));
end;

procedure task_finalize;
var i:Integer;
begin
 for i:=Low(task_array) to High(task_array) do task_free(i);
 Kill(task_latch);
end;

function task_init(const cmd_line:LongString):Integer;
var i:Integer;
begin
 Result:=0;
 try
  task_latch.Lock;
  try
   for i:=Low(task_array) to High(task_array) do
   if not Assigned(task_array[i]) then begin
    task_array[i]:=NewTask('',cmd_line);
    task_array[i].Master:=@task_array[i];
    Result:=i;
    Break;
   end;
  finally
   task_latch.Unlock;
  end;
 except
  on E:Exception do BugReport(E);
 end;
end;

function task_free(tid:Integer):Boolean;
var task:TTask;
begin
 task:=nil;
 if tid >= Low(task_array) then
 if tid <= High(task_array) then begin
  task_latch.Lock;
  task:=task_array[tid];
  task_array[tid]:=nil;
  task_latch.Unlock;
 end;
 Result:=Assigned(task);
 Kill(task);
end;

function task_ref(tid:Integer):TTask;
begin
 Result:=nil;
 if tid >= Low(task_array) then
 if tid <= High(task_array) then Result:=task_array[tid];
end;

function task_pid(tid:Integer):Integer;
begin
 Result:=task_ref(tid).Pid;
end;

function task_run(tid:Integer):Boolean;
begin
 Result:=task_ref(tid).Run;
end;

function task_wait(tid,timeout:Integer):Boolean;
begin
 Result:=task_ref(tid).Running(timeout);
end;

function task_send(tid:Integer; const data:LongString):Integer;
begin
 Result:=ord(task_ref(tid).StdInpPipeFifoPutText(data))*Length(data);
end;

function task_recv(tid:Integer; maxlen:Integer):LongString;
begin
 Result:=task_ref(tid).StdOutPipeFifoGetText(maxlen);
end;

function task_txcount(tid:Integer):Integer;
begin
 Result:=task_ref(tid).StdInpPipeFifoCount;
end;

function task_rxcount(tid:Integer):Integer;
begin
 Result:=task_ref(tid).StdOutPipeFifoCount;
end;

function task_txspace(tid:Integer):Integer;
begin
 Result:=task_ref(tid).StdInpPipeFifoSpace;
end;

function task_rxspace(tid:Integer):Integer;
begin
 Result:=task_ref(tid).StdOutPipeFifoSpace;
end;

function task_result(tid:Integer):Integer;
begin
 Result:=task_ref(tid).ExitCode;
end;

function task_kill(tid,how,exit_code,timeout:Integer):Boolean;
begin
 Result:=task_ref(tid).Terminate(how,exit_code,timeout);
end;

function task_ctrl(tid:Integer; const param:LongString):LongString;
var task:TTask; p:Integer; sn,sv:LongString;
begin
 Result:='?';
 sn:=''; sv:='';
 task:=task_ref(tid);
 if Assigned(task) then
 try
  p:=System.Pos('=',param);
  if p=0 then begin
   sn:=param;
   sv:='';
  end else begin
   sn:=System.Copy(param,1,p-1);
   sv:=System.Copy(param,p+1,length(param)-p);
  end;
  if IsSameText(sn,'AppName') then begin
   if p=0 then Result:=Format('%s',[task.AppName]) else begin
    task.AppName:=sv;
    Result:=Format('%d',[Length(task.AppName)]);
   end;
  end;
  if IsSameText(sn,'CmdLine') then begin
   if p=0 then Result:=Format('%s',[task.CmdLine]) else begin
    task.CmdLine:=sv;
    Result:=Format('%d',[Length(task.CmdLine)]);
   end;
  end;
  if IsSameText(sn,'HomeDir') then begin
   if p=0 then Result:=Format('%s',[task.HomeDir]) else begin
    task.HomeDir:=sv;
    Result:=Format('%d',[Length(task.HomeDir)]);
   end;
  end;
  if IsSameText(sn,'ExeName') then begin
   Result:=task.ExeName;
  end;
  if IsSameText(sn,'Encrypt') then begin
   Result:=task.Encrypt(sv);
  end;
  if IsSameText(sn,'Account') then begin
   if p=0 then Result:=Format('%s',[task.Account]) else begin
    task.Account:=sv;
    Result:=Format('%d',[Length(task.Account)]);
   end;
  end;
  if IsSameText(sn,'Display') then begin
   if p>0 then begin
    task.Display:=StrToIntDef(sv,-1);
    if IsSameText(sv,'SW_HIDE')            then task.Display:=SW_HIDE;
    if IsSameText(sv,'SW_MAXIMIZE')        then task.Display:=SW_MAXIMIZE;
    if IsSameText(sv,'SW_MINIMIZE')        then task.Display:=SW_MINIMIZE;
    if IsSameText(sv,'SW_RESTORE')         then task.Display:=SW_RESTORE;
    if IsSameText(sv,'SW_SHOW')            then task.Display:=SW_SHOW;
    if IsSameText(sv,'SW_SHOWDEFAULT')     then task.Display:=SW_SHOWDEFAULT;
    if IsSameText(sv,'SW_SHOWMAXIMIZED')   then task.Display:=SW_SHOWMAXIMIZED;
    if IsSameText(sv,'SW_SHOWMINIMIZED')   then task.Display:=SW_SHOWMINIMIZED;
    if IsSameText(sv,'SW_SHOWMINNOACTIVE') then task.Display:=SW_SHOWMINNOACTIVE;
    if IsSameText(sv,'SW_SHOWNA')          then task.Display:=SW_SHOWNA;
    if IsSameText(sv,'SW_SHOWNOACTIVATE')  then task.Display:=SW_SHOWNOACTIVATE;
    if IsSameText(sv,'SW_SHOWNORMAL')      then task.Display:=SW_SHOWNORMAL;
   end;
   Result:=Format('%d',[task.Display]);
  end;
  if IsSameText(sn,'TxPipeSize')
  or IsSameText(sn,'StdInPipeSize')
  or IsSameText(sn,'StdInpPipeSize') then begin
   if p>0 then task.StdInpPipeSize:=StrToIntDef(Trim(sv),0);
   Result:=Format('%d',[task.StdInpPipeSize]);
  end;
  if IsSameText(sn,'RxPipeSize')
  or IsSameText(sn,'StdOutPipeSize') then begin
   if p>0 then task.StdOutPipeSize:=StrToIntDef(Trim(sv),0);
   Result:=Format('%d',[task.StdOutPipeSize]);
  end;
  if IsSameText(sn,'TxFileName')
  or IsSameText(sn,'StdInFileName')
  or IsSameText(sn,'StdInpFileName') then begin
   if p=0 then Result:=Format('%s',[task.StdInpFileName]) else begin
    task.StdInpFileName:=sv;
    Result:=Format('%d',[Length(task.StdInpFileName)]);
   end;
  end;
  if IsSameText(sn,'RxFileName')
  or IsSameText(sn,'StdOutFileName') then begin
   if p=0 then Result:=Format('%s',[task.StdOutFileName]) else begin
    task.StdOutFileName:=sv;
    Result:=Format('%d',[Length(task.StdOutFileName)]);
   end;
  end;
  if IsSameText(sn,'TxPriority')
  or IsSameText(sn,'StdInPriority')
  or IsSameText(sn,'StdInpPriority') then begin
   if p>0 then task.StdInpPriority:=GetPriorityByName(Trim(sv));
   Result:=GetPriorityName(task.StdInpPriority);
  end;
  if IsSameText(sn,'RxPriority')
  or IsSameText(sn,'StdOutPriority') then begin
   if p>0 then task.StdOutPriority:=GetPriorityByName(Trim(sv));
   Result:=GetPriorityName(task.StdOutPriority);
  end;
  if IsSameText(sn,'ThreadPriority') then begin
   if p>0 then task.ThreadPriority:=GetPriorityByName(Trim(sv));
   Result:=GetPriorityName(task.ThreadPriority);
  end;
  if IsSameText(sn,'ProcessPriority') then begin
   if p>0 then task.ProcessPriority:=GetPriorityClassLevel(GetPriorityClassByName(Trim(sv)));
   Result:=GetPriorityClassName(GetPriorityClassByLevel(task.ProcessPriority));
  end;
 except
  on E:Exception do BugReport(E);
 end;
 sn:=''; sv:='';
end;

 //////////////////////////////
 // FullTaskList implementation
 //////////////////////////////
const
 TheFullTaskList : TObjectStorage = nil;

function FullTaskList:TObjectStorage;
begin
 if not Assigned(TheFullTaskList) then begin
  TheFullTaskList:=NewObjectStorage(false);
  TheFullTaskList.Master:=@TheFullTaskList;
  TheFullTaskList.OwnsObjects:=false;
 end;
 Result:=TheFullTaskList;
end;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_task;
begin
 FullTaskList.Ok;
 task_initialize;
end;

procedure Free_crw_task;
begin
 task_finalize;
 ResourceLeakageLog(Format('%-60s = %d',['FullTaskList.Count', TheFullTaskList.Count]));
 Kill(TheFullTaskList);
end;

initialization

 Init_crw_task;

finalization

 Free_crw_task;

end.

//////////////
// END OF FILE
//////////////

