Multiple NT service owned by the same program in Delphi

I'm looking for Delphi sample code to develope a Win32 Windows service which can be installed many times (with di开发者_如何学JAVAfferent Name). The idea is to have 1 exe and 1 registry key with 1 subkey for every service to be installed. I use the exe to install/run many service, every service take his parameter from his registry subkey.

Does anyone have a sample code?

---

We've done this by creating a TService descendant and adding an 'InstanceName' property. This gets passed on the command line as something like ... instance="MyInstanceName" and gets checked for and set (if it exists) before SvcMgr.Application.Run.

eg Project1.dpr:

program Project1;

uses
  SvcMgr,
  SysUtils,
  Unit1 in 'Unit1.pas' {Service1: TService};

{$R *.RES}

const
  INSTANCE_SWITCH = '-instance=';

function GetInstanceName: string;
var
  index: integer;
begin
  result := '';
  for index := 1 to ParamCount do
  begin
    if SameText(INSTANCE_SWITCH, Copy(ParamStr(index), 1, Length(INSTANCE_SWITCH))) then
    begin
      result := Copy(ParamStr(index), Length(INSTANCE_SWITCH) + 1, MaxInt);
      break;
    end;
  end;
  if (result <> '') and (result[1] = '"') then
    result := AnsiDequotedStr(result, '"');
end;

var
  inst: string;

begin
  Application.Initialize;
  Application.CreateForm(TService1, Service1);
  // Get the instance name
  inst := GetInstanceName;
  if (inst <> '') then
  begin
    Service1.InstanceName := inst;
  end;
  Application.Run;
end.

Unit1 (a TService descendant)

unit Unit1;

interface

uses
  Windows, SysUtils, Classes, SvcMgr, WinSvc;

type
  TService1 = class(TService)
    procedure ServiceAfterInstall(Sender: TService);
  private
    FInstanceName: string;
    procedure SetInstanceName(const Value: string);
    procedure ChangeServiceConfiguration;
  public
    function GetServiceController: TServiceController; override;
    property InstanceName: string read FInstanceName write SetInstanceName;
  end;

var
  Service1: TService1;

implementation

{$R *.DFM}

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
  Service1.Controller(CtrlCode);
end;

procedure TService1.ChangeServiceConfiguration;
var
  mngr: Cardinal;
  svc: Cardinal;
  newpath: string;
begin
  // Open the service manager
  mngr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if (mngr = 0) then
    RaiseLastOSError;
  try
    // Open the service
    svc := OpenService(mngr, PChar(Self.Name), SERVICE_CHANGE_CONFIG);
    if (svc = 0) then
      RaiseLastOSError;
    try
      // Change the service params
      newpath := ParamStr(0) + ' ' + Format('-instance="%s"', [FInstanceName]); // + any other cmd line params you fancy
      ChangeServiceConfig(svc, SERVICE_NO_CHANGE, //  dwServiceType
                               SERVICE_NO_CHANGE, //  dwStartType
                               SERVICE_NO_CHANGE, //  dwErrorControl
                               PChar(newpath),    //  <-- The only one we need to set/change
                               nil,               //  lpLoadOrderGroup
                               nil,               //  lpdwTagId
                               nil,               //  lpDependencies
                               nil,               //  lpServiceStartName
                               nil,               //  lpPassword
                               nil);              //  lpDisplayName
    finally
      CloseServiceHandle(svc);
    end;
  finally
    CloseServiceHandle(mngr);
  end;
end;

function TService1.GetServiceController: TServiceController;
begin
  Result := ServiceController;
end;

procedure TService1.ServiceAfterInstall(Sender: TService);
begin
  if (FInstanceName <> '') then
  begin
    ChangeServiceConfiguration;
  end;
end;

procedure TService1.SetInstanceName(const Value: string);
begin
  if (FInstanceName <> Value) then
  begin
    FInstanceName := Value;
    if (FInstanceName <> '') then
    begin
      Self.Name := 'Service1_' + FInstanceName;
      Self.DisplayName := Format('Service1 (%s)', [FInstanceName]);
    end;
  end;
end;

end.

Usage:
Project1.exe /install
Project1.exe /install -instance="MyInstanceName"
Project1.exe /uninstall [-instance="MyInstanceName]
It doesn't actually do anything - it's up to you to write the start/stop server bits etc.

The ChangeServiceConfiguration call is used to update the real command line that the service manager calls when it starts up. You could just edit the registry instead but at least this is the 'proper' API way.

This allows any number of instances of the service to be run at the same time and they will appear in the service manager as 'MyService', 'MyService (Inst1)', 'MyService (AnotherInstance)' etc etc.

---

There's an issue on how services are implemented in Delphi that does not make easy to install a service more than once using a different name (see Quality Central report #79781). You may need to bypass the TService/TServiceApplication implementation. To create the service using different names you can't simply use the /INSTALL command line parameter but you have to use the SCM API or one of its implementation (i.e. SC.EXE command line utility) or a setup tool. To tell the service which key to read you can pass a parameter to the service on its command line (they have as well), parameters are set when the service is created.

---

Context: Service installed by running exename.exe /install as MyService. Service installed a second time as MyService2.

Delphi doesn't allow for a service in a single executable to be installed twice with different names. See QC 79781 as idsandon mentioned. The different name causes the service to "hang" (at least according to the SCM) in the "Starting" phase. This is because DispatchServiceMain checks for equality of the TService instance name and the name according to the SCM (passed in when it starts the service). When they differ DispatchServiceMain does not execute TService.Main which means the TService's start up code isn't executed.

To circumvent this (somewhat), call the FixServiceNames procedure just before the Application.Run call.

Limitations: alternate names must start with the original one. IE if the original name is MyService then you can install MyService1, MyServiceAlternate, MyServiceBoneyHead, etc.

What FixServiceNames does is look for all installed services, check ImagePath to see if the service is implemented by this executable and collect those in a list. Sort the list on installed ServiceName. Then check all TService descendents in SvcMgr.Application.Components. When a ServiceName is installed that starts with Component.Name (the original name of the service), then replace that with the one we got from the SCM.

procedure FixServiceNames;
const
  RKEY_SERVICES = 'SYSTEM\CurrentControlSet\Services';
  RKEY_IMAGE_PATH = 'ImagePath';
  RKEY_START = 'Start';
var
  ExePathName: string;
  ServiceNames: TStringList;
  Reg: TRegistry;
  i: Integer;
  ServiceKey: string;
  ImagePath: string;
  StartType: Integer;
  Component: TComponent;
  SLIndex: Integer;
begin
  ExePathName := ParamStr(0);

  ServiceNames := TStringList.Create;
  try
    Reg := TRegistry.Create(KEY_READ);
    try
      Reg.RootKey := HKEY_LOCAL_MACHINE;

      // Openen registry key with all the installed services.
      if Reg.OpenKeyReadOnly(RKEY_SERVICES) then
      begin
        // Read them all installed services.
        Reg.GetKeyNames(ServiceNames);

        // Remove Services whose ImagePath does not match this executable.
        for i := ServiceNames.Count - 1 downto 0 do
        begin
          ServiceKey := '\' + RKEY_SERVICES + '\' + ServiceNames[i];
          if Reg.OpenKeyReadOnly(ServiceKey) then
          begin
            ImagePath := Reg.ReadString(RKEY_IMAGE_PATH);
            if SamePath(ImagePath, ExePathName) then
            begin
              // Only read 'Start' after 'ImagePath', the other way round often fails, because all 
              // services are read here and not all of them have a "start" key or it has a different datatype.
              StartType := Reg.ReadInteger(RKEY_START);
              if StartType <> SERVICE_DISABLED then
                Continue;
            end;

            ServiceNames.Delete(i);
          end;
        end;
      end;
    finally
      FreeAndNil(Reg);
    end;

    // ServiceNames now only contains enabled services using this executable.
    ServiceNames.Sort;  // Registry may give them sorted, but now we are sure.

    if ServiceNames.Count > 0 then
      for i := 0 to SvcMgr.Application.ComponentCount - 1 do
      begin
        Component := SvcMgr.Application.Components[i];
        if not ( Component is TService ) then
          Continue;

        // Find returns whether the string is found and reports through Index where it is (found) or 
        // where it should be (not found).
        if ServiceNames.Find(Component.Name, SLIndex) then
          // Component.Name found, nothing to do
        else
          // Component.Name not found, check whether ServiceName at SLIndex starts with Component.Name.
          // If it does, replace Component.Name.
          if SameText(Component.Name, Copy(ServiceNames[SLIndex], 1, Length(Component.Name))) then
          begin
            Component.Name := ServiceNames[SLIndex];
          end
          else
            ; // Service no longer in executable?
      end;
  finally
    FreeAndNil(ServiceNames);
  end;
end;

Note: SO pretty printer gets confused at the "ServiceKey := '\' + RKEY_SERVICES + '\' + ServiceNames[i];" line, Delphi (2009) has no issues with it.