multithreading - 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”。但是，如果我不编写此方法，则Svc线程结束时，永远不会调用ProcessRequest并且“ServiceExecute”也永远不会结束。此外，服务结束后，该进程在Windows任务管理器(sysinternals中的Process Explorer)中仍停留约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: The explication for the delay of 30 seconds for the service to terminate seems to be here

Answer 1

如果线程想要终止自身，则可以调用SCM通知服务需要停止，这将依次终止线程，如下面的概念验证代码所示。为了使这项工作有效，我将一个匿名方法传递给Thread构造函数，以避免对Service本身具有依赖关系(并且可以在服务外部测试线程代码)。
如果您启动该服务却不执行任何操作，它将在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.