Delphi, WinSvc.StartService аргументы не успешно переданы приложению службы - PullRequest
Новая
       1

Delphi, WinSvc.StartService аргументы не успешно переданы приложению службы

0 голосов
/ 20 февраля 2019

Я пишу несколько приложений-служб в Delphi 10.2 pro и хочу добавить параметр, контролируемый временем запуска, чтобы заставить приложения-службы достаточно долго запускать цикл запуска, чтобы я мог нажать на кнопкуОкно «Run \ Attach to Process» (до того, как приложение начинает код инициализации).

Для этого я хочу поместить цикл Sleep в обработчик TService.OnCreate, который активируется только в случае Winapi.WinSvc.StartService передает аргумент, который задает желаемую длительность задержки в секундах.

Проблема, с которой я сталкиваюсь: значения, помещаемые в lpServiceArgVectors (3-й аргумент StartService), недоступны в функции ParamStr (1) изнутриоказание услуг.Я читал, что есть проблема с передачей параметров VAR этого аргумента, но я думаю, что я учел это в моем тестовом приложении (StartService всегда возвращает TRUE).

Я просто не могу получить параметры, которые будут видны в службе, и мне нужна помощь, чтобы обойти эту стену.содержал пример.Суть этого примера - взаимодействие TMainWindow.StartService (где собирается и передается lpServiceArgVectors) и процедур ServiceCreate -> CheckStartUpDelayParam в TSimpleServiceDelayTest.Служба регистрирует в текстовый файл, который отображает некоторые диагностические журналы;журнал расположен в порядке убывания, поэтому самые новые данные вставляются сверху.

Существует 3 различных пункта меню для вызова StartService (для изменения аргументов вызова). Обратите внимание, что зарегистрированное значение ParamStr (1) равновсегда независимо от того, какой пункт меню «Пуск службы» выбран:

image

// -------------- 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

Далее короткое приложение с интерфейсом службы графического интерфейса для (Un) Install, Start /Стоп

// ------------- 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

1 Ответ

0 голосов
/ 20 февраля 2019

Событие TService.OnCreate является неправильным местом для запуска цикла задержки.Вместо этого необходимо поместить его в событие TService.OnStart.

Событие OnCreate всегда вызывается при запуске процесса, независимо от того, почему процесс выполняется - (не) установкаили запуск службы.

Событие OnStart вызывается только при запуске службы SCM.Именно здесь вам нужно обработать параметры запуска службы.

Функция ParamStr() извлекает только параметры командной строки вызывающего процесса, и это не то место, где нужно искать службупараметры запуска, поскольку они не передаются в командной строке.Вместо этого они будут доступны из свойства 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;
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...