Delphi, WinSvc.StartService arguments not successfully passed Service app - delphi

Question

I'm writing a few Service apps in Delphi 10.2 pro, and I want to add a launch-time-controllable parameter to force the service apps into a start-up wait-loop long enough to allow me to click into the "Run\Attach to Process" window (before the app commences the initialization code).
To accomplish this, I want to put a Sleep loop into the TService.OnCreate handler which only gets activated if Winapi.WinSvc.StartService passes an argument which specifies the desired delay length in seconds.
The problem I am having: The values being placed into lpServiceArgVectors (StartService 3rd argument) aren't available in the ParamStr(1) function from within the service. I've read that there is an issue with the VAR parameter passing of this argument, but I think I've got that accounted for in my test app (StartService always returns TRUE).
I just can't get the parameters to be seen in the service, and I need some help to get around this wall.
I've put together a short(ish) self-contained example. The crux of this example is the interaction between TMainWindow.StartService (where the lpServiceArgVectors get assembled and passed) and the ServiceCreate -> CheckStartUpDelayParam procedures in TSimpleServiceDelayTest. The service logs to a text file which displays some diagnostic logging; the log is in descending order so that the newest data is inserted at the top.
There are 3 different menu items to call StartService (to vary the calling args) Note that the logged value of ParamStr(1) is always regardless of which Start Service menu option is selected:
//-------------- SimpleHeartbeatService.dpr --------------
program SimpleHeartbeatService;
uses
Vcl.SvcMgr,
ServiceUnit in 'ServiceUnit.pas' {SimpleServiceDelayTest: TService};
{$R *.RES}
begin
if not Application.DelayInitialize or Application.Installing then
Application.Initialize;
Application.CreateForm(TSimpleServiceDelayTest, SimpleServiceDelayTest);
Application.Run;
end.
//------------------ ServiceUnit.pas -----------------------------
unit ServiceUnit;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.SvcMgr, Vcl.Dialogs;
type
TSimpleServiceDelayTest = class(TService)
procedure ServiceExecute(Sender: TService);
procedure ServiceCreate(Sender: TObject);
procedure ServiceShutdown(Sender: TService);
procedure ServiceStart(Sender: TService; var Started: Boolean);
procedure ServiceStop(Sender: TService; var Stopped: Boolean);
procedure ServiceDestroy(Sender: TObject);
private
PrevHeartbeatStr: String;
ServiceLog: TStringList;
Procedure CheckStartUpDelayParam;
Procedure DriveHeartbeatLogging;
Procedure Log(Const Msg: String);
Function LogFileName: String;
public
function GetServiceController: TServiceController; override;
{ Public declarations }
end;
var
SimpleServiceDelayTest: TSimpleServiceDelayTest;
implementation
{$R *.dfm}
// =============================================================================
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
SimpleServiceDelayTest.Controller(CtrlCode);
end;
// =============================================================================
Procedure TSimpleServiceDelayTest.CheckStartUpDelayParam;
Const
OneSec = 1 / 86400;
Var
DelaySecs: Integer;
TZero: TDateTime;
Begin
Log('CheckStartUpDelayParam');
Log('ParamStr(0)=' + ParamStr(0));
Log('ParamStr(1)=' + ParamStr(1));
// ********** THIS IS THE GOAL OF THIS WHOLE ENDEAVOR: **********
// I want to pause the initialization long enough to attach the
// Delphi debugger (via Run | Attach to Process...)
// I want to pass a command line parameter via the NumArgs/pArgVectors args
// from: Winapi.WinSvc.StartService(Svc, NumArgs, pArgVectors)
// So far, I have not been able to pass arguments this way.
DelaySecs := StrToIntDef(ParamStr(1), 0);
If DelaySecs > 0 Then
Begin
TZero := Now;
While Now - TZero > DelaySecs * OneSec do
Sleep(250);
End;
End;
// =============================================================================
Procedure TSimpleServiceDelayTest.DriveHeartbeatLogging;
Var
HeartbeatStr: String;
begin
HeartbeatStr := FormatDateTime('hh:mm', Now);
If HeartbeatStr <> PrevHeartbeatStr Then
Try
Log('HeartbeatStr = ' + HeartbeatStr);
Finally
PrevHeartbeatStr := HeartbeatStr;
End;
end;
// =============================================================================
function TSimpleServiceDelayTest.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
// =============================================================================
Procedure TSimpleServiceDelayTest.Log(const Msg: string);
begin
ServiceLog.Insert(0, FormatDateTime('yyyy/mm/dd hh:mm:ss.zzz ', Now) + Msg);
While ServiceLog.Count > 500 do
ServiceLog.Delete(ServiceLog.Count-1);
// Save after every addition; inefficient, but thorough for debugging
ServiceLog.SaveToFile(LogFileName);
end;
// =============================================================================
Function TSimpleServiceDelayTest.LogFileName: String;
Begin
Result := System.SysUtils.ChangeFileExt(ParamStr(0), '.txt');
End;
// =============================================================================
procedure TSimpleServiceDelayTest.ServiceCreate(Sender: TObject);
begin
ServiceLog := TStringList.Create;
If FileExists(LogFileName) Then
ServiceLog.LoadFromFile(LogFileName);
Log('^^^ ServiceCreate ^^^');
CheckStartUpDelayParam;
end;
// =============================================================================
procedure TSimpleServiceDelayTest.ServiceDestroy(Sender: TObject);
begin
PrevHeartbeatStr := '';
ServiceLog.Free;
end;
// =============================================================================
procedure TSimpleServiceDelayTest.ServiceExecute(Sender: TService);
begin
Try
Log('Entering ServiceExecute loop');
While Not Terminated do
Begin
ServiceThread.ProcessRequests(False);
DriveHeartbeatLogging;
// Do other stuff
Sleep(1000);
End;
Log('Exiting due to normal termination');
Except
On E: Exception do
Log('Exiting due to Exception:' + #13#10 + E.Message);
End;
End;
// =============================================================================
procedure TSimpleServiceDelayTest.ServiceShutdown(Sender: TService);
begin
Log('ServiceShutdown');
end;
// =============================================================================
procedure TSimpleServiceDelayTest.ServiceStart(Sender: TService;
var Started: Boolean);
begin
Log('ServiceStart');
Started := True;
end;
// =============================================================================
procedure TSimpleServiceDelayTest.ServiceStop(Sender: TService;
var Stopped: Boolean);
begin
Log('ServiceStop');
Stopped := True;
end;
// =============================================================================
end.
//------------ ServiceUnit.dfm -----------------------
object SimpleServiceDelayTest: TSimpleServiceDelayTest
OldCreateOrder = False
OnCreate = ServiceCreate
OnDestroy = ServiceDestroy
DisplayName = 'Simple Delphi Service (Startup-Delay Test)'
OnExecute = ServiceExecute
OnShutdown = ServiceShutdown
OnStart = ServiceStart
OnStop = ServiceStop
Height = 150
Width = 215
end
Next, a short GUI Service Interface app to (Un)Install, Start/Stop
//------------- SimpleServiceController.dpr ------------
program SimpleServiceController;
uses
Vcl.Forms,
ControllerMainUnit in 'ControllerMainUnit.pas' {MainWindow};
{$R *.res}
begin
Application.Initialize;
Application.MainFormOnTaskbar := True;
Application.CreateForm(TMainWindow, MainWindow);
Application.Run;
end.
//-------------- ControlerMainUnit.pas ------------------
unit ControllerMainUnit;
interface
uses
System.Classes, System.SysUtils, System.Variants, Vcl.ComCtrls,
Vcl.Controls, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.Forms, Vcl.Graphics, Vcl.Menus,
Vcl.StdCtrls, Winapi.Messages, Winapi.Windows;
type
TMainWindow = class(TForm)
InstallService1: TMenuItem;
MainMenu1: TMainMenu;
Memo1: TMemo;
StartService1: TMenuItem;
StopService1: TMenuItem;
Timer1: TTimer;
UninstallService1: TMenuItem;
StatusBar1: TStatusBar;
StartWithoutDelayMenuItem: TMenuItem;
StartWith10SecondDelay1: TMenuItem;
StartWithXParameter1: TMenuItem;
procedure Timer1Timer(Sender: TObject);
procedure InstallService1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure StartWithoutDelayMenuItemClick(Sender: TObject);
procedure StartWith10SecondDelay1Click(Sender: TObject);
procedure StopService1Click(Sender: TObject);
procedure UninstallService1Click(Sender: TObject);
procedure StartWithXParameter1Click(Sender: TObject);
private
{ Private declarations }
FileTimeLoaded: _FILETIME;
SCMError: Cardinal;
SCMHandle: THandle;
StatusStr: String;
Function CurrentFileTime: _FILETIME;
Function LogFileName: String;
Procedure RelaunchElevatedPrompt;
Function ServiceExePath: String;
Procedure StartService(Const Parameter: String);
Procedure StopService;
public
{ Public declarations }
end;
var
MainWindow: TMainWindow;
implementation
{$R *.dfm}
Uses
System.UITypes, Winapi.ShellAPI, Winapi.WinSvc;
Const
cServiceName = 'SimpleServiceDelayTest';
// =============================================================================
Function AppHasElevatedPrivs: Boolean;
const
TokenElevationType = 18;
TokenElevation = 20;
TokenElevationTypeDefault = 1;
TokenElevationTypeFull = 2;
TokenElevationTypeLimited = 3;
var
token: THandle;
Elevation: DWord;
dwSize: Cardinal;
begin
Try
if OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, token) then
try
if GetTokenInformation(token, TTokenInformationClass(TokenElevation),
#Elevation, SizeOf(Elevation), dwSize) then
Result := Elevation <> 0
else
Result := False;
finally
CloseHandle(token);
end
else
Result := False;
Except
Result := False;
End;
End;
// =============================================================================
Procedure Launch(Exe, Params: String);
Var
Dir: String;
Begin
Dir := ExtractFileDir(Exe);
ShellExecute(0, 'open', PChar(Exe), PChar(Params), PChar(Dir), SW_SHOWNORMAL);
End;
// =============================================================================
Function NowStr: String;
Begin
Result := FormatDateTime('yyyy/mm/dd hh:mm:ss', Now);
End;
// =============================================================================
Procedure LaunchElevated(Const Exe, Params: String);
Var
Dir: String;
Begin
Dir := ExtractFileDir(Exe);
ShellExecute(0, 'runas', PChar(Exe), PChar(Params), PChar(Dir),
SW_SHOWNORMAL);
End;
// =============================================================================
Function TMainWindow.CurrentFileTime;
Var
FAD: TWin32FileAttributeData;
begin
GetFileAttributesEx(PChar(LogFileName), GetFileExInfoStandard, #FAD);
Result := FAD.ftLastWriteTime;
end;
// =============================================================================
procedure TMainWindow.FormCreate(Sender: TObject);
begin
Application.Title := 'SimpleServiceController';
if AppHasElevatedPrivs then
begin
SetLastError(0);
SCMHandle := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
SCMError := GetLastError;
end
else
begin
SCMHandle := 0;
SCMError := 0;
end;
end;
// =============================================================================
procedure TMainWindow.InstallService1Click(Sender: TObject);
begin
If AppHasElevatedPrivs Then
Launch(ServiceExePath, '/install')
Else
LaunchElevated(ServiceExePath, '/install');
End;
// =============================================================================
Function TMainWindow.LogFileName: String;
Begin
Result := ExtractFileDir(Application.ExeName) + '\SimpleHeartbeatService.txt';
End;
// =============================================================================
Procedure TMainWindow.RelaunchElevatedPrompt;
Var
Prompt: String;
X, Y: Integer;
Begin
Prompt := 'Elevated privileges required to start/stop service.'#13#10 +
'Re-launch ' + Application.Title + ' with elevated privileges?';
X := Left + 32;
Y := Top + 32;
If MessageDlgPos(Prompt, mtConfirmation, [mbYes, mbNo], 0, X, Y) = mrYes then
Begin
LaunchElevated(Application.ExeName, '');
Close;
End;
End;
// =============================================================================
Function TMainWindow.ServiceExePath;
begin
Result := ExtractFileDir(Application.ExeName) + '\SimpleHeartbeatService.exe';
end;
// =============================================================================
Procedure TMainWindow.StartService(Const Parameter: string);
Var
Result:Boolean;
Svc: THandle;
NumArgs: DWord;
// ********** IS THIS THE CORRECT WAY TO SETUP lpServiceArgVectors ? *********
// learn.microsoft.com/en-us/windows/desktop/api/winsvc/nf-winsvc-startservicea
// ***************************************************************************
ArgVectors: Array [0 .. 1] of PChar;
pArgVectors: LPCWSTR; // To match VAR parameter type in StartService
Begin
Try
If SCMHandle = 0 Then
RelaunchElevatedPrompt
Else
Begin
Svc := OpenService(SCMHandle, PChar(cServiceName), SERVICE_START);
if Svc = 0 then
RaiseLastOSError;
try
// ******************* THIS IS WHERE I AM STYMIED **********************
// StartService reports no errors either way it gets called below,
// but no parameter are detected in the service when
// ArgVectors = 'SimpleServiceDelayTest','10' and NumArgs = 2
// *********************************************************************
If Parameter <> '' Then
Begin
NumArgs := 2;
ArgVectors[0] := PChar(cServiceName);
ArgVectors[1] := PChar(Parameter); // Try 10 second delay
pArgVectors := #ArgVectors;
End
Else
Begin
NumArgs := 0;
ArgVectors[0] := '';
ArgVectors[1] := '';
pArgVectors := Nil;
End;
// NO ERROR, EITHER WAY; BUT PARAMSTR(1) ALWAYS BLANK IN SERVICE
If Parameter = 'X'
Then
// http://codeverge.com/embarcadero.delphi.nativeapi/calling-startservice-with-multip/1067853
Result := Winapi.WinSvc.StartService(Svc, NumArgs, ArgVectors[0])
Else
Result := Winapi.WinSvc.StartService(Svc, NumArgs, pArgVectors);
If Result then
ShowMessage('StartService('''+Parameter+''') returned TRUE')
else
RaiseLastOSError;
finally
CloseServiceHandle(Svc);
end;
End;
except
On E: Exception do
Raise Exception.Create('StartService: ' + E.Message);
end;
end;
// =============================================================================
procedure TMainWindow.StartWith10SecondDelay1Click(Sender: TObject);
begin
StartService('10');
end;
// =============================================================================
procedure TMainWindow.StartWithoutDelayMenuItemClick(Sender: TObject);
begin
StartService('');
end;
procedure TMainWindow.StartWithXParameter1Click(Sender: TObject);
begin
StartService('X');
end;
// =============================================================================
Procedure TMainWindow.StopService;
Const
OneSec = 1 / 86400;
Var
Svc: THandle;
Status: SERVICE_STATUS;
TZero: TDateTime;
begin
Try
If SCMHandle = 0 Then
RelaunchElevatedPrompt
Else
Begin
Svc := OpenService(SCMHandle, PChar(cServiceName), SERVICE_STOP or
SERVICE_QUERY_STATUS);
if Svc = 0 then
RaiseLastOSError
else
Try
if Winapi.WinSvc.ControlService(Svc, SERVICE_CONTROL_STOP, Status)
then
Begin
TZero := Now;
while QueryServiceStatus(Svc, Status) and
(Status.dwCurrentState <> SERVICE_STOPPED) and
(Now - TZero < 5 * OneSec) do
Begin
Application.ProcessMessages;
Sleep(10);
End;
End
Else
Raise Exception.Create('WinSvc.ControlService returned FALSE');
finally
CloseServiceHandle(Svc);
end;
End;
except
On E: Exception do
Raise Exception.Create('StartService: ' + E.Message);
end;
end;
// =============================================================================
procedure TMainWindow.StopService1Click(Sender: TObject);
begin
StopService;
end;
// =============================================================================
procedure TMainWindow.Timer1Timer(Sender: TObject);
begin
Try
If Int64(CurrentFileTime) <> Int64(FileTimeLoaded) Then
Begin
Memo1.Lines.LoadFromFile(LogFileName);
FileTimeLoaded := CurrentFileTime;
StatusStr := ' File loaded # ' + NowStr;
End;
Except
StatusStr := ' Unable to load file # ' + NowStr;
End;
StatusBar1.Panels[0].Text := FormatDateTime('hh:mm:ss ', Now) + StatusStr;
end;
// =============================================================================
procedure TMainWindow.UninstallService1Click(Sender: TObject);
begin
If AppHasElevatedPrivs Then
Launch(ServiceExePath, '/uninstall')
Else
LaunchElevated(ServiceExePath, '/uninstall');
end;
// =============================================================================
end.
//------------------- ControllerMainUnit.dfm ----------------
object MainWindow: TMainWindow
Left = 0
Top = 0
Caption = 'Simple Service Controller'
ClientHeight = 264
ClientWidth = 530
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
Menu = MainMenu1
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Memo1: TMemo
Left = 0
Top = 0
Width = 530
Height = 245
Align = alClient
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'Courier New'
Font.Style = []
Lines.Strings = (
'Memo1')
ParentFont = False
ScrollBars = ssBoth
TabOrder = 0
end
object StatusBar1: TStatusBar
Left = 0
Top = 245
Width = 530
Height = 19
Panels = <
item
Width = 50
end>
end
object MainMenu1: TMainMenu
Left = 136
Top = 40
object InstallService1: TMenuItem
Caption = 'Install Service'
OnClick = InstallService1Click
end
object UninstallService1: TMenuItem
Caption = 'Uninstall Service'
OnClick = UninstallService1Click
end
object StartService1: TMenuItem
Caption = 'Start Service'
object StartWithoutDelayMenuItem: TMenuItem
Caption = 'Start Without Delay'
OnClick = StartWithoutDelayMenuItemClick
end
object StartWith10SecondDelay1: TMenuItem
Caption = 'Start With 10 Second Delay'
OnClick = StartWith10SecondDelay1Click
end
object StartWithXParameter1: TMenuItem
Caption = 'Start With "X" Parameter'
OnClick = StartWithXParameter1Click
end
end
object StopService1: TMenuItem
Caption = 'Stop Service'
OnClick = StopService1Click
end
end
object Timer1: TTimer
OnTimer = Timer1Timer
Left = 240
Top = 40
end
end

Answer 1

The TService.OnCreate event is the wrong place to run a delay loop. You need to put it in the TService.OnStart event instead.
The OnCreate event is always called at process startup, regardless of why the process is being run - (un)installation or service start.
The OnStart event is called only when the service is being started by the SCM. That is where you need to process your service start parameters.
The ParamStr() function retrieves the calling process's command-line parameters only, and that is not the correct place to look for service start parameters as they are not passed on the command line. They will be accessible from the TService.Param[] property instead, once the SCM has signaled the service to start.
Try something more like this instead:
Procedure TSimpleServiceDelayTest.CheckStartUpDelayParam;
const
OneSec = 1000;
var
DelaySecs: Integer;
TZero: DWORD;
i, num: Integer;
begin
Log('CheckStartUpDelayParam');
DelaySecs := 0;
for i := 0 to ParamCount-1 do
begin
Log('Param['+IntToStr(i)+']=' + Param[i]);
if DelaySecs = 0 then
begin
if TryStrToInt(Param[i], num) and (num > 0) then
DelaySecs := num;
end;
end;
if DelaySecs > 0 then
begin
TZero := GetTickCount();
repeat
Sleep(250); // NOTE: should not exceed the TService.WaitHint value...
ReportStatus;
until (GetTickCount() - TZero) >= (DelaySecs * OneSec);
end;
end;
...
procedure TSimpleServiceDelayTest.ServiceCreate(Sender: TObject);
begin
ServiceLog := TStringList.Create;
if FileExists(LogFileName) then
ServiceLog.LoadFromFile(LogFileName);
Log('^^^ ServiceCreate ^^^');
// DO NOT call CheckStartUpDelayParam() here!
end;
procedure TSimpleServiceDelayTest.ServiceStart(Sender: TService; var Started: Boolean);
begin
Log('ServiceStart');
// call CheckStartUpDelayParam() here instead!
CheckStartUpDelayParam;
Started := True;
end;
procedure TMainWindow.StartService(Const Parameter: string);
var
Result: Boolean;
Svc: THandle;
ArgVectors: Array [0 .. 1] of PChar;
NumArgs: DWORD;
pArgs: PPChar;
begin
try
if SCMHandle = 0 Then
RelaunchElevatedPrompt
else
begin
Svc := OpenService(SCMHandle, PChar(cServiceName), SERVICE_START);
if Svc = 0 then
RaiseLastOSError;
try
if Parameter <> '' then
begin
NumArgs := 2;
ArgVectors[0] := PChar(cServiceName);
ArgVectors[1] := PChar(Parameter);
pArgs := #ArgVectors[0];
end
else
begin
NumArgs := 0;
pArgs := nil;
end;
if not Winapi.WinSvc.StartService(Svc, NumArgs, pArgs^) then
RaiseLastOSError;
finally
CloseServiceHandle(Svc);
end;
ShowMessage('StartService('''+Parameter+''') returned TRUE')
end;
except
on E: Exception do
begin
raise Exception.Create('StartService: ' + E.Message);
end;
end;
end;