units/service/Service.pas

   1 unit Service;
   2 {* This unit contains definitions of TService and TServiceCtl objects intended
   3    to create Windows NT services using Delphi + KOL. }
   4
   5 interface
   6
   7 uses
   8   Windows, KOL, WinSVC, Messages;
   9
  10 const
  11   SERVICE_CONTROL_STOP           = $00000001;
  12   SERVICE_CONTROL_PAUSE          = $00000002;
  13   SERVICE_CONTROL_CONTINUE       = $00000003;
  14   SERVICE_CONTROL_INTERROGATE    = $00000004;
  15   SERVICE_CONTROL_SHUTDOWN       = $00000005;
  16
  17   SERVICE_NO_CHANGE              = $FFFFFFFF;
  18
  19   // Service State -- for Enum Requests (Bit Mask)
  20   SERVICE_ACTIVE                 = $00000001;
  21   SERVICE_INACTIVE               = $00000002;
  22   SERVICE_STATE_ALL              = (SERVICE_ACTIVE   or
  23                                     SERVICE_INACTIVE);
  24   SERVICE_STOPPED                = $00000001;
  25   SERVICE_START_PENDING          = $00000002;
  26   SERVICE_STOP_PENDING           = $00000003;
  27   SERVICE_RUNNING                = $00000004;
  28   SERVICE_CONTINUE_PENDING       = $00000005;
  29   SERVICE_PAUSE_PENDING          = $00000006;
  30   SERVICE_PAUSED                 = $00000007;
  31
  32   // Controls Accepted  (Bit Mask)
  33   SERVICE_ACCEPT_STOP            = $00000001;
  34   SERVICE_ACCEPT_PAUSE_CONTINUE  = $00000002;
  35   SERVICE_ACCEPT_SHUTDOWN        = $00000004;
  36
  37 //
  38 // Service Control Manager object specific access types
  39 //
  40   SC_MANAGER_CONNECT             = $0001;
  41   SC_MANAGER_CREATE_SERVICE      = $0002;
  42   SC_MANAGER_ENUMERATE_SERVICE   = $0004;
  43   SC_MANAGER_LOCK                = $0008;
  44   SC_MANAGER_QUERY_LOCK_STATUS   = $0010;
  45   SC_MANAGER_MODIFY_BOOT_CONFIG  = $0020;
  46
  47   SC_MANAGER_ALL_ACCESS          = (STANDARD_RIGHTS_REQUIRED or
  48                                     SC_MANAGER_CONNECT or
  49                                     SC_MANAGER_CREATE_SERVICE or
  50                                     SC_MANAGER_ENUMERATE_SERVICE or
  51                                     SC_MANAGER_LOCK or
  52                                     SC_MANAGER_QUERY_LOCK_STATUS or
  53                                     SC_MANAGER_MODIFY_BOOT_CONFIG);
  54
  55   // Service object specific access type
  56   SERVICE_QUERY_CONFIG           = $0001;
  57   SERVICE_CHANGE_CONFIG          = $0002;
  58   SERVICE_QUERY_STATUS           = $0004;
  59   SERVICE_ENUMERATE_DEPENDENTS   = $0008;
  60   SERVICE_START                  = $0010;
  61   SERVICE_STOP                   = $0020;
  62   SERVICE_PAUSE_CONTINUE         = $0040;
  63   SERVICE_INTERROGATE            = $0080;
  64   SERVICE_USER_DEFINED_CONTROL   = $0100;
  65   SERVICE_ALL_ACCESS             = (STANDARD_RIGHTS_REQUIRED or
  66                                     SERVICE_QUERY_CONFIG or
  67                                     SERVICE_CHANGE_CONFIG or
  68                                     SERVICE_QUERY_STATUS or
  69                                     SERVICE_ENUMERATE_DEPENDENTS or
  70                                     SERVICE_START or
  71                                     SERVICE_STOP or
  72                                     SERVICE_PAUSE_CONTINUE or
  73                                     SERVICE_INTERROGATE or
  74                                     SERVICE_USER_DEFINED_CONTROL);
  75
  76
  77   // Service Types (Bit Mask)
  78   SERVICE_KERNEL_DRIVER         = $00000001;
  79   SERVICE_FILE_SYSTEM_DRIVER    = $00000002;
  80   SERVICE_ADAPTER               = $00000004;
  81   SERVICE_RECOGNIZER_DRIVER     = $00000008;
  82
  83   SERVICE_DRIVER                = (SERVICE_KERNEL_DRIVER or
  84                                    SERVICE_FILE_SYSTEM_DRIVER or
  85                                    SERVICE_RECOGNIZER_DRIVER);
  86
  87   SERVICE_WIN32_OWN_PROCESS     = $00000010;
  88   SERVICE_WIN32_SHARE_PROCESS   = $00000020;
  89   SERVICE_WIN32                 = (SERVICE_WIN32_OWN_PROCESS or
  90                                    SERVICE_WIN32_SHARE_PROCESS);
  91
  92   SERVICE_INTERACTIVE_PROCESS   = $00000100;
  93
  94   SERVICE_TYPE_ALL              = (SERVICE_WIN32 or
  95                                   SERVICE_ADAPTER or
  96                                   SERVICE_DRIVER or
  97                                   SERVICE_INTERACTIVE_PROCESS);
  98
  99   // Start Type
 100   SERVICE_BOOT_START            = $00000000;
 101   SERVICE_SYSTEM_START          = $00000001;
 102   SERVICE_AUTO_START            = $00000002;
 103   SERVICE_DEMAND_START          = $00000003;
 104   SERVICE_DISABLED              = $00000004;
 105
 106   // Error control type
 107   SERVICE_ERROR_IGNORE          = $00000000;
 108   SERVICE_ERROR_NORMAL          = $00000001;
 109   SERVICE_ERROR_SEVERE          = $00000002;
 110   SERVICE_ERROR_CRITICAL        = $00000003;
 111
 112   CM_SERVICE_CONTROL_CODE       = WM_USER + 1000;
 113
 114 type
 115
 116   TKOLService = Pointer;
 117   TKOLServiceEx = Pointer;
 118
 119   TServiceStatus = WinSVC.TServiceStatus;
 120
 121   PServiceCtl = ^TServiceCtl;
 122   TServiceCtl = object( TObj )
 123   {* TServiceCtl object is intended to create new service or to maintain existing
 124      service. To provide service itself, use TService object. }
 125   private
 126     FSCHandle: THandle;
 127     FHandle: THandle;
 128     //FTag: DWORD;
 129     FStatus: TServiceStatus;
 130     function GetStatus: TServiceStatus;
 131   protected
 132   public
 133     destructor Destroy; virtual;
 134     property SCHandle: THandle read FSCHandle;
 135     {* Handle of SC manager. }
 136     property Handle: THandle read FHandle;
 137     {* Handle of service opened or created. }
 138     property Status: TServiceStatus read GetStatus;
 139     {* Current status of the service. }
 140     function Stop: Boolean;
 141     {* }
 142     function Pause: Boolean;
 143     {* }
 144     function Resume: Boolean;
 145     {* }
 146     function Refresh: Boolean;
 147     {* }
 148     function Shutdown: Boolean;
 149     {* }
 150     function Delete: Boolean;
 151     {* Removes service from the system. }
 152     function Start( const Args: array of PChar ): Boolean;
 153     {* }
 154   end;
 155
 156 function NewServiceCtl( const TargetComputer, DatabaseName, Name, DisplayName, Path,
 157                      OrderGroup, Dependances, Username, Password: String;
 158          DesiredAccess, ServiceType, StartType, ErrorControl: DWORD ): PServiceCtl;
 159 {* Creates new service and allows to control it and/or its configuration.
 160    Parameters:
 161    |<br>
 162    TargetComputer - set it to empty string if local computer is the target.
 163    |<br>
 164    DatabaseName - set it to empty string if the default database is supposed
 165                 ( 'ServicesActive' ).
 166    |<br>
 167    Name - name of a service.
 168    |<br>
 169    DisplayName - display name of a service.
 170    |<br>
 171    Path - a path to binary (executable) of the service created.
 172    |<br>
 173    OrderGroup - an order group name (unnecessary)
 174    |<br>
 175    Dependances - string containing a list with names of services, which must
 176                start before (every name should be separated with #0, entire
 177                list should be separated with #0#0. Or, an empty string can be
 178                passed if there are no dependances).
 179    |<br>
 180    Username - login name. For service type SERVICE_WIN32_OWN_PROCESS, the
 181             account name in the form of "DomainName\Username"; If the account
 182             belongs to the built-in domain, ".\Username" can be specified;
 183             Services of type SERVICE_WIN32_SHARE_PROCESS are not allowed to
 184             specify an account other than LocalSystem. If '' is specified, the
 185             service will be logged on as the 'LocalSystem' account, in which
 186             case, the Password parameter must be empty too.
 187    |<br>
 188    Password - a password for login name. If the service type is
 189             SERVICE_KERNEL_DRIVER or SERVICE_FILE_SYSTEM_DRIVER,
 190             this parameter is ignored.
 191    |<br>
 192    DesiredAccess - a combination of following flags:
 193      SERVICE_ALL_ACCESS
 194      SERVICE_CHANGE_CONFIG
 195      SERVICE_ENUMERATE_DEPENDENTS
 196      SERVICE_INTERROGATE
 197      SERVICE_PAUSE_CONTINUE
 198      SERVICE_QUERY_CONFIG
 199      SERVICE_QUERY_STATUS
 200      SERVICE_START
 201      SERVICE_STOP
 202      SERVICE_USER_DEFINED_CONTROL
 203     |<br>
 204     ServiceType - a set of following flags:
 205       SERVICE_WIN32_OWN_PROCESS
 206       SERVICE_WIN32_SHARE_PROCESS
 207       SERVICE_KERNEL_DRIVER
 208       SERVICE_FILE_SYSTEM_DRIVER
 209       SERVICE_INTERACTIVE_PROCESS
 210     |<br>
 211     StartType - one of following values:
 212       SERVICE_BOOT_START
 213       SERVICE_SYSTEM_START
 214       SERVICE_AUTO_START
 215       SERVICE_DEMAND_START
 216       SERVICE_DISABLED
 217     |<br>
 218     ErrorControl - one of following:
 219       SERVICE_ERROR_IGNORE
 220       SERVICE_ERROR_NORMAL
 221       SERVICE_ERROR_SEVERE
 222       SERVICE_ERROR_CRITICAL
 223 }
 224
 225 function OpenServiceCtl( const TargetComputer, DataBaseName, Name: String;
 226                       DesiredAccess: DWORD ): PServiceCtl;
 227 {* Opens existing service to control it or its configuration from your
 228    application.
 229    |<br>Parameters:
 230    |<br>
 231    TargetComputer - set it to empty string if local computer is the target.
 232    |<br>
 233    DatabaseName - set it to empty string if the default database is supposed
 234                 ( 'ServicesActive' ).
 235    |<br>
 236    Name - name of a service.
 237    |<br>
 238    DesiredAccess - a combination of following flags:
 239      SERVICE_ALL_ACCESS
 240      SERVICE_CHANGE_CONFIG
 241      SERVICE_ENUMERATE_DEPENDENTS
 242      SERVICE_INTERROGATE
 243      SERVICE_PAUSE_CONTINUE
 244      SERVICE_QUERY_CONFIG
 245      SERVICE_QUERY_STATUS
 246      SERVICE_START
 247      SERVICE_STOP
 248      SERVICE_USER_DEFINED_CONTROL
 249     |<br>
 250 }
 251
 252 type
 253   PService = ^TService;
 254
 255   TControlProc = procedure( Sender: PService; Code: DWORD ) of object;
 256   {* }
 257   TServiceProc = procedure( Sender: PService ) of object;
 258   {* }
 259
 260   TService = object( TObj )
 261   {* TService is the object to represent service provided by the application
 262      itself. When service application is started, it should create necessary
 263      number of TService object instances and then call InstallServices
 264      function with a list of pointers to services created. }
 265   private
 266     fSName: String;
 267     fDName: String;
 268     fParam: String;
 269     fServiceType,
 270     fStartType: dword;
 271     fStatusHandle: THandle;
 272     fStatusRec: TServiceStatus;
 273     fJumper: Pointer;
 274     fOnStart: TServiceProc;
 275     fOnExecute: TServiceProc;
 276     fOnControl: TControlProc;
 277     fOnPause: TServiceProc;
 278     fOnResume: TServiceProc;
 279     fOnStop: TServiceProc;
 280     fOnInterrogate: TServiceProc;
 281     fOnShutdown: TServiceProc;
 282     fArgsList: PStrList;
 283     fData: DWORD;
 284     fControl: DWORD;
 285     function GetArgCount: Integer;
 286     function GetArgs(Idx: Integer): String;
 287     procedure SetStatus(const Value: TServiceStatus);
 288     procedure DoCtrlHandle( Code: DWORD ); virtual;
 289     function GetInstalled: boolean;
 290   protected
 291     procedure Execute; virtual;
 292     procedure CtrlHandle( Code: DWORD );
 293   public
 294     destructor Destroy; virtual;
 295     function ReportStatus( dwState, dwExitCode, dwWait:DWORD ):BOOL;
 296     {* Reports new status to the system. }
 297     procedure Install;
 298     {* Installs service in the database *}
 299     procedure Remove;
 300     {* Removes service from database *}
 301     procedure Start;
 302     {* Starts service *}
 303     procedure Stop;
 304     {* Stops service *}
 305     property ServiceName: String read fSName;
 306     {* Name of the service. Must be unique. }
 307     property DisplayName: String read fDName write fDName;
 308     {* Display name of the service *}
 309     property Param: String read fParam write fParam;
 310     {* Parameters for service *}
 311     property ServiceType: dword read fServiceType write fServiceType;
 312     {* Type of service *}
 313     property StartType: dword read fStartType write fStartType;
 314     {* Type of start of service *}
 315     property ArgCount: Integer read GetArgCount;
 316     {* Number of arguments passed to the service. }
 317     property Args[ Idx: Integer ]: String read GetArgs;
 318     {* Listof arguments passed. }
 319     property Status: TServiceStatus read FStatusRec write SetStatus;
 320     {* Current status. To report new status to the system, assign another
 321        value to this record, or use ReportStatus method (better). }
 322     property Accepted: DWORD read fControl write fControl;
 323     {* Set of control codes the service will accept }
 324     property Data: DWORD read FData write FData;
 325     {* Any data You wish to associate with the service object. }
 326     property Installed: boolean read GetInstalled;
 327     {* Whether service is installed in DataBase *}
 328     property OnStart: TServiceProc read fOnStart write fOnStart;
 329     {* Start event is executed befor main service thread *}
 330     property OnExecute: TServiceProc read fOnExecute write fOnExecute;
 331     {* Execute event. }
 332     property OnControl: TControlProc read fOnControl write fOnControl;
 333     {* Control handler event. *}
 334     property OnStop: TServiceProc read fOnStop write fOnStop;
 335     {* Stop service event. }
 336     property OnPause: TServiceProc read fOnPause write fOnPause;
 337     {* Pause service event. *}
 338     property OnResume: TServiceProc read fOnResume write fOnResume;
 339     {* Resume service event *}
 340     property OnInterrogate: TServiceProc read fOnInterrogate write fOnInterrogate;
 341     {* Interrogate service event. *}
 342     property OnShutdown: TServiceProc read fOnShutdown write fOnShutdown;
 343     {* Shutdown service event. *}
 344   end;
 345
 346   PServiceEx =^TServiceEx;
 347   TServiceEx = object(TService)
 348     fSThread: PThread;
 349     fAThread: PThread;
 350     fMThread: PThread;
 351     fOnApplRun: TServiceProc;
 352     procedure DoCtrlHandle( Code: DWORD ); virtual;
 353     function ThreadExecute(Sender: PThread): Integer;
 354     function ApplicExecute(Sender: PThread): Integer;
 355     function MessagExecute(Sender: PThread): integer;
 356   protected
 357     procedure Execute; virtual;
 358   public
 359     destructor Destroy; virtual;
 360     property OnApplicationRun: TServiceProc read fOnApplRun write fOnApplRun;
 361     {* Execute application procedure *}
 362   end;
 363
 364 function NewService( const _SName: String;
 365                      const _DName: String) : PService;
 366
 367 {* Creates the service. *}
 368
 369 function NewServiceEx( const _SName: String;
 370                        const _DName: String) : PServiceEx;
 371
 372 {* Creates the serviceEX. *}
 373
 374 function GetServiceList(sn, sd: PStrList): boolean;
 375
 376 procedure run;
 377 {* Call this function to pass a list of services provided by the application to
 378    the operating system. }
 379
 380 implementation
 381
 382 function Str2PChar( const S: String ): PChar;
 383 begin
 384   Result := nil;
 385   if StrComp( PChar( S ), '' ) <> 0 then
 386     Result := PChar( S );
 387 end;
 388
 389 {--- TServiceCtl ---}
 390
 391 function _NewServiceCtl( const TargetComputer, DatabaseName: String;
 392          Access: DWORD ): PServiceCtl;
 393 begin
 394   new( Result, Create );
 395   Result.FSCHandle := OpenSCManager( Str2PChar( TargetComputer ), Str2PChar( DatabaseName ),
 396                     Access );
 397 end;
 398
 399 function NewServiceCtl( const TargetComputer, DatabaseName, Name, DisplayName, Path,
 400                      OrderGroup, Dependances, Username, Password: String;
 401                      DesiredAccess, ServiceType, StartType, ErrorControl: DWORD ): PServiceCtl;
 402 begin
 403   Result := _NewServiceCtl( TargetComputer, DatabaseName, SC_MANAGER_ALL_ACCESS );
 404   if Result.FSCHandle = 0 then Exit;
 405   Result.FHandle := CreateService( Result.FSCHandle, Str2PChar( Name ), Str2PChar( DisplayName ),
 406                  DesiredAccess, ServiceType, StartType, ErrorControl, PChar( Path ),
 407                  Str2PChar( OrderGroup ), nil, Str2PChar( Dependances ),
 408                  Str2PChar( Username ), Str2PChar( Password ) );
 409 end;
 410
 411 function OpenServiceCtl( const TargetComputer, DataBaseName, Name: String;
 412                       DesiredAccess: DWORD ): PServiceCtl;
 413 begin
 414   Result := _NewServiceCtl( TargetComputer, DataBaseName, SC_MANAGER_ALL_ACCESS );
 415   if Result.FSCHandle = 0 then Exit;
 416   Result.FHandle := WinSvc.OpenService( Result.FSCHandle, PChar( Name ), DesiredAccess );
 417 end;
 418
 419 { TServiceCtl }
 420
 421 function TServiceCtl.Delete: Boolean;
 422 begin
 423   Result := FALSE;
 424   if FHandle <> 0 then
 425   begin
 426     if DeleteService( FHandle ) then
 427     begin
 428       Result := CloseServiceHandle( FHandle );
 429       FHandle := 0;
 430     end;
 431   end;
 432 end;
 433
 434 destructor TServiceCtl.Destroy;
 435 begin
 436   if FHandle <> 0 then
 437     CloseServiceHandle( FHandle );
 438   if FSCHandle <> 0 then
 439     CloseServiceHandle( FSCHandle );
 440   inherited;
 441 end;
 442
 443 function TServiceCtl.GetStatus: TServiceStatus;
 444 begin
 445   FillChar( FStatus, Sizeof( FStatus ), 0 );
 446   QueryServiceStatus( FHandle, FStatus );
 447   Result := FStatus;
 448 end;
 449
 450 function TServiceCtl.Pause: Boolean;
 451 begin
 452   Result := ControlService( FHandle, SERVICE_CONTROL_PAUSE, FStatus );
 453 end;
 454
 455 function TServiceCtl.Refresh: Boolean;
 456 begin
 457   Result := ControlService( FHandle, SERVICE_CONTROL_INTERROGATE, FStatus );
 458 end;
 459
 460 function TServiceCtl.Resume: Boolean;
 461 begin
 462   Result := ControlService( FHandle, SERVICE_CONTROL_CONTINUE, FStatus );
 463 end;
 464
 465 function TServiceCtl.Shutdown: Boolean;
 466 begin
 467   Result := ControlService( FHandle, SERVICE_CONTROL_SHUTDOWN, FStatus );
 468 end;
 469
 470 function StartService(hService: SC_HANDLE; dwNumServiceArgs: DWORD;
 471   {var} lpServiceArgVectors: Pointer ): BOOL; stdcall;
 472 external advapi32 name 'StartServiceA';
 473
 474 function TServiceCtl.Start(const Args: array of PChar): Boolean;
 475 begin
 476   Result := StartService( FHandle, High( Args ) + 1, @Args[ 0 ] );
 477 end;
 478
 479 function TServiceCtl.Stop: Boolean;
 480 begin
 481   Result := ControlService( FHandle, SERVICE_CONTROL_STOP, FStatus );
 482 end;
 483
 484 {--- TService ---}
 485
 486 var Services: PList;
 487
 488 function ServiceName2Idx( const Name: String ): Integer;
 489 var I: Integer;
 490     Srv: PService;
 491 begin
 492   assert( Services <> nil, 'Services are not created yet - nothing to search for.' );
 493   if Services <> nil then
 494   for I := 0 to services.Count - 1 do
 495   begin
 496     Srv := Services.Items[ I ];
 497     if Srv.fSName = Name then
 498     begin
 499       Result := I;
 500       Exit;
 501     end;
 502   end;
 503   Result := -1;
 504 end;
 505
 506 procedure JumpToService;
 507 asm
 508           POP     EAX
 509           MOV     EAX, [EAX]
 510           MOV     EDX, [ESP+4]
 511           CALL    TService.CtrlHandle
 512           RET     4
 513 end;
 514
 515 type
 516   PPChar = ^PChar;
 517
 518 procedure ServiceProc( ArgCount: DWORD; Args: PPChar ); stdcall;
 519 var I: Integer;
 520     Srv: PService;
 521 begin
 522   I := ServiceName2Idx( Args^ );
 523   Srv := Services.Items[ I ];
 524   for I := 1 to ArgCount - 1 do
 525   begin
 526     Inc( Args );
 527     Srv.FArgsList.Add( Args^ );
 528   end;
 529   Srv.FStatusHandle := RegisterServiceCtrlHandler( PChar( Srv.fSName ), Srv.FJumper );
 530   if Srv.FStatusHandle = 0 then
 531   begin
 532     Srv.ReportStatus( SERVICE_STOPPED, GetLastError, 0 );
 533     Exit;
 534   end;
 535   Srv.ReportStatus( SERVICE_START_PENDING, 0, 0 );
 536   Srv.Execute;
 537 {  Srv.ReportStatus( SERVICE_STOPPED, 0, 0 );}
 538 end;
 539
 540 function CheckUniqueServiceName( const Name: String ): Boolean;
 541 var I: Integer;
 542 begin
 543   Result := TRUE;
 544   if Services = nil then Exit;
 545   I := ServiceName2Idx( Name );
 546   if I < 0 then Exit;
 547   Result := FALSE;
 548 end;
 549
 550 function NewService( const _SName: String;
 551                      const _DName: String) : PService;
 552 var JumperAddr: Pointer;
 553     AfterCallAddr: Pointer;
 554     Offset: Integer;
 555 begin
 556   assert( CheckUniqueServiceName( _SName ),  PChar( 'Attempt to install a service ' +
 557           'with duplicated name: ' + _SName ) );
 558   new( Result, Create );
 559   Result.fSName := _SName;
 560   Result.fDName := _DName;
 561   if _DName = '' then Result.fDName := _SName;
 562   if Services = nil then Services := NewList;
 563   Services.Add( Result );
 564   Result.FArgsList := NewStrList;
 565   Result.fServiceType := SERVICE_WIN32_OWN_PROCESS or
 566                          SERVICE_INTERACTIVE_PROCESS;
 567   Result.fStartType   := SERVICE_AUTO_START;
 568
 569   Result.FStatusRec.dwServiceType := Result.fServiceType;
 570   Result.FStatusRec.dwCurrentState := SERVICE_STOPPED;
 571   Result.FStatusRec.dwControlsAccepted := fControl;
 572   Result.FStatusRec.dwWin32ExitCode := NO_ERROR;
 573
 574   Result.FJumper := VirtualAlloc( nil, 9, MEM_COMMIT, PAGE_EXECUTE_READWRITE );
 575
 576   assert( Result.FJumper <> nil, PChar( 'Cannot allocate memory for service jump gate: ' +
 577                                         _SName ) );
 578   JumperAddr := @JumpToService;
 579   AfterCallAddr := Pointer( Integer( Result.FJumper ) + 5 );
 580   Offset :=  Integer( JumperAddr ) - Integer( AfterCallAddr );
 581   PByte   ( Pointer( Integer( Result.FJumper ) + 0 ) )^ := $E8; // call
 582   PInteger( Pointer( Integer( Result.FJumper ) + 1 ) )^ := Offset;
 583   PDWord  ( Pointer( Integer( Result.FJumper ) + 5 ) )^ := DWORD( Result );
 584 end;
 585
 586 function NewServiceEx( const _SName: String;
 587                        const _DName: String) : PServiceEx;
 588 var JumperAddr: Pointer;
 589     AfterCallAddr: Pointer;
 590     Offset: Integer;
 591 begin
 592   assert( CheckUniqueServiceName( _SName ),  PChar( 'Attempt to install a service ' +
 593           'with duplicated name: ' + _SName ) );
 594
 595   new( Result, Create );
 596   if Services = nil then Services := NewList;
 597   Services.Add( Result );
 598
 599   Result.fSName := _SName;
 600   Result.fDName := _DName;
 601   if _DName = '' then Result.fDName := _SName;
 602   Result.FArgsList := NewStrList;
 603   Result.fSThread := NewThread;
 604   Result.fSThread.OnExecute := Result.ThreadExecute;
 605   Result.fAThread := NewThread;
 606   Result.fAThread.OnExecute := Result.ApplicExecute;
 607   Result.fMThread := NewThread;
 608   Result.fMThread.OnExecute := Result.MessagExecute;
 609
 610   Result.fServiceType := SERVICE_WIN32_OWN_PROCESS or
 611                          SERVICE_INTERACTIVE_PROCESS;
 612
 613   Result.fStartType   := SERVICE_AUTO_START;
 614
 615   Result.FStatusRec.dwServiceType := Result.fServiceType;
 616   Result.FStatusRec.dwCurrentState := SERVICE_STOPPED;
 617   Result.FStatusRec.dwControlsAccepted := fControl;
 618   Result.FStatusRec.dwWin32ExitCode := NO_ERROR;
 619
 620   Result.FJumper := VirtualAlloc( nil, 9, MEM_COMMIT, PAGE_EXECUTE_READWRITE );
 621
 622   assert( Result.FJumper <> nil, PChar( 'Cannot allocate memory for service jump gate: ' +
 623                                         _SName ) );
 624   JumperAddr := @JumpToService;
 625   AfterCallAddr := Pointer( Integer( Result.FJumper ) + 5 );
 626   Offset :=  Integer( JumperAddr ) - Integer( AfterCallAddr );
 627   PByte   ( Pointer( Integer( Result.FJumper ) + 0 ) )^ := $E8; // call
 628   PInteger( Pointer( Integer( Result.FJumper ) + 1 ) )^ := Offset;
 629   PDWord  ( Pointer( Integer( Result.FJumper ) + 5 ) )^ := DWORD( Result );
 630 end;
 631
 632 procedure run;
 633 var STA,
 634     NTA: PServiceTableEntry;
 635     Srv: PService;
 636     I  : Integer;
 637 begin
 638   GetMem( STA, (Services.Count + 1) * Sizeof( TServiceTableEntry ) );
 639   NTA := STA;
 640   for I := 0 to Services.Count - 1 do
 641   begin
 642     Srv := Services.Items[i];
 643     NTA.lpServiceName := PChar( Srv.ServiceName );
 644     NTA.lpServiceProc := @ServiceProc;
 645     Inc( NTA );
 646   end;
 647   NTA.lpServiceName := nil;
 648   NTA.lpServiceProc := nil;
 649   StartServiceCtrlDispatcher( STA^ );
 650   FreeMem( STA );
 651 end;
 652
 653 { TService }
 654
 655 procedure TService.DoCtrlHandle(Code: DWORD);
 656 begin
 657    case Code of
 658 SERVICE_CONTROL_STOP:
 659       begin
 660          ReportStatus( SERVICE_STOP_PENDING, NO_ERROR, 0 );
 661          if Assigned( fOnStop ) then fOnStop( @Self );
 662          ReportStatus( SERVICE_STOPPED, NO_ERROR, 0 );
 663       end;
 664 SERVICE_CONTROL_PAUSE:
 665       begin
 666          ReportStatus( SERVICE_PAUSE_PENDING, NO_ERROR, 0 );
 667          if Assigned( fOnPause ) then fOnPause( @Self );
 668          ReportStatus( SERVICE_PAUSED, NO_ERROR, 0 )
 669       end;
 670 SERVICE_CONTROL_CONTINUE:
 671       begin
 672          ReportStatus( SERVICE_CONTINUE_PENDING, NO_ERROR, 0 );
 673          if Assigned( fOnResume ) then fOnResume( @Self );
 674          ReportStatus( SERVICE_RUNNING, NO_ERROR, 0 );
 675       end;
 676 SERVICE_CONTROL_SHUTDOWN:
 677       begin
 678          if Assigned( fOnShutdown ) then fOnShutdown( @Self );
 679       end;
 680 SERVICE_CONTROL_INTERROGATE:
 681       begin
 682          SetServiceStatus( FStatusHandle, FStatusRec );
 683          if Assigned( fOnInterrogate ) then fOnInterrogate( @Self );
 684       end;
 685    end;
 686    if Assigned( fOnControl ) then fOnControl( @Self, Code );
 687 end;
 688
 689 procedure TServiceEx.DoCtrlHandle(Code: DWORD);
 690 begin
 691   while not
 692      PostThreadMessage(fMThread.ThreadID, CM_SERVICE_CONTROL_CODE, Code, 0) do begin
 693      sleep(500);
 694   end;
 695 end;
 696
 697 function TService.GetInstalled;
 698 var Ctl: PServiceCTL;
 699 begin
 700    Ctl := OpenServiceCtl( '', '', fSName, SERVICE_QUERY_STATUS );
 701    result := Ctl.Handle <> 0;
 702    Ctl.Free;
 703 end;
 704
 705 procedure TService.Install;
 706 var
 707    schService:SC_HANDLE;
 708    schSCManager:SC_HANDLE;
 709    ServicePath:String;
 710 begin
 711    if installed then exit;
 712    ServicePath := paramstr(0);
 713    if fParam <> '' then ServicePath := ServicePath + ' ' + fParam;
 714    schSCManager:=OpenSCManager(nil,
 715                                nil,
 716                                SC_MANAGER_ALL_ACCESS);
 717    if (schSCManager>0) then begin
 718       schService:=CreateService(schSCManager,
 719                                 Str2PChar(fSName),
 720                                 Str2PChar(fDName),
 721                                 SERVICE_ALL_ACCESS,
 722                                 fServiceType,
 723                                 fStartType,
 724                                 SERVICE_ERROR_NORMAL,
 725                                 Str2PChar(ServicePath),
 726                                 nil,
 727                                 nil,
 728                                 nil,
 729                                 nil,
 730                                 nil);
 731       if (schService>0) then begin
 732          CloseServiceHandle(schService);
 733       end;
 734    end;
 735 end;
 736
 737 procedure TService.Remove;
 738 var Ctl: PServiceCtl;
 739 begin
 740   Ctl := OpenServiceCtl( '',
 741                          '',
 742                          fSName,
 743                          SERVICE_ALL_ACCESS );
 744   if Ctl.Handle = 0 then Exit;
 745   Ctl.Stop;
 746   Ctl.Delete;
 747   Ctl.Free;
 748 end;
 749
 750 procedure TService.Start;
 751 var Ctl: PServiceCtl;
 752 begin
 753     Ctl := OpenServiceCtl( '',
 754                            '',
 755                            fSName,
 756                            SERVICE_ALL_ACCESS );
 757     Ctl.Start( [ ] );
 758     Ctl.Free;
 759 end;
 760
 761 procedure TService.Stop;
 762 var Ctl: PServiceCtl;
 763 begin
 764     Ctl := OpenServiceCtl( '',
 765                            '',
 766                            fSName,
 767                            SERVICE_ALL_ACCESS );
 768     Ctl.Stop;
 769     Ctl.Free;
 770 end;
 771
 772 destructor TService.Destroy;
 773 var I: Integer;
 774 begin
 775   I := ServiceName2Idx( fSName );
 776   assert( I >= 0,
 777           PChar( 'Cannot find service ' + fSName + 'to remove from the list.' ) );
 778   Services.Delete( I );
 779   fSName := '';
 780   FArgsList.Free;
 781   VirtualFree( FJumper, 0, MEM_RELEASE );
 782   inherited;
 783 end;
 784
 785 destructor TServiceEx.Destroy;
 786 var I: Integer;
 787 begin
 788   I := ServiceName2Idx( fSName );
 789   assert( I >= 0,
 790           PChar( 'Cannot find service ' + fSName + 'to remove from the list.' ) );
 791   Services.Delete( I );
 792   fSName := '';
 793   FArgsList.Free;
 794   fSThread.Free;
 795   fAThread.Free;
 796   fMThread.Free;
 797   VirtualFree( FJumper, 0, MEM_RELEASE );
 798   inherited;
 799 end;
 800
 801 procedure TService.Execute;
 802 begin
 803   if Assigned( fOnStart ) then
 804     fOnStart( @Self );
 805   ReportStatus( SERVICE_RUNNING, 0, 0 );
 806   if Assigned( fOnExecute ) then
 807     fOnExecute( @Self );
 808 end;
 809
 810 procedure TServiceEx.Execute;
 811 begin
 812   fMThread.Resume;
 813   if Assigned( fOnStart ) then
 814     fOnStart( @Self );
 815   if Assigned( fOnExecute ) then
 816     fSThread.Resume;
 817   if Assigned( fOnApplRun ) then
 818     fAThread.Resume;
 819   ReportStatus( SERVICE_RUNNING, 0, 0 );
 820 end;
 821
 822 function TServiceEx.ThreadExecute( Sender: PThread ): Integer;
 823 begin
 824   if Assigned( fOnExecute ) then fOnExecute( @Self );
 825   Result := 0;
 826 end;
 827
 828 function TServiceEx.ApplicExecute( Sender: PThread ): Integer;
 829 begin
 830   if Assigned( fOnApplRun ) then fOnApplRun( @Self );
 831   Result := 0;
 832 end;
 833
 834 function TServiceEx.MessagExecute;
 835 var Msg: TMsg;
 836     Rslt: boolean;
 837 begin
 838    PeekMessage(msg, 0, WM_USER, WM_USER, PM_NOREMOVE); { Create message queue }
 839    while True do begin
 840       Sleep(1);
 841       Rslt := PeekMessage(msg, 0, 0, 0, PM_REMOVE);
 842       if not Rslt then Continue;
 843       if msg.hwnd = 0 then { Thread message }
 844       begin
 845          if msg.message = CM_SERVICE_CONTROL_CODE then begin
 846             case msg.wParam of
 847             SERVICE_CONTROL_STOP:
 848               begin
 849                  ReportStatus( SERVICE_STOP_PENDING, NO_ERROR, 0 );
 850                  if Assigned( fOnStop ) then
 851                    fOnStop( @Self );
 852                  ReportStatus( SERVICE_STOPPED, NO_ERROR, 0 );
 853                  fSThread.Terminate;
 854                  fAThread.Terminate;
 855                  fMThread.Terminate;
 856               end;
 857             SERVICE_CONTROL_PAUSE:
 858               begin
 859                  ReportStatus( SERVICE_PAUSE_PENDING, NO_ERROR, 0 );
 860                  if Assigned( fOnPause ) then
 861                    fOnPause( @Self );
 862                  fSThread.Suspend;
 863                  ReportStatus( SERVICE_PAUSED, NO_ERROR, 0 )
 864               end;
 865             SERVICE_CONTROL_CONTINUE:
 866               begin
 867                  ReportStatus( SERVICE_CONTINUE_PENDING, NO_ERROR, 0 );
 868                  if Assigned( fOnResume ) then
 869                    fOnResume( @Self );
 870                  fSThread.Resume;
 871                  ReportStatus( SERVICE_RUNNING, NO_ERROR, 0 );
 872               end;
 873             SERVICE_CONTROL_SHUTDOWN:
 874               if Assigned( fOnShutdown ) then
 875                 fOnShutdown( @Self );
 876             SERVICE_CONTROL_INTERROGATE:
 877               begin
 878                  SetServiceStatus( FStatusHandle, FStatusRec );
 879                  if Assigned( fOnInterrogate ) then
 880                    fOnInterrogate( @Self );
 881               end;
 882             end;
 883             if Assigned( fOnControl ) then
 884               fOnControl( @Self, msg.wParam );
 885          end else
 886             DispatchMessage(msg);
 887       end else
 888          DispatchMessage(msg);
 889    end;
 890 end;
 891
 892 function TService.GetArgCount: Integer;
 893 begin
 894   Result := FArgsList.Count;
 895 end;
 896
 897 function TService.GetArgs(Idx: Integer): String;
 898 begin
 899   Result := FArgsList.Items[ Idx ];
 900 end;
 901
 902 function TService.ReportStatus(dwState, dwExitCode, dwWait: DWORD): BOOL;
 903 begin
 904   if dwState = SERVICE_START_PENDING then
 905        FStatusRec.dwControlsAccepted := 0
 906    else
 907        FStatusRec.dwControlsAccepted := fControl;
 908
 909   FStatusRec.dwCurrentState  := dwState;
 910   FStatusRec.dwWin32ExitCode := dwExitCode;
 911   FStatusRec.dwWaitHint := dwWait;
 912
 913   if (dwState = SERVICE_RUNNING) or (dwState = SERVICE_STOPPED) then
 914       FStatusRec.dwCheckPoint := 0
 915   else
 916       inc( FStatusRec.dwCheckPoint );
 917   Result := SetServiceStatus( FStatusHandle, FStatusRec );
 918 end;
 919
 920 procedure TService.SetStatus(const Value: TServiceStatus);
 921 begin
 922   FStatusRec := Value;
 923   if FStatusHandle <> 0 then
 924     SetServiceStatus( FStatusHandle, FStatusRec );
 925 end;
 926
 927 procedure TService.CtrlHandle(Code: DWORD);
 928 begin
 929   DoCtrlHandle( Code );
 930 end;
 931
 932 function GetServiceList;
 933 type
 934     ss = array[0..0] of TENUMSERVICESTATUS;
 935 var sc: SC_HANDLE;
 936     pt: pointer;
 937     nd,
 938     sq,
 939     rh: dword;
 940 begin
 941    result := false;
 942    sc := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
 943    if sc <> 0 then begin
 944       getmem(pt, 1024 * sizeof(TENUMSERVICESTATUS));
 945       nd := 0;
 946       sq := 0;
 947       rh := 0;
 948       if EnumServicesStatus(sc,
 949                             SERVICE_WIN32,
 950                             SERVICE_ACTIVE or SERVICE_INACTIVE,
 951                             TENUMSERVICESTATUS(pt^),
 952                             1024 * sizeof(TENUMSERVICESTATUS),
 953                             nd,
 954                             sq,
 955                             rh) then begin
 956          result := true;
 957          for rh := 0 to sq - 1 do begin
 958             if sn <> nil then
 959                sn.Add(ss(pt^)[rh].lpServiceName);
 960             if sd <> nil then
 961                sd.Add(ss(pt^)[rh].lpDisplayName);
 962          end;
 963          freemem(pt, 1024 * sizeof(TENUMSERVICESTATUS));
 964       end;
 965    end;
 966 end;
 967
 968 initialization
 969
 970 finalization
 971
 972 end.