svcmgr.pas

定时关机程序

  begin
    Inc(Len, Length(Dependencies[i].Name) + 1); // For null-terminator
    if Dependencies[i].IsGroup then Inc(Len);
  end;
  if Len <> 0 then
  begin
    Inc(Len); // For final null-terminator;
    SetLength(Result, Len);
    P := @Result[1];
    for i := 0 to Dependencies.Count - 1 do
    begin
      if Dependencies[i].IsGroup then
      begin
        P^ := SC_GROUP_IDENTIFIER;
        Inc(P);
      end;
      P := StrECopy(P, PChar(Dependencies[i].Name));
      Inc(P);
    end;
    P^ := #0;
  end;
end;

function TService.GetNTServiceType: Integer;
const
  NTServiceType: array[TServiceType] of Integer = ( SERVICE_WIN32_OWN_PROCESS,
    SERVICE_KERNEL_DRIVER, SERVICE_FILE_SYSTEM_DRIVER);
begin
  Result := NTServiceType[FServiceType];
  if (FServiceType = stWin32) and Interactive then
    Result := Result or SERVICE_INTERACTIVE_PROCESS;
  if (FServiceType = stWin32) and (Application.ServiceCount > 1) then
    Result := (Result xor SERVICE_WIN32_OWN_PROCESS) or SERVICE_WIN32_SHARE_PROCESS;
end;

function TService.GetNTStartType: Integer;
const
  NTStartType: array[TStartType] of Integer = (SERVICE_BOOT_START,
    SERVICE_SYSTEM_START, SERVICE_AUTO_START, SERVICE_DEMAND_START,
    SERVICE_DISABLED);
begin
  Result := NTStartType[FStartType];
  if (FStartType in [stBoot, stSystem]) and (FServiceType <> stDevice) then
    Result := SERVICE_AUTO_START;
end;

function TService.GetNTErrorSeverity: Integer;
const
  NTErrorSeverity: array[TErrorSeverity] of Integer = (SERVICE_ERROR_IGNORE,
    SERVICE_ERROR_NORMAL, SERVICE_ERROR_SEVERE, SERVICE_ERROR_CRITICAL);
begin
  Result := NTErrorSeverity[FErrorSeverity];
end;

function TService.GetNTControlsAccepted: Integer;
begin
  Result := SERVICE_ACCEPT_SHUTDOWN;
  if AllowStop then Result := Result or SERVICE_ACCEPT_STOP;
  if AllowPause then Result := Result or SERVICE_ACCEPT_PAUSE_CONTINUE;
end;

procedure TService.LogMessage(Message: String; EventType: DWord; Category, ID: Integer);
begin
  if FEventLogger = nil then
    FEventLogger := TEventLogger.Create(Name);
  FEventLogger.LogMessage(Message, EventType, Category, ID);
end;

procedure TService.ReportStatus;
const
  LastStatus: TCurrentStatus = csStartPending;
  NTServiceStatus: array[TCurrentStatus] of Integer = (SERVICE_STOPPED,
    SERVICE_START_PENDING, SERVICE_STOP_PENDING, SERVICE_RUNNING,
    SERVICE_CONTINUE_PENDING, SERVICE_PAUSE_PENDING, SERVICE_PAUSED);
  PendingStatus: set of TCurrentStatus = [csStartPending, csStopPending,
    csContinuePending, csPausePending];
var
  ServiceStatus: TServiceStatus;
begin
  with ServiceStatus do
  begin
    dwWaitHint := FWaitHint;
    dwServiceType := GetNTServiceType;
    if FStatus = csStartPending then
      dwControlsAccepted := 0 else
      dwControlsAccepted := GetNTControlsAccepted;
    if (FStatus in PendingStatus) and (FStatus = LastStatus) then
      Inc(dwCheckPoint) else
      dwCheckPoint := 0;
    LastStatus := FStatus;
    dwCurrentState := NTServiceStatus[FStatus];
    dwWin32ExitCode := Win32ErrCode;
    dwServiceSpecificExitCode := ErrCode;
    if ErrCode <> 0 then
      dwWin32ExitCode := ERROR_SERVICE_SPECIFIC_ERROR;
    if not SetServiceStatus(FStatusHandle, ServiceStatus) then
      LogMessage(SysErrorMessage(GetLastError));
  end;
end;

procedure TService.SetStatus(Value: TCurrentStatus);
begin
  FStatus := Value;
  if not (csDesigning in ComponentState) then
    ReportStatus;
end;

procedure TService.Main(Argc: DWord; Argv: PLPSTR);
type
  PPCharArray = ^TPCharArray;
  TPCharArray = array [0..1024] of PChar;
var
  i: Integer;
  Controller: TServiceController;
begin
  for i := 0 to Argc - 1 do
    FParams.Add(PPCharArray(Argv)[i]);
  Controller := GetServiceController();
  FStatusHandle := RegisterServiceCtrlHandler(PChar(Name), @Controller);
  if (FStatusHandle = 0) then
    LogMessage(SysErrorMessage(GetLastError)) else
    DoStart;
end;

procedure TService.Controller(CtrlCode: DWord);
begin
  PostThreadMessage(ServiceThread.ThreadID, CM_SERVICE_CONTROL_CODE, CtrlCode, 0);
  if ServiceThread.Suspended then ServiceThread.Resume;
end;

procedure TService.DoStart;
begin
  try
    Status := csStartPending;
    try
      FServiceThread := TServiceThread.Create(Self);
      FServiceThread.Resume;
      FServiceThread.WaitFor;
      FreeAndNil(FServiceThread);
    finally
      Status := csStopped;
    end;
  except
    on E: Exception do
      LogMessage(Format(SServiceFailed,[SExecute, E.Message]));
  end;
end;

function TService.DoStop: Boolean;
begin
  Result := True;
  Status := csStopPending;
  if Assigned(FOnStop) then FOnStop(Self, Result);
  if Result then ServiceThread.Terminate;
end;

function TService.DoPause: Boolean;
begin
  Result := True;
  Status := csPausePending;
  if Assigned(FOnPause) then FOnPause(Self, Result);
  if Result then
  begin
    Status := csPaused;
    ServiceThread.Suspend;
  end;
end;

function TService.DoContinue: Boolean;
begin
  Result := True;
  Status := csContinuePending;
  if Assigned(FOnContinue) then FOnContinue(Self, Result);
  if Result then
    Status := csRunning;
end;

procedure TService.DoInterrogate;
begin
  ReportStatus;
end;

procedure TService.DoShutdown;
begin
  Status := csStopPending;
  try
    if Assigned(FOnShutdown) then FOnShutdown(Self);
  finally
    { Shutdown cannot abort, it must stop regardless of any exception }
    ServiceThread.Terminate;
  end;
end;

function TService.DoCustomControl(CtrlCode: DWord): Boolean;
begin
  Result := True;
end;

{ TServiceApplication }

type
  TServiceClass = class of TService;

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

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;

constructor TServiceApplication.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FEventLogger := TEventLogger.Create(ExtractFileName(ParamStr(0)));
  Forms.Application.HookMainWindow(Hook);
end;

destructor TServiceApplication.Destroy;
begin
  FEventLogger.Free;
  Forms.Application.OnException := nil;
  Forms.Application.UnhookMainWindow(Hook);
  inherited Destroy;
end;

procedure TServiceApplication.DispatchServiceMain(Argc: DWord; Argv: PLPSTR);
var
  i: Integer;
begin
  for i := 0 to ComponentCount - 1 do
    if (Components[i] is TService) and
       (AnsiCompareText(PChar(Argv^), Components[i].Name) = 0) then
    begin
      TService(Components[i]).Main(Argc, Argv);
      break;
    end;
end;

function TServiceApplication.GetServiceCount: Integer;
var
  i: Integer;
begin
  Result := 0;
  for i := 0 to ComponentCount - 1 do
    if Components[i] is TService then
      Inc(Result);
end;

procedure TServiceApplication.RegisterServices(Install, Silent: Boolean);

  procedure InstallService(Service: TService; SvcMgr: Integer);
  var
    TmpTagID, Svc: Integer;
    PTag, PSSN: Pointer;
    Path: string;
  begin
    Path := ParamStr(0);
    with Service do
    begin
      if Assigned(BeforeInstall) then BeforeInstall(Service);
      TmpTagID := TagID;
      if TmpTagID > 0 then PTag := @TmpTagID else PTag := nil;
      if ServiceStartName = '' then
        PSSN := nil else
        PSSN := PChar(ServiceStartName);
      Svc := CreateService(SvcMgr, PChar(Name), PChar(DisplayName),
        SERVICE_ALL_ACCESS, GetNTServiceType, GetNTStartType, GetNTErrorSeverity,
        PChar(Path), PChar(LoadGroup), PTag, PChar(GetNTDependencies),
        PSSN, PChar(Password));
      TagID := TmpTagID;
      if Svc = 0 then
        RaiseLastOSError;
      try
        try
          if Assigned(AfterInstall) then AfterInstall(Service);
        except
          on E: Exception do
          begin
            DeleteService(Svc);
            raise;
          end;
        end;
      finally
        CloseServiceHandle(Svc);
      end;
    end;
  end;

  procedure UninstallService(Service: TService; SvcMgr: Integer);
  var
    Svc: Integer;
  begin
    with Service do
    begin
      if Assigned(BeforeUninstall) then BeforeUninstall(Service);
      Svc := OpenService(SvcMgr, PChar(Name), SERVICE_ALL_ACCESS);
      if Svc = 0 then RaiseLastOSError;
      try
        if not DeleteService(Svc) then RaiseLastOSError;
      finally
        CloseServiceHandle(Svc);
      end;
      if Assigned(AfterUninstall) then AfterUninstall(Service);
    end;
  end;


var
  SvcMgr: Integer;
  i: Integer;
  Success: Boolean;
  //Msg: string;
begin
  Success := True;
  SvcMgr := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if SvcMgr = 0 then RaiseLastOSError;
  try
    for i := 0 to ComponentCount - 1 do
      if Components[i] is TService then
      try
        if Install then
          InstallService(TService(Components[i]), SvcMgr) else
          UninstallService(TService(Components[i]), SvcMgr)
      except
        on E: Exception do
        begin
          Success := False;
          {if Install then
            Msg := SServiceInstallFailed else
            Msg := SServiceUninstallFailed;
          with TService(Components[i]) do
            MessageDlg(Format(Msg, [DisplayName, E.Message]), mtError, [mbOK],0); }
        end;
      end;
    if Success and not Silent then
      if Install then
        MessageDlg('服务成功安装', mtInformation, [mbOk], 0)
      else
        MessageDlg('服务已经删除', mtInformation, [mbOk], 0);
  finally
    CloseServiceHandle(SvcMgr);
  end;
end;

function TServiceApplication.Hook(var Message: TMessage): Boolean;
begin
  Result := Message.Msg = WM_ENDSESSION;
end;

procedure TServiceApplication.CreateForm(InstanceClass: TComponentClass;
  var Reference);
begin
  if InstanceClass.InheritsFrom(TService) then
  begin
    try
      TComponent(Reference) := InstanceClass.Create(Self);
    except
      TComponent(Reference) := nil;
      raise;
    end;
  end else
    Forms.Application.CreateForm(InstanceClass, Reference);
end;

procedure TServiceApplication.DoHandleException(E: Exception);
begin
  FEventLogger.LogMessage(E.Message);
end;

procedure TServiceApplication.Initialize;
begin
  Forms.Application.ShowMainForm :=False;
  Forms.Application.Initialize;
end;

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

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;
  PostMessage(Forms.Application.Handle, WM_QUIT, 0, 0);
end;

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

procedure TServiceApplication.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 do
        Forms.Application.HandleMessage;
      Forms.Application.Terminate;
      if StartThread.ReturnValue <> 0 then
        FEventLogger.LogMessage(SysErrorMessage(StartThread.ReturnValue));
    finally
      StartThread.Free;
    end;
  end;
end;

procedure InitApplication;
begin
  Application := TServiceApplication.Create(nil);
end;

procedure DoneApplication;
begin
  Application.Free;
  Application := nil;
end;

initialization
  InitApplication;
finalization
  DoneApplication;
end.