Delphi中的同一程序拥有多个NT服务

Question

我正在寻找Delphi示例代码来开发Win32 Windows服务，该服务可以安装多次（使用不同的名称）。 这个想法是为每个要安装的服务提供1个exe和1个注册表项以及1个子项。 我使用exe来安装/运行许多服务，每个服务都从他的注册表子项中获取他的参数。

有人有示例代码吗？

Answer 1

我们通过创建TService后代并添加'InstanceName'属性来完成此操作。 这在命令行上以诸如... instance =“ MyInstanceName”之类的形式传递，并在SvcMgr.Application.Run之前进行检查和设置（如果存在）。

例如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（TService后代）

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.

用法：
Project1.exe /安装
Project1.exe / install -instance =“ MyInstanceName”
Project1.exe / uninstall [-instance =“ MyInstanceName]
它实际上什么也没做-取决于您编写启动/停止服务器位等。

ChangeServiceConfiguration调用用于更新服务管理器启动时调用的真实命令行。 您可以只编辑注册表，但至少这是“正确的” API方式。

这允许同时运行任意数量的服务实例，它们将在服务管理器中显示为“ MyService”，“ MyService（Inst1）”，“ MyService（AnotherInstance）”等。

Answer 2

关于在Delphi中如何实现服务存在一个问题，即使用一个不同的名称多次安装一次服务并不容易（请参阅Quality Central报告＃79781 ）。 您可能需要绕过TService / TServiceApplication实现。 要使用不同的名称创建服务，您不能简单地使用/ INSTALL命令行参数，而是必须使用SCM API或其实现之一（即SC.EXE命令行实用程序）或安装工具。 要告诉服务读取哪个键，您可以在其命令行上将参数传递给服务（它们也具有），因此在创建服务时会设置参数。

Answer 3

上下文：通过将exename.exe / install作为MyService运行来安装服务。 服务已第二次安装为MyService2。

Delphi不允许将单个可执行文件中的服务以不同的名称安装两次。 参见idsandon提到的QC 79781。 使用不同的名称会使服务在“启动”阶段“挂起”（至少根据SCM）。 这是因为DispatchServiceMain检查TService实例名称和根据SCM（启动服务时传入的名称）的名称是否相等。 当它们不同时，DispatchServiceMain不执行TService.Main，这意味着不执行TService的启动代码。

为了避免这种情况（某种程度上），请在Application.Run调用之前调用FixServiceNames过程。

限制：备用名称必须以原始名称开头。 IE如果原始名称是MyService，则可以安装MyService1，MyServiceAlternate，MyServiceBoneyHead等。

FixServiceNames的作用是查找所有已安装的服务，检查ImagePath以查看该服务是否由此可执行文件实现，并将它们收集在列表中。 对已安装的ServiceName上的列表进行排序。 然后检查SvcMgr.Application.Components中的所有TService后代。 当安装以Component.Name（服务的原始名称）开头的ServiceName时，请用从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;

注意：如此漂亮的打印机在“ ServiceKey：='\\'+ RKEY_SERVICES +'\\'+ ServiceNames [i];”处感到困惑。 ，Delphi（2009）对此没有任何疑问。