(******************************************************************************)
(* NtCpuTim - Measure total processor time (percent) on Windows NT            *)
(* Shorter Path Free Components                                               *)
(*                                                                            *)
(* Copyright (c) 2003 Shorter Path Software                                   *)
(* http://develop.shorterpath.com                                             *)
(* KOL version (c) 2003, 2005, Thaddy de Koning                               *)
(******************************************************************************)

unit kolntcputime;

interface

uses
  Windows, Kol;

{ GetProcessorTimePct returns the percentage of time that the processor is
  executing application or operating system processes other than Idle. This
  counter is a primary indicator of processor activity. It is calculated by
  measuring the time that the processor spends executing the thread of the
  Idle process in each sample interval, and subtracting that value from 100%.
  Each processor has an Idle thread which consumes cycles when no other threads
  are ready to run.

  The function returns a single value for all processors in a multi-processor
  system.

  The function is based on comparing the current activity with the previous
  activity. The result is therefore only meaningful when the function is called
  for the second time.

  With each call, the result is stored in a global variable. Because of this,
  the function is not thread safe.

  Note that calling the function can affect the result, since the function
  measures CPU activity. It is recommended to call the function at a one second
  interval, at least. }

function GetProcessorTimePct: Integer;

implementation

type
  PPerfDataBlock = ^TPerfDataBlock;
  TPerfDataBlock = record
    Signature: array[0..3] of WCHAR;
    LittleEndian: DWORD;
    Version: DWORD;
    Revision: DWORD;
    TotalByteLength: DWORD;
    HeaderLength: DWORD;
    NumObjectTypes: DWORD;
    DefaultObject: Longint;
    SystemTime: TSystemTime;
    PerfTime: TLargeInteger;
    PerfFreq: TLargeInteger;
    PerfTime100nSec: TLargeInteger;
    SystemNameLength: DWORD;
    SystemNameOffset: DWORD;
  end;

  PPerfObjectType = ^TPerfObjectType;
  TPerfObjectType = record
    TotalByteLength: DWORD;
    DefinitionLength: DWORD;
    HeaderLength: DWORD;
    ObjectNameTitleIndex: DWORD;
    ObjectNameTitle: LPWSTR;
    ObjectHelpTitleIndex: DWORD;
    ObjectHelpTitle: LPWSTR;
    DetailLevel: DWORD;
    NumCounters: DWORD;
    DefaultCounter: Longint;
    NumInstances: Longint;
    CodePage: DWORD;
    PerfTime: TLargeInteger;
    PerfFreq: TLargeInteger;
  end;

  PPerfCounterDefinition = ^TPerfCounterDefinition;
  TPerfCounterDefinition = record
    ByteLength: DWORD;
    CounterNameTitleIndex: DWORD;
    CounterNameTitle: LPWSTR;
    CounterHelpTitleIndex: DWORD;
    CounterHelpTitle: LPWSTR;
    DefaultScale: Longint;
    DetailLevel: DWORD;
    CounterType: DWORD;
    CounterSize: DWORD;
    CounterOffset: DWORD;
  end;

  PPerfInstanceDefinition = ^TPerfInstanceDefinition;
  TPerfInstanceDefinition = record
    ByteLength: DWORD;
    ParentObjectTitleIndex: DWORD;
    ParentObjectInstance: DWORD;
    UniqueID: Longint;
    NameOffset: DWORD;
    NameLength: DWORD;
  end;

  PPerfCounterBlock = ^TPerfCounterBlock;
  TPerfCounterBlock = record
    ByteLength: DWORD;
  end;

function GetProcessorTimeCounter(var CurValue,
  PerfTime100nSec: TLargeInteger): Boolean;
var
  PerfData: PPerfDataBlock;
  PerfObj: PPerfObjectType;
  PerfInst: PPerfInstanceDefinition;
  PerfCntr, CurCntr: PPerfCounterDefinition;
  PtrToCntr: PPerfCounterBlock;
  BufferSize: Integer;
  i, j, k: Integer;
  s: string;
  pData: PLargeInteger;

  { Navigation helpers }
  function FirstObject(PerfData: PPerfDataBlock): PPerfObjectType;
  begin
    Result := PPerfObjectType(DWORD(PerfData) + PerfData.HeaderLength);
  end;

  function NextObject(PerfObj: PPerfObjectType): PPerfObjectType;
  begin
    Result := PPerfObjectType(DWORD(PerfObj) + PerfObj.TotalByteLength);
  end;

  function FirstInstance(PerfObj: PPerfObjectType): PPerfInstanceDefinition;
  begin
    Result := PPerfInstanceDefinition(DWORD(PerfObj) + PerfObj.DefinitionLength);
  end;

  function NextInstance(PerfInst: PPerfInstanceDefinition): PPerfInstanceDefinition;
  var
    PerfCntrBlk: PPerfCounterBlock;
  begin
    PerfCntrBlk := PPerfCounterBlock(DWORD(PerfInst) + PerfInst.ByteLength);
    Result := PPerfInstanceDefinition(DWORD(PerfCntrBlk) + PerfCntrBlk.ByteLength);
  end;

  function FirstCounter(PerfObj: PPerfObjectType): PPerfCounterDefinition;
  begin
    Result := PPerfCounterDefinition(DWORD(PerfObj) + PerfObj.HeaderLength);
  end;

  function NextCounter(PerfCntr: PPerfCounterDefinition): PPerfCounterDefinition;
  begin
    Result := PPerfCounterDefinition(DWORD(PerfCntr) + PerfCntr.ByteLength);
  end;

begin
  Result := False;

  // Allocate initial buffer for object information
  BufferSize := 65536;
  GetMem(PerfData, BufferSize);

  // retrieve data
  while RegQueryValueEx(HKEY_PERFORMANCE_DATA,
    '238',  // Processor object
    nil, nil, Pointer(PerfData), @BufferSize) = ERROR_MORE_DATA do
  begin
    // buffer is too small
    Inc(BufferSize, 1024);
    ReallocMem(PerfData, BufferSize);
  end;
  RegCloseKey(HKEY_PERFORMANCE_DATA);

  // Get the first object type
  PerfObj := FirstObject(PerfData);

  // Process all objects
  for i := 0 to PerfData.NumObjectTypes-1 do
  begin
    // Check for Processor object
    if PerfObj.ObjectNameTitleIndex = 238 then
    begin
      // Get the first counter
      PerfCntr := FirstCounter(PerfObj);
      if PerfObj.NumInstances > 0  then
      begin
        // Get the first instance
        PerfInst := FirstInstance(PerfObj);
        // Retrieve all instances
        for k := 0 to PerfObj.NumInstances-1 do
        begin
          CurCntr := PerfCntr;
          // Check instance name for "_Total"
          s := WideCharToString(PWideChar(DWORD(PerfInst) +
            PerfInst.NameOffset));
          if (AnsiCompareText(s, '_Total') = 0) then
            // Retrieve all counters
            for j := 0 to PerfObj.NumCounters-1 do
            begin
              PtrToCntr := PPerfCounterBlock(DWORD(PerfInst) + PerfInst.ByteLength);
              // Check for % Process Time counter
              if CurCntr.CounterNameTitleIndex = 6 then
              begin
                pData := Pointer(DWORD(PtrToCntr) + CurCntr.CounterOffset);
                CurValue := pData^;
                PerfTime100nSec := PerfData.PerfTime100nSec;
                Result := True;
              end;
              // Get the next counter
              CurCntr := NextCounter(CurCntr);
            end;
          // Get the next instance.
          PerfInst := NextInstance(PerfInst);
        end;
      end;
    end;
    // Get the next object type
    PerfObj := NextObject(PerfObj);
  end;
  // Release buffer
  FreeMem(PerfData);
end;

var
  LastProcessorTimeCounter: TLargeInteger = 0;
  LastPerfTime100nSec: TLargeInteger = 0;

function GetProcessorTimePct: Integer;
var
  CurValue, PerfTime100nSec: TLargeInteger;
  p: Extended;
begin
  Result := 0;
  if Winver < WvNT then Exit;

  if GetProcessorTimeCounter(CurValue, PerfTime100nSec) then
  begin
    if LastProcessorTimeCounter <> 0 then
    begin
      p := (CurValue - LastProcessorTimeCounter) /
           (PerfTime100nSec - LastPerfTime100nSec);
      Result := Trunc(100 * (1 - p));
    end;
    LastProcessorTimeCounter := CurValue;
    LastPerfTime100nSec := PerfTime100nSec;
  end;
end;

end.