MiTec/MSICS/MSI_SvcListMon.pas
2024-07-06 22:30:25 +02:00

671 lines
19 KiB
ObjectPascal

{*******************************************************}
{ MiTeC System Information Component Suite }
{ Service List Monitor Thread }
{ version 14.3.0 }
{ }
{ Copyright (c) 1997-2021 Michal Mutl }
{ }
{*******************************************************}
{$INCLUDE Compilers.inc}
unit MSI_SvcListMon;
interface
uses {$IFDEF RAD9PLUS}
WinAPI.Windows, System.SysUtils, System.Classes, System.SyncObjs, System.Win.Registry,
{$ELSE}
Windows, SysUtils, Classes, SyncObjs, Registry,
{$ENDIF}
MiTeC_CommonDefs, MSI_Defs, MiTeC_Routines, MiTeC_AdvApi;
type
TServiceTypes = set of TServiceType;
const
stAll = [svcUnknown, svcKernelDriver, svcFileSystemDriver, svcAdapter, svcRecognizerDriver,
svcOwnProcess, svcSharedProcess, svcDesktopInteractiveProcess,
svcOwnInteractiveProcess, svcShareInteractiveProcess];
stServices = [svcOwnProcess, svcSharedProcess, svcOwnInteractiveProcess, svcShareInteractiveProcess];
stDrivers = [svcKernelDriver, svcFileSystemDriver, svcAdapter, svcRecognizerDriver];
type
TServiceRecord = record
DependOnService,
DisplayName,
Name,
CmdLine,
ImageName,
ObjectName,
Group,
Description: String;
StartUp: integer;
Delayed,
TriggerStart: Boolean;
Status: Cardinal;
Tag,
ErrCtrl: Integer;
PID :Cardinal;
ControlsAccepted: Cardinal;
Size: Int64;
Installed,
Started: TDatetime;
_Typ: Cardinal;
Typ: TServiceType;
VersionInfo: TVersionInfo;
New: Boolean;
_Exists: Boolean;
_ImageIndex: integer;
_ForceRefresh: Boolean;
end;
PServiceRecord = ^TServiceRecord;
TSvcListMonThread = class;
TSvcListMonNotifyEvent = procedure(Sender: TSvcListMonThread) of object;
TSvcListMonThread = class(TThread)
private
FReg: TRegistry;
InternalLock: TCriticalSection;
FOnInterval: TSvcListMonNotifyEvent;
FInterval: Cardinal;
FList: TList;
FAutoSuspend: Boolean;
FTypes: TServiceTypes;
FII: integer;
FSD: string;
procedure DoSync;
function GetInterval: Cardinal;
function GetOnInterval: TSvcListMonNotifyEvent;
procedure SetInterval(const Value: Cardinal);
procedure SetOnInterval(const Value: TSvcListMonNotifyEvent);
procedure RefreshData;
function GetRecCount: Integer;
function GetTypes: TServiceTypes;
procedure SetTypes(const Value: TServiceTypes);
function GetAutoSuspend: Boolean;
procedure SetAutoSuspend(const Value: Boolean);
protected
procedure Execute; override;
public
constructor Create;
destructor Destroy; override;
procedure SetServiceRefresh(AIndex: integer);
procedure GetRecord(AIndex: Integer; var ARecord: TServiceRecord);
procedure GetRecordByName(const AName: string; var ARecord: TServiceRecord);
procedure GetRecordByDisplayName(const AName: string; var ARecord: TServiceRecord);
procedure GetServiceDependants(const AName: string; AList: TStringList);
procedure GetList(AList: TList);
procedure GetServicesByPID(APID: Cardinal; AList: TStringList);
procedure Clear;
function GetRecordCount(ATypes: TServiceTypes): Integer;
property AutoSuspend: Boolean read GetAutoSuspend write SetAutoSuspend;
property RecordCount: Integer read GetRecCount;
property Types: TServiceTypes read GetTypes write SetTypes;
property Interval: Cardinal read GetInterval write SetInterval;
property OnInterval: TSvcListMonNotifyEvent read GetOnInterval write SetOnInterval;
end;
implementation
uses {$IFDEF RAD9PLUS}
{$IFDEF TRIAL}VCL.Dialogs,{$ENDIF}Winapi.WinSvc, WinApi.ShellApi,
{$ELSE}
{$IFDEF TRIAL}Dialogs,{$ENDIF}{$IFDEF FPC}JwaWinSvc{$ELSE}WinSvc{$ENDIF}, ShellApi,
{$ENDIF}
MiTeC_RegUtils, MiTeC_StrUtils, MiTeC_Datetime;
{ TSvcListMonThread }
procedure TSvcListMonThread.Clear;
var
i: Integer;
begin
{$IFDEF TRIAL}
if not RunFromIDE then
MessageDlg('TSvcListMonThread'+sLineBreak+cCompName+sLineBreak+cCopyright,mtInformation,[mbOK],0);
{$ENDIF}
InternalLock.Enter;
try
for i:=0 to FList.Count-1 do
Dispose(PServiceRecord(FList[i]));
FList.Clear;
finally
InternalLock.Leave;
end;
end;
constructor TSvcListMonThread.Create;
var
ShInfo: TSHFileInfo;
begin
inherited Create(True);
InternalLock:=TCriticalSection.Create;
FList:=TList.Create;
FTypes:=stAll;
FreeOnTerminate:=False;
FAutoSuspend:=False;
FInterval:=1000;
FII:=0;
FSD:=GetWinDir;
FReg:=OpenRegistryReadOnly;
if SHGetFileInfo(PChar(IncludeTrailingPathDelimiter(GetSysDir)+'svchost.exe'),0,ShInfo,SizeOf(ShInfo),SHGFI_SYSICONINDEX)>0 then
FII:=shInfo.iIcon;
end;
destructor TSvcListMonThread.Destroy;
var
i: Integer;
begin
FOnInterval:=nil;
if not Terminated then
Terminate;
while not Terminated do
Sleep(100);
for i:=0 to FList.Count-1 do
Dispose(PServiceRecord(FList[i]));
FList.Clear;
FList.Free;
FReg.Free;
FreeAndNil(InternalLock);
inherited;
end;
procedure TSvcListMonThread.DoSync;
begin
if Assigned(FOnInterval) then
FOnInterval(Self);
end;
procedure TSvcListMonThread.Execute;
var
se: TSimpleEvent;
begin
se:=TSimpleEvent.Create{$IFDEF BDS35PLUS}(nil,False,False,''){$ENDIF};
try
while not Terminated do begin
RefreshData;
if Assigned(FOnInterval) and not Terminated then
Synchronize(DoSync);
if not Terminated then begin
if FAutoSuspend and not Suspended then
Suspended:=True
else
se.WaitFor(FInterval);
end;
end;
finally
se.Free;
end;
end;
function TSvcListMonThread.GetAutoSuspend: Boolean;
begin
InternalLock.Enter;
try
Result:=FAutoSuspend;
finally
InternalLock.Leave;
end;
end;
function TSvcListMonThread.GetInterval: Cardinal;
begin
InternalLock.Enter;
try
Result:=FInterval;
finally
InternalLock.Leave;
end;
end;
procedure TSvcListMonThread.GetList(AList: TList);
var
i: Integer;
p: PServiceRecord;
begin
InternalLock.Enter;
try
for i:=0 to AList.Count-1 do
Dispose(PServiceRecord(AList[i]));
AList.Clear;
AList.Capacity:=FList.Capacity;
for i:=0 to FList.Count-1 do begin
new(p);
p^:=PServiceRecord(FList[i])^;
AList.Add(p);
end;
finally
InternalLock.Leave;
end;
end;
function TSvcListMonThread.GetOnInterval: TSvcListMonNotifyEvent;
begin
InternalLock.Enter;
try
Result:=FOnInterval;
finally
InternalLock.Leave;
end;
end;
function TSvcListMonThread.GetRecCount: Integer;
begin
InternalLock.Enter;
try
Result:=FList.Count;
finally
InternalLock.Leave;
end;
end;
procedure TSvcListMonThread.GetRecord(AIndex: Integer;
var ARecord: TServiceRecord);
begin
InternalLock.Enter;
try
ResetMemory(ARecord,SizeOf(ARecord));
if AIndex<FList.Count then
ARecord:=PServiceRecord(FList[AIndex])^;
finally
InternalLock.Leave;
end;
end;
procedure TSvcListMonThread.GetRecordByDisplayName(const AName: string;
var ARecord: TServiceRecord);
var
i: Integer;
begin
InternalLock.Enter;
try
ResetMemory(ARecord,SizeOf(ARecord));
for i:=0 to FList.Count-1 do
if SameText(PServiceRecord(FList[i])^.DisplayName,AName) then begin
ARecord:=PServiceRecord(FList[i])^;
Break;
end;
finally
InternalLock.Leave;
end;
end;
procedure TSvcListMonThread.GetRecordByName(const AName: string; var ARecord: TServiceRecord);
var
i: Integer;
begin
InternalLock.Enter;
try
ResetMemory(ARecord,SizeOf(ARecord));
for i:=0 to FList.Count-1 do
if SameText(PServiceRecord(FList[i])^.Name,AName) then begin
ARecord:=PServiceRecord(FList[i])^;
Break;
end;
finally
InternalLock.Leave;
end;
end;
function TSvcListMonThread.GetRecordCount(ATypes: TServiceTypes): Integer;
var
r: PServiceRecord;
begin
InternalLock.Enter;
try
Result:=0;
for r in FList do
if r.Typ in ATypes then
Inc(Result);
finally
InternalLock.Leave;
end;
end;
procedure TSvcListMonThread.GetServiceDependants(const AName: string;
AList: TStringList);
var
i: Integer;
s: string;
begin
s:=UpperCase(AName);
AList.Clear;
for i:=0 to FList.Count-1 do
if Pos(s,UpperCase(PServiceRecord(FList[i])^.DependOnService))>0 then
AList.Add(PServiceRecord(FList[i])^.Name+'='+PServiceRecord(FList[i])^.DisplayName);
end;
procedure TSvcListMonThread.GetServicesByPID(APID: Cardinal;
AList: TStringList);
var
i: Integer;
begin
InternalLock.Enter;
try
AList.Clear;
for i:=0 to FList.Count-1 do begin
if PServiceRecord(FList[i])^.PID=APID then
AList.Add(Format('%s=%s',[PServiceRecord(FList[i])^.Name,PServiceRecord(FList[i])^.DisplayName]));
end;
finally
InternalLock.Leave;
end;
end;
function TSvcListMonThread.GetTypes: TServiceTypes;
begin
InternalLock.Enter;
try
Result:=FTypes;
finally
InternalLock.Leave;
end;
end;
procedure TSvcListMonThread.RefreshData;
const
cnMaxServices = 4096;
type
PSvcArray = ^TSvcArray;
TSvcArray = array[0..511] of TEnumServiceStatus;
var
i,j,idx: Integer;
pqsc: {$IFDEF RAD9PLUS}LPQuery_Service_ConfigW{$ELSE}PQueryServiceConfig{$ENDIF};
ssa: TSvcArray;
r: PServiceRecord;
schm,sh: THandle;
b,c,rh,m: Cardinal;
p,q: PChar;
ssp: PByte;
s: string;
st: Cardinal;
ShInfo: TSHFileInfo;
ForceRefresh: Boolean;
ss: TServiceStatus;
rki: TRegKeyInfo;
begin
InternalLock.Enter;
try
for i:=0 to FList.Count-1 do
PServiceRecord(FList[i])._Exists:=False;
st:=0;
if svcKernelDriver in Ftypes then
st:=st or SERVICE_KERNEL_DRIVER;
if svcFileSystemDriver in FTypes then
st:=st or SERVICE_FILE_SYSTEM_DRIVER;
if svcAdapter in Ftypes then
st:=st or SERVICE_ADAPTER;
if svcRecognizerDriver in FTypes then
st:=st or SERVICE_RECOGNIZER_DRIVER;
if svcOwnProcess in FTypes then
st:=st or SERVICE_WIN32_OWN_PROCESS;
if svcSharedProcess in FTypes then
st:=st or SERVICE_WIN32_SHARE_PROCESS;
if svcDesktopInteractiveProcess in FTypes then
st:=st or SERVICE_INTERACTIVE_PROCESS;
if svcOwnInteractiveProcess in FTypes then
st:=st or SERVICE_INTERACTIVE_OWN_PROCESS;
if svcShareInteractiveProcess in FTypes then
st:=st or SERVICE_INTERACTIVE_SHARE_PROCESS;
schm:=OpenSCManager(nil,nil,GENERIC_READ);
if (schm>0) then
try
rh:=0;
while True do begin
EnumServicesStatus(schm,st,SERVICE_STATE_ALL,{$if defined(FPC) or defined(RAD21PLUS)}@{$ifend}ssa[0],SizeOf(ssa),b,c,rh);
for i:=0 to c-1 do begin
s:=ssa[i].lpServiceName;
idx:=-1;
for j:=0 to FList.Count-1 do begin
if SameText(PServiceRecord(FList[j]).Name,s) then begin
idx:=j;
Break;
end;
end;
if idx=-1 then begin
new(r);
Zeromemory(r,sizeof(TServiceRecord));
r.New:=True;
r._ImageIndex:=FII;
if FReg.OpenKeyReadOnly('SYSTEM\CurrentControlSet\Services\'+s) then begin
FReg.GetKeyInfo(rki);
FReg.CloseKey;
r.Installed:={$IFNDEF FPC}FileTimeToDateTime{$ENDIF}(rki.FileTime);
end;
FList.Add(r);
idx:=FList.Count-1;
end else
PServiceRecord(FList[idx])^.New:=False;
with PServiceRecord(FList[idx])^ do begin
_Exists:=True;
Name:=s;
DisplayName:=ssa[i].lpDisplayName;
Name:=ssa[i].lpServiceName;
ForceRefresh:=_ForceRefresh or (Status<>ssa[i].ServiceStatus.dwCurrentState) or (ImageName='');
_ForceRefresh:=False;
Status:=ssa[i].ServiceStatus.dwCurrentState;
if ForceRefresh then begin
sh:=OpenService(schm,ssa[i].lpServiceName,SERVICE_QUERY_CONFIG or SERVICE_QUERY_STATUS);
if (sh>0) then
try
ssp:=nil;
if Assigned(@QueryServiceConfig2) then begin
m:=$100;
ssp:=AllocMem(m);
try
if not QueryServiceConfig2(sh,SERVICE_CONFIG_DESCRIPTION,ssp,m,{$IFNDEF FPC}@{$ENDIF}m) then begin
if m>0 then
ReallocMem(ssp,m);
QueryServiceConfig2(sh,SERVICE_CONFIG_DESCRIPTION,ssp,m,{$IFNDEF FPC}@{$ENDIF}m)
end;
if m>0 then
Description:=string(PChar(PAnsiChar(ssp)+SizeOf(NativeUInt)));
finally
FreeMem(ssp);
end;
m:=SizeOf(TServiceDelayedAutoStartInfo);
ssp:=AllocMem(m);
try
if not QueryServiceConfig2(sh,SERVICE_CONFIG_DELAYED_AUTO_START_INFO,ssp,m,{$IFNDEF FPC}@{$ENDIF}m) then begin
if m>0 then
ReallocMem(ssp,m);
QueryServiceConfig2(sh,SERVICE_CONFIG_DELAYED_AUTO_START_INFO,ssp,m,{$IFNDEF FPC}@{$ENDIF}m)
end;
if m>0 then
Delayed:=PServiceDelayedAutoStartInfo(ssp).fDelayedAutostart;
finally
FreeMem(ssp);
end;
m:=SizeOf(TServiceTriggerInfo);
ssp:=AllocMem(m);
try
if not QueryServiceConfig2(sh,SERVICE_CONFIG_TRIGGER_INFO,ssp,m,{$IFNDEF FPC}@{$ENDIF}m) then begin
if m>0 then
ReallocMem(ssp,m);
QueryServiceConfig2(sh,SERVICE_CONFIG_TRIGGER_INFO,ssp,m,{$IFNDEF FPC}@{$ENDIF}m)
end;
if m>0 then
TriggerStart:=PServiceTriggerInfo(ssp).cTriggers>0;
finally
FreeMem(ssp);
end;
end;
QueryServiceConfig(sh,nil,0,m);
pqsc:=Allocmem(m);
try
if QueryServiceConfig(sh,pqsc,m,m) then begin
_Typ:=pqsc^.dwServiceType;
case pqsc^.dwServiceType of
SERVICE_KERNEL_DRIVER :Typ:=svcKernelDriver;
SERVICE_FILE_SYSTEM_DRIVER :Typ:=svcFileSystemDriver;
SERVICE_ADAPTER :Typ:=svcAdapter;
SERVICE_RECOGNIZER_DRIVER :Typ:=svcRecognizerDriver;
SERVICE_WIN32_OWN_PROCESS :Typ:=svcOwnProcess;
SERVICE_WIN32_SHARE_PROCESS :Typ:=svcSharedProcess;
SERVICE_INTERACTIVE_PROCESS :Typ:=svcDesktopInteractiveProcess;
SERVICE_INTERACTIVE_OWN_PROCESS :Typ:=svcOwnInteractiveProcess;
SERVICE_INTERACTIVE_SHARE_PROCESS :Typ:=svcShareInteractiveProcess;
else Typ:=svcUnknown;
end;
StartUp:=pqsc^.dwStartType;
ErrCtrl:=pqsc^.dwErrorControl;
CmdLine:=pqsc^.lpBinaryPathName;
Group:=pqsc^.lpLoadOrderGroup;
Tag:=pqsc^.dwTagId;
ObjectName:=pqsc^.lpServiceStartName;
if QueryServiceStatus(sh,ss) then
ControlsAccepted:=ss.dwControlsAccepted;
QueryServiceStatusEx(sh,SC_STATUS_PROCESS_INFO,nil,0,m);
ssp:=AllocMem(m);
try
if QueryServiceStatusEx(sh,SC_STATUS_PROCESS_INFO,ssp,m,m) then begin
PID:=LPSERVICE_STATUS_PROCESS(ssp).dwProcessId;
end;
finally
Freemem(ssp);
end;
DependOnService:='';
p:=pqsc^.lpDependencies;
if p<>nil then
while p^<>#0 do begin
q:=p;
while p^<>#0 do
Inc(p);
if p>q then
DependOnService:=DependOnService+Copy(q,1,p-q)+',';
Inc(p);
end;
SetLength(DependOnService,Length(DependOnService)-1);
CmdLine:=FastStringReplace(CmdLine,'\??\','');
CmdLine:=FastStringReplace(CmdLine,'\SystemRoot\',FSD);
if PosText('system32\',CmdLine)=1 then
CmdLine:=FSD+CmdLine;
if (ImageName='') or (ForceRefresh) then begin
if FileExistsEx(DequoteStr(CmdLine)) then
ImageName:=DequoteStr(CmdLine)
else
ImageName:=ExtractImageName(CmdLine);
if ImageName<>'' then begin
GetFileVerInfo(ImageName,VersionInfo);
Size:=GetFileSize(ImageName);
if Size<0 then
Size:=0;
end;
if (SHGetFileInfo(PChar(ImageName),0,ShInfo,SizeOf(ShInfo),SHGFI_SYSICONINDEX)>0) then
_ImageIndex:=shInfo.iIcon;
if ImageName='' then
ImageName:=' ';
end;
end;
finally
Freemem(pqsc);
end;
finally
CloseServiceHandle(sh);
end;
end;
end;
end;
if b=0 then
Break;
end;
finally
CloseServiceHandle(schm);
end;
i:=0;
while i<FList.Count do
if not PServiceRecord(FList[i])._Exists then begin
Dispose(PServiceRecord(FList[i]));
FList.Delete(i);
end else
Inc(i);
FList.Capacity:=FList.Count;
finally
InternalLock.Leave;
end;
end;
procedure TSvcListMonThread.SetAutoSuspend(const Value: Boolean);
begin
InternalLock.Enter;
try
FAutoSuspend:=Value;
finally
InternalLock.Leave;
end;
end;
procedure TSvcListMonThread.SetInterval(const Value: Cardinal);
begin
InternalLock.Enter;
try
FInterval:=Value;
finally
InternalLock.Leave;
end;
end;
procedure TSvcListMonThread.SetOnInterval(const Value: TSvcListMonNotifyEvent);
begin
InternalLock.Enter;
try
FOnInterval:=Value;
finally
InternalLock.Leave;
end;
end;
procedure TSvcListMonThread.SetServiceRefresh(AIndex: integer);
begin
InternalLock.Enter;
try
if AIndex<FList.Count then
PServiceRecord(FList[AIndex])^._ForceRefresh:=True;
finally
InternalLock.Leave;
end;
end;
procedure TSvcListMonThread.SetTypes(const Value: TServiceTypes);
begin
InternalLock.Enter;
try
FTypes:=Value;
finally
InternalLock.Leave;
end;
end;
initialization
end.