Delphi、WinSvc.StartService 个参数未成功传递给服务应用
Delphi, WinSvc.StartService arguments not successfully passed Service app
我正在 Delphi 10.2 pro 中编写一些服务应用程序，我想添加一个启动时间可控参数以强制服务应用程序进入启动等待循环足够长的时间请允许我点击进入 "Run\Attach to Process" window（在应用程序开始初始化代码之前）。
为此，我想将睡眠循环放入 TService.OnCreate 处理程序中，只有在 Winapi.WinSvc.StartService 传递指定所需延迟长度（以秒为单位）的参数时才会激活该处理程序。
我遇到的问题：放置到 lpServiceArgVectors（StartService 第三个参数）中的值在服务中的 ParamStr(1) 函数中不可用。我读到过传递此参数的 VAR 参数存在问题，但我认为我已经在我的测试应用程序中解决了这个问题（StartService 始终 returns TRUE）。
我只是无法在服务中看到参数，我需要一些帮助来绕过这堵墙。
我整理了一个简短的（大概）独立示例。此示例的症结在于 TMainWindow.StartService（lpServiceArgVectors 在此组装并传递）与 TSimpleServiceDelayTest 中的 ServiceCreate -> CheckStartUpDelayParam 过程之间的交互。该服务记录到一个显示一些诊断日志记录的文本文件；日志按降序排列，以便将最新数据插入顶部。
有 3 个不同的菜单项可以调用 StartService（以改变调用参数）请注意，无论选择哪个 Start Service 菜单选项，ParamStr(1) 的记录值始终是：
//------------- 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
接下来，要（卸载）安装一个简短的 GUI 服务界面应用程序，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 ? *********
// docs.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
TService.OnCreate event is the wrong place to run a delay loop. You need to put it in the TService.OnStart 事件。
OnCreate 事件总是在进程启动时调用，无论进程为何 运行 -（卸载）安装或服务启动。
OnStart 事件仅在 SCM 启动服务时调用。那是您需要处理服务启动参数的地方。
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[] 属性 相反，一旦 SCM 发出服务启动信号。
尝试更像这样的东西：
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;
我正在 Delphi 10.2 pro 中编写一些服务应用程序，我想添加一个启动时间可控参数以强制服务应用程序进入启动等待循环足够长的时间请允许我点击进入 "Run\Attach to Process" window（在应用程序开始初始化代码之前）。
为此，我想将睡眠循环放入 TService.OnCreate 处理程序中，只有在 Winapi.WinSvc.StartService 传递指定所需延迟长度（以秒为单位）的参数时才会激活该处理程序。
我遇到的问题：放置到 lpServiceArgVectors（StartService 第三个参数）中的值在服务中的 ParamStr(1) 函数中不可用。我读到过传递此参数的 VAR 参数存在问题，但我认为我已经在我的测试应用程序中解决了这个问题（StartService 始终 returns TRUE）。
我只是无法在服务中看到参数，我需要一些帮助来绕过这堵墙。
我整理了一个简短的（大概）独立示例。此示例的症结在于 TMainWindow.StartService（lpServiceArgVectors 在此组装并传递）与 TSimpleServiceDelayTest 中的 ServiceCreate -> CheckStartUpDelayParam 过程之间的交互。该服务记录到一个显示一些诊断日志记录的文本文件；日志按降序排列，以便将最新数据插入顶部。
有 3 个不同的菜单项可以调用 StartService（以改变调用参数）请注意，无论选择哪个 Start Service 菜单选项，ParamStr(1) 的记录值始终是：
//------------- 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
接下来，要（卸载）安装一个简短的 GUI 服务界面应用程序，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 ? *********
// docs.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
TService.OnCreate event is the wrong place to run a delay loop. You need to put it in the TService.OnStart 事件。
OnCreate 事件总是在进程启动时调用，无论进程为何 运行 -（卸载）安装或服务启动。
OnStart 事件仅在 SCM 启动服务时调用。那是您需要处理服务启动参数的地方。
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[] 属性 相反，一旦 SCM 发出服务启动信号。
尝试更像这样的东西：
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;