Delphi 服务无法自行停止

Question

我运行一个简单的服务。 我可以使用 SCM 启动和停止它。 我还需要该服务在条件成立时自行停止。

问题 1 ：当我使用 SCM 时服务停止。 我点击“停止服务”，服务几乎立即停止。 但是我注意到 exe 在停止之前在 Windows 任务列表中停留了大约 10 秒。 这是正常行为吗？

问题 2 ：我模拟了一种情况，我需要服务通过增加下面代码示例中的变量来停止自身。 在这种情况下，服务永远不会停止。 我必须在 Windows 任务管理器中终止任务才能停止它。

我尝试了几件事都没有成功。

当我使用SCM停止服务时，ServiceStop调用线程Kill方法，因此线程停止并且服务可以轻轻停止。

当服务想要停止自己时，会从线程本身内部测试条件。 线程会自行停止，但不会停止服务。 所以我想我必须调用 DoShutDown 来告诉服务它必须停止。 但它并没有停止。 无论是否调用 DoShutDown，服务都会继续运行。

我究竟做错了什么？

unit TestSvc;

interface

uses
 System.SyncObjs
,SysUtils
,Windows
,SvcMgr
,Classes
;


Type
  TSvcTh =  class(TThread)
  private
    FEvent : TEvent;  
    FInterval : Cardinal; 
    vi_dbg : byte;
  protected
    procedure Execute; override;
    procedure DoTimer; 
  public
    procedure Kill;
    Constructor Create();
    Destructor Destroy; override;
end;

type
  TMyService = class(TService)
    procedure ServiceCreate(Sender: TObject);
    procedure ServiceStart(Sender: TService; var Started: Boolean);
    procedure ServiceShutdown(Sender: TService);
    procedure ServiceStop(Sender: TService; var Stopped: Boolean);
  private
    SelfStop : Boolean;
    Svc : TSvcTh;
  public
    function GetServiceController: TServiceController; override;
  end;
  var MyService: TMyService;




implementation

procedure ServiceController(CtrlCode: DWord); stdcall;
const sname='ServiceController';
begin
  MyService.Controller(CtrlCode);
end;
function TMyService.GetServiceController: TServiceController;
const sname='TMyService.GetServiceController';
begin
  Result := ServiceController;
end;
procedure TMyService.ServiceCreate(Sender: TObject);
const sname='TMyService.ServiceCreate';
begin
  try
    Name := SvcName;
  except
    on e: exception do begin
    end;
  end;
end;


procedure TMyService.ServiceShutdown(Sender: TService);
const sname='TMyService.ServiceShutdown';
var Stopped : boolean;
begin
  ServiceStop(Self, Stopped);
end;

procedure TMyService.ServiceStart(Sender: TService; var Started: Boolean);
const sname='TMyService.ServiceStart';
begin
    SelfStop := false;
    Started := false;
    try
      Dbg(sname + ' ******* STARTING THREAD');
      Svc := TSvcTh.Create;
      Dbg(sname + '******* THREAD STARTED');
      Started := true;
    except
       on e : exception do begin
         Dbg(sname + '============== EXCEPTION =============>' + e.Message);
       end;
    end;
end;

procedure TMyService.ServiceStop(Sender: TService; var Stopped: Boolean);
const sname='TMyService.ServiceStop';
begin
  try

    Stopped := True;

    if not SelfStop then begin
      Dbg(sname + '*** Stop using service controller');
      Svc.Kill;
      Svc.WaitFor;
      Svc.Free;
      Svc := nil;
    end
    else begin
      dbg(sname + ' *** Stop by the service itself ') ;
    end;

  except
    on E : Exception do
    begin
      dbg(sname + ' Exception ! ' + e.Message);
    end;
  end;
  Dbg(sname + '*** END');
end;

procedure TSvcTh.DoTimer;
const sname = 'TSvcTh.DoTimer';
begin
  try
    inc(vi_dbg);
    Dbg(sname + '******* DoTimer');
  except
    on e : exception do begin
      Dbg(sname +' ============== EXCEPTION =============>' + e.Message);
    end;
  end;
end;

procedure TSvcTh.Execute;
const sname = 'TSvcTh.Execute';
begin
  while not Terminated do begin
      try
        case FEvent.WaitFor(FInterval) of
         wrSignaled : begin // Triggered when we stop the service using service controller
          Terminate;
         end;
         wrTimeout : begin
          if not Servicemni.SelfStop then begin
             DoTimer; 
             if vi_dbg > 5 then begin
                MyService.SelfStop := true; // Testing auto stop
                terminate;
             end;
          end;
         end;
        end;
      except
         on e : exception do begin
          Dbg(sname + ' ============== EXCEPTION =============>' + e.Message);
         end;
      end;
  end;


  if MyService.SelfStop then begin
    MyService.DoShutdown;
  end;

  Dbg(sname + ' ARRET ... ' + StrLog(MyService.Terminated));
  if MyService.SelfStop then begin
    MyService.ReportStatus;
  end;


end;

Constructor TSvcTh.Create();
const sname = 'TSvcTh.Create';
begin
  FEvent := TEvent.Create(nil, False, False, '');
  FInterval := heartbeat;
  vi_dbg := 0;
  inherited Create(False);
end;
destructor TSvcTh.Destroy;
const sname = 'TSvcTh.Destroy';
begin
  try
    if assigned(FEvent) then begin
      FreeAndNil(FEvent);
    end;
  except
    on e:exception do begin
      Dbg(sname + '==========================> EXCEPTION : '+ e.Message);
    end;
  end;
  inherited;
end;

procedure TSvcTh.Kill;
const sname = 'TSvcTh.Kill';
begin
  try
    FEvent.SetEvent;
  except
    on e:exception do begin
      dbg(sname +  ' ==========================> EXCEPTION : '+ e.Message);
    end;
  end;
end;



end.

更新：

如果我添加一个 ServiceExecute 方法并将 Svc 线程修改为仅将 SelfStop 设置为 true（不终止它），则服务结束。 但是看起来不是很优雅。 我不明白为什么需要它。 事实上，该服务似乎无论如何都会创建一个线程“ServiceExecute”。 但是，如果我不编写此方法，则永远不会调用 ProcessRequest，并且当 Svc 线程结束时，“ServiceExecute”永远不会结束。 此外，该进程在服务结束后仍会在 Windows 任务管理器（来自 sysinternals 的进程资源管理器）中停留约 30 秒。

procedure TSvcTh.Execute;
const sname = 'TSvcTh.Execute';
begin
  while not Terminated do begin
      try
        case FEvent.WaitFor(FInterval) of
         wrSignaled : begin // Triggered when we stop the service using service controller
          Terminate;
         end;
         wrTimeout : begin
          DoTimer; 
          if vi_dbg > 5 then begin
            MyService.SelfStop := true; // Testing auto stop
          end;
         end;
        end;
      except
         on e : exception do begin
          Dbg(sname + ' ============== EXCEPTION =============>' + e.Message);
         end;
      end;
  end;
end;

procedure TMyService.ServiceExecute(Sender: TService);
    begin
    while not terminated do begin
      ServiceThread.ProcessRequests(false);
      if SelfStop then begin
        ServiceThread.terminate;
        Svc.Terminate;
        Svc.WaitFor;
        Svc.Free;
        Svc := nil;
      end;
      sleep(1000);      
    end;

更新 2：服务终止延迟 30 秒的解释似乎在这里

Answer 1

如果线程想要终止自己，它可以调用 SCM 通知服务需要停止，这反过来将终止线程，如下面的概念验证代码所示。 为了完成这项工作，我将一个匿名方法传递给 Thread 构造函数以避免依赖于服务本身（并且可以在服务之外测试线程代码）。 如果您启动该服务并且什么都不做，它将在 10 秒后自行关闭。

服务代码：

unit Unit1;

interface

uses
  Unit2,
  WinApi.WinSvc,
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.SvcMgr, Vcl.Dialogs;

type
  TService1 = class(TService)
    procedure ServiceStart(Sender: TService; var Started: Boolean);
    procedure ServiceStop(Sender: TService; var Stopped: Boolean);
  private
    { Private declarations }
    MyThread : TMyThread;
    Eventlog : TEventLogger;
  public
    function GetServiceController: TServiceController; override;
    { Public declarations }
  end;

var
  Service1: TService1;

implementation

{$R *.dfm}

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

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

procedure TService1.ServiceStart(Sender: TService; var Started: Boolean);
begin
 EventLog := TEventLogger.Create('Service1');
 // call our thread and inject code for premature service shutdown
 MyThread := TMyThread.Create(procedure begin Service1.Controller(SERVICE_CONTROL_STOP) end);
 MyThread.Start;
 EventLog.LogMessage('Started');
end;

procedure TService1.ServiceStop(Sender: TService; var Stopped: Boolean);
begin
 EventLog.LogMessage('Stop');
 MyThread.Terminate;
 // Give some time to the thread to cleanup, then bailout
 WaitForSingleObject(MyThread.Handle, 5000);
 EventLog.LogMessage('Stopped');
 EventLog.Free;
 Stopped := True;
end;

end.

工作线程：

unit Unit2;

interface

uses
  SysUtils,
  Vcl.SvcMgr,
  Windows,
  System.Classes;

type
  TSimpleProcedure = reference to procedure;

  TMyThread = class(TThread)
  private
    { Private declarations }
    ShutDownProc : TSimpleProcedure;
    EventLog     : TEventLogger;
  protected
    procedure Execute; override;
  public
    constructor Create(AShutDownProc: TSimpleProcedure);
    destructor Destroy; override;
  end;

implementation

{ MyThread }
constructor TMyThread.Create(AShutDownProc: TSimpleProcedure);
begin
 inherited Create(True);
 ShutDownProc := AShutDownProc;
end;

procedure TMyThread.Execute;

var
  Count : Integer;
  Running : Boolean;

begin
 EventLog := TEventLogger.Create('MyThread');
 EventLog.LogMessage('Thread Started');
 Count := 0;
 Running := True;
 while not Terminated and Running do
  begin
   EventLog.LogMessage(Format('Count: %d', [Count]));
   Running :=  Count <> 10;
   Inc(Count);
   if Running then
    Sleep(1000); // do some work
  end;
 // if thread wants to stop itself, call service thread shutdown and wait for termination
 if not Running and not Terminated then
  begin
   EventLog.LogMessage(Format('Thread Wants to Stop', [Count]));
   ShutDownProc();
  end;
 EventLog.LogMessage(Format('Thread Await terminate', [Count]));
 // await termination
 while not Terminated do Sleep(10);
 EventLog.LogMessage(Format('Thread Terminated', [Count]));
 EventLog.Free;
end;

end.

Delphi 服务无法自行停止

问题描述

1 个解决方案

解决方案1
4 已采纳 2017-10-13 21:18:36

Delphi 服务无法自行停止

问题描述

1 个解决方案

解决方案1 4 已采纳 2017-10-13 21:18:36

解决方案1
4 已采纳 2017-10-13 21:18:36