/// daemon managment classes for mORMot, including low-level Win NT Service
// - this unit is a part of the freeware Synopse mORMot framework,
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
unit mORMotService;

{
    This file is part of Synopse mORMot framework.

    Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez
      Synopse Informatique - https://synopse.info

  *** BEGIN LICENSE BLOCK *****
  Version: MPL 1.1/GPL 2.0/LGPL 2.1

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

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

  The Original Code is Synopse mORMot framework.

  The Initial Developer of the Original Code is Arnaud Bouchez.

  Portions created by the Initial Developer are Copyright (C) 2022
  the Initial Developer. All Rights Reserved.

  Contributor(s):
  - Eric Grange
  - Leander007
  - Maciej Izak (hnb)

  Alternatively, the contents of this file may be used under the terms of
  either the GNU General Public License Version 2 or later (the "GPL"), or
  the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
  in which case the provisions of the GPL or the LGPL are applicable instead
  of those above. If you wish to allow use of your version of this file only
  under the terms of either the GPL or the LGPL, and not to allow others to
  use your version of this file under the terms of the MPL, indicate your
  decision by deleting the provisions above and replace them with the notice
  and other provisions required by the GPL or the LGPL. If you do not delete
  the provisions above, a recipient may use your version of this file under
  the terms of any one of the MPL, the GPL or the LGPL.

  ***** END LICENSE BLOCK *****

}

interface

{$I Synopse.inc}

uses
  {$ifdef MSWINDOWS}
  Windows,
  Messages,
  {$else}
  {$ifdef FPC}
  SynFPCLinux,
  BaseUnix,
  Unix,
  {$else}
  Types,
  LibC, // Kylix
  {$endif FPC}
  {$endif MSWINDOWS}
  Classes,
  SysUtils,
  {$ifndef LVCL}
  Contnrs,
  {$endif}
  SynCommons,
  SynTable,
  SynLog,
  SynCrypto, // for executable MD5/SHA256 hashes
  mORMot; // for TSynJsonFileSettings (i.e. JSON serialization)

{$ifdef MSWINDOWS}

{ *** some minimal Windows API definitions, replacing WinSvc.pas missing for FPC }

const
  CM_SERVICE_CONTROL_CODE = WM_USER+1000;

  SERVICE_QUERY_CONFIG         = $0001;
  SERVICE_CHANGE_CONFIG        = $0002;
  SERVICE_QUERY_STATUS         = $0004;
  SERVICE_ENUMERATE_DEPENDENTS = $0008;
  SERVICE_START                = $0010;
  SERVICE_STOP                 = $0020;
  SERVICE_PAUSE_CONTINUE       = $0040;
  SERVICE_INTERROGATE          = $0080;
  SERVICE_USER_DEFINED_CONTROL = $0100;
  SERVICE_ALL_ACCESS           = STANDARD_RIGHTS_REQUIRED or
                                 SERVICE_QUERY_CONFIG or
                                 SERVICE_CHANGE_CONFIG or
                                 SERVICE_QUERY_STATUS or
                                 SERVICE_ENUMERATE_DEPENDENTS or
                                 SERVICE_START or
                                 SERVICE_STOP or
                                 SERVICE_PAUSE_CONTINUE or
                                 SERVICE_INTERROGATE or
                                 SERVICE_USER_DEFINED_CONTROL;

  SC_MANAGER_CONNECT            = $0001;
  SC_MANAGER_CREATE_SERVICE     = $0002;
  SC_MANAGER_ENUMERATE_SERVICE  = $0004;
  SC_MANAGER_LOCK               = $0008;
  SC_MANAGER_QUERY_LOCK_STATUS  = $0010;
  SC_MANAGER_MODIFY_BOOT_CONFIG = $0020;
  SC_MANAGER_ALL_ACCESS         = STANDARD_RIGHTS_REQUIRED or
                                  SC_MANAGER_CONNECT or
                                  SC_MANAGER_CREATE_SERVICE or
                                  SC_MANAGER_ENUMERATE_SERVICE or
                                  SC_MANAGER_LOCK or
                                  SC_MANAGER_QUERY_LOCK_STATUS or
                                  SC_MANAGER_MODIFY_BOOT_CONFIG;

  SERVICE_CONFIG_DESCRIPTION    = $0001;

  SERVICE_WIN32_OWN_PROCESS     = $00000010;
  SERVICE_WIN32_SHARE_PROCESS   = $00000020;
  SERVICE_INTERACTIVE_PROCESS   = $00000100;

  SERVICE_BOOT_START            = $00000000;
  SERVICE_SYSTEM_START          = $00000001;
  SERVICE_AUTO_START            = $00000002;
  SERVICE_DEMAND_START          = $00000003;
  SERVICE_DISABLED              = $00000004;
  SERVICE_ERROR_IGNORE          = $00000000;
  SERVICE_ERROR_NORMAL          = $00000001;
  SERVICE_ERROR_SEVERE          = $00000002;
  SERVICE_ERROR_CRITICAL        = $00000003;

  SERVICE_CONTROL_STOP          = $00000001;
  SERVICE_CONTROL_PAUSE         = $00000002;
  SERVICE_CONTROL_CONTINUE      = $00000003;
  SERVICE_CONTROL_INTERROGATE   = $00000004;
  SERVICE_CONTROL_SHUTDOWN      = $00000005;
  SERVICE_STOPPED               = $00000001;
  SERVICE_START_PENDING         = $00000002;
  SERVICE_STOP_PENDING          = $00000003;
  SERVICE_RUNNING               = $00000004;
  SERVICE_CONTINUE_PENDING      = $00000005;
  SERVICE_PAUSE_PENDING         = $00000006;
  SERVICE_PAUSED                = $00000007;

type
  PServiceStatus = ^TServiceStatus;
  TServiceStatus = object
  public
    dwServiceType: DWORD;
    dwCurrentState: DWORD;
    dwControlsAccepted: DWORD;
    dwWin32ExitCode: DWORD;
    dwServiceSpecificExitCode: DWORD;
    dwCheckPoint: DWORD;
    dwWaitHint: DWORD;
  end;

  PServiceStatusProcess = ^TServiceStatusProcess;
  TServiceStatusProcess = object(TServiceStatus)
  public
    dwProcessId: DWORD;
    dwServiceFlags: DWORD;
  end;

  SC_HANDLE = THandle;
  SERVICE_STATUS_HANDLE = DWORD;
  TServiceTableEntry = record
    lpServiceName: PChar;
    lpServiceProc: procedure(ArgCount: DWORD; Args: PPChar); stdcall;
  end;
  PServiceTableEntry = ^TServiceTableEntry;
  {$Z4}
  SC_STATUS_TYPE = (SC_STATUS_PROCESS_INFO);
  {$Z1}

function OpenSCManager(lpMachineName, lpDatabaseName: PChar;
  dwDesiredAccess: DWORD): SC_HANDLE; stdcall; external advapi32
  name 'OpenSCManager'+{$ifdef UNICODE}'W'{$else}'A'{$endif};
function ChangeServiceConfig2(hService: SC_HANDLE; dwsInfoLevel: DWORD;
  lpInfo: Pointer): BOOL; stdcall; external advapi32 name 'ChangeServiceConfig2W';
function StartService(hService: SC_HANDLE; dwNumServiceArgs: DWORD;
  lpServiceArgVectors: Pointer): BOOL; stdcall; external advapi32
  name 'StartService'+{$ifdef UNICODE}'W'{$else}'A'{$endif};
function CreateService(hSCManager: SC_HANDLE; lpServiceName, lpDisplayName: PChar;
  dwDesiredAccess, dwServiceType, dwStartType, dwErrorControl: DWORD;
  lpBinaryPathName, lpLoadOrderGroup: PChar; lpdwTagId: LPDWORD; lpDependencies,
  lpServiceStartName, lpPassword: PChar): SC_HANDLE; stdcall; external advapi32
  name 'CreateService'+{$ifdef UNICODE}'W'{$else}'A'{$endif};
function OpenService(hSCManager: SC_HANDLE; lpServiceName: PChar;
  dwDesiredAccess: DWORD): SC_HANDLE; stdcall; external advapi32
  name 'OpenService'+{$ifdef UNICODE}'W'{$else}'A'{$endif};
function DeleteService(hService: SC_HANDLE): BOOL; stdcall; external advapi32;
function CloseServiceHandle(hSCObject: SC_HANDLE): BOOL; stdcall; external advapi32;
function QueryServiceStatus(hService: SC_HANDLE;
  var lpServiceStatus: TServiceStatus): BOOL; stdcall; external advapi32;
function QueryServiceStatusEx(hService: SC_HANDLE;
  InfoLevel: SC_STATUS_TYPE; lpBuffer: Pointer; cbBufSize: DWORD;
  var pcbBytesNeeded: DWORD): BOOL; stdcall; external advapi32;
function ControlService(hService: SC_HANDLE; dwControl: DWORD;
  var lpServiceStatus: TServiceStatus): BOOL; stdcall; external advapi32;
function SetServiceStatus(hServiceStatus: SERVICE_STATUS_HANDLE;
  var lpServiceStatus: TServiceStatus): BOOL; stdcall; external advapi32;
function RegisterServiceCtrlHandler(lpServiceName: PChar;
  lpHandlerProc: TFarProc): SERVICE_STATUS_HANDLE; stdcall; external advapi32
  name 'RegisterServiceCtrlHandler'+{$ifdef UNICODE}'W'{$else}'A'{$endif};
function StartServiceCtrlDispatcher(
  lpServiceStartTable: PServiceTableEntry): BOOL; stdcall; external advapi32
  name 'StartServiceCtrlDispatcher'+{$ifdef UNICODE}'W'{$else}'A'{$endif};


{ *** high level classes to define and manage Windows Services }

var
  /// you can set this global variable to TSynLog or TSQLLog to enable logging
  // - default is nil, i.e. disabling logging, since it may interfere with the
  // logging process of the service itself
  ServiceLog: TSynLogClass;

type
  /// all possible states of the service
  TServiceState =
    (ssNotInstalled, ssStopped, ssStarting, ssStopping, ssRunning,
     ssResuming, ssPausing, ssPaused, ssErrorRetrievingState);

  /// TServiceControler class is intended to create a new service instance or
  // to maintain (that is start, stop, pause, resume...) an existing service
  // - to provide the service itself, use the TService class
  TServiceController = class
  protected
    FSCHandle: THandle;
    FHandle: THandle;
    FStatus: TServiceStatus;
    FName: RawUTF8;
  private
    function GetStatus: TServiceStatus;
    function GetState: TServiceState;
  public
    /// Creates a new service and allows to control it and/or its configuration
    // - TargetComputer - set it to empty string if local computer is the target.
    // - DatabaseName - set it to empty string if the default database is supposed
    // ('ServicesActive').
    // - Name - name of a service.
    // - DisplayName - display name of a service.
    // - Path - a path to binary (executable) of the service created.
    // - OrderGroup - an order group name (unnecessary)
    // - Dependencies - string containing a list with names of services, which must
    // start before (every name should be separated with #0, entire
    // list should be separated with #0#0. Or, an empty string can be
    // passed if there is no dependancy).
    // - Username - login name. For service type SERVICE_WIN32_OWN_PROCESS, the
    // account name in the form of "DomainName\Username"; If the account
    // belongs to the built-in domain, ".\Username" can be specified;
    // Services of type SERVICE_WIN32_SHARE_PROCESS are not allowed to
    // specify an account other than LocalSystem. If '' is specified, the
    // service will be logged on as the 'LocalSystem' account, in which
    // case, the Password parameter must be empty too.
    // - Password - a password for login name. If the service type is
    // SERVICE_KERNEL_DRIVER or SERVICE_FILE_SYSTEM_DRIVER,
    // this parameter is ignored.
    // - DesiredAccess - a combination of following flags:
    // SERVICE_ALL_ACCESS (default value), SERVICE_CHANGE_CONFIG,
    // SERVICE_ENUMERATE_DEPENDENTS, SERVICE_INTERROGATE, SERVICE_PAUSE_CONTINUE,
    // SERVICE_QUERY_CONFIG, SERVICE_QUERY_STATUS, SERVICE_START, SERVICE_STOP,
    // SERVICE_USER_DEFINED_CONTROL
    // - ServiceType - a set of following flags:
    // SERVICE_WIN32_OWN_PROCESS (default value, which specifies a Win32 service
    // that runs in its own process), SERVICE_WIN32_SHARE_PROCESS,
    // SERVICE_KERNEL_DRIVER, SERVICE_FILE_SYSTEM_DRIVER,
    // SERVICE_INTERACTIVE_PROCESS (default value, which enables a Win32 service
    // process to interact with the desktop)
    // - StartType - one of following values:
    // SERVICE_BOOT_START, SERVICE_SYSTEM_START,
    // SERVICE_AUTO_START (which specifies a device driver or service started by
    // the service control manager automatically during system startup),
    // SERVICE_DEMAND_START (default value, which specifies a service started by
    // a service control manager when a process calls the StartService function,
    // that is the TServiceController.Start method), SERVICE_DISABLED
    // - ErrorControl - one of following:
    // SERVICE_ERROR_IGNORE, SERVICE_ERROR_NORMAL (default value, by which
    // the startup program logs the error and displays a message but continues
    // the startup operation), SERVICE_ERROR_SEVERE,
    // SERVICE_ERROR_CRITICAL
    constructor CreateNewService(const TargetComputer, DatabaseName,
      Name, DisplayName, Path: string;
      const OrderGroup: string = ''; const Dependencies: string = '';
      const Username: string = ''; const Password: string = '';
      DesiredAccess: DWORD = SERVICE_ALL_ACCESS;
      ServiceType: DWORD = SERVICE_WIN32_OWN_PROCESS or SERVICE_INTERACTIVE_PROCESS;
      StartType: DWORD = SERVICE_DEMAND_START; ErrorControl: DWORD = SERVICE_ERROR_NORMAL);
    /// wrapper around CreateNewService() to install the current executable as service
    class function Install(const Name,DisplayName,Description: string;
      AutoStart: boolean; ExeName: TFileName=''; Dependencies: string=''): TServiceState;
    /// Opens an existing service, in order  to control it or its configuration
    // from your application. Parameters (strings are unicode-ready since Delphi 2009):
    // - TargetComputer - set it to empty string if local computer is the target.
    // - DatabaseName - set it to empty string if the default database is supposed
    // ('ServicesActive').
    // - Name - name of a service.
    // - DesiredAccess - a combination of following flags:
    // SERVICE_ALL_ACCESS, SERVICE_CHANGE_CONFIG, SERVICE_ENUMERATE_DEPENDENTS,
    // SERVICE_INTERROGATE, SERVICE_PAUSE_CONTINUE, SERVICE_QUERY_CONFIG,
    // SERVICE_QUERY_STATUS, SERVICE_START, SERVICE_STOP, SERVICE_USER_DEFINED_CONTROL
    constructor CreateOpenService(const TargetComputer, DataBaseName, Name: String;
      DesiredAccess: DWORD = SERVICE_ALL_ACCESS);
    /// release memory and handles
    destructor Destroy; override;
    /// Handle of SC manager
    property SCHandle: THandle read FSCHandle;
    /// Handle of service opened or created
    // - its value is 0 if something failed in any Create*() method
    property Handle: THandle read FHandle;
    /// Retrieve the Current status of the service
    property Status: TServiceStatus read GetStatus;
    /// Retrieve the Current state of the service
    property State: TServiceState read GetState;
    /// Requests the service to stop
    function Stop: boolean;
    /// Requests the service to pause
    function Pause: boolean;
    /// Requests the paused service to resume
    function Resume: boolean;
    /// Requests the service to update immediately its current status information
    // to the service control manager
    function Refresh: boolean;
    /// Request the service to shutdown
    // - this function always return false
    function Shutdown: boolean;
    /// Removes service from the system, i.e. close the Service
    function Delete: boolean;
    /// starts the execution of a service with some specified arguments
    // - this version expect PChar pointers, either AnsiString (for FPC and old
    //  Delphi compiler), either UnicodeString (till Delphi 2009)
    function Start(const Args: array of PChar): boolean;
    /// try to define the description text of this service
    procedure SetDescription(const Description: string);
    /// this class method will check the command line parameters, and will let
    //  control the service according to it
    // - MyServiceSetup.exe /install will install the service
    // - MyServiceSetup.exe /start   will start the service
    // - MyServiceSetup.exe /stop    will stop the service
    // - MyServiceSetup.exe /uninstall will uninstall the service
    // - so that you can write in the main block of your .dpr:
    // !CheckParameters('MyService.exe',HTTPSERVICENAME,HTTPSERVICEDISPLAYNAME);
    // - if ExeFileName='', it will install the current executable
    // - optional Description and Dependencies text may be specified
    class procedure CheckParameters(const ExeFileName: TFileName;
      const ServiceName,DisplayName,Description: string; const Dependencies: string='');
  end;

  {$M+}
  TService = class;
  {$M-}

  /// callback procedure for Windows Service Controller
  TServiceControlHandler = procedure(CtrlCode: DWORD); stdcall;

  /// event triggered for Control handler
  TServiceControlEvent = procedure(Sender: TService; Code: DWORD) of object;

  /// event triggered to implement the Service functionality
  TServiceEvent = procedure(Sender: TService) of object;

  /// TService is the class used to implement a service provided by an application
  TService = class
  protected
    fSName: String;
    fDName: String;
    fStartType: DWORD;
    fServiceType: DWORD;
    fData: DWORD;
    fControlHandler: TServiceControlHandler;
    fOnControl: TServiceControlEvent;
    fOnInterrogate: TServiceEvent;
    fOnPause: TServiceEvent;
    fOnShutdown: TServiceEvent;
    fOnStart: TServiceEvent;
    fOnExecute: TServiceEvent;
    fOnResume: TServiceEvent;
    fOnStop: TServiceEvent;
    fStatusRec: TServiceStatus;
    fArgsList: array of string;
    fJumper: PByteArray;
    fStatusHandle: THandle;
    function GetArgCount: Integer;
    function GetArgs(Idx: Integer): String;
    function GetInstalled: boolean;
    procedure SetStatus(const Value: TServiceStatus);
    procedure CtrlHandle(Code: DWORD);
    function GetControlHandler: TServiceControlHandler;
    procedure SetControlHandler(const Value: TServiceControlHandler);
  public
    /// this method is the main service entrance, from the OS point of view
    // - it will call OnControl/OnStop/OnPause/OnResume/OnShutdown events
    // - and report the service status to the system (via ReportStatus method)
    procedure DoCtrlHandle(Code: DWORD); virtual;
    /// Creates the service
    // - the service is added to the internal registered services
    // - main application must call the global ServicesRun procedure to actually
    // start the services
    // - caller must free the TService instance when it's no longer used
    constructor Create(const aServiceName, aDisplayName: String); reintroduce; virtual;
    /// free memory and release handles
    destructor Destroy; override;
    /// Reports new status to the system
    function ReportStatus(dwState, dwExitCode, dwWait: DWORD): BOOL;
    /// Installs the service in the database
    // - return true on success
    // - create a local TServiceController with the current executable file,
    // with the supplied command line parameters
    function Install(const Params: string=''): boolean;
    /// Removes the service from database
    //  - uses a local TServiceController with the current Service Name
    procedure Remove;
    /// Starts the service
    //  - uses a local TServiceController with the current Service Name
    procedure Start;
    /// Stops the service
    // - uses a local TServiceController with the current Service Name
    procedure Stop;
    /// this is the main method, in which the Service should implement its run
    procedure Execute; virtual;

    /// Number of arguments passed to the service by the service controler
    property ArgCount: Integer read GetArgCount;
    /// List of arguments passed to the service by the service controler
    property Args[Idx: Integer]: String read GetArgs;
    /// Any data You wish to associate with the service object
    property Data: DWORD read FData write FData;
    /// Whether service is installed in DataBase
    // - uses a local TServiceController to check if the current Service Name exists
    property Installed: boolean read GetInstalled;
    /// Current service status
    // - To report new status to the system, assign another
    // value to this record, or use ReportStatus method (preferred)
    property Status: TServiceStatus read fStatusRec write SetStatus;
    /// Callback handler for Windows Service Controller
    // - if handler is not set, then auto generated handler calls DoCtrlHandle
    // (note that this auto-generated stubb is... not working yet - so you should
    // either set your own procedure to this property, or use TServiceSingle)
    // - a typical control handler may be defined as such:
    // ! var MyGlobalService: TService;
    // !
    // ! procedure MyServiceControlHandler(Opcode: LongWord); stdcall;
    // ! begin
    // !   if MyGlobalService<>nil then
    // !     MyGlobalService.DoCtrlHandle(Opcode);
    // ! end;
    // !
    // ! ...
    // ! MyGlobalService := TService.Create(...
    // ! MyGlobalService.ControlHandler := MyServiceControlHandler;
    property ControlHandler: TServiceControlHandler
      read GetControlHandler write SetControlHandler;
    /// Start event is executed before the main service thread (i.e. in the Execute method)
    property OnStart: TServiceEvent read fOnStart write fOnStart;
    /// custom Execute event
    // - launched in the main service thread (i.e. in the Execute method)
    property OnExecute: TServiceEvent read fOnExecute write fOnExecute;
    /// custom event triggered when a Control Code is received from Windows
    property OnControl: TServiceControlEvent read fOnControl write fOnControl;
    /// custom event triggered when the service is stopped
    property OnStop: TServiceEvent read fOnStop write fOnStop;
    /// custom event triggered when the service is paused
    property OnPause: TServiceEvent read fOnPause write fOnPause;
    /// custom event triggered when the service is resumed
    property OnResume: TServiceEvent read fOnResume write fOnResume;
    /// custom event triggered when the service receive an Interrogate
    property OnInterrogate: TServiceEvent read fOnInterrogate write fOnInterrogate;
    /// custom event triggered when the service is shut down
    property OnShutdown: TServiceEvent read fOnShutdown write fOnShutdown;
  published
    /// Name of the service. Must be unique
    property ServiceName: String read fSName;
    /// Display name of the service
    property DisplayName: String read fDName write fDName;
    /// Type of service
    property ServiceType: DWORD read fServiceType write fServiceType;
    /// Type of start of service
    property StartType: DWORD read fStartType write fStartType;
  end;

  /// inherit from this service if your application has a single service
  // - note that TService jumper does not work well - so use this instead
  TServiceSingle = class(TService)
  public
    /// will set a global function as service controller
    constructor Create(const aServiceName, aDisplayName: String); override;
    /// will release the global service controller
    destructor Destroy; override;
  end;


var
  /// the internal list of Services handled by this unit
  // - not to be accessed directly: create TService instances, and they will
  // be added/registered to this list
  // - then run the global ServicesRun procedure
  // - every TService instance is to be freed by the main application, when
  // it's no more used
  Services: TSynList = nil;

  /// the main TService instance running
  ServiceSingle: TServiceSingle = nil;

/// launch the registered Services execution
// - the registered list of service provided by the aplication is sent
// to the operating system
// - returns TRUE on success
// - returns FALSE on error (to get extended information, call GetLastError)
function ServicesRun: boolean;

/// convert the Control Code retrieved from Windows into a service state
// enumeration item
function CurrentStateToServiceState(CurrentState: DWORD): TServiceState;

/// return the ready to be displayed text of a TServiceState value
function ServiceStateText(State: TServiceState): string;

/// return service PID
function GetServicePid(const aServiceName: string): DWORD;

/// kill Windows process
function KillProcess(pid: DWORD; waitseconds: integer = 30): boolean;

{$else}

/// low-level function able to properly run or fork the current process
// then execute the start/stop methods of a TSynDaemon / TDDDDaemon instance
// - fork will create a local /run/[ProgramName]-[ProgramPathHash].pid file name
procedure RunUntilSigTerminated(daemon: TObject; dofork: boolean;
  const start, stop: TThreadMethod; log: TSynLog = nil; const servicename: string = '');

/// kill a process previously created by RunUntilSigTerminated(dofork=true)
// - will lookup a local /run/[ProgramName]-[ProgramPathHash].pid file name to
// retrieve the actual PID to be killed, then send a SIGTERM, and wait
// waitseconds for the .pid file to disapear
// - returns true on success, false on error (e.g. no valid .pid file or
// the file didn't disappear, which may mean that the daemon is broken)
function RunUntilSigTerminatedForKill(waitseconds: integer = 30): boolean;

/// local .pid file name as created by RunUntilSigTerminated(dofork=true)
function RunUntilSigTerminatedPidFile: TFileName;

var
  /// once SynDaemonIntercept has been called, this global variable
  // contains the SIGQUIT / SIGTERM / SIGINT received signal
  SynDaemonTerminated: integer;

/// enable low-level interception of executable stop signals
// - any SIGQUIT / SIGTERM / SIGINT signal will set appropriately the global
// SynDaemonTerminated variable, with an optional logged entry to log
// - as called e.g. by RunUntilSigTerminated()
// - you can call this method several times with no issue
procedure SynDaemonIntercept(log: TSynLog=nil);

{$endif MSWINDOWS}

type
  /// command line patterns recognized by ParseCommandArgs()
  TParseCommand = (
    pcHasRedirection, pcHasSubCommand, pcHasParenthesis,
    pcHasJobControl, pcHasWildcard, pcHasShellVariable,
    pcUnbalancedSingleQuote, pcUnbalancedDoubleQuote,
    pcTooManyArguments, pcInvalidCommand, pcHasEndingBackSlash);
  TParseCommands = set of TParseCommand;
  PParseCommands = ^TParseCommands;
  /// used to store references of arguments recognized by ParseCommandArgs()
  TParseCommandsArgs = array[0..31] of PAnsiChar;
  PParseCommandsArgs = ^TParseCommandsArgs;

const
  /// identifies some bash-specific processing
  PARSECOMMAND_BASH = [pcHasRedirection .. pcHasShellVariable];
  /// identifies obvious invalid content
  PARSECOMMAND_ERROR = [pcUnbalancedSingleQuote .. pcHasEndingBackSlash];

/// low-level parsing of a RunCommand() execution command
// - parse and fills argv^[0..argc^-1] with corresponding arguments, after
// un-escaping and un-quoting if applicable, using temp^ to store the content
// - if argv=nil, do only the parsing, not the argument extraction - could be
// used for fast validation of the command line syntax
// - you can force arguments OS flavor using the posix parameter - note that
// Windows parsing is not consistent by itself (e.g. double quoting or
// escaping depends on the actual executable called) so returned flags
// should be considered as indicative only with posix=false
function ParseCommandArgs(const cmd: RawUTF8; argv: PParseCommandsArgs = nil;
  argc: PInteger = nil; temp: PRawUTF8 = nil;
  posix: boolean = {$ifdef MSWINDOWS}false{$else}true{$endif}): TParseCommands;

function ToText(cmd: TParseCommands): shortstring; overload;
  {$ifdef HASINLINE}inline;{$endif}

/// like SysUtils.ExecuteProcess, but allowing not to wait for the process to finish
// - optional env value follows 'n1=v1'#0'n2=v2'#0'n3=v3'#0#0 Windows layout
function RunProcess(const path, arg1: TFileName; waitfor: boolean;
  const arg2: TFileName=''; const arg3: TFileName=''; const arg4: TFileName='';
  const arg5: TFileName=''; const env: TFileName=''; envaddexisting: boolean=false): integer;

/// like fpSystem, but cross-platform
// - under POSIX, calls bash only if needed, after ParseCommandArgs() analysis
// - under Windows (especially Windows 10), creating a process can be dead slow
// https://randomascii.wordpress.com/2019/04/21/on2-in-createprocess
function RunCommand(const cmd: TFileName; waitfor: boolean;
  const env: TFileName=''; envaddexisting: boolean=false;
  parsed: PParseCommands=nil): integer;


{ *** cross-plaform high-level services/daemons }

type
  /// abstract parent containing information able to initialize a TSynDaemon class
  // - will handle persistence as JSON local files
  // - you may consider using TDDDAppSettingsAbstract from dddInfraSettings
  TSynDaemonSettings  = class(TSynJsonFileSettings)
  protected
    fServiceName: string;
    fServiceDisplayName: string;
    fLog: TSynLogInfos;
    fLogPath: TFileName;
    fLogRotateFileCount: integer;
    fLogClass: TSynLogClass;
    fServiceDependencies: string;
  public
    /// initialize and set the default settings
    constructor Create; override;
    /// define the log information into the supplied TSynLog class
    // - if you don't call this method, the logging won't be initiated
    // - is to be called typically in the overriden Create constructor of the
    // associated TSynDaemon class, just after "inherited Create"
    procedure SetLog(aLogClass: TSynLogClass);
    /// returns user-friendly description of the service, including version
    // information and company copyright (if available)
    function ServiceDescription: string;
    /// read-only access to the TSynLog class, if SetLog() has been called
    property LogClass: TSynLogClass read fLogClass;
    /// optional service dependencies
    // - not published by default: could be defined if needed, or e.g. set in
    // overriden constructor
    // - several depending services may be set by appending #0 between names
    property ServiceDependencies: string read fServiceDependencies write fServiceDependencies;
  published
    /// the service name, as used internally by Windows or the TSynDaemon class
    // - default is the executable name
    property ServiceName: string read fServiceName write fServiceName;
    /// the service name, as displayed by Windows or at the console level
    // - default is the executable name
    property ServiceDisplayName: string read fServiceDisplayName write fServiceDisplayName;
    /// if not void, will enable the logs (default is LOG_STACKTRACE)
    property Log: TSynLogInfos read fLog write fLog;
    /// allow to customize where the logs should be written
    property LogPath: TFileName read fLogPath write fLogPath;
    /// how many files will be rotated (default is 2)
    property LogRotateFileCount: integer read fLogRotateFileCount write fLogRotateFileCount;
  end;
  /// meta-class of TSynDaemon settings information
  TSynDaemonSettingsClass = class of TSynDaemonSettings;

  /// abstract parent to implements a daemon/service
  // - inherit from this abstract class and override Start and Stop methods
  // - you may consider using TDDDAdministratedDaemon from dddInfraApps
  TSynDaemon = class(TSynPersistent)
  protected
    fConsoleMode: boolean;
    fWorkFolderName: TFileName;
    fSettings: TSynDaemonSettings;
    function CustomCommandLineSyntax: string; virtual;
    {$ifdef MSWINDOWS}
    procedure DoStart(Sender: TService);
    procedure DoStop(Sender: TService);
    {$endif}
  public
    /// initialize the daemon, creating the associated settings
    // - TSynDaemonSettings instance will be owned and freed by the daemon
    // - any non supplied folder name will be replaced by a default value
    // (executable folder under Windows, or /etc /var/log on Linux)
    constructor Create(aSettingsClass: TSynDaemonSettingsClass;
      const aWorkFolder, aSettingsFolder, aLogFolder: TFileName;
      const aSettingsExt: TFileName = '.settings';
      const aSettingsName: TFileName = ''); reintroduce;
    /// main entry point of the daemon, to process the command line switches
    // - aAutoStart is used only under Windows
    procedure CommandLine(aAutoStart: boolean=true);
    /// inherited class should override this abstract method with proper process
    procedure Start; virtual; abstract;
    /// inherited class should override this abstract method with proper process
    // - should do nothing if the daemon was already stopped
    procedure Stop; virtual; abstract;
    /// call Stop, finalize the instance, and its settings
    destructor Destroy; override;
  published
    /// if this instance was run as /console or /verb
    property ConsoleMode: boolean read fConsoleMode;
    /// the settings associated with this daemon
    // - will be allocated in Create constructor, and released in Destroy
    property Settings: TSynDaemonSettings read fSettings;
  end;

{$ifdef MSWINDOWS}

  /// Enum synchronized with WinAPI
  // - see https://docs.microsoft.com/en-us/windows/desktop/secauthz/privilege-constants
  TWinSystemPrivilege = (wspCreateToken, wspAssignPrimaryToken, wspLockMemory,
    wspIncreaseQuota, wspUnsolicitedInput, wspMachineAccount, wspTCP, wspSecurity,
    wspTakeOwnership, wspLoadDriver, wspSystemProfile, wspSystemTime, wspProfSingleProcess,
    wspIncBasePriority, wspCreatePageFile, wspCreatePermanent, wspBackup, wspRestore,
    wspShutdown, wspDebug, wspAudit, wspSystemEnvironment, wspChangeNotify,
    wspRemoteShutdown, wspUndock, wspSyncAgent, wspEnableDelegation, wspManageVolume,
    wspImpersonate, wspCreateGlobal, wspTrustedCredmanAccess, wspRelabel,
    wspIncWorkingSet, wspTimeZone, wspCreateSymbolicLink);
  TWinSystemPrivileges = set of TWinSystemPrivilege;
  TPrivilegeTokenType = (pttProcess, pttThread);

  /// object dedicated to management of available privileges for Windows platform
  // - not all available privileges are active for process
  // - for usage of more advanced WinAPI, explicit enabling of privilege is
  // sometimes needed
  TSynWindowsPrivileges = object
  private
    fAvailable: TWinSystemPrivileges;
    fEnabled: TWinSystemPrivileges;
    fDefEnabled: TWinSystemPrivileges;
    function SetPrivilege(aPrivilege: Pointer; aEnablePrivilege: boolean): boolean;
    procedure LoadPrivileges;
  public
    /// handle to privileges token
    Token: THandle;
    /// initialize the object dedicated to management of available privileges
    // - aTokenPrivilege can be used for current process or current thread
    procedure Init(aTokenPrivilege: TPrivilegeTokenType = pttProcess);
    /// finalize the object and relese Token handle
    // - aRestoreInitiallyEnabled parameter can be used to restore initially
    // state of enabled privileges
    procedure Done(aRestoreInitiallyEnabled: boolean = true);
    /// enable privilege
    // - if aPrivilege is already enabled return true, if operation is not
    // possible (required privilege doesn't exist or API error) return false
    function Enable(aPrivilege: TWinSystemPrivilege): boolean;
    /// disable privilege
    // - if aPrivilege is already disabled return true, if operation is not
    // possible (required privilege doesn't exist or API error) return false
    function Disable(aPrivilege: TWinSystemPrivilege): boolean;
    /// set of available privileges for current process/thread
    property Available: TWinSystemPrivileges read fAvailable;
    /// set of enabled privileges for current process/thread
    property Enabled: TWinSystemPrivileges read fEnabled;
  end;

  TWinProcessAvailableInfos = set of (wpaiPID, wpaiBasic, wpaiPEB, wpaiCommandLine, wpaiImagePath);
  PWinProcessInfo = ^TWinProcessInfo;
  TWinProcessInfo = record
    AvailableInfo: TWinProcessAvailableInfos;
    PID: Cardinal;
    ParentPID: Cardinal;
    SessionID: Cardinal;
    PEBBaseAddress: Pointer;
    AffinityMask: Cardinal;
    BasePriority: LongInt;
    ExitStatus: LongInt;
    BeingDebugged: Byte;
    ImagePath: SynUnicode;
    CommandLine: SynUnicode;
  end;
  TWinProcessInfoDynArray = array of TWinProcessInfo;

procedure GetProcessInfo(aPid: Cardinal; out aInfo: TWinProcessInfo); overload;
procedure GetProcessInfo(const aPidList: TCardinalDynArray; out aInfo: TWinProcessInfoDynArray); overload;

{$endif MSWINDOWS}

const
  /// text identifier typically used before command line switches
  // - equals '/' on Windows, and '--' on POSIX systems
  CMDLINESWITCH = {$ifdef MSWINDOWS}'/'{$else}'--'{$endif};


implementation

{$ifdef MSWINDOWS}

{ TServiceController }

constructor TServiceController.CreateNewService(const TargetComputer,
  DatabaseName,Name,DisplayName,Path,OrderGroup,Dependencies,Username,Password: String;
  DesiredAccess,ServiceType,StartType,ErrorControl: DWORD);
var Exe: TFileName;
   backupError: cardinal;
begin
  inherited Create;
  if Path='' then begin
    ServiceLog.Add.Log(sllError,'CreateNewService("%","%") with Path=""',
      [Name,DisplayName]);
    Exit;
  end;
  if TargetComputer='' then
  if GetDriveType(pointer(ExtractFileDrive(Path)))=DRIVE_REMOTE then begin
    Exe := ExpandUNCFileName(Path);
    if (copy(Exe,1,12)<>'\\localhost\') or (Exe[14]<>'$') then begin
      ServiceLog.Add.Log(sllError,'CreateNewService("%","%") on remote drive: Path="%" is %',
        [Name,DisplayName,Path,Exe]);
      Exit;
    end;
    system.delete(Exe,1,12); // \\localhost\c$\... -> c:\...
    Exe[2] := ':';
  end else
    Exe := Path;
  StringToUTF8(Name,FName);
  FSCHandle := OpenSCManager(pointer(TargetComputer), pointer(DatabaseName),
    SC_MANAGER_ALL_ACCESS);
  if FSCHandle=0 then begin
    backupError := GetLastError;
    ServiceLog.Add.Log(sllLastError,'OpenSCManager(''%'',''%'') for [%]',
      [TargetComputer,DatabaseName,FName]);
    SetLastError(backupError);
    Exit;
  end;
  FHandle := CreateService(FSCHandle, pointer(Name), pointer(DisplayName),
               DesiredAccess, ServiceType, StartType, ErrorControl, pointer(Exe),
               pointer(OrderGroup), nil, pointer(Dependencies),
               pointer(Username), pointer(Password));
  if FHandle=0 then begin
    backupError := GetLastError;
    ServiceLog.Add.Log(sllLastError,'CreateService("%","%","%")',[Name,DisplayName,Path]);
    SetLastError(backupError);
  end;
end;

constructor TServiceController.CreateOpenService(const TargetComputer,
  DataBaseName, Name: String; DesiredAccess: DWORD);
var backupError: cardinal;
begin
  inherited Create;
  StringToUTF8(Name,FName);
  FSCHandle := OpenSCManager(pointer(TargetComputer), pointer(DatabaseName),
    GENERIC_READ);
  if FSCHandle = 0 then begin
    backupError := GetLastError;
    ServiceLog.Add.Log(sllLastError,'OpenSCManager(''%'',''%'') for [%]',
      [TargetComputer,DatabaseName,FName]);
    SetLastError(backupError);
    Exit;
  end;
  FHandle := OpenService(FSCHandle, pointer(Name), DesiredAccess);
  if FHandle=0 then begin
    backupError := GetLastError;
    ServiceLog.Add.Log(sllLastError,'OpenService("%")',[Name]);
    SetLastError(backupError);
  end;
end;

function TServiceController.Delete: boolean;
begin
  Result := FALSE;
  if FHandle <> 0 then
    if DeleteService(FHandle) then begin
      Result := CloseServiceHandle(FHandle);
      FHandle := 0;
    end
    else ServiceLog.Add.Log(sllLastError,'DeleteService("%")',[FName]);
end;

destructor TServiceController.Destroy;
begin
  if FHandle <> 0 then
    CloseServiceHandle(FHandle);
  if FSCHandle <> 0 then
    CloseServiceHandle(FSCHandle);
  inherited;
end;

function TServiceController.GetState: TServiceState;
begin
  if (self=nil) or (FSCHandle=0) or (FHandle=0) then
    result := ssNotInstalled else
    result := CurrentStateToServiceState(Status.dwCurrentState);
  ServiceLog.Add.Log(sllTrace,FName,TypeInfo(TServiceState),result,self);
end;

function TServiceController.GetStatus: TServiceStatus;
begin
  FillChar(FStatus, Sizeof(FStatus), 0);
  QueryServiceStatus(FHandle, FStatus);
  Result := FStatus;
end;

function TServiceController.Pause: boolean;
begin
  Result := ControlService(FHandle, SERVICE_CONTROL_PAUSE, FStatus);
end;

function TServiceController.Refresh: boolean;
begin
  Result := ControlService(FHandle, SERVICE_CONTROL_INTERROGATE, FStatus);
end;

function TServiceController.Resume: boolean;
begin
  Result := ControlService(FHandle, SERVICE_CONTROL_CONTINUE, FStatus);
end;

function TServiceController.Shutdown: boolean;
begin
  Result := ControlService(FHandle, SERVICE_CONTROL_SHUTDOWN, FStatus);
end;

function TServiceController.Start(const Args: array of PChar): boolean;
begin
  if length(Args)=0 then
    Result := StartService(FHandle, 0, nil) else
    Result := StartService(FHandle, length(Args), @Args[0]);
end;

function TServiceController.Stop: boolean;
begin
  Result := ControlService(FHandle, SERVICE_CONTROL_STOP, FStatus);
end;

procedure TServiceController.SetDescription(const Description: string);
var desc: SynUnicode;
begin
  if Description='' then
    exit;
  StringToSynUnicode(Description, desc);
  ChangeServiceConfig2(FHandle, SERVICE_CONFIG_DESCRIPTION, @desc);
end;

class procedure TServiceController.CheckParameters(const ExeFileName: TFileName;
  const ServiceName, DisplayName, Description, Dependencies: string);
var param: string;
    i: integer;
procedure ShowError(const Msg: RawUTF8);
begin
  ServiceLog.Add.Log(sllLastError,'During % for %',[Msg,param]);
  if not IsConsole then
    exit;
  {$I-} // ignore if no console has been allocated
  writeln(ServiceName,': Error "',Msg,'" for ',param);
  ioresult;
  {$I+}
end;
begin
  for i := 1 to ParamCount do begin
    param := SysUtils.LowerCase(paramstr(i));
    ServiceLog.Add.Log(sllInfo,'Controling % with command [%]',[ServiceName,param]);
    if param='/install' then
     TServiceController.Install(
       ServiceName,DisplayName,Description,true,ExeFileName,Dependencies) else
    with TServiceController.CreateOpenService('','',ServiceName) do
    try
      if State=ssErrorRetrievingState then
        ShowError('State') else
      if param='/uninstall' then begin
        if not Stop then
          ShowError('Stop');
        if not Delete then
          ShowError('Delete');
      end else
      if param='/stop' then begin
        if not Stop then
          ShowError('Stop');
      end else
      if param='/start' then begin
        if not Start([]) then
          ShowError('Start');
      end;
    finally
      Free;
    end;
  end;
end;

class function TServiceController.Install(const Name, DisplayName,
  Description: string; AutoStart: boolean; ExeName: TFileName; Dependencies: string): TServiceState;
var ctrl: TServiceController;
    start: DWORD;
begin
  if AutoStart then
    start := SERVICE_AUTO_START else
    start := SERVICE_DEMAND_START;
  if ExeName='' then
    ExeName := ExeVersion.ProgramFileName;
  ctrl := TServiceController.CreateNewService('','',Name,DisplayName,ExeName,
    '',Dependencies,'','',SERVICE_ALL_ACCESS,SERVICE_WIN32_OWN_PROCESS,start);
  try
    result := ctrl.State;
    if result<>ssNotInstalled then
      ctrl.SetDescription(Description);
  finally
    ctrl.Free;
  end;
end;


{ TService }

function FindServiceIndex(const Name: String): integer;
begin
  if Services<>nil then
  for result := 0 to Services.Count-1 do
    if TService(Services.List[result]).ServiceName=Name then
      exit;
  result := -1;
end;

constructor TService.Create(const aServiceName, aDisplayName: String);
begin
  if FindServiceIndex(aServiceName)>=0 then
    raise EServiceException.CreateUTF8('%.Create: Attempt to install a service ' +
      'with duplicated name: %', [self, aServiceName]);
  fSName := aServiceName;
  fDName := aDisplayName;
  if aDisplayName = '' then
    fDName := aServiceName;
  if Services=nil then
    GarbageCollectorFreeAndNil(Services,TSynList.Create);
  Services.Add(self);
  fServiceType := SERVICE_WIN32_OWN_PROCESS or SERVICE_INTERACTIVE_PROCESS;
  fStartType   := SERVICE_AUTO_START;
  fStatusRec.dwServiceType := fServiceType;
  fStatusRec.dwCurrentState := SERVICE_STOPPED;
  fStatusRec.dwControlsAccepted := 31;
  fStatusRec.dwWin32ExitCode := NO_ERROR;
  ServiceLog.Add.Log(sllInfo,'Create: % (%) running as [%]',
    [ServiceName,aDisplayName,ExeVersion.ProgramFullSpec],self);
end;

procedure TService.CtrlHandle(Code: DWORD);
begin
  DoCtrlHandle(Code);
end;

destructor TService.Destroy;
var i: integer;
begin
  if fsName<>'' then begin
    i := FindServiceIndex(fsName);
    if i<0 then
      raise EServiceException.CreateUTF8('%.Destroy: Cannot find service % to remove',
       [self, fsName]);
    Services.Delete(i);
    if fJumper<>nil then
      VirtualFree(fJumper, 0, MEM_RELEASE);
  end;
  inherited Destroy;
end;

procedure TService.DoCtrlHandle(Code: DWORD);
var log: ISynLog;
begin
  log := ServiceLog.Enter(self, 'DoCtrlHandle');
  if log<>nil then
    log.Log(sllInfo,'%: command % received from OS',[ServiceName,Code],self);
  try
    case Code of
    SERVICE_CONTROL_STOP: begin
     ReportStatus(SERVICE_STOP_PENDING, NO_ERROR, 0);
     try
       if Assigned(fOnStop) then
         fOnStop(Self);
       ReportStatus(SERVICE_STOPPED, NO_ERROR, 0);
     except
       ReportStatus(SERVICE_STOPPED, ERROR_CAN_NOT_COMPLETE, 0);
     end;
    end;
    SERVICE_CONTROL_PAUSE: begin
     ReportStatus(SERVICE_PAUSE_PENDING, NO_ERROR, 0);
     try
       if Assigned(fOnPause) then
         fOnPause(Self);
       ReportStatus(SERVICE_PAUSED, NO_ERROR, 0)
     except
       ReportStatus(SERVICE_PAUSED, ERROR_CAN_NOT_COMPLETE, 0)
     end;
    end;
    SERVICE_CONTROL_CONTINUE: begin
     ReportStatus(SERVICE_CONTINUE_PENDING, NO_ERROR, 0);
     try
       if Assigned(fOnResume) then
         fOnResume(Self);
       ReportStatus(SERVICE_RUNNING, NO_ERROR, 0);
     except
       ReportStatus(SERVICE_RUNNING, ERROR_CAN_NOT_COMPLETE, 0);
     end;
    end;
    SERVICE_CONTROL_SHUTDOWN: begin
     if Assigned(fOnShutdown) then
       fOnShutdown(Self);
     Code := 0;
    end;
    SERVICE_CONTROL_INTERROGATE: begin
     SetServiceStatus(FStatusHandle, fStatusRec);
     if Assigned(fOnInterrogate) then
       fOnInterrogate(Self);
    end;
    end;
    if Assigned(fOnControl) then
      fOnControl(Self, Code);
  except
  end;
end;

procedure TService.Execute;
begin
  try
    if Assigned(fOnStart) then
      fOnStart(@Self);
    ReportStatus(SERVICE_RUNNING, NO_ERROR, 0);
    if Assigned(fOnExecute) then
      fOnExecute(@Self);
  except
    ReportStatus(SERVICE_RUNNING, ERROR_CAN_NOT_COMPLETE, 0);
  end;
end;

function TService.GetArgCount: Integer;
begin
  result := length(FArgsList);
end;

function TService.GetArgs(Idx: Integer): String;
begin
  if cardinal(Idx)>cardinal(high(FArgsList)) then
    result := '' else // avoid GPF
    result := FArgsList[Idx];
end;


{$ifdef CPUX86}
  {.$define X86JUMPER} // this preliminary version is buggy so disabled
  // a single service per excecutable is fine enough for our daemons
  // also for proper Delphi 10.4 compilation with no hint
{$endif CPUX86}

{$ifdef X86JUMPER}
procedure JumpToService;
asm
  pop  eax
  mov  eax, [eax]           // retrieve TService self value
  mov  edx, [esp+4]
  call TService.CtrlHandle
  ret  4
end;
{$endif X86JUMPER}

function TService.GetControlHandler: TServiceControlHandler;
{$ifdef X86JUMPER}
var AfterCallAddr: Pointer;
    Offset: Integer;
{$endif X86JUMPER}
begin
  Result := fControlHandler;
  if not Assigned(Result) then
    ServiceLog.Add.Log(sllError,'%.GetControlHandler with fControlHandler=nil: '+
      'use TServiceSingle or set a custom ControlHandler',[self]);
  {$ifdef X86JUMPER}
  if not Assigned(Result) then
  begin
    raise EServiceException.Create('Automated jumper generation is not working: '+
     'use TServiceSingle or set a custom ControlHandler');
    if fJumper=nil then begin
      fJumper := VirtualAlloc(nil, 5+sizeof(Pointer), MEM_COMMIT, PAGE_EXECUTE_READWRITE);
      if fJumper=nil then
        raise EServiceException.CreateUTF8('Cannot allocate memory for service jump gate: %',
          [fSName]);
      AfterCallAddr := Pointer(PtrUInt(fJumper)+5);
      Offset := PtrUInt(@JumpToService)-PtrUInt(AfterCallAddr);
      fJumper[0] := $E8; // call opcode
      PInteger(@fJumper[1])^ := Offset;       // points to JumpToService
      PPtrUInt(@fJumper[5])^ := PtrUInt(self); // will be set as EAX=self
    end;
    Result := Pointer(fJumper);
  end;
  {$endif X86JUMPER}
end;

function TService.GetInstalled: boolean;
begin
  with TServiceController.CreateOpenService('','',fSName,SERVICE_QUERY_STATUS) do
  try
    result := Handle<>0;
  finally
    Free;
  end;
end;

function TService.Install(const Params: string): boolean;
var schService: SC_HANDLE;
    schSCManager: SC_HANDLE;
    ServicePath: TFileName;
begin
  result := false;
  if installed then
    exit;
  ServicePath := ExeVersion.ProgramFileName;
  if Params<>'' then
    ServicePath := ServicePath+' '+Params;
  schSCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if (schSCManager>0) then begin
     schService := CreateService(schSCManager,
       pointer(fSName), pointer(fDName), SERVICE_ALL_ACCESS,
       fServiceType, fStartType, SERVICE_ERROR_NORMAL,
       pointer(ServicePath), nil, nil, nil, nil, nil);
     if (schService>0) then begin
       result := true;
       CloseServiceHandle(schService);
     end;
  end;
end;

procedure TService.Remove;
begin
  with TServiceController.CreateOpenService('','',fSName,SERVICE_ALL_ACCESS) do
  try
    if Handle=0 then exit;
    Stop;
    Delete;
  finally
    Free;
  end;
end;

function TService.ReportStatus(dwState, dwExitCode, dwWait: DWORD): BOOL;
var status: string;
begin
  status := ServiceStateText(CurrentStateToServiceState(dwState));
  ServiceLog.Add.Log(sllInfo,'% ReportStatus(%,%,%)',
    [ServiceName,status,dwExitCode,dwWait],self);
  if dwState = SERVICE_START_PENDING then
    fStatusRec.dwControlsAccepted := 0 else
    fStatusRec.dwControlsAccepted := 31;
  fStatusRec.dwCurrentState  := dwState;
  fStatusRec.dwWin32ExitCode := dwExitCode;
  fStatusRec.dwWaitHint := dwWait;
  if (dwState = SERVICE_RUNNING) or (dwState = SERVICE_STOPPED) then
    fStatusRec.dwCheckPoint := 0 else
    inc(fStatusRec.dwCheckPoint);
  result := SetServiceStatus(FStatusHandle, fStatusRec);
  if not result then
    ServiceLog.Add.Log(sllLastError,'% ReportStatus(%,%,%)',
      [ServiceName,status,dwExitCode,dwWait],self);
end;

procedure TService.SetControlHandler(const Value: TServiceControlHandler);
begin
  fControlHandler := Value;
  if fJumper<>nil then
    VirtualFree(fJumper, 0, MEM_RELEASE);
end;

procedure TService.SetStatus(const Value: TServiceStatus);
begin
  fStatusRec := Value;
  if FStatusHandle <> 0 then
    SetServiceStatus(FStatusHandle, fStatusRec);
end;

procedure TService.Start;
begin
  with TServiceController.CreateOpenService('','',fSName,SERVICE_ALL_ACCESS) do
  try
    Start([]);
  finally
    Free;
  end;
end;

procedure TService.Stop;
begin
  with TServiceController.CreateOpenService('','',fSName,SERVICE_ALL_ACCESS) do
  try
    Stop;
  finally
    Free;
  end;
end;

function CurrentStateToServiceState(CurrentState: DWORD): TServiceState;
begin
  case CurrentState of
    SERVICE_STOPPED:          result := ssStopped;
    SERVICE_START_PENDING:    result := ssStarting;
    SERVICE_STOP_PENDING:     result := ssStopping;
    SERVICE_RUNNING:          result := ssRunning;
    SERVICE_CONTINUE_PENDING: result := ssResuming;
    SERVICE_PAUSE_PENDING:    result := ssPausing;
    SERVICE_PAUSED:           result := ssPaused;
    else result := ssNotInstalled; // e.g. SERVICE_CONTROL_SHUTDOWN
  end;
end;

function ServiceStateText(State: TServiceState): string;
var P: PShortString;
begin
  P := GetEnumName(TypeInfo(TServiceState),ord(State));
  result := string(copy(P^,3,length(P^)-2));
end;

function GetServicePid(const aServiceName: string): DWORD;
var
  ssp: TServiceStatusProcess;
  scm: THandle;
  svc: THandle;
  size: DWORD;
begin
  result := 0;
  scm := OpenSCManager(nil, nil, SC_MANAGER_CONNECT);
  if scm <> 0 then
  try
    svc := OpenService(scm, pointer(aServiceName), SERVICE_QUERY_STATUS);
    if svc <> 0 then
    try
      if QueryServiceStatusEx(svc, SC_STATUS_PROCESS_INFO, @ssp, SizeOf(TServiceStatusProcess), size) then
        result := ssp.dwProcessId
      else
        ServiceLog.Add.Log(sllLastError);
    finally
      CloseServiceHandle(svc);
    end;
  finally
    CloseServiceHandle(scm);
  end;
end;

function KillProcess(pid: DWORD; waitseconds: integer): boolean;
var
  ph: THandle;
begin
  ph := OpenProcess(PROCESS_TERMINATE or SYNCHRONIZE, false, pid);
  result := ph <> 0;
  if result then begin
    try
      result := TerminateProcess(ph, 0) and (WaitForSingleObject(ph, waitseconds * 1000) <> WAIT_TIMEOUT);
    finally
      CloseHandle(ph);
    end;
  end;
end;

{  function that a service process specifies as the entry point function
  of a particular service. The function can have any application-defined name
  - Args points to an array of pointers that point to null-terminated
    argument strings. The first argument in the array is the name of the service,
    and subsequent arguments are any strings passed to the service by the process
    that called the StartService function to start the service.  }
procedure ServiceProc(ArgCount: DWORD; Args: PPChar); stdcall;
var i: integer;
    Srv: TService;
begin
  i := FindServiceIndex(Args^);
  if i<0 then
    exit; // avoid any GPF
  Srv := Services.Items[i];
  for i := 1 to ArgCount-1 do begin
    Inc(Args);
    SetLength(Srv.FArgsList, length(Srv.FArgsList)+1);
    Srv.FArgsList[high(Srv.FArgsList)] := Args^;
  end;
  Srv.FStatusHandle := RegisterServiceCtrlHandler(
    pointer(Srv.fSName), @Srv.ControlHandler);
  if Srv.FStatusHandle = 0 then begin
    Srv.ReportStatus(SERVICE_STOPPED, GetLastError, 0);
    Exit;
  end;
  Srv.ReportStatus(SERVICE_START_PENDING, 0, 0);
  Srv.Execute;
end;

function ServicesRun: boolean;
var S: array of TServiceTableEntry;
    service: TService;
    i: integer;
    {$ifndef NOEXCEPTIONINTERCEPT}
    dummy: TSynLog;
    {$endif}
begin
  if (Services=nil) or (Services.Count=0) then begin
    result := false;
    exit;
  end;
  for i := 0 to Services.Count-1 do begin
    service := Services.List[i];
    if not assigned(service.fControlHandler) then
      raise EServiceException.CreateUTF8('%.ControlHandler=nil (ServiceName="%"): '+
       'use TServiceSingle or set a custom ControlHandler',[service,service.ServiceName]);
  end;
  SetLength(S,Services.Count+1); // +1 so that the latest entry is nil
  for i := 0 to Services.Count-1 do begin
    S[i].lpServiceName := pointer(TService(Services.List[i]).ServiceName);
    S[i].lpServiceProc := ServiceProc;
  end;
  {$ifndef NOEXCEPTIONINTERCEPT}
  dummy := GlobalCurrentHandleExceptionSynLog;
  GlobalCurrentHandleExceptionSynLog := nil; // don't log any EExternalException
  try
  {$endif}
    result := StartServiceCtrlDispatcher(pointer(S));
  {$ifndef NOEXCEPTIONINTERCEPT}
  finally
    GlobalCurrentHandleExceptionSynLog := dummy;
  end;
  {$endif}
end;

{ TServiceSingle }

procedure SingleServiceControlHandler(Opcode: LongWord); stdcall;
begin
  if ServiceSingle<>nil then
    ServiceSingle.DoCtrlHandle(Opcode);
end;

constructor TServiceSingle.Create(const aServiceName,
  aDisplayName: String);
begin
  inherited Create(aServiceName,aDisplayName);
  if ServiceSingle<>nil then
    raise EServiceException.Create('Only one TServiceSingle is allowed at a time');
  ServiceSingle := self;
  ControlHandler := SingleServiceControlHandler;
end;

destructor TServiceSingle.Destroy;
begin
  try
    inherited;
  finally
    ServiceSingle := nil;
  end;
end;

// redefined here so that we can share code with FPC and Delphi
function CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar;
  lpProcessAttributes, lpThreadAttributes: PSecurityAttributes;
  bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer;
  lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfo;
  out lpProcessInformation: TProcessInformation): BOOL; stdcall; external kernel32;
function GetExitCodeProcess(hProcess: THandle; out lpExitCode: DWORD): BOOL; stdcall;
  external kernel32;

function RunProcess(const path, arg1: TFileName; waitfor: boolean;
  const arg2,arg3,arg4,arg5,env: TFileName; envaddexisting: boolean): integer;
begin
  result := RunCommand(FormatString('"%" % % % % %', [path, arg1, arg2, arg3, arg4, arg5]),
    waitfor, env, envaddexisting);
end;

var
  EnvironmentCache: SynUnicode;

function RunCommand(const cmd: TFileName; waitfor: boolean;
  const env: TFileName; envaddexisting: boolean; parsed: PParseCommands): integer;
var
  startupinfo: TStartupInfo; // _STARTUPINFOW or _STARTUPINFOA is equal here
  processinfo: TProcessInformation;
  path: TFileName;
  wcmd, wenv, wpath: SynUnicode;
  e, p: PWideChar;
  exitcode: DWORD;
  i: integer;
begin
  // https://support.microsoft.com/en-us/help/175986/info-understanding-createprocess-and-command-line-arguments
  result := -1;
  if cmd = '' then
    exit;
  // CreateProcess can alter the strings -> use local SynUnicode
  StringToSynUnicode(cmd, wcmd);
  if cmd[1] = '"' then begin
    path := copy(cmd, 2, maxInt);
    i := Pos('"', path);
    if i = 0 then
      exit;
    SetLength(path, i - 1); // unquote "path" string
  end
  else begin
    i := Pos(' ', cmd);
    if i <= 1 then
      exit;
    path := copy(cmd, 1, i - 1);
  end;
  path := ExtractFilePath(path);
  if path = '' then
    path := ExeVersion.ProgramFilePath;
  StringToSynUnicode(path, wpath);
  if env <> '' then begin
    StringToSynUnicode(env, wenv);
    if envaddexisting then begin
      GlobalLock;
      if EnvironmentCache = '' then begin
        e := GetEnvironmentStringsW;
        p := e;
        while p^ <> #0 do
          inc(p, StrLenW(p) + 1); // go to name=value#0 pairs end
        SetString(EnvironmentCache, e, (PtrUInt(p) - PtrUInt(e)) shr 1);
        FreeEnvironmentStringsW(e);
      end;
      wenv := EnvironmentCache + wenv;
      GlobalUnLock;
    end;
  end;
  FillCharFast(startupinfo, SizeOf(startupinfo), 0);
  startupinfo.cb := SizeOf(startupinfo);
  FillCharFast(processinfo, SizeOf(processinfo), 0);
  // https://docs.microsoft.com/pl-pl/windows/desktop/ProcThread/process-creation-flags
  if CreateProcessW(nil, pointer(wcmd), nil, nil, false, CREATE_UNICODE_ENVIRONMENT or
      CREATE_DEFAULT_ERROR_MODE or DETACHED_PROCESS or CREATE_NEW_PROCESS_GROUP,
      pointer(wenv), pointer(wpath), startupinfo, processinfo) then begin
    if waitfor then
      if WaitForSingleObject(processinfo.hProcess,INFINITE) = WAIT_FAILED then
        result := -GetLastError
      else if not GetExitCodeProcess(processinfo.hProcess, exitcode) then
        result := -GetLastError
      else
        result := exitcode
    else
      result := 0;
    CloseHandle(processinfo.hProcess);
    CloseHandle(processinfo.hThread);
  end else
    result := -GetLastError;
end;

{$else} // Linux/POSIX signal interception

var
  SynDaemonIntercepted: boolean;
  SynDaemonInterceptLog: TSynLogClass;

{$ifdef FPC}
procedure DoShutDown(Sig: Longint; Info: PSigInfo; Context: PSigContext); cdecl;
var level: TSynLogInfo;
    log: TSynLog;
    si_code: integer;
    text: TShort4;
begin // code below has no memory (re)allocation
  if SynDaemonInterceptLog <> nil then begin
    log := SynDaemonInterceptLog.Add;
    case Sig of
      SIGQUIT: text := 'QUIT';
      SIGTERM: text := 'TERM';
      SIGINT:  text := 'INT';
      SIGABRT: text := 'ABRT';
      else text := UInt3DigitsToShort(Sig);
    end;
    if Sig = SIGTERM then // polite quit
      level := sllInfo else
      level := sllExceptionOS;
    if Info=nil then
      si_code := 0 else
      si_code := Info^.si_code;
    log.Writer.CustomOptions := log.Writer.CustomOptions + [twoFlushToStreamNoAutoResize];
    log.Log(level, 'SynDaemonIntercepted received SIG%=% si_code=%', [text, Sig, si_code]);
    log.Flush({flushtodisk=}Sig <> SIGTERM); // ensure all log is safely written
  end;
  SynDaemonTerminated := Sig;
end;
{$else}
procedure DoShutDown(Sig: integer); cdecl;
begin
  SynDaemonTerminated := Sig;
end;
{$endif FPC}

procedure SynDaemonIntercept(log: TSynLog);
var
  saOld, saNew: {$ifdef FPC}SigactionRec{$else}TSigAction{$endif};
begin // note: SIGFPE/SIGSEGV/SIGBUS/SIGILL are handled by the RTL
  if SynDaemonIntercepted then
    exit;
  SynDaemonIntercepted := true;
  SynDaemonInterceptLog := log.LogClass;
  FillCharFast(saNew, SizeOf(saNew), 0);
  {$ifdef FPC}
  saNew.sa_handler := @DoShutDown;
  fpSigaction(SIGQUIT, @saNew, @saOld);
  fpSigaction(SIGTERM, @saNew, @saOld);
  fpSigaction(SIGINT, @saNew, @saOld);
  fpSigaction(SIGABRT, @saNew, @saOld);
  {$else} // Kylix
  saNew.__sigaction_handler := @DoShutDown;
  sigaction(SIGQUIT, @saNew, @saOld);
  sigaction(SIGTERM, @saNew, @saOld);
  sigaction(SIGINT, @saNew, @saOld);
  sigaction(SIGABRT, @saNew, @saOld);
  {$endif}
end;

function RunUntilSigTerminatedPidFile: TFileName;
begin
  result := FormatString('%.%.pid', [ExeVersion.ProgramFilePath, ExeVersion.ProgramName]);
end;

function RunUntilSigTerminatedForKill(waitseconds: integer): boolean;
var
  pid: PtrInt;
  pidfilename: TFileName;
  tix: Int64;
begin
  result := false;
  pidfilename := RunUntilSigTerminatedPidFile;
  pid := GetInteger(pointer(StringFromFile(pidfilename)));
  if pid <= 0 then
    exit;
  {$ifdef FPC}
  if fpkill(pid, SIGTERM) <> 0 then // polite quit
    if fpgeterrno<>ESysESRCH then
  {$else} // Kylix
  if kill(pid, SIGTERM) <> 0 then
    if errno<>ESRCH then
  {$endif}
      exit else // no such process -> try to delete the .pid file
      if DeleteFile(pidfilename) then begin
        result := true; // process crashed or hard reboot -> nothing to kill
        exit;
      end;
  if waitseconds <= 0 then begin
    result := true;
    exit;
  end;
  tix := GetTickCount64 + waitseconds * 1000;
  repeat // RunUntilSigTerminated() below should delete the .pid file
    sleep(100);
    if not FileExists(pidfilename) then
      result := true;
  until result or (GetTickCount64 > tix);
  if not result then
    {$ifdef FPC}fpkill{$else}kill{$endif}(pid, SIGKILL); // finesse
end;

procedure CleanAfterFork;
begin
  {$ifdef FPC}fpUMask{$else}umask{$endif}(0); // reset file mask
  chdir('/'); // avoid locking current directory
  Close(input);
  AssignFile(input, '/dev/null');
  ReWrite(input);
  Close(output);
  AssignFile(output, '/dev/null');
  ReWrite(output);
  {$ifdef FPC}Close{$else}__close{$endif}(stderr);
end;

procedure RunUntilSigTerminated(daemon: TObject; dofork: boolean;
  const start, stop: TThreadMethod; log: TSynLog; const servicename: string);
var
  pid, sid: {$ifdef FPC}TPID{$else}pid_t{$endif};
  pidfilename: TFileName;
const
  TXT: array[boolean] of string[4] = ('run', 'fork');
begin
  SynDaemonIntercept(log);
  if dofork then begin
    pidfilename := RunUntilSigTerminatedPidFile;
    pid := GetInteger(pointer(StringFromFile(pidfilename)));
    if pid > 0 then
      if ({$ifdef FPC}fpkill{$else}kill{$endif}(pid, 0) = 0) or not DeleteFile(pidfilename) then
        raise EServiceException.CreateUTF8('%.CommandLine Fork failed: % is already forked as pid=%',
          [daemon, ExeVersion.ProgramName, pid]);
    pid := {$ifdef FPC}fpFork{$else}fork{$endif};
    if pid < 0 then
      raise EServiceException.CreateUTF8('%.CommandLine Fork failed', [daemon]);
    if pid > 0 then  // main program - just terminate
      exit;
    // clean forked instance
    sid := {$ifdef FPC}fpSetSID{$else}setsid{$endif};
    if sid < 0 then // new session (process group) created?
      raise EServiceException.CreateUTF8('%.CommandLine SetSID failed', [daemon]);
    CleanAfterFork;
    // create local .[ExeVersion.ProgramName].pid file
    pid := {$ifdef FPC}fpgetpid{$else}getpid{$endif};
    FileFromString(Int64ToUtf8(pid), pidfilename);
  end;
  try
    if log <> nil then
      log.Log(sllNewRun, 'Start % /% %', [serviceName, TXT[dofork],
        ExeVersion.Version.DetailedOrVoid], daemon);
    start;
    while SynDaemonTerminated = 0 do
      if GetCurrentThreadID = MainThreadID then
        CheckSynchronize(100) else
        Sleep(100);
  finally
    if log <> nil then
      log.Log(sllNewRun, 'Stop /% from Sig=%', [TXT[dofork], SynDaemonTerminated], daemon);
    try
      stop;
    finally
      if dofork and (pidfilename <> '') then begin
        DeleteFile(pidfilename);
        if log <> nil then
          log.Log(sllTrace, 'RunUntilSigTerminated: deleted file %', [pidfilename]);
      end;
    end;
  end;
end;

{$ifndef FPC} // Kylix doesn't have a proper WaitProcess
function WaitProcess(pid: pid_t): pid_t;
var r: pid_t;
    s: integer;
begin
  repeat
    r := WaitPid(pid, @s, 0);
    if (r = -1) and (errno = EINTR) then
      r := 0;
  until r <> 0;
  if r < 0 then // WaitPid() failed
    result := -1 else
    if WIFEXITED(s) then // returns the exit status code
      result := WEXITSTATUS(s) else
      result := -abs(s); // ensure returns a negative value for other errors
end;
{$endif FPC}

function RunInternal(args: PPAnsiChar; waitfor: boolean;
  const env: TFileName; envaddexisting: boolean): integer;
var
  pid: {$ifdef FPC}TPID{$else}pid_t{$endif};
  e: array[0..511] of PAnsiChar; // max 512 environment variables
  envpp: PPAnsiChar;
  P: PAnsiChar;
  n: PtrInt;
begin
  {$ifdef FPC}
  {$if (defined(BSD) or defined(SUNOS)) and defined(FPC_USE_LIBC)}
  pid := FpvFork;
  {$else}
  pid := FpFork;
  {$ifend}
  {$else}
  pid := fork; // Kylix
  {$endif FPC}
  if pid < 0 then begin
    result := -1; // fork failed
    exit;
  end;
  if pid = 0 then begin // we are in child process -> switch to new executable
    if not waitfor then
      CleanAfterFork; // don't share the same console
    envpp := envp;
    if env <> '' then begin
      n := 0;
      result := {$ifdef FPC}-ESysE2BIG{$else}-7{$endif};
      if envaddexisting and (envpp <> nil) then begin
        while envpp^ <> nil do begin
          if PosChar(envpp^, #10) = nil then begin // filter simple variables
            if n = high(e) - 1 then
              exit;
            e[n] := envpp^;
            inc(n);
          end;
          inc(envpp);
        end;
      end;
      P := pointer(env); // env follows Windows layout 'n1=v1'#0'n2=v2'#0#0
      while P^ <> #0 do begin
        if n = high(e) - 1 then
          exit;
        e[n] := P; // makes POSIX compatible
        inc(n);
        inc(P, StrLen(P) + 1);
      end;
      e[n] := nil; // end with null
      envpp := @e;
    end;
    {$ifdef FPC}
    FpExecve(args^, args, envpp);
    FpExit(127);
    {$else}
    execve(args^, args, envpp);
    _exit(127);
    {$endif}
  end;
  if waitfor then begin
    result := WaitProcess(pid);
    if result = 127 then
      result := -result; // execv() failed in child process
  end else
    result := 0; // fork success (don't wait for the child process to fail)
end;

function RunProcess(const path, arg1: TFileName; waitfor: boolean;
  const arg2,arg3,arg4,arg5,env: TFileName; envaddexisting: boolean): integer;
var
  a: array[0..6] of PAnsiChar;   // assume no UNICODE on BSD, i.e. as TFileName
begin
  a[0] := pointer(path);
  a[1] := pointer(arg1);
  a[2] := pointer(arg2);
  a[3] := pointer(arg3);
  a[4] := pointer(arg4);
  a[5] := pointer(arg5);
  a[6] := nil; // end with null
  result := RunInternal(@a, waitfor, env, envaddexisting);
end;

function RunCommand(const cmd: TFileName; waitfor: boolean;
  const env: TFileName; envaddexisting: boolean;
  parsed: PParseCommands): integer;
var
  temp: RawUTF8;
  err: TParseCommands;
  a: TParseCommandsArgs;
begin
  err := ParseCommandArgs(cmd, @a, nil, @temp);
  if parsed <> nil then
    parsed^ := err;
  if err = [] then
    // no need to spawn the shell for simple commands
    result := RunInternal(a, waitfor, env, envaddexisting)
  else if err * PARSECOMMAND_ERROR <> [] then
    // no system call for clearly invalid command line
    result := {$ifdef FPCLINUXNOTBSD}-ESysELIBBAD{$else}-80{$endif}
  else begin // execute complex commands via the shell
    a[0] := '/bin/sh';
    a[1] := '-c';
    a[2] := pointer(cmd);
    a[3] := nil;
    result := RunInternal(@a, waitfor, env, envaddexisting);
  end;
end;

{$endif MSWINDOWS}

function ToText(cmd: TParseCommands): shortstring;
begin
  if cmd = [] then
    result[0] := #0
  else
    GetSetNameShort(TypeInfo(TParseCommands), cmd, result, {trim=}true);
end;

function ParseCommandArgs(const cmd: RawUTF8; argv: PParseCommandsArgs;
  argc: PInteger; temp: PRawUTF8; posix: boolean): TParseCommands;
var
  n: PtrInt;
  state: set of (sWhite, sInArg, sInSQ, sInDQ, sSpecial, sBslash);
  c: AnsiChar;
  D, P: PAnsiChar;
begin
  result := [pcInvalidCommand];
  if argv <> nil then
    argv[0] := nil;
  if argc <> nil then
    argc^ := 0;
  if cmd = '' then
    exit;
  if argv = nil then
    D := nil
  else begin
    if temp = nil then
      exit;
    SetLength(temp^, length(cmd));
    D := pointer(temp^);
  end;
  state := [];
  n := 0;
  P := pointer(cmd);
  repeat
    c := P^;
    if D <> nil then
      D^ := c;
    inc(P);
    case c of
      #0: begin
        if sInSQ in state then
          include(result, pcUnbalancedSingleQuote);
        if sInDQ in state then
          include(result, pcUnbalancedDoubleQuote);
        exclude(result, pcInvalidCommand);
        if argv <> nil then
          argv[n] := nil;
        if argc <> nil then
          argc^ := n;
        exit;
      end;
      #1 .. ' ': begin
       if state = [sInArg] then begin
         state := [];
         if D <> nil then begin
           D^ := #0;
           inc(D);
         end;
         continue;
       end;
       if state * [sInSQ, sInDQ] = [] then
         continue;
      end;
      '\':
        if posix and (state * [sInSQ, sBslash] = []) then
          if sInDQ in state then begin
            case P^ of
              '"', '\', '$', '`': begin
                include(state, sBslash);
                continue;
              end;
            end;
          end else if P^ = #0 then begin
            include(result, pcHasEndingBackSlash);
            exit;
          end else begin
            if D <> nil then
              D^ := P^;
            inc(P);
          end;
      '^':
        if not posix and (state * [sInSQ, sInDQ, sBslash] = []) then
          if PWord(P)^ = $0a0d then begin
            inc(P, 2);
            continue;
          end
          else if P^ = #0 then begin
            include(result, pcHasEndingBackSlash);
            exit;
          end else begin
            if D <> nil then
              D^ := P^;
            inc(P);
          end;
      '''':
        if posix and not(sInDQ in state) then
          if sInSQ in state then begin
            exclude(state, sInSQ);
            continue;
          end else if state = [] then begin
            if argv <> nil then begin
              argv[n] := D;
              inc(n);
              if n = high(argv^) then
                exit;
            end;
            state := [sInSQ, sInArg];
            continue;
          end else if state = [sInArg] then begin
            state := [sInSQ, sInArg];
            continue;
          end;
      '"':
        if not(sInSQ in state) then
          if sInDQ in state then begin
            exclude(state, sInDQ);
            continue;
          end else if state = [] then begin
            if argv <> nil then begin
              argv[n] := D;
              inc(n);
              if n = high(argv^) then
                exit;
            end;
            state := [sInDQ, sInArg];
            continue;
          end else if state = [sInArg] then begin
            state := [sInDQ, sInArg];
            continue;
          end;
      '|', '<', '>':
        if state * [sInSQ, sInDQ] = [] then
          include(result, pcHasRedirection);
      '&', ';':
        if posix and (state * [sInSQ, sInDQ] = []) then begin
          include(state, sSpecial);
          include(result, pcHasJobControl);
        end;
      '`':
        if posix and (state * [sInSQ, sBslash] = []) then
           include(result, pcHasSubCommand);
      '(', ')':
        if posix and (state * [sInSQ, sInDQ] = []) then
          include(result, pcHasParenthesis);
      '$':
        if posix and (state * [sInSQ, sBslash] = []) then
          if p^ = '(' then
            include(result, pcHasSubCommand)
          else
            include(result, pcHasShellVariable);
      '*', '?':
        if posix and (state * [sInSQ, sInDQ] = []) then
          include(result, pcHasWildcard);
    end;
    exclude(state, sBslash);
    if state = [] then begin
      if argv <> nil then begin
        argv[n] := D;
        inc(n);
        if n = high(argv^) then
          exit;
      end;
      state := [sInArg];
    end;
    if D <> nil then
      inc(D);
  until false;
end;


{ *** cross-plaform high-level services }

{ TSynDaemonSettings }

constructor TSynDaemonSettings.Create;
begin
  inherited Create;
  fLog := LOG_STACKTRACE + [sllNewRun];
  fLogRotateFileCount := 2;
  fServiceName := UTF8ToString(ExeVersion.ProgramName);
  fServiceDisplayName := fServiceName;
end;

function TSynDaemonSettings.ServiceDescription: string;
var
  versionnumber: string;
begin
  result := ServiceDisplayName;
  with ExeVersion.Version do begin
    versionnumber := DetailedOrVoid;
    if versionnumber <> '' then
      result := result + ' ' + versionnumber;
    if CompanyName <> '' then
      result := FormatString('% - (c)% %', [result, BuildYear, CompanyName]);
  end;
end;

procedure TSynDaemonSettings.SetLog(aLogClass: TSynLogClass);
begin
  if (self <> nil) and (Log <> []) and (aLogClass <> nil) then
    with aLogClass.Family do begin
      DestinationPath := LogPath;
      PerThreadLog := ptIdentifiedInOnFile; // ease multi-threaded server debug
      RotateFileCount := LogRotateFileCount;
      if RotateFileCount > 0 then begin
        RotateFileSizeKB := 20 * 1024; // rotate by 20 MB logs
        FileExistsAction := acAppend;  // as expected in rotation mode
      end
      else
        HighResolutionTimestamp := true;
      Level := Log;
      fLogClass := aLogClass;
    end;
end;


{ TSynDaemon }

constructor TSynDaemon.Create(aSettingsClass: TSynDaemonSettingsClass;
  const aWorkFolder, aSettingsFolder, aLogFolder, aSettingsExt, aSettingsName: TFileName);
var
  fn: TFileName;
begin
  inherited Create;
  if aWorkFolder = '' then
    fWorkFolderName := ExeVersion.ProgramFilePath
  else
    fWorkFolderName := EnsureDirectoryExists(aWorkFolder, true);
  if aSettingsClass = nil then
    aSettingsClass := TSynDaemonSettings;
  fSettings := aSettingsClass.Create;
  fn := aSettingsFolder;
  if fn = '' then
    fn := {$ifdef MSWINDOWS}fWorkFolderName{$else}'/etc/'{$endif};
  fn :=  EnsureDirectoryExists(fn);
  if aSettingsName = '' then
    fn := fn + UTF8ToString(ExeVersion.ProgramName)
  else
    fn := fn + aSettingsName;
  fSettings.LoadFromFile(fn + aSettingsExt);
  if fSettings.LogPath = '' then
    if aLogFolder = '' then
      fSettings.LogPath := {$ifdef MSWINDOWS}fWorkFolderName{$else}GetSystemPath(spLog){$endif}
    else
      fSettings.LogPath := EnsureDirectoryExists(aLogFolder);
end;

destructor TSynDaemon.Destroy;
begin
  if fSettings <> nil then
    fSettings.SaveIfNeeded;
  Stop;
  inherited Destroy;
  FreeAndNil(fSettings);
end;

{$ifdef MSWINDOWS}
procedure TSynDaemon.DoStart(Sender: TService);
begin
  Start;
end;

procedure TSynDaemon.DoStop(Sender: TService);
begin
  Stop;
end;
{$endif MSWINDOWS}

function TSynDaemon.CustomCommandLineSyntax: string;
begin
  result := '';
end;

{$I-}

type
  TExecuteCommandLineCmd = (
     cNone, cVersion, cVerbose, cStart, cStop, cState, cSilentKill,
     cHelp, cInstall, cRun, cFork, cUninstall, cConsole, cKill);

procedure TSynDaemon.CommandLine(aAutoStart: boolean);
const CMD_CHR: array[cHelp .. cKill] of AnsiChar = ('H', 'I', 'R', 'F', 'U', 'C', 'K');
var
  cmd, c: TExecuteCommandLineCmd;
  p: PUTF8Char;
  ch: AnsiChar;
  param: RawUTF8;
  exe: RawByteString;
  log: TSynLog;
  {$ifdef MSWINDOWS}
  service: TServiceSingle;
  ctrl: TServiceController;
  {$endif MSWINDOWS}

  procedure WriteCopyright;
  var
    msg, name, copyright: string;
    i: integer;
  begin
    msg := fSettings.ServiceDescription;
    i := Pos(' - ', msg);
    if i = 0 then
      name := msg
    else begin
      name := copy(msg, 1, i - 1);
      copyright := copy(msg, i + 3, 1000);
    end;
    TextColor(ccLightGreen);
    writeln(' ', name);
    writeln(StringOfChar('-', length(name) + 2));
    TextColor(ccGreen);
    if copyright <> '' then
      writeln(' ', copyright);
    writeln;
    TextColor(ccLightGray);
  end;

  procedure Syntax;
  var
    spaces, custom: string;
  begin
    WriteCopyright;
    writeln('Try with one of the switches:');
    spaces := StringOfChar(' ', length(ExeVersion.ProgramName) + 4);
    {$ifdef MSWINDOWS}
    writeln('   ', ExeVersion.ProgramName, ' /console -c /verbose /help -h /version');
    writeln(spaces, '/install /uninstall /start /stop /state');
    {$else}
    writeln(' ./', ExeVersion.ProgramName, ' --console -c --verbose --help -h --version');
    writeln(spaces, '--run -r --fork -f --kill -k');
    {$endif MSWINDOWS}
    custom := CustomCommandLineSyntax;
    if custom <> '' then
      writeln(spaces, custom);
  end;

  function cmdText: RawUTF8;
  begin
    result := GetEnumNameTrimed(TypeInfo(TExecuteCommandLineCmd), cmd);
  end;

  procedure Show(Success: Boolean);
  var
    msg: RawUTF8;
    error: integer;
  begin
    WriteCopyright;
    if Success then begin
      msg := 'Successfully executed';
      TextColor(ccWhite);
    end
    else begin
      error := GetLastError;
      msg := FormatUTF8('Error % [%] occured with',
        [error, StringToUTF8(SysErrorMessage(error))]);
      TextColor(ccLightRed);
      ExitCode := 1; // notify error to caller batch
    end;
    msg := FormatUTF8('% [%] (%) on Service ''%''',
      [msg, param, cmdText, fSettings.ServiceName]);
    writeln(UTF8ToConsole(msg));
    TextColor(ccLightGray);
    log.Log(sllDebug, 'CommandLine: %', [msg], self);
  end;

begin
  if (self = nil) or (fSettings = nil) then
    exit;
  log := nil;
  param := trim(StringToUTF8(paramstr(1)));
  cmd := cNone;
  if (param <> '') and (param[1] in ['/', '-']) then begin
    p := @param[2];
    if p^ = '-' then
      inc(p); // allow e.g. --fork switch (idem to /f -f /fork -fork)
    ch := NormToUpper[p^];
    for c := low(CMD_CHR) to high(CMD_CHR) do
      if CMD_CHR[c] = ch then begin
        cmd := c;
        break;
      end;
    if cmd = cNone then
      byte(cmd) := ord(cVersion) +
        IdemPCharArray(p, ['VERS', 'VERB', 'START', 'STOP', 'STAT', 'SILENTK']);
    end;
  try
    case cmd of
    cHelp:
      Syntax;
    cVersion: begin
      WriteCopyright;
      exe := StringFromFile(ExeVersion.ProgramFileName);
      writeln(' ', fSettings.ServiceName,
        #13#10' Size: ', length(exe), ' bytes (', KB(exe), ')' +
        #13#10' Build date: ', ExeVersion.Version.BuildDateTimeString,
        #13#10' MD5: ', MD5(exe),
        #13#10' SHA256: ', SHA256(exe));
      if ExeVersion.Version.Version32 <> 0 then
        writeln(' Version: ', ExeVersion.Version.Detailed);
    end;
    cConsole, cVerbose: begin
        WriteCopyright;
        writeln('Launched in ', cmdText, ' mode'#10);
        TextColor(ccLightGray);
        log := fSettings.fLogClass.Add;
        if (cmd = cVerbose) and (log <> nil) then begin
          log.Family.Level := LOG_VERBOSE;
          log.Family.EchoToConsole := LOG_VERBOSE;
        end;
        try
          log.Log(sllNewRun, 'Start % /% %', [fSettings.ServiceName,cmdText,
            ExeVersion.Version.DetailedOrVoid], self);
          fConsoleMode := true;
          Start;
          writeln('Press [Enter] to quit');
          ioresult;
          readln;
          writeln('Shutting down server');
        finally
          ioresult;
          log.Log(sllNewRun, 'Stop /%', [cmdText], self);
          Stop;
        end;
    end;
    {$ifdef MSWINDOWS} // implement the daemon as a Windows Service
    else if fSettings.ServiceName = '' then
      if cmd = cNone then
        Syntax
      else begin
        TextColor(ccLightRed);
        writeln('No ServiceName specified - please fix the settings');
      end
    else
    case cmd of
      cNone:
        if param = '' then begin // executed as a background service
          service := TServiceSingle.Create(
            fSettings.ServiceName, fSettings.ServiceDisplayName);
          try
            service.OnStart := DoStart;
            service.OnStop := DoStop;
            service.OnShutdown := DoStop; // sometimes, is called without Stop
            if ServicesRun then // blocking until service shutdown
              Show(true)
            else if GetLastError = 1063 then
              Syntax
            else
              Show(false);
          finally
            service.Free;
          end;
        end
        else
          Syntax;
      cInstall:
        with fSettings do
          Show(TServiceController.Install(ServiceName, ServiceDisplayName,
            ServiceDescription, aAutoStart, '', ServiceDependencies) <> ssNotInstalled);
      cStart, cStop, cUninstall, cState: begin
        ctrl := TServiceController.CreateOpenService('', '', fSettings.ServiceName);
        try
          case cmd of
          cStart:
            Show(ctrl.Start([]));
          cStop:
            Show(ctrl.Stop);
          cUninstall:
            begin
              ctrl.Stop;
              Show(ctrl.Delete);
            end;
          cState:
            writeln(fSettings.ServiceName, ' State=', ServiceStateText(ctrl.State));
          end;
        finally
          ctrl.Free;
        end;
      end;
      else
        Syntax;
    end;
    {$else}
    cRun, cFork:
      RunUntilSigTerminated(self,(cmd=cFork),Start,Stop,fSettings.fLogClass.Add,fSettings.ServiceName);
    cKill, cSilentKill:
      if RunUntilSigTerminatedForKill then begin
        if cmd <> cSilentKill then
          writeln('Forked process ', ExeVersion.ProgramName, ' killed successfully');
      end
      else
        raise EServiceException.Create('No forked process found to be killed');
    else
      Syntax;
    {$endif MSWINDOWS}
    end;
  except
    on E: Exception do begin
      if cmd <> cSilentKill then
        ConsoleShowFatalException(E, true);
      ExitCode := 1; // indicates error
    end;
  end;
  if cmd <> cSilentKill then
    TextColor(ccLightGray);
  ioresult;
end;

{$I+}

{$ifdef MSWINDOWS}
const
  SE_CREATE_TOKEN_NAME           = 'SeCreateTokenPrivilege';
  SE_ASSIGNPRIMARYTOKEN_NAME     = 'SeAssignPrimaryTokenPrivilege';
  SE_LOCK_MEMORY_NAME            = 'SeLockMemoryPrivilege';
  SE_INCREASE_QUOTA_NAME         = 'SeIncreaseQuotaPrivilege';
  SE_UNSOLICITED_INPUT_NAME      = 'SeUnsolicitedInputPrivilege';
  SE_MACHINE_ACCOUNT_NAME        = 'SeMachineAccountPrivilege';
  SE_TCB_NAME                    = 'SeTcbPrivilege';
  SE_SECURITY_NAME               = 'SeSecurityPrivilege';
  SE_TAKE_OWNERSHIP_NAME         = 'SeTakeOwnershipPrivilege';
  SE_LOAD_DRIVER_NAME            = 'SeLoadDriverPrivilege';
  SE_SYSTEM_PROFILE_NAME         = 'SeSystemProfilePrivilege';
  SE_SYSTEMTIME_NAME             = 'SeSystemtimePrivilege';
  SE_PROF_SINGLE_PROCESS_NAME    = 'SeProfileSingleProcessPrivilege';
  SE_INC_BASE_PRIORITY_NAME      = 'SeIncreaseBasePriorityPrivilege';
  SE_CREATE_PAGEFILE_NAME        = 'SeCreatePagefilePrivilege';
  SE_CREATE_PERMANENT_NAME       = 'SeCreatePermanentPrivilege';
  SE_BACKUP_NAME                 = 'SeBackupPrivilege';
  SE_RESTORE_NAME                = 'SeRestorePrivilege';
  SE_SHUTDOWN_NAME               = 'SeShutdownPrivilege';
  SE_DEBUG_NAME                  = 'SeDebugPrivilege';
  SE_AUDIT_NAME                  = 'SeAuditPrivilege';
  SE_SYSTEM_ENVIRONMENT_NAME     = 'SeSystemEnvironmentPrivilege';
  SE_CHANGE_NOTIFY_NAME          = 'SeChangeNotifyPrivilege';
  SE_REMOTE_SHUTDOWN_NAME        = 'SeRemoteShutdownPrivilege';
  SE_UNDOCK_NAME                 = 'SeUndockPrivilege';
  SE_SYNC_AGENT_NAME             = 'SeSyncAgentPrivilege';
  SE_ENABLE_DELEGATION_NAME      = 'SeEnableDelegationPrivilege';
  SE_MANAGE_VOLUME_NAME          = 'SeManageVolumePrivilege';
  SE_IMPERSONATE_NAME            = 'SeImpersonatePrivilege';
  SE_CREATE_GLOBAL_NAME          = 'SeCreateGlobalPrivilege';
  SE_TRUSTED_CREDMAN_ACCESS_NAME = 'SeTrustedCredManAccessPrivilege';
  SE_RELABEL_NAME                = 'SeRelabelPrivilege';
  SE_INC_WORKING_SET_NAME        = 'SeIncreaseWorkingSetPrivilege';
  SE_TIME_ZONE_NAME              = 'SeTimeZonePrivilege';
  SE_CREATE_SYMBOLIC_LINK_NAME   = 'SeCreateSymbolicLinkPrivilege';

  MAX_SE_NAME_LENGTH = 31;

  WinSystemPrivilegeToSE_NAME: array[TWinSystemPrivilege] of string = (
    SE_CREATE_TOKEN_NAME,
    SE_ASSIGNPRIMARYTOKEN_NAME,
    SE_LOCK_MEMORY_NAME,
    SE_INCREASE_QUOTA_NAME,
    SE_UNSOLICITED_INPUT_NAME,
    SE_MACHINE_ACCOUNT_NAME,
    SE_TCB_NAME,
    SE_SECURITY_NAME,
    SE_TAKE_OWNERSHIP_NAME,
    SE_LOAD_DRIVER_NAME,
    SE_SYSTEM_PROFILE_NAME,
    SE_SYSTEMTIME_NAME,
    SE_PROF_SINGLE_PROCESS_NAME,
    SE_INC_BASE_PRIORITY_NAME,
    SE_CREATE_PAGEFILE_NAME,
    SE_CREATE_PERMANENT_NAME,
    SE_BACKUP_NAME,
    SE_RESTORE_NAME,
    SE_SHUTDOWN_NAME,
    SE_DEBUG_NAME,
    SE_AUDIT_NAME,
    SE_SYSTEM_ENVIRONMENT_NAME,
    SE_CHANGE_NOTIFY_NAME,
    SE_REMOTE_SHUTDOWN_NAME,
    SE_UNDOCK_NAME,
    SE_SYNC_AGENT_NAME,
    SE_ENABLE_DELEGATION_NAME,
    SE_MANAGE_VOLUME_NAME,
    SE_IMPERSONATE_NAME,
    SE_CREATE_GLOBAL_NAME,
    SE_TRUSTED_CREDMAN_ACCESS_NAME,
    SE_RELABEL_NAME,
    SE_INC_WORKING_SET_NAME,
    SE_TIME_ZONE_NAME,
    SE_CREATE_SYMBOLIC_LINK_NAME
  );

type
  PTOKEN_PRIVILEGES = ^TOKEN_PRIVILEGES;
  TOKEN_PRIVILEGES = packed record
    PrivilegeCount : DWORD;
    Privileges : array[0..0] of LUID_AND_ATTRIBUTES;
  end;

function OpenProcessToken(ProcessHandle: THandle; DesiredAccess: DWORD;
  var TokenHandle: THandle): BOOL; stdcall; external advapi32 name 'OpenProcessToken';
function LookupPrivilegeValue(lpSystemName, lpName: PChar;
  var lpLuid: TLargeInteger): BOOL; stdcall; external advapi32
  name {$ifdef UNICODE}'LookupPrivilegeValueW'{$else}'LookupPrivilegeValueA'{$endif};
function LookupPrivilegeNameA(lpSystemName: LPCSTR; var lpLuid: TLargeInteger;
  lpName: LPCSTR; var cbName: DWORD): BOOL; stdcall; external advapi32 name 'LookupPrivilegeNameA';
function AdjustTokenPrivileges(TokenHandle: THandle; DisableAllPrivileges: BOOL;
  const NewState: TOKEN_PRIVILEGES; BufferLength: DWORD;
  PreviousState: PTokenPrivileges; ReturnLength: PDWORD): BOOL; stdcall; external advapi32
  name 'AdjustTokenPrivileges';

{ TSynWindowsPrivileges }

procedure TSynWindowsPrivileges.Init(aTokenPrivilege: TPrivilegeTokenType);
var
  access: Cardinal;
begin
  Token := 0;
  fAvailable := [];
  fEnabled := [];
  fDefEnabled := [];
  access := TOKEN_QUERY or TOKEN_ADJUST_PRIVILEGES;
  if aTokenPrivilege = pttProcess then begin
    if not OpenProcessToken(GetCurrentProcess, access, Token) then
      raise ESynException.Create('TSynWindowsPrivileges cannot open process token');
  end
  else if not OpenThreadToken(GetCurrentThread, access, false, Token) then
    if GetLastError = ERROR_NO_TOKEN then begin
      if not ImpersonateSelf(SecurityImpersonation) or
       not OpenThreadToken(GetCurrentThread, access, false, Token) then
        raise ESynException.Create('TSynWindowsPrivileges cannot open thread token');
    end else
      raise ESynException.Create('TSynWindowsPrivileges cannot open thread token');
  LoadPrivileges;
end;

procedure TSynWindowsPrivileges.Done(aRestoreInitiallyEnabled: boolean = true);
var
  i: TWinSystemPrivilege;
  new: TWinSystemPrivileges;
begin
  if aRestoreInitiallyEnabled then begin
    new := fEnabled-fDefEnabled;
    for i := low(TWinSystemPrivilege) to high(TWinSystemPrivilege) do
      if i in new then
        Disable(i);
  end;
  CloseHandle(Token);
end;

function TSynWindowsPrivileges.Enable(aPrivilege: TWinSystemPrivilege): boolean;
begin
  result := aPrivilege in fEnabled;
  if result or not (aPrivilege in fAvailable) or not SetPrivilege(Pointer(WinSystemPrivilegeToSE_NAME[aPrivilege]), true) then
    exit;
  Include(fEnabled, aPrivilege);
  result := true;
end;

function TSynWindowsPrivileges.Disable(aPrivilege: TWinSystemPrivilege
  ): boolean;
begin
  result := not (aPrivilege in fEnabled);
  if result or not (aPrivilege in fAvailable) or not SetPrivilege(Pointer(WinSystemPrivilegeToSE_NAME[aPrivilege]), false) then
    exit;
  Exclude(fEnabled, aPrivilege);
  result := true;
end;

procedure TSynWindowsPrivileges.LoadPrivileges;
const
  UPCASE_SE_NAMES: array[TWinSystemPrivilege] of PAnsiChar = (
    'SECREATETOKENPRIVILEGE','SEASSIGNPRIMARYTOKENPRIVILEGE','SELOCKMEMORYPRIVILEGE',
    'SEINCREASEQUOTAPRIVILEGE','SEUNSOLICITEDINPUTPRIVILEGE','SEMACHINEACCOUNTPRIVILEGE',
    'SETCBPRIVILEGE','SESECURITYPRIVILEGE','SETAKEOWNERSHIPPRIVILEGE',
    'SELOADDRIVERPRIVILEGE','SESYSTEMPROFILEPRIVILEGE','SESYSTEMTIMEPRIVILEGE',
    'SEPROFILESINGLEPROCESSPRIVILEGE','SEINCREASEBASEPRIORITYPRIVILEGE',
    'SECREATEPAGEFILEPRIVILEGE','SECREATEPERMANENTPRIVILEGE','SEBACKUPPRIVILEGE',
    'SERESTOREPRIVILEGE','SESHUTDOWNPRIVILEGE','SEDEBUGPRIVILEGE','SEAUDITPRIVILEGE',
    'SESYSTEMENVIRONMENTPRIVILEGE','SECHANGENOTIFYPRIVILEGE','SEREMOTESHUTDOWNPRIVILEGE',
    'SEUNDOCKPRIVILEGE','SESYNCAGENTPRIVILEGE','SEENABLEDELEGATIONPRIVILEGE',
    'SEMANAGEVOLUMEPRIVILEGE','SEIMPERSONATEPRIVILEGE','SECREATEGLOBALPRIVILEGE',
    'SETRUSTEDCREDMANACCESSPRIVILEGE','SERELABELPRIVILEGE','SEINCREASEWORKINGSETPRIVILEGE',
    'SETIMEZONEPRIVILEGE','SECREATESYMBOLICLINKPRIVILEGE');
var
  buf: TSynTempBuffer;
  tp: PTOKEN_PRIVILEGES;
  len: Cardinal;
  i: integer;
  name: AnsiString;
  enumval: integer;
begin
  if Token = 0 then
    raise ESynException.Create('TSynWindowsPrivileges: invalid privileges token');
  buf.Init;
  try
    len := 0;
    if not GetTokenInformation(Token, TokenPrivileges, buf.buf, buf.len, len) then
      if GetLastError <> ERROR_INSUFFICIENT_BUFFER then
        raise ESynException.Create('TSynWindowsPrivileges cannot get token information')
      else begin
        buf.Done;
        buf.Init(len);
        if not GetTokenInformation(Token, TokenPrivileges, buf.buf, buf.len, len) then
          raise ESynException.Create('TSynWindowsPrivileges cannot get token information')
      end;
    tp := buf.buf;
    SetLength(name, MAX_SE_NAME_LENGTH);
    for i := 0 to tp.PrivilegeCount-1 do
    begin
      len := Length(name);
      if not LookupPrivilegeNameA(nil,tp.Privileges[i].Luid,@name[1],len) then
        if GetLastError <> ERROR_INSUFFICIENT_BUFFER then
          raise ESynException.CreateUTF8('TSynWindowsPrivileges cannot lookup privilege name for Luid (%)',
            [PInt64(@tp.Privileges[i].Luid)^]) // PInt64() to avoid URW699 on Delphi 6
        else begin
          SetLength(name, len);
          if not LookupPrivilegeNameA(nil,tp.Privileges[i].Luid,@name[1],len) then
            raise ESynException.CreateUTF8('TSynWindowsPrivileges cannot lookup privilege name for Luid (%)',
              [PInt64(@tp.Privileges[i].Luid)^])
        end;
      enumval := IdemPCharArray(@name[1], UPCASE_SE_NAMES);
      if (enumval >= ord(low(TWinSystemPrivilege))) and (enumval <= ord(high(TWinSystemPrivilege))) then begin
        Include(fAvailable, TWinSystemPrivilege(enumval));
        if tp.Privileges[i].Attributes and SE_PRIVILEGE_ENABLED <> 0 then
          Include(fDefEnabled, TWinSystemPrivilege(enumval));
      end;
    end;
    fEnabled := fDefEnabled;
  finally
    buf.Done;
  end;
end;

function TSynWindowsPrivileges.SetPrivilege(aPrivilege: Pointer;
  aEnablePrivilege: boolean): boolean;
var
  tp: TOKEN_PRIVILEGES;
  id: TLargeInteger;
  tpprev: TOKEN_PRIVILEGES;
  cbprev: DWORD;
begin
  result := false;
  cbprev := sizeof(TOKEN_PRIVILEGES);
  if not LookupPrivilegeValue(nil, aPrivilege, id) then
    exit;
  tp.PrivilegeCount := 1;
  tp.Privileges[0].Luid := PInt64(@id)^;
  tp.Privileges[0].Attributes := 0;
  AdjustTokenPrivileges(Token, false, tp, sizeof(TOKEN_PRIVILEGES), @tpprev, @cbprev);
  if GetLastError <> ERROR_SUCCESS then
    exit;
  tpprev.PrivilegeCount := 1;
  tpprev.Privileges[0].Luid := PInt64(@id)^;
  with tpprev.Privileges[0] do
    if aEnablePrivilege then
      Attributes := Attributes or SE_PRIVILEGE_ENABLED
    else
      Attributes := Attributes xor (SE_PRIVILEGE_ENABLED and Attributes);
  AdjustTokenPrivileges(Token, false, tpprev, cbprev, nil, nil);
  if GetLastError <> ERROR_SUCCESS then
    exit;
  result := true;
end;

const
  ntdll = 'NTDLL.DLL';

type
  _PPS_POST_PROCESS_INIT_ROUTINE = ULONG;

  PUNICODE_STRING = ^UNICODE_STRING;
  UNICODE_STRING = packed record
    Length: word;
    MaximumLength: word;
    {$ifdef CPUX64}
    _align: array[0..3] of byte;
    {$endif}
    Buffer: PWideChar;
  end;

  PMS_PEB_LDR_DATA = ^MS_PEB_LDR_DATA;
  MS_PEB_LDR_DATA = packed record
    Reserved1: array[0..7] of BYTE;
    Reserved2: array[0..2] of pointer;
    InMemoryOrderModuleList: LIST_ENTRY;
  end;

  PMS_RTL_USER_PROCESS_PARAMETERS = ^MS_RTL_USER_PROCESS_PARAMETERS;
  MS_RTL_USER_PROCESS_PARAMETERS = packed record
    Reserved1: array[0..15] of BYTE;
    Reserved2: array[0..9] of pointer;
    ImagePathName: UNICODE_STRING;
    CommandLine: UNICODE_STRING ;
  end;

  PMS_PEB = ^MS_PEB;
  MS_PEB = packed record
    Reserved1: array[0..1] of BYTE;
    BeingDebugged: BYTE;
    Reserved2: array[0..0] of BYTE;
    {$ifdef CPUX64}
    _align1: array[0..3] of byte;
    {$endif}
    Reserved3: array[0..1] of pointer;
    Ldr: PMS_PEB_LDR_DATA;
    ProcessParameters: PMS_RTL_USER_PROCESS_PARAMETERS;
    Reserved4: array[0..103] of BYTE;
    Reserved5: array[0..51] of pointer;
    PostProcessInitRoutine: _PPS_POST_PROCESS_INIT_ROUTINE; // for sure not pointer, otherwise SessionId is broken
    Reserved6: array[0..127] of BYTE;
    {$ifdef CPUX64}
    _align2: array[0..3] of byte;
    {$endif}
    Reserved7: array[0..0] of pointer;
    SessionId: ULONG;
    {$ifdef CPUX64}
    _align3: array[0..3] of byte;
    {$endif}
  end;

  PMS_PROCESS_BASIC_INFORMATION = ^MS_PROCESS_BASIC_INFORMATION;
  MS_PROCESS_BASIC_INFORMATION = packed record
    ExitStatus: Longint;
    {$ifdef CPUX64}
    _align1: array[0..3] of byte;
    {$endif}
    PebBaseAddress: PMS_PEB;
    AffinityMask: PtrUInt;
    BasePriority: Longint;
    {$ifdef CPUX64}
    _align2: array[0..3] of byte;
    {$endif}
    UniqueProcessId: PtrUInt;
    InheritedFromUniqueProcessId: PtrUInt;
  end;

  {$Z4}
  PROCESSINFOCLASS = (ProcessBasicInformation = 0, ProcessDebugPort = 7,
    ProcessWow64Information = 26, ProcessImageFileName = 27,
    ProcessBreakOnTermination = 29, ProcessSubsystemInformation = 75);
  {$Z1}

  NTSTATUS = LongInt;

function NtQueryInformationProcess(ProcessHandle: THandle;
  ProcessInformationClass: PROCESSINFOCLASS; ProcessInformation: pointer;
  ProcessInformationLength: ULONG; ReturnLength: PULONG): NTSTATUS; stdcall;
  external ntdll name 'NtQueryInformationProcess';
function ReadProcessMemory(hProcess: THandle; const lpBaseAddress: Pointer; lpBuffer: Pointer;
  nSize: PTRUINT; var lpNumberOfBytesRead: PTRUINT): BOOL; external 'kernel32' name 'ReadProcessMemory';

function InternalGetProcessInfo(aPID: DWORD; out aInfo: TWinProcessInfo): boolean;
var
  bytesread: PtrUInt;
  sizeneeded: DWORD;
  pbi: PMS_PROCESS_BASIC_INFORMATION;
  peb: MS_PEB;
  peb_upp: MS_RTL_USER_PROCESS_PARAMETERS;
  prochandle: THandle;
  buf: TSynTempBuffer;
begin
  result := false;
  with aInfo do begin
    AvailableInfo := [];
    PID := 0;
    ParentPID := 0;
    SessionID := 0;
    PEBBaseAddress := nil;
    AffinityMask := 0;
    BasePriority := 0;
    ExitStatus := 0;
    BeingDebugged := 0;
    ImagePath := '';
    CommandLine := '';
  end;
  if APID = 0 then
    exit;
  prochandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, FALSE, aPid);
  if prochandle = INVALID_HANDLE_VALUE then
    exit;
  Include(aInfo.AvailableInfo, wpaiPID);
  aInfo.PID := aPid;
  buf.InitZero(SizeOf(MS_PROCESS_BASIC_INFORMATION));
  try
    sizeneeded := 0;
    if NtQueryInformationProcess(prochandle, ProcessBasicInformation, buf.buf, buf.len, @sizeneeded) < 0 then
      exit;
    if buf.len < integer(sizeneeded) then begin
      buf.Done;
      buf.InitZero(sizeneeded);
      if NtQueryInformationProcess(prochandle, ProcessBasicInformation, buf.buf, buf.len, @sizeneeded) < 0 then
        exit;
    end;
    Include(aInfo.AvailableInfo, wpaiBasic);
    pbi := buf.buf;
    with aInfo do begin
      PID := pbi^.UniqueProcessId;
      ParentPID := pbi^.InheritedFromUniqueProcessId;
      BasePriority := pbi^.BasePriority;
      ExitStatus := pbi^.ExitStatus;
      PEBBaseAddress := pbi^.PebBaseAddress;
      AffinityMask := pbi^.AffinityMask;
    end;
    // read PEB (Process Environment Block)
    if not Assigned(pbi.PebBaseAddress) then
      exit;
    bytesread := 0;
    FillCharFast(peb, sizeof(MS_PEB), 0);
    if not ReadProcessMemory(prochandle, pbi.PebBaseAddress, @peb, sizeof(MS_PEB), bytesread) then
      exit;
    Include(aInfo.AvailableInfo, wpaiPEB);
    aInfo.SessionID := peb.SessionId;
    aInfo.BeingDebugged := peb.BeingDebugged;
    FillCharFast(peb_upp, sizeof(MS_RTL_USER_PROCESS_PARAMETERS), 0);
    bytesread := 0;
    if not ReadProcessMemory(prochandle, peb.ProcessParameters, @peb_upp, sizeof(MS_RTL_USER_PROCESS_PARAMETERS), bytesread) then
      exit;
    // command line info
    if peb_upp.CommandLine.Length > 0 then begin
      SetLength(aInfo.CommandLine, peb_upp.CommandLine.Length div 2);
      bytesread := 0;
      if not ReadProcessMemory(prochandle, peb_upp.CommandLine.Buffer, @aInfo.CommandLine[1], peb_upp.CommandLine.Length, bytesread) then
        exit;
      Include(aInfo.AvailableInfo, wpaiCommandLine);
    end;
    // image info
    if(peb_upp.ImagePathName.Length > 0) then begin
      SetLength(aInfo.ImagePath, peb_upp.ImagePathName.Length div 2);
      bytesread := 0;
      if not ReadProcessMemory(prochandle, peb_upp.ImagePathName.Buffer, @aInfo.ImagePath[1], peb_upp.ImagePathName.Length, bytesread) then
        exit;
      Include(aInfo.AvailableInfo, wpaiImagePath);
    end;
    result := true;
  finally
    CloseHandle(prochandle);
    buf.Done;
  end;
end;

procedure GetProcessInfo(aPid: Cardinal; out aInfo: TWinProcessInfo);
var
  privileges: TSynWindowsPrivileges;
begin
  privileges.Init(pttThread);
  try
    privileges.Enable(wspDebug);
    InternalGetProcessInfo(aPid, aInfo);
  finally
    privileges.Done;
  end;
end;

procedure GetProcessInfo(const aPidList: TCardinalDynArray; out aInfo: TWinProcessInfoDynArray);
var
  privileges: TSynWindowsPrivileges;
  i: integer;
begin
  SetLength(aInfo, Length(aPidList));
  privileges.Init(pttThread);
  try
    privileges.Enable(wspDebug);
    for i := 0 to High(aPidList) do
      InternalGetProcessInfo(aPidList[i], aInfo[i]);
  finally
    privileges.Done;
  end;
end;

{$endif MSWINDOWS}

end.