jclsvcctrl.pas

East make Tray Icon in delphi

  FDependentServices := TList.Create;
  FDependentGroups := TList.Create;
  FDependentByServices := nil; // Create on demand
  FSCManager.AddService(Self);
end;

destructor TJclNtService.Destroy;
begin
  FreeAndNil(FDependentServices);
  FreeAndNil(FDependentGroups);
  FreeAndNil(FDependentByServices);
  inherited Destroy;
end;

procedure TJclNtService.UpdateDescription;
var
  Ret: BOOL;
  BytesNeeded: DWORD;
  PSvcDesc: PServiceDescriptionA;
begin
  if Assigned(SCManager.QueryServiceConfig2A) then
  try
    PSvcDesc := nil;
    BytesNeeded := 4096;
    repeat
      ReallocMem(PSvcDesc, BytesNeeded);
      Ret := SCManager.QueryServiceConfig2A(FHandle, SERVICE_CONFIG_DESCRIPTION,
        PByte(PSvcDesc), BytesNeeded, BytesNeeded);
    until Ret or (GetLastError <> ERROR_INSUFFICIENT_BUFFER);
    Win32Check(Ret);

    FDescription := PSvcDesc.lpDescription;
  finally
    FreeMem(PSvcDesc);
  end;
end;

function TJclNtService.GetActive: Boolean;
begin
  Result := FHandle <> INVALID_SCM_HANDLE;
end;

procedure TJclNtService.SetActive(const Value: Boolean);
begin
  if Value <> GetActive then
  begin
    if Value then
      Open
    else
      Close;
    Assert(Value = GetActive);
  end;
end;

procedure TJclNtService.SetStartType(AStartType: TJclServiceStartType);
begin
  if AStartType <> FStartType then
  begin
    FStartType := AStartType;
    FCommitNeeded := True;
  end;
end;

procedure TJclNtService.UpdateDependents;
var
  I: Integer;
  Ret: BOOL;
  PBuf: Pointer;
  PEss: PEnumServiceStatus;
  NtSvc: TJclNtService;
  BytesNeeded, ServicesReturned: DWORD;
begin
  Open(SERVICE_ENUMERATE_DEPENDENTS);
  try
    if Assigned(FDependentByServices) then
      FDependentByServices.Clear
    else
      FDependentByServices := TList.Create;

    try
      PBuf := nil;
      BytesNeeded := 40960;
      repeat
        ReallocMem(PBuf, BytesNeeded);
        Ret := EnumDependentServices(FHandle, SERVICE_STATE_ALL,
          PEnumServiceStatus(PBuf){$IFNDEF FPC}^{$ENDIF}, BytesNeeded, BytesNeeded, ServicesReturned);
      until Ret or (GetLastError <> ERROR_INSUFFICIENT_BUFFER);
      Win32Check(Ret);

      PEss := PBuf;
      for I := 0 to ServicesReturned - 1 do
      begin
        if (PEss.lpServiceName[1] <> SC_GROUP_IDENTIFIER) and
          (SCManager.FindService(PEss.lpServiceName, NtSvc)) then
          FDependentByServices.Add(NtSvc);
        Inc(PEss);
      end;
    finally
      FreeMem(PBuf);
    end;
  finally
    Close;
  end;
end;

function TJclNtService.GetDependentService(const Idx: Integer): TJclNtService;
begin
  Result := TJclNtService(FDependentServices.Items[Idx]);
end;

function TJclNtService.GetDependentServiceCount: Integer;
begin
  Result := FDependentServices.Count;
end;

function TJclNtService.GetDependentGroup(const Idx: Integer): TJclServiceGroup;
begin
  Result := TJclServiceGroup(FDependentGroups.Items[Idx]);
end;

function TJclNtService.GetDependentGroupCount: Integer;
begin
  Result := FDependentGroups.Count;
end;

function TJclNtService.GetDependentByService(const Idx: Integer): TJclNtService;
begin
  if not Assigned(FDependentByServices) then
    UpdateDependents;
  Result := TJclNtService(FDependentByServices.Items[Idx])
end;

function TJclNtService.GetDependentByServiceCount: Integer;
begin
  if not Assigned(FDependentByServices) then
    UpdateDependents;
  Result := FDependentByServices.Count;
end;

function TJclNtService.GetServiceStatus: TServiceStatus;
begin
  Assert(Active);
  Assert((DesiredAccess and SERVICE_QUERY_STATUS) <> 0);
  Win32Check(QueryServiceStatus(FHandle, Result));
end;


procedure TJclNtService.UpdateStatus(const SvcStatus: TServiceStatus);
begin
  with SvcStatus do
  begin
    FServiceTypes := TJclSCManager.ServiceType(dwServiceType);
    FServiceState := TJclServiceState(dwCurrentState);
    FControlsAccepted := TJclSCManager.ControlAccepted(dwControlsAccepted);
    FWin32ExitCode := dwWin32ExitCode;
  end;
end;

procedure TJclNtService.UpdateConfig(const SvcConfig: TQueryServiceConfig);

  procedure UpdateLoadOrderGroup;
  begin
    if not Assigned(FGroup) then
      SCManager.FindGroup(SvcConfig.lpLoadOrderGroup, FGroup)
    else
    if CompareText(Group.Name, SvcConfig.lpLoadOrderGroup) = 0 then
    begin
      FGroup.Remove(Self);
      SCManager.FindGroup(SvcConfig.lpLoadOrderGroup, FGroup);
      FGroup.Add(Self);
    end;
  end;

  procedure UpdateDependencies;
  var
    P: PChar;
    NtSvc: TJclNtService;
    SvcGrp: TJclServiceGroup;
  begin
    P := SvcConfig.lpDependencies;
    FDependentServices.Clear;
    FDependentGroups.Clear;
    if Assigned(P) then
    while P^ <> #0 do
    begin
      if P^ = SC_GROUP_IDENTIFIER then
      begin
        SCManager.FindGroup(P + 1, SvcGrp);
        FDependentGroups.Add(SvcGrp);
      end
      else
      if SCManager.FindService(P, NtSvc) then
        FDependentServices.Add(NtSvc);
      Inc(P, StrLen(P) + 1);
    end;
  end;

begin
  with SvcConfig do
  begin
    FFileName := lpBinaryPathName;
    FStartType := TJclServiceStartType(dwStartType);
    FErrorControlType := TJclServiceErrorControlType(dwErrorControl);
    UpdateLoadOrderGroup;
    UpdateDependencies;
  end;
end;

procedure TJclNtService.CommitConfig(var SvcConfig: TQueryServiceConfig);
begin
  with SvcConfig do
  begin
    StrCopy(lpBinaryPathName, PChar(FileName));
    dwStartType := Ord(StartType);    {TJclServiceStartType}
    dwErrorControl := Ord(ErrorControlType);  {TJclServiceErrorControlType}
    //UpdateLoadOrderGroup;
    //UpdateDependencies;
  end;
end;

procedure TJclNtService.Open(const ADesiredAccess: DWORD);
begin
  Assert((ADesiredAccess and (not SERVICE_ALL_ACCESS)) = 0);
  Active := False;
  FDesiredAccess := ADesiredAccess;
  FHandle := OpenService(SCManager.Handle, PChar(ServiceName), DesiredAccess);
  Win32Check(FHandle <> INVALID_SCM_HANDLE);
end;

procedure TJclNtService.Close;
begin
  Assert(Active);
  Win32Check(CloseServiceHandle(FHandle));
  FHandle := INVALID_SCM_HANDLE;
end;

procedure TJclNtService.Refresh;
var
  Ret: BOOL;
  BytesNeeded: DWORD;
  PQrySvcCnfg: PQueryServiceConfig;
begin
  Open(SERVICE_QUERY_STATUS or SERVICE_QUERY_CONFIG);
  try
    UpdateDescription;
    UpdateStatus(GetServiceStatus);
    try
      PQrySvcCnfg := nil;
      BytesNeeded := 4096;
      repeat
        ReallocMem(PQrySvcCnfg, BytesNeeded);
        Ret := QueryServiceConfig(FHandle, PQrySvcCnfg, BytesNeeded, BytesNeeded);
      until Ret or (GetLastError <> ERROR_INSUFFICIENT_BUFFER);
      Win32Check(Ret);

      UpdateConfig(PQrySvcCnfg^);
    finally
      FreeMem(PQrySvcCnfg);
    end;
  finally
    Close;
  end;
end;

// Commit is reverse of Refresh.
procedure TJclNtService.Commit;
var
  Ret: BOOL;
  BytesNeeded: DWORD;
  PQrySvcCnfg: PQueryServiceConfig;
begin
 if not FCommitNeeded then
   Exit;
 FCommitNeeded := False;

  Open(SERVICE_CHANGE_CONFIG or SERVICE_QUERY_STATUS or SERVICE_QUERY_CONFIG);
  try
    //UpdateDescription;
    //UpdateStatus(GetServiceStatus);
    try
      PQrySvcCnfg := nil;
      BytesNeeded := 4096;
      repeat
        ReallocMem(PQrySvcCnfg, BytesNeeded);
        Ret := QueryServiceConfig(FHandle, PQrySvcCnfg, BytesNeeded, BytesNeeded);
      until Ret or (GetLastError <> ERROR_INSUFFICIENT_BUFFER);
      Win32Check(Ret);

      CommitConfig(PQrySvcCnfg^);
      Win32Check(ChangeServiceConfig(Handle,
        PQrySvcCnfg^.dwServiceType,
        PQrySvcCnfg^.dwStartType,
        PQrySvcCnfg^.dwErrorControl,
        nil, {PQrySvcCnfg^.lpBinaryPathName,}
        nil, {PQrySvcCnfg^.lpLoadOrderGroup,}
        nil, {PQrySvcCnfg^.dwTagId,}
        nil, {PQrySvcCnfg^.lpDependencies,}
        nil, {PQrySvcCnfg^.lpServiceStartName,}
        nil, {password-write only-not readable}
        PQrySvcCnfg^.lpDisplayName));
    finally
      FreeMem(PQrySvcCnfg);
    end;
  finally
    Close;
  end;
end;

procedure TJclNtService.Delete;
{$IFDEF FPC}
const
  _DELETE = $00010000; { Renamed from DELETE }
{$ENDIF FPC}
begin
  Open(_DELETE);
  try
    Win32Check(DeleteService(FHandle));
  finally
    Close;
  end;
end;

procedure TJclNtService.Start(const Args: array of string; const Sync: Boolean);
type
  PStrArray = ^TStrArray;
  TStrArray = array [0..32767] of PChar;
var
  I: Integer;
  PServiceArgVectors: PChar;
begin
  Open(SERVICE_START);
  try
    try
      if Length(Args) = 0 then
        PServiceArgVectors := nil
      else
      begin
        GetMem(PServiceArgVectors, SizeOf(PChar)*Length(Args));
        for I := 0 to Length(Args) - 1 do
          PStrArray(PServiceArgVectors)^[I] := PChar(Args[I]);
      end;
      Win32Check(StartService(FHandle, Length(Args), PServiceArgVectors));
    finally
      FreeMem(PServiceArgVectors);
    end;
  finally
    Close;
  end;
  if Sync then
    WaitFor(ssRunning);
end;

procedure TJclNtService.Start(const Sync: Boolean = True);
begin
  Start([], Sync);
end;

function TJclNtService.Controls(const ControlType: DWORD; const ADesiredAccess: DWORD): TServiceStatus;
begin
  Open(ADesiredAccess);
  try
    Win32Check(ControlService(FHandle, ControlType, Result));
  finally
    Close;
  end;
end;

procedure TJclNtService.Stop(const Sync: Boolean);
begin
  Controls(SERVICE_CONTROL_STOP, SERVICE_STOP);
  if Sync then
    WaitFor(ssStopped);
end;

procedure TJclNtService.Pause(const Sync: Boolean);
begin
  Controls(SERVICE_CONTROL_PAUSE, SERVICE_PAUSE_CONTINUE);
  if Sync then
    WaitFor(ssPaused);
end;

procedure TJclNtService.Continue(const Sync: Boolean);
begin
  Controls(SERVICE_CONTROL_CONTINUE, SERVICE_PAUSE_CONTINUE);
  if Sync then