DELPHI中对NT服务型程序的控制单元

 {*******************************************************************************

   XOtecExpress Visual Component Library Copyright (c) 2008 XOtec Studio.

   By: PengJunLi Build: 2008-05-24
   E-mail: iinsnian@126.com  xotec@vip.qq.com
   QQ:442801172  (陆岛工作室)

*******************************************************************************}

unit xtSrvUnit;

interface

uses Windows, Messages,  SysUtils, Classes, Forms, WinSvc, SvcMgr;

const
  SM_BASE                      = WM_USER + 1736;
  SM_INITIALIZE                = SM_BASE + 1;
  SM_SHUTDOWN                  = SM_BASE + 2;
  SM_BREAKWAIT                 = SM_BASE + 5;
  SM_USERSINFOUPDATE           = SM_BASE + 11;

type
  EServiceError = class(Exception);
  TxtServiceStatus = (ssUnknow, ssStopped, ssStartPending, ssStopPending, ssRuning, ssContinuePending, ssPausePending, ssPaused);

  { TxtServiceApplication }
  
  TxtServiceApplication = class(TServiceApplication)
  private
    FEventLogger: TEventLogger;
    procedure OnExceptionHandler(Sender: TObject; E: Exception);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Run; override;
    procedure ContinueRun;
  end;


function Application: TxtServiceApplication;

function ServerInstalling: Boolean;

function IsServerIsRuning(ServiceName: string): Boolean;

//取服务状态
function GetServiceStatus(ServiceName: string): TxtServiceStatus;
//服务是否正在运行
function IsServiceRuning(ServiceName: string): Boolean;
//服务是否已停止
function IsServiceStopped(ServiceName: string): Boolean;

//启动服务
function StartService(ServiceName: string): Boolean; overload; // Simple start
function StartService(ServiceName: string; NumberOfArgument: DWORD; ServiceArgVectors: PChar): Boolean;overload; // More complex start
//停止服务
function StopService(ServiceName: string): Boolean;
//暂停服务
function PauseService(ServiceName: string): Boolean;
//继续服务
function ContinueService(ServiceName: string): Boolean;
//关闭服务
function ShutdownService(ServiceName: string): Boolean;
//禁止服务启动
function DisableService(ServiceName: string): Boolean;

//服务是否已安装
function IsServiceInstalled(ServiceName: string): Boolean;
//安装服务
function InstallService(ServiceName, DisplayName, Filename: string; ServiceDescription: string=''): Boolean;
//反安装服务
function UnInstallService(ServiceName: string): Boolean;
//为服务程序添加描述
procedure ServiceUpdateDescription(const ServiceName, Description: string);

//取得系统中所有服务列表
function GetNtServiceList(sMachine: string; AList: TStrings): Boolean;

function InitServiceDesktop: boolean;
procedure DoneServiceDeskTop;

implementation

uses Registry;

const
  DefaultWindowStation         = 'WinSta0';
  DefaultDesktop               = 'Default';

var
  hwinstaSave: HWINSTA;
  hdeskSave: HDESK;
  hwinstaUser: HWINSTA;
  hdeskUser: HDESK;
  FContinueHandlingMessages: Boolean = true;

{ ServerInstalling }

function ServerInstalling: Boolean;
begin
  Result := FindCmdLineSwitch('INSTALL',['-','\','/'], True) or
            FindCmdLineSwitch('UNINSTALL',['-','\','/'], True);
end;

{ GetServiceStatus }

function GetServiceStatus(ServiceName: string): TxtServiceStatus;
var
  ServiceStatus: TServiceStatus;
  hSCManager, ServiceHandle: SC_Handle;
begin
  Result := ssUnknow;
  if (Trim(ServiceName)='') then Exit;

  hSCManager := OpenSCManager(nil, SERVICES_ACTIVE_DATABASE, SC_MANAGER_CONNECT);
  if hSCManager<>0 then
  begin
    ServiceHandle := OpenService(hSCManager, PChar(ServiceName), SERVICE_QUERY_STATUS);
    if ServiceHandle<>0 then
    begin
      QueryServiceStatus(ServiceHandle, ServiceStatus);
      CloseServiceHandle(ServiceHandle);
    end;
    CloseServiceHandle(hSCManager);
  end;

  case ServiceStatus.dwCurrentState of
    SERVICE_STOPPED         : Result := ssStopped;
    SERVICE_START_PENDING   : Result := ssStartPending;
    SERVICE_STOP_PENDING    : Result := ssStopPending;
    SERVICE_RUNNING         : Result := ssRuning;
    SERVICE_CONTINUE_PENDING: Result := ssContinuePending;
    SERVICE_PAUSE_PENDING   : Result := ssPausePending;
    SERVICE_PAUSED          : Result := ssPaused;
  end;
end;

{ IsServiceRuning }

function IsServiceRuning(ServiceName: string): Boolean;
begin
  Result := (GetServiceStatus(ServiceName) = ssRuning);
end;

{ IsServiceStopped }

function IsServiceStopped(ServiceName: string): Boolean;
begin
  Result := (GetServiceStatus(ServiceName) = ssStopped);
end;

{ StartService }

function StartService(ServiceName: string): Boolean; overload; // Simple start
begin
  Result := StartService(ServiceName, 0, nil);
end;

function StartService(ServiceName: string; NumberOfArgument: DWORD; ServiceArgVectors: PChar): Boolean;overload; // More complex start
var
  SCManager, hService: SC_HANDLE;
begin
   Result := False;
  if (Trim(ServiceName)='') then Exit;
  
   SCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
   Result := SCManager <> 0;
   if Result then
   try
     hService := OpenService(SCManager, PChar(ServiceName), SERVICE_ALL_ACCESS);
     Result := hService <> 0;
     if (hService <> 0) then
     try
       Result := WinSvc.StartService(hService, NumberOfArgument, PChar(ServiceArgVectors));
       if not Result and (GetLastError = ERROR_SERVICE_ALREADY_RUNNING) then
         Result := True;
     finally
       CloseServiceHandle(hService);
     end;
   finally
     CloseServiceHandle(SCManager);
   end;
end;

function DoControlService(ServiceName: string; ControlFalg: Cardinal): Boolean;
var
  ServiceStatus: TServiceStatus;
  SCManager, hService: SC_HANDLE;
begin
  Result := False;
  if (Trim(ServiceName)='') then Exit;

   SCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if SCManager<>0 then
  begin
     hService := OpenService(SCManager, PChar(ServiceName), SERVICE_ALL_ACCESS);
    if hService<>0 then
    begin
      Result := ControlService(hService, ControlFalg, ServiceStatus);
      CloseServiceHandle(hService);
    end;
    CloseServiceHandle(SCManager);
  end;
end;

{ StopService }

function StopService(ServiceName: string): Boolean;
begin
  Result := DoControlService(ServiceName, SERVICE_CONTROL_STOP);
end;
{ PauseService }

function PauseService(ServiceName: string): Boolean;
begin
  Result := DoControlService(ServiceName, SERVICE_CONTROL_PAUSE);
end;

{ ContinueService }

function ContinueService(ServiceName: string): Boolean;
begin
  Result := DoControlService(ServiceName, SERVICE_CONTROL_CONTINUE);
end;

{ ShutdownService }

function ShutdownService(ServiceName: string): Boolean;
begin
  Result := DoControlService(ServiceName, SERVICE_CONTROL_SHUTDOWN);
end;

{ DisableService }

function DisableService(ServiceName: string): Boolean;
var
  SCManager, ServiceHandle: SC_HANDLE;
begin
  Result := False;
  if (Trim(ServiceName)='') then Exit;

  SCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if SCManager<>0 then
  begin
    ServiceHandle := OpenService(SCManager, PChar(ServiceName), SERVICE_CHANGE_CONFIG);
    if ServiceHandle<>0 then
    begin
      ChangeServiceConfig(ServiceHandle,
                          SERVICE_NO_CHANGE, SERVICE_DISABLED, SERVICE_NO_CHANGE,
                          nil, nil, nil, nil, nil, nil, nil);
      CloseServiceHandle(ServiceHandle);
      Result := True;
    end;
    CloseServiceHandle(SCManager);
  end;
end;

{ InstallService }

function InstallService(ServiceName, DisplayName, Filename: string; ServiceDescription: string=''): Boolean;
var
  SCManager, ServiceHandle: SC_HANDLE;
begin
  Result := False;
  if (Trim(ServiceName)='') and not FileExists(Filename) then Exit;
  
  SCManager := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if SCManager = 0 then Exit;
  
  try
    ServiceHandle := CreateService(SCManager, PChar(ServiceName), PChar(DisplayName),
                                   SERVICE_ALL_ACCESS, SERVICE_WIN32_OWN_PROCESS or SERVICE_INTERACTIVE_PROCESS,
                                   SERVICE_AUTO_START, SERVICE_ERROR_NORMAL, PChar(Filename),
                                   nil, nil, nil, nil, nil);

    if IsServiceInstalled(ServiceName) and (ServiceDescription<>'') then
      ServiceUpdateDescription(ServiceName, ServiceDescription);
    CloseServiceHandle(ServiceHandle);
    Result := ServiceHandle<>0;
  finally
    CloseServiceHandle(SCManager);
  end;
end;

{ UnInstallService }

function UnInstallService(ServiceName: string): Boolean;
var
  SCManager, ServiceHandle: SC_HANDLE;
begin
  Result := False;
  if (Trim(ServiceName)='') then Exit;

  SCManager := OpenSCManager(nil,nil,GENERIC_WRITE);
  if SCManager = 0 then Exit;
  try
    ServiceHandle := OpenService(SCManager, PChar(ServiceName), _DELETE);
    Result := DeleteService(ServiceHandle);
    CloseServiceHandle(ServiceHandle);
  finally
    CloseServiceHandle(SCManager);
  end;
end;

procedure ServiceUpdateDescription(const ServiceName, Description: string);
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  try
    with reg do begin
      RootKey := HKEY_LOCAL_MACHINE;
      if OpenKey('SYSTEM\CurrentControlSet\Services\' + ServiceName, False) then
      begin
         WriteString('Description', Description);
         end;
         CloseKey;
      end;
   finally
     reg.Free;
   end;
end;

{ IsServiceInstalled }

function IsServiceInstalled(ServiceName: string): Boolean;
var
  Mgr, Svc: Integer;
begin
  Result := False;
  if (Trim(ServiceName)='') then Exit;

  Mgr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if Mgr <> 0 then
  begin
    Svc := OpenService(Mgr, PChar(ServiceName), SERVICE_ALL_ACCESS);
    Result := Svc <> 0;
    if Result then
      CloseServiceHandle(Svc);
    CloseServiceHandle(Mgr);
  end;
end;

{ IsServerIsRuning }

function IsServerIsRuning(ServiceName: string): Boolean;
begin
  Result := False;
  
  if (Trim(ServiceName)<>'') and not ServerInstalling then
  begin
    CreateMutex(nil, True, PChar(ServiceName + '_Mutex'));
    Result := GetLastError = ERROR_ALREADY_EXISTS;
  end;
end;

function GetNtServiceList(sMachine: string; AList: TStrings): Boolean;
var
   i: integer;
   sName, sDisplay: string;
   SCManager: SC_Handle;
   nBytesNeeded, nServices, nResumeHandle: Cardinal;
   ServiceStatusRecs: array[0..511] of TEnumServiceStatus;
begin
   Result := false;
   SCManager := OpenSCManager(PChar(sMachine), nil, SC_MANAGER_ALL_ACCESS);
   try
     if (SCManager = 0) then Exit;
     nResumeHandle := 0;
     while True do
     begin
       EnumServicesStatus(SCManager, SERVICE_WIN32, SERVICE_STATE_ALL, ServiceStatusRecs[0], SizeOf(ServiceStatusRecs),
         nBytesNeeded, nServices, nResumeHandle);
         
       for i := 0 to nServices - 1 do
       begin
         sName := ServiceStatusRecs[i].lpServiceName;
         sName := StringReplace(sName, '=', '?', [rfReplaceAll, rfIgnoreCase]);

         sDisplay := ServiceStatusRecs[i].lpDisplayName;
         sDisplay := StringReplace(sDisplay, '=', '#13#10', [rfReplaceAll, rfIgnoreCase]);
         sDisplay := StringReplace(sDisplay, '=', '#13', [rfReplaceAll, rfIgnoreCase]);
         sDisplay := StringReplace(sDisplay, '=', '#10', [rfReplaceAll, rfIgnoreCase]);
         AList.Add(sName + '=' + sDisplay);
       end;
       
       if nBytesNeeded = 0 then Break;
     end;
     Result := True;
   finally
     CloseServiceHandle(SCManager);
   end;
end;

{ InitServiceDesktop }

function InitServiceDesktop: boolean;
var
  dwThreadId: DWORD;
begin
  dwThreadId := GetCurrentThreadID;
  // Ensure connection to service window station and desktop, and
  // save their handles.
  hwinstaSave := GetProcessWindowStation;
  hdeskSave   := GetThreadDesktop(dwThreadId);


  hwinstaUser := OpenWindowStation(DefaultWindowStation, FALSE, MAXIMUM_ALLOWED);
  if hwinstaUser = 0 then
  begin
    OutputDebugString(PChar('OpenWindowStation failed' +  SysErrorMessage(GetLastError)));
    Result := false;
    exit;
  end;

  if not SetProcessWindowStation(hwinstaUser)  then
  begin
    OutputDebugString('SetProcessWindowStation failed');
    Result := false;
    exit;
  end;

  hdeskUser := OpenDesktop(DefaultDesktop, 0, FALSE, MAXIMUM_ALLOWED);
  if hdeskUser = 0 then
  begin
    OutputDebugString('OpenDesktop failed');
    SetProcessWindowStation(hwinstaSave);
    CloseWindowStation(hwinstaUser);
    Result := false;
    exit;
  end;
  Result := SetThreadDesktop(hdeskUser);
  if not Result then
    OutputDebugString(PChar('SetThreadDesktop' + SysErrorMessage(GetLastError)));
end;

{ DoneServiceDeskTop }

procedure DoneServiceDeskTop;
begin
  // Restore window station and desktop.
  SetThreadDesktop(hdeskSave);
  SetProcessWindowStation(hwinstaSave);
  if hwinstaUser <> 0 then
    CloseWindowStation(hwinstaUser);
  if hdeskUser <> 0 then
    CloseDesktop(hdeskUser);
end;

{ TServiceStartThread }

type
  TServiceTableEntryArray = array of TServiceTableEntry;

  TServiceStartThread = class(TThread)
  private
    FServiceStartTable: TServiceTableEntryArray;
  protected
    procedure DoTerminate; override;
    procedure Execute; override;
  public
    constructor Create(Services: TServiceTableEntryArray);
  end;

constructor TServiceStartThread.Create(Services: TServiceTableEntryArray);
begin
  FreeOnTerminate := False;
  ReturnValue := 0;
  FServiceStartTable := Services;
  inherited Create(False);
end;

procedure TServiceStartThread.DoTerminate;
begin
  inherited DoTerminate;
  // Application run as application on NT or application run on the Win 9x
  if (ReturnValue = ERROR_FAILED_SERVICE_CONTROLLER_) or
     (ReturnValue = ERROR_CALL_NOT_IMPLEMENTED)
  then
  begin
    // for break Application.ProcessMessages loop
    FContinueHandlingMessages := False;
    // Send a fake message to Application, for a breaking WaitMessage-loop
    PostMessage(Forms.Application.Handle, SM_BREAKWAIT, 0, 0);
  end
  else
    PostMessage(Forms.Application.Handle, WM_QUIT, 0, 0);
end;

procedure TServiceStartThread.Execute;
begin
  if StartServiceCtrlDispatcher(FServiceStartTable[0]) then
    ReturnValue := 0 else
    ReturnValue := GetLastError;
end;

{ DoneServiceApplication }

procedure DoneServiceApplication;
begin
  with Forms.Application do
  begin
    if Handle <> 0 then ShowOwnedPopups(Handle, False);
    ShowHint := False;
    Destroying;
    DestroyComponents;
  end;
  with Application do
  begin
    Destroying;
    DestroyComponents;
  end;
end;

{ TxtServiceApplication }

procedure TxtServiceApplication.ContinueRun;
begin
  while not Forms.Application.Terminated do
    Forms.Application.HandleMessage;
    
  Forms.Application.Terminate;
end;

constructor TxtServiceApplication.Create(AOwner: TComponent);
begin
  FEventLogger := TEventLogger.Create(ExtractFileName(ParamStr(0)));
  inherited Create(AOwner);
end;

destructor TxtServiceApplication.Destroy;
begin
  inherited Destroy;
  FEventLogger.Free;
end;

procedure TxtServiceApplication.OnExceptionHandler(Sender: TObject; E: Exception);
begin
  DoHandleException(E);
end;

procedure ServiceMain(Argc: DWord; Argv: PLPSTR); stdcall;
begin
  TxtServiceApplication(Application).DispatchServiceMain(Argc, Argv);
end;

procedure TxtServiceApplication.Run;

  function FindSwitch(const Switch: string): Boolean;
  begin
    Result := FindCmdLineSwitch(Switch, ['-', '/'], True);
  end;

var
  ServiceStartTable: TServiceTableEntryArray;
  ServiceCount, i, J: Integer;
  StartThread: TServiceStartThread;
begin
  AddExitProc(DoneServiceApplication);
  
  if FindSwitch('INSTALL') then
    RegisterServices(True, FindSwitch('SILENT')) else
  if FindSwitch('UNINSTALL') then
    RegisterServices(False, FindSwitch('SILENT')) else
  begin
    Forms.Application.OnException := OnExceptionHandler;
    ServiceCount := 0;
    for i := 0 to ComponentCount - 1 do
      if Components[i] is TService then Inc(ServiceCount);
    SetLength(ServiceStartTable, ServiceCount + 1);
    FillChar(ServiceStartTable[0], SizeOf(TServiceTableEntry) * (ServiceCount + 1), 0);
    J := 0;
    for i := 0 to ComponentCount - 1 do
      if Components[i] is TService then
      begin
        ServiceStartTable[J].lpServiceName := PChar(Components[i].Name);
        ServiceStartTable[J].lpServiceProc := @ServiceMain;
        Inc(J);
      end;
    StartThread := TServiceStartThread.Create(ServiceStartTable);
    try
      while (not Forms.Application.Terminated) and FContinueHandlingMessages do
        Forms.Application.HandleMessage;
      // Application start as standalone application?
      if ((StartThread.ReturnValue = ERROR_FAILED_SERVICE_CONTROLLER_) or
         (StartThread.ReturnValue = ERROR_CALL_NOT_IMPLEMENTED)) and (not Forms.Application.Terminated)
      then
      begin
        raise EServiceError.Create('Not as service');
      end
      else if StartThread.ReturnValue <> 0 then
      begin
        FEventLogger.LogMessage(SysErrorMessage(GetLastError));
      end;
    finally
      StartThread.Free;
    end;
  end;
end;

procedure InitApplication;
begin
  SvcMgr.Application.Free;
  SvcMgr.Application := TxtServiceApplication.Create(nil);
end;

function Application: TxtServiceApplication;
begin
  Result := TxtServiceApplication(SvcMgr.Application);
end;

initialization
  InitApplication;
  InitServiceDesktop;

finalization
  DoneServiceDesktop;
  
end.