Multiple NT service owned by the same program in Delphi - delphi

Question

I'm looking for Delphi sample code to develope a Win32 Windows service which can be installed many times (with different 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?

Answer 1

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.

Answer 2

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.

Answer 3

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.