home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Softwarová Záchrana 3
/
Softwarova-zachrana-3.bin
/
StartRight
/
source.zip
/
UnitCPUUsage.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
2004-10-09
|
9KB
|
344 lines
unit UnitCPUUsage;
{
Purpose:
Get the current damn CPU Usage percentage
(So much damn work for something so damn simple. Damn damn.)
Updates:
Fix for error when NO performance counter is found.
}
{///////////////}
{//}interface{//}
{///////////////}
function GetCPUUsage : double;
function IsFailedCounter : boolean;
{////////////////////}
{//}implementation{//}
{////////////////////}
uses SysUtils, Windows, Registry, UnitMyRegistry, UnitUtils, Dialogs,
UnitErrorLog, UnitFrmOptions;
var r : TMyRegistry;
lastCounter, lastTime : int64;
CounterFailed : boolean;
var IsTickled : boolean;
type TWindowsVersion = (
VERSION_WIN9X,
VERSION_WINNT,
VERSION_WIN2K,
VERSION_WINXP
);
function IsFailedCounter : boolean;
begin
result := CounterFailed;
end;
function GetWindowsVersion: TWindowsVersion;
begin
Result := VERSION_WIN9X;
if SysUtils.Win32Platform = VER_PLATFORM_WIN32_NT then
case Win32MajorVersion of
3..4: Result := VERSION_WINNT;
5: case Win32MinorVersion of
0: Result := VERSION_WIN2K;
1: Result := VERSION_WINXP;
end;
end;
end;
procedure StartTickle;
var a : array[0..2024] of byte;
begin
// tickle the counter to init it
if (GetWindowsVersion = VERSION_WIN9X) then begin
r.RootKey:= HKEY_DYN_DATA;
if (r.OpenKeyReadOnly('PerfStats\StartStat')) then begin
r.ReadBinaryData('KERNEL\CPUUsage', a ,Sizeof(a));
r.CloseKey;
end;
end else begin
r.RootKey := HKEY_PERFORMANCE_DATA;
end;
IsTickled := true;
end;
procedure StopTickle;
var a : array[0..2024] of byte;
begin
if (GetWindowsVersion = VERSION_WIN9X) then begin
r.RootKey:= HKEY_DYN_DATA;
if (r.OpenKeyReadOnly('PerfStats\StopStat')) then begin
r.ReadBinaryData('KERNEL\CPUUsage', a, SizeOf(a));
r.closekey;
end;
end else begin
r.RootKey := HKEY_PERFORMANCE_DATA;
end;
end;
{
see
http://msdn.microsoft.com/library/default.asp?url=/library/en-us/perfmon/base/performance_data_format.asp
for the dirt on the format
}
type TPERF_DATA_BLOCK=record
Signature:array[0..3] of WideChar;
LittleEndian:DWORD;
Version:DWORD;
Revision:DWORD;
TotalByteLength:DWORD;
HeaderLength:DWORD;
NumObjectTypes:DWORD;
DefaultObject:DWORD;
SystemTime:SYSTEMTIME;
PerfTime:LARGE_INTEGER;
PerfFreq:LARGE_INTEGER;
PerfTime100nSec:LARGE_INTEGER;
SystemNameLength:DWORD;
SystemNameOffset:DWORD;
end;
type TPERF_OBJECT_TYPE=record
TotalByteLength:DWORD;
DefinitionLength:DWORD;
HeaderLength:DWORD;
ObjectNameTitleIndex:DWORD;
ObjectNameTitle:LPWSTR;
ObjectHelpTitleIndex:DWORD;
ObjectHelpTitle:LPWSTR;
DetailLevel:DWORD;
NumCounters:DWORD;
DefaultCounter:DWORD;
NumInstances:DWORD;
CodePage:DWORD;
PerfTime:LARGE_INTEGER;
PerfFreq:LARGE_INTEGER;
end;
type TPERF_INSTANCE_DEFINITION =record
ByteLength:DWORD;
ParentObjectTitleIndex:DWORD;
ParentObjectInstance:DWORD;
UniqueID:DWORD;
NameOffset:DWORD;
NameLength:DWORD;
end;
type TPERF_COUNTER_DEFINITION = record
ByteLength:DWORD;
CounterNameTitleIndex:DWORD;
CounterNameTitle:LPWSTR;
CounterHelpTitleIndex:DWORD;
CounterHelpTitle:LPWSTR;
DefaultScale:DWORD;
DetailLevel:DWORD;
CounterType:DWORD;
CounterSize:DWORD;
CounterOffset:DWORD;
end;
type TPERF_COUNTER_BLOCK =record
ByteLength:DWORD;
end;
type PPERF_DATA_BLOCK = ^TPERF_DATA_BLOCK;
type PPERF_OBJECT_TYPE = ^TPERF_OBJECT_TYPE;
type PPERF_INSTANCE_DEFINITION = ^TPERF_INSTANCE_DEFINITION;
type PPERF_COUNTER_DEFINITION = ^TPERF_COUNTER_DEFINITION;
type PPERF_COUNTER_BLOCK = ^TPERF_COUNTER_BLOCK;
const PERF_NO_INSTANCES = DWORD(-1);
procedure GetCPUSample(var counter : TLargeInteger; var time100ns : TLargeInteger);
const PROCESS_NAME = '238';
const PROCESS_INT = 238;
const PROCESS_TIME_INT = 6;
var data : PPERF_DATA_BLOCK;
objs : PPERF_OBJECT_TYPE;
cd : PPERF_COUNTER_DEFINITION;
pcb : PPERF_COUNTER_BLOCK;
pid : PPERF_INSTANCE_DEFINITION;
h : HKEY;
dw, dummydw : DWORD;
i : integer;
s : string;
error : boolean;
function GetData(Name : string; var data : PByte) : integer;
var dw : integer;
dummydw : integer;
begin
end;
begin
if (RegConnectRegistry('', HKEY_PERFORMANCE_DATA, h) = ERROR_SUCCESS) then begin
data := nil;
dw := 1000;
dummydw := dw;
error := true;
repeat
ReallocMem( data, dw );
i := RegQueryValueEx( HKEY_PERFORMANCE_DATA, PROCESS_NAME, nil, nil,
PByte(data), @dummydw);
inc(dw, 1000);
dummydw := dw;
until (i <> ERROR_MORE_DATA);
if (i = ERROR_SUCCESS) then begin
// enumerate object and locate object #238
objs := PPERF_OBJECT_TYPE(DWORD(data) + data^.HeaderLength);
s := 'NumObjectTypes: ' + IntToStr(data^.NumObjectTypes);
s := s + 'Performance Objects - 238 not found in '#13#10;
for i := 1 to data^.NumObjectTypes do begin
s := s + '-' + IntToStr(objs^.ObjectNameTitleIndex);
if objs^.ObjectNameTitleIndex = PROCESS_INT then begin
Break;
end;
objs := PPERF_OBJECT_TYPE(DWORD(objs) + objs^.TotalByteLength);
end;
error := not (objs^.ObjectNameTitleIndex = PROCESS_INT);
if (not error) then begin
// in the object, enumerate counters and locate #6 for the "definition"
error := true;
cd := PPERF_Counter_DEFINITION(DWORD(objs) + objs^.HeaderLength);
s := 'Counter Index 6 not found in - '#13#10;
for i := 1 to objs^.NumCounters do begin
s := s + '-' + IntToStr(cd^.CounterNameTitleIndex);
if (cd^.CounterNameTitleIndex = PROCESS_TIME_INT) then begin
break;
end;
cd := PPERF_COUNTER_DEFINITION(DWORD(cd) + cd^.ByteLength);
end;
error := not (cd^.CounterNameTitleIndex = PROCESS_TIME_INT);
end;
if (error) then begin
ErrorLog.Add(s);
end;
counter := 0;
time100ns := 0;
if (not error) then begin
// Collecting counters
if (objs.NumInstances = PERF_NO_INSTANCES) then begin
counter := PInt64(Cardinal(objs) +
objs^.DefinitionLength + cd^.CounterOffset)^;
end else begin
// just get the first instance
pid := PPERF_INSTANCE_DEFINITION(DWORD(objs) + objs^.DefinitionLength);
pcb := PPERF_COUNTER_BLOCK(DWORD(pid) + pid^.ByteLength );
counter := PLargeInteger(DWORD(pcb) + cd^.CounterOffset)^;
end;
time100ns := data^.PerfTime100nSec.QuadPart;
end;
RegCloseKey(h);
FreeMem(data);
CounterFailed := error;
end;
end;
end;
function GetCPUUsage : double;
var i : integer;
n0, n1 : TLargeInteger;
d0, d1 : TLargeInteger;
begin
try
// tickle the counter to init it
if not IsTickled then StartTickle;
result := 0;
if (GetWindowsVersion = VERSION_WIN9X) then begin
r.RootKey:= HKEY_DYN_DATA;
if r.OpenKeyReadOnly('PerfStats\StatData') then begin
MySleep(200);
r.ReadBinaryData('KERNEL\CPUUsage', i, SizeOf(i));
result := i;
r.CloseKey;
end;
end else begin
MySleep(50);
GetCPUSample(n0, d0);
MySleep(100);
GetCPUSample(n1, d1);
try
result := 100 * (1- (n0 - n1)/(d0 - d1));
except
result := 0;
end;
if (result > 100) then begin
CounterFailed := true;
result := 0;
end;
lastCounter := n0;
lastTime := d0;
end;
except
CounterFailed := true;
end;
if result < 0 then result := 0;
end;
initialization
begin
r := TMyRegistry.Create;
StartTickle;
MySleep(100);
StartTickle; // workaround - 100% shown always otherwise for CPU on Win9x
GetCPUSample(lastCounter, lastTime);
end;
finalization
begin
StopTickle;
end;
end.