* Long overdue simple windows service class

packages/fcl-process/fpmake.pp

@@ -38,6 +38,7 @@ begin
     P.IncludePath.Add('src/$(OS)',AllOSes-[win32,win64]-AllUnixOSes-AllAmigaLikeOSes);
     P.IncludePath.Add('src/dummy',AllOSes-[win32,win64]-AllUnixOSes-AllAmigaLikeOSes);
 
+    P.Dependencies.add('winunits-jedi',[win32,win64]);
     P.Dependencies.add('morphunits',[morphos]);
     P.Dependencies.add('arosunits',[aros]);
     if Defaults.CPU=powerpc then
@@ -52,6 +53,7 @@ begin
       T.Dependencies.AddInclude('processbody.inc');
       T.Dependencies.AddInclude('process.inc');
       T.ResourceStrings:=True;
+    T:=P.Targets.AddUnit('fpsimpleservice.pp',[win32,win64]);
     T:=P.Targets.AddUnit('processunicode.pp',[win32,win64]);
       T.Dependencies.AddInclude('processbody.inc');
       T.Dependencies.AddInclude('process.inc');

packages/fcl-process/src/fpsimpleservice.pp

@@ -0,0 +1,465 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2025 by the Free Pascal development team
+      
+    Simple service application class for windows.  
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit fpsimpleservice;
+
+{
+  Application checks following command-line options to determine behaviour:
+  -r run service
+  -i install service
+  -u uninstall service.
+  
+  When the service is run, a descendent of TFPServiceThread is created and executed.
+  You must set the descendant class to use in Application.ServiceClass before calling initialize.
+}
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, custapp, windows, eventlog, jwawinsvc;
+
+Type
+  { TFPServiceThread }
+
+  TFPServiceThread = Class (TThread)
+  Private
+    FPaused : Boolean;
+  protected
+    Procedure HandleControlCode(Command :Integer); virtual;
+    Procedure Log(EventType : TEventType; const Msg : String);
+    Procedure PauseService; virtual;
+    Procedure StopService; virtual;
+    Procedure RunService; virtual;
+    Procedure ContinueService; virtual;
+    Procedure Execute; override;
+    property Paused : Boolean Read FPaused;
+  end;
+  TFPServiceThreadClass = Class of TFPServiceThread;
+
+  { TFPServiceApplication }
+
+  TFPServiceApplication = Class(TCustomApplication)
+  private
+    FAllowServicePause: Boolean;
+    FServiceClass: TFPServiceThreadClass;
+    FServiceParamStr   : string;
+    FTimeout,
+    FExitCode,
+    FServiceParamCount : integer;
+    FStatus : TServiceStatus;
+    FStopEvent : THandle;
+    FReportStartStop : boolean;
+    FStatusHandle : Service_Status_Handle;
+    FServiceThread : TFPServiceThread;
+    FChkPoint : Integer;
+    FEventLog : TEventLog;
+    procedure ServiceController(Command: Integer);
+    procedure ServiceMain(ArgC: integer; ArgV: ppchar);
+    procedure StopNow;
+    function ReportNoError(AState : integer) : boolean;
+    function ReportServiceStatus(CurrentState, Win32ExitCode, CheckPoint, WaitHint: integer): boolean;
+  Protected
+    function ConnectToServiceManager: SC_Handle;
+    procedure DoRun; override;
+    Procedure RunService;
+    Procedure InstallService;
+    Procedure UninstallService;
+    Procedure DoLog(EventType : TEventType; const Msg : String); override;
+  public
+    Constructor Create(AOwner : TComponent); override;
+    destructor Destroy; override;
+    // Return service error code.
+    function GetServiceError: integer;
+    // Return service error message.
+    function GetServiceErrorMessage: string;
+    // Report that a start is pending. Return true on success.
+    function ReportStartPending: boolean;
+    // Report that a stop is pending. Return true on success.
+    function ReportStopPending: boolean;
+    // Application start
+    procedure Initialize; override;
+    // Thread class to use when starting the service.
+    Property ServiceClass : TFPServiceThreadClass Read FServiceClass Write FServiceClass;
+    // Time before to generate an error. Default 20000 milliseconds
+    property Timeout : integer read FTimeout write FTimeout; 
+    // Exit code to return to Service Manager
+    property ExitCode : integer read FExitCode write FExitCode;
+    // Parameter list passed when the service was started
+    property ServiceParamStr : string read FServiceParamStr; 
+    // Number of parameters passed when the service was started
+    property ServiceParamCount : integer read FServiceParamCount; 
+    // Does the service accept pause/continue commands ?
+    Property AllowServicePause : Boolean Read FAllowServicePause Write FAllowServicePause; 
+  end;
+
+  EFPService = Class(Exception);
+
+function Application: TFPServiceApplication;
+
+implementation
+
+
+Resourcestring
+  SErrNoServiceClass   = 'Cannot run: No service thread class registered.';
+  SErrRunNeedsOverride = 'Cannot run: Runservice must be overridden';
+  SErrRunningService   = 'Error running service: %s';
+  SControlCodeReceived = 'Service: Recived control code %d';
+  SServicePaused       = 'Service received pause command.';
+  SServiceContinued    = 'Service received continue command.';
+
+procedure ServiceControllerEntry(Command : DWord); stdcall;
+
+begin
+  Application.ServiceController(Command);
+end;
+
+procedure ServiceMainEntry(ArgC : DWord; ArgV : pchar); stdcall;
+
+begin
+  Application.ServiceMain(ArgC,PPchar(ArgV));
+end;
+
+Var
+  App : TFPServiceApplication;
+
+function Application: TFPServiceApplication;
+begin
+  If (App=Nil) then
+    App:=TFPServiceApplication.Create(Nil);
+  Result:=App;
+end;
+
+{ TFPServiceThread }
+
+procedure TFPServiceThread.HandleControlCode(Command: Integer);
+begin
+  Log(etInfo,Format(SControlCodeReceived,[Command]));
+end;
+
+procedure TFPServiceThread.Log(EventType: TEventType; const Msg: String);
+begin
+  If Assigned(App) then
+    App.Log(EventType,Msg);
+end;
+
+procedure TFPServiceThread.PauseService;
+begin
+  Log(etInfo,SServicePaused);
+  Suspend;
+end;
+
+procedure TFPServiceThread.ContinueService;
+begin
+  Resume;
+  Log(etInfo,SServiceContinued);
+end;
+
+procedure TFPServiceThread.StopService;
+begin
+  Terminate;
+end;
+
+procedure TFPServiceThread.RunService;
+begin
+  Raise EFPService.Create(SErrRunNeedsOverride);
+end;
+
+
+
+{ TFPServiceApplication }
+
+function TFPServiceApplication.ReportServiceStatus(CurrentState,
+  Win32ExitCode, CheckPoint, WaitHint: integer): boolean;
+
+begin
+  SetLastError(0);
+  With FStatus do
+    begin
+    dwServiceType := SERVICE_WIN32_OWN_PROCESS;
+    dwServiceSpecificExitCode := 0;
+    if CurrentState = SERVICE_START_PENDING then
+      dwControlsAccepted := 0
+    else
+      begin
+      dwControlsAccepted := SERVICE_ACCEPT_STOP;
+      if FAllowServicePause then
+        dwControlsAccepted:=dwControlsAccepted or SERVICE_ACCEPT_PAUSE_CONTINUE;
+      end;
+    dwCurrentState:=CurrentState;
+    dwCheckPoint:=CheckPoint;
+    dwWaitHint:=WaitHint;
+    if (ExitCode=0) then
+      dwWin32ExitCode := Win32ExitCode
+    else
+      begin
+      dwWin32ExitCode := ERROR_SERVICE_SPECIFIC_ERROR;
+      dwServiceSpecificExitCode := ExitCode;
+      end;
+    end;
+  Result:=SetServiceStatus(FStatusHandle, FStatus);
+  if not Result then
+    StopNow;
+end;
+
+procedure TFPServiceApplication.DoRun;
+begin
+  If HasOption('r','run') then
+    RunService
+  else if HasOption('i','install') then
+    InstallService
+  else if HasOption('u','uninstall') then
+    UninstallService
+  else
+    Inherited;
+  Terminate;
+end;
+
+
+procedure TFPServiceApplication.InstallService;
+
+Var
+  S : string;
+  FManager,
+  FService : SC_Handle;
+
+begin
+  S:=ParamStr(0)+' -r';
+  If HasOption('c','config') then
+    S:=S+' -c '+self.GetOptionValue('c','config');
+  try
+    FManager:=ConnectToServiceManager;
+    try
+      FService := CreateService(FManager, PChar(Name), Pchar(Title), SERVICE_ALL_ACCESS, SERVICE_WIN32_OWN_PROCESS, SERVICE_AUTO_START,
+                                SERVICE_ERROR_NORMAL, pchar(S), nil, nil, nil, nil, nil);
+      if (FService=0) then
+         RaiseLastOSError;
+      CloseServiceHandle(FService);
+    finally
+      CloseServiceHandle(FManager);
+    end;
+  finally
+    Terminate;
+  end;
+end;
+
+Function TFPServiceApplication.ConnectToServiceManager : SC_Handle;
+
+begin
+  Result:=OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
+  if (Result=0) then
+    RaiseLastOSError;
+end;
+
+procedure TFPServiceApplication.UninstallService;
+Var
+  FManager,
+  FService : SC_Handle;
+
+begin
+  try
+    FManager:=ConnectToServiceManager;
+    try
+      FService:=OpenService(FManager, Pchar(Name), SERVICE_ALL_ACCESS);
+      if (FService=0) then
+         RaiseLastOSError;
+      if not DeleteService(FService) then
+         RaiseLastOSError;
+      CloseServiceHandle(FService);
+    finally
+      CloseServiceHandle(FManager);
+    end;
+  finally
+    Terminate;
+  end;
+end;
+
+procedure TFPServiceApplication.DoLog(EventType: TEventType; const Msg: String);
+begin
+
+  FeventLog.Log(EventType,Msg);
+end;
+
+constructor TFPServiceApplication.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FEventLog:=TEventLog.Create(Self);
+  FEventLog.RegisterMessageFile(ParamStr(0));
+  StopOnException:=True;
+end;
+
+
+function TFPServiceApplication.GetServiceError : integer;
+begin
+  Result := GetLastError;
+  if Result = 0 then
+    Result := -1
+end;
+
+// Returns last error message
+function TFPServiceApplication.GetServiceErrorMessage : string;
+begin
+  Result := SysErrorMessage(GetServiceError)
+end;
+
+procedure TFPServiceApplication.StopNow;
+begin
+  SetLastError(0);
+  SetEvent(FStopEvent)
+end;
+
+function TFPServiceApplication.ReportNoError(AState : integer) : boolean;
+begin
+  Result:=ReportServiceStatus(AState, NO_ERROR, 0, 0)
+end;
+
+function TFPServiceApplication.ReportStartPending : boolean;
+
+begin
+  Inc(FChkPoint);
+  Result := ReportServiceStatus(SERVICE_START_PENDING, NO_ERROR, FChkPoint, Timeout);
+end;
+
+function TFPServiceApplication.ReportStopPending : boolean;
+begin
+  Inc(FChkPoint);
+  Result := ReportServiceStatus(SERVICE_STOP_PENDING, NO_ERROR, FChkPoint, Timeout);
+end;
+
+Procedure TFPServiceApplication.ServiceController(Command :Integer);
+
+begin
+  case Command of
+    SERVICE_CONTROL_PAUSE:
+      if FStatus.dwCurrentState = SERVICE_RUNNING then
+        begin
+        FServiceThread.FPaused:=True;
+        FServiceThread.PauseService;
+        ReportNoError(SERVICE_PAUSED);
+        end;
+    SERVICE_CONTROL_CONTINUE:
+      if FStatus.dwCurrentState = SERVICE_PAUSED then
+        begin
+        FServiceThread.FPaused:=False;
+        FServiceThread.ContinueService;
+        ReportNoError(SERVICE_RUNNING);
+        end;
+    SERVICE_CONTROL_STOP:
+      begin
+      ReportStopPending;
+      If Assigned(FServiceThread) then
+        begin
+        FServiceThread.StopService;
+        ReportStopPending;
+        end;
+      ReportStopPending;
+      StopNow;
+      end;
+    SERVICE_CONTROL_INTERROGATE:
+      ReportNoError(SERVICE_RUNNING);
+  else
+    FServiceThread.HandleControlCode(Command);
+  end;
+end;
+
+procedure TFPServiceApplication.ServiceMain(ArgC : integer; ArgV : ppchar);
+
+begin
+  FServiceParamCount := ArgC;
+  if (ArgV<>Nil) then
+    FServiceParamStr := strpas(ArgV^);
+  SetLastError(0);
+  FStatusHandle := RegisterServiceCtrlHandlerA(PChar(Name),@ServiceControllerEntry);
+  if FStatusHandle <> 0 then
+    begin
+    if ReportStartPending then
+      begin
+      SetLastError(0);
+      FStopEvent := CreateEvent(nil, true, false, nil);
+      if FStopEvent <> 0 then
+        begin
+        ReportStartPending;
+        FServiceThread:=FServiceClass.Create(False);
+        // Wait for stop signal
+        if ReportNoError(SERVICE_RUNNING) then
+          begin
+          {$ifdef svcdebug}  DebugLog('Starting wait for stop event');{$endif svcdebug}
+          WaitForSingleObject(FStopEvent, INFINITE);
+          {$ifdef svcdebug}  DebugLog('End wait for stop event');{$endif svcdebug}
+          end;
+        ReportStopPending;
+        SetLastError(0);
+        CloseHandle(FStopEvent);
+        end;
+      end;
+    end;
+  ReportServiceStatus(SERVICE_STOPPED, GetLastError, 0, 0);
+end;
+
+
+Procedure TFPServiceApplication.RunService;
+
+var
+  SvcTbl : array[0..1] of TServiceTableEntry;
+
+begin
+  if (FServiceClass=nil) then
+    Raise EFPService.Create(SErrNoServiceClass);
+  FEventLog.Identification:='Service '+Name;
+  FeventLog.Active:=True;
+  fillchar(SvcTbl, sizeof(SvcTbl),0);
+  SvcTbl[0].lpServiceName := Pchar(Name);
+  SvcTbl[0].lpServiceProc := @ServiceMainEntry;
+  SetLastError(0);
+  // Returns only when the service stops
+  StartServiceCtrlDispatcher(@SvcTbl[0]);
+end;
+
+procedure TFPServiceApplication.Initialize;
+begin
+  FTimeout  := 20000;
+  FReportStartStop := true;
+end;
+
+
+destructor TFPServiceApplication.Destroy;
+
+begin
+  FreeAndNil(FEventLog);
+  Inherited;
+end;
+
+procedure TFPServiceThread.Execute;
+
+begin
+  try
+    try
+      RunService;
+    finally
+      Terminate;
+    end;
+  except
+    On E : Exception do
+      Log(etError,Format(SerrRunningService,[E.Message]));
+  end;
+end;
+
+initialization
+
+Finalization
+  FreeAndNil(App);
+
+end.
+