BSOne.SFC/Tocsg.Module/AppMon/ThdProcessMon.pas

{*******************************************************}
{                                                       }
{       ThdProcessMon                                   }
{                                                       }
{       Copyright (C) 2022 kku                          }
{                                                       }
{*******************************************************}

unit ThdProcessMon;

interface

uses
  Tocsg.Thread, System.SysUtils, System.Classes, Tocsg.Process, Winapi.Windows,
  System.Generics.Collections;

type
  TProcTimeInfoRec = record
    ftKernelTime,
    ftUserTime: TFileTime;
  end;

  TProcResInfo = record
    fCpu: Single;
    llMemSize: LONGLONG;
    hProcess: THandle;
    LastSystemTimes,
    LastProcessTimes: TProcTimeInfoRec;
  end;

  PProcMonEnt = ^TProcMonEnt;
  TProcMonEnt = record
    Info: TProcessEntInfo;
    Res: TProcResInfo;
    bTerminated: Boolean;
    pNode: Pointer;
  end;
  TProcMonEntList = class(TList<PProcMonEnt>)
  protected
    procedure Notify(const Item: PProcMonEnt; Action: TCollectionNotification); override;
  end;

  TThdProcessMon = class(TTgThread)
  protected
    EntList_: TProcMonEntList;
    procedure Execute; override;
  public
    Constructor Create;
    Destructor Destroy; override;

    procedure LockThread;
    procedure UnlockThread;

    property EntList: TProcMonEntList read EntList_;
  end;

implementation

uses
  Tocsg.Safe, Winapi.PsAPI;

{ TProcMonEntList }

procedure TProcMonEntList.Notify(const Item: PProcMonEnt; Action: TCollectionNotification);
begin
  if Action = cnRemoved then
    Dispose(Item);
end;

{ TThdProcessMon }

Constructor TThdProcessMon.Create;
begin
  Inherited Create;
  EntList_ := TProcMonEntList.Create;
  StartThread;
end;

Destructor TThdProcessMon.Destroy;
begin
  FreeAndNil(EntList_);
  Inherited;
end;

procedure TThdProcessMon.LockThread;
begin
  Lock;
end;

procedure TThdProcessMon.UnlockThread;
begin
  Unlock;
end;

procedure TThdProcessMon.Execute;

  procedure UpdateProcRes(var aRes: TProcResInfo);

    function SubtFileTime(ft1: TFileTIme; ft2: TFileTIme): TFileTIme;
    begin
      Result := TFileTIme(LONGLONG(ft1) - LONGLONG(ft2));
    end;

  var
    SystemTimes,
    SystemDiffTimes,
    ProcessDiffTimes,
    ProcessTimes: TProcTimeInfoRec;
    SystemTimesIdleTime,
    ProcessTimesCreationTime,
    ProcessTimesExitTime: TFileTime;
    ProcMemCnts: TProcessMemoryCounters;
  begin
    if aRes.hProcess <> 0 then
    begin
      if Winapi.Windows.GetSystemTimes(SystemTimesIdleTime, SystemTimes.ftKernelTime, SystemTimes.ftUserTime) then
      begin
        SystemDiffTimes.ftKernelTime := SubtFileTime(SystemTimes.ftKernelTime, aRes.LastSystemTimes.ftKernelTime);
        SystemDiffTimes.ftUserTime := SubtFileTime(SystemTimes.ftUserTime, aRes.LastSystemTimes.ftUserTime);
        aRes.LastSystemTimes := SystemTimes;
        if GetProcessTimes(aRes.hProcess, ProcessTimesCreationTime, ProcessTimesExitTime, ProcessTimes.ftKernelTime, ProcessTimes.ftUserTime) then
        begin
          ProcessDiffTimes.ftKernelTime := SubtFileTime(ProcessTimes.ftKernelTime, aRes.LastProcessTimes.ftKernelTime);
          ProcessDiffTimes.ftUserTime := SubtFileTime(ProcessTimes.ftUserTime, aRes.LastProcessTimes.ftUserTime);
          aRes.LastProcessTimes := ProcessTimes;
          if (Int64(SystemDiffTimes.ftKernelTime) + Int64(SystemDiffTimes.ftUserTime)) > 0 then
            aRes.fCpu := (Int64(ProcessDiffTimes.ftKernelTime) + Int64(ProcessDiffTimes.ftUserTime)) / (Int64(SystemDiffTimes.ftKernelTime) + Int64(SystemDiffTimes.ftUserTime)) * 100;
        end;
      end;

      if GetProcessMemoryInfo(aRes.hProcess, @ProcMemCnts, SizeOf(ProcMemCnts)) then
        aRes.llMemSize := ProcMemCnts.WorkingSetSize
      else
        aRes.llMemSize := -1;
    end;
  end;

  procedure AddProcMonEnt(pPinfo: PProcessEntInfo);
  var
    pEnt: PProcMonEnt;
  begin
    New(pEnt);
    ZeroMemory(pEnt, SizeOf(TProcMonEnt));
    pEnt.Info := pPinfo^;
    pEnt.Res.hProcess := OpenProcess(PROCESS_ALL_ACCESS, false, pEnt.Info.dwPid);
    EntList_.Add(pEnt);
  end;

var
  ChkList: TProcessEntList;
  i, c: Integer;
  pEnt: PProcMonEnt;
  pPInfo: PProcessEntInfo;
begin
  Guard(ChkList, TProcessEntList.Create);
  while not Terminated and not GetWorkStop do
  begin
    ChkList.UpdateProcessList;

    Lock;
    try
      if EntList_.Count = 0 then
      begin
        for i := 0 to ChkList.Count - 1 do
        begin
          if Terminated or GetWorkStop then
            exit;
          AddProcMonEnt(ChkList[i]);
        end;
      end else begin
        for i := EntList_.Count - 1 downto 0 do
        begin
          if Terminated or GetWorkStop then
            exit;

          pEnt := EntList_[i];
          pPInfo := ChkList.GetProcInfoByPid(pEnt.Info.dwPid);
          if not pEnt.bTerminated and (pPinfo <> nil) then
          begin
            pEnt.Info := pPInfo^;
            UpdateProcRes(pEnt.Res);
            c := ChkList.IndexOf(pPInfo);
            if c <> -1 then
              ChkList.Delete(c);
          end else begin
            if pEnt.pNode = nil then
              EntList_.Delete(i)
            else
              pEnt.bTerminated := true;
          end;
        end;

        for i := 0 to ChkList.Count - 1 do
        begin
          if Terminated or GetWorkStop then
            exit;

          AddProcMonEnt(ChkList[i]);
        end;
      end;
    finally
      Unlock;
    end;
    Sleep(1000);
  end;
end;

end.