home *** CD-ROM | disk | FTP | other *** search
/ Softwarová Záchrana 3 / Softwarova-zachrana-3.bin / StartRight / source.zip / UnitCPUUsage.pas < prev    next >
Pascal/Delphi Source File  |  2004-10-09  |  9KB  |  344 lines
  1. unit UnitCPUUsage;
  2.  
  3. {
  4.     Purpose:
  5.         Get the current damn CPU Usage percentage
  6.         (So much damn work for something so damn simple. Damn damn.)
  7.  
  8.     Updates:
  9.         Fix for error when NO performance counter is found.        
  10. }
  11.  
  12. {///////////////}
  13. {//}interface{//}
  14. {///////////////}
  15.  
  16. function GetCPUUsage : double;
  17. function IsFailedCounter : boolean;
  18.  
  19. {////////////////////}
  20. {//}implementation{//}
  21. {////////////////////}
  22.  
  23. uses SysUtils, Windows, Registry, UnitMyRegistry, UnitUtils, Dialogs,
  24.   UnitErrorLog, UnitFrmOptions;
  25. var r : TMyRegistry;
  26.     lastCounter, lastTime : int64;
  27.     CounterFailed : boolean;
  28.  
  29. var IsTickled : boolean;
  30. type TWindowsVersion = (
  31.     VERSION_WIN9X,
  32.     VERSION_WINNT,
  33.     VERSION_WIN2K,
  34.     VERSION_WINXP
  35. );
  36.  
  37.  
  38. function IsFailedCounter : boolean;
  39. begin
  40.     result := CounterFailed;
  41. end;
  42.  
  43. function GetWindowsVersion: TWindowsVersion;
  44. begin
  45.   Result := VERSION_WIN9X;
  46.   if SysUtils.Win32Platform = VER_PLATFORM_WIN32_NT then
  47.     case Win32MajorVersion of
  48.       3..4: Result := VERSION_WINNT;
  49.       5: case Win32MinorVersion of
  50.            0: Result := VERSION_WIN2K;
  51.            1: Result := VERSION_WINXP;
  52.          end;
  53.     end;
  54. end;
  55.  
  56.  
  57. procedure StartTickle;
  58. var a : array[0..2024] of byte;
  59. begin
  60.     // tickle the counter to init it
  61.     if (GetWindowsVersion = VERSION_WIN9X) then begin
  62.         r.RootKey:= HKEY_DYN_DATA;
  63.         if (r.OpenKeyReadOnly('PerfStats\StartStat')) then begin
  64.             r.ReadBinaryData('KERNEL\CPUUsage', a ,Sizeof(a));
  65.             r.CloseKey;
  66.         end;
  67.  
  68.     end else begin
  69.         r.RootKey := HKEY_PERFORMANCE_DATA;
  70.     end;
  71.  
  72.     IsTickled := true;
  73. end;
  74.  
  75. procedure StopTickle;
  76. var a : array[0..2024] of byte;
  77. begin
  78.     if (GetWindowsVersion = VERSION_WIN9X) then begin
  79.         r.RootKey:= HKEY_DYN_DATA;
  80.         if (r.OpenKeyReadOnly('PerfStats\StopStat')) then begin
  81.             r.ReadBinaryData('KERNEL\CPUUsage', a, SizeOf(a));
  82.             r.closekey;
  83.         end;
  84.     end else begin
  85.         r.RootKey := HKEY_PERFORMANCE_DATA;
  86.     end;
  87. end;
  88.  
  89.  
  90. {
  91. see
  92. http://msdn.microsoft.com/library/default.asp?url=/library/en-us/perfmon/base/performance_data_format.asp
  93. for the dirt on the format
  94. }
  95.  
  96.  
  97. type TPERF_DATA_BLOCK=record
  98.    Signature:array[0..3] of WideChar;
  99.     LittleEndian:DWORD;
  100.     Version:DWORD;
  101.     Revision:DWORD;
  102.     TotalByteLength:DWORD;
  103.     HeaderLength:DWORD;
  104.     NumObjectTypes:DWORD;
  105.     DefaultObject:DWORD;
  106.     SystemTime:SYSTEMTIME;
  107.     PerfTime:LARGE_INTEGER;
  108.     PerfFreq:LARGE_INTEGER;
  109.     PerfTime100nSec:LARGE_INTEGER;
  110.     SystemNameLength:DWORD;
  111.     SystemNameOffset:DWORD;
  112. end;
  113.  
  114. type TPERF_OBJECT_TYPE=record
  115.     TotalByteLength:DWORD;
  116.     DefinitionLength:DWORD;
  117.     HeaderLength:DWORD;
  118.     ObjectNameTitleIndex:DWORD;
  119.     ObjectNameTitle:LPWSTR;
  120.     ObjectHelpTitleIndex:DWORD;
  121.     ObjectHelpTitle:LPWSTR;
  122.     DetailLevel:DWORD;
  123.     NumCounters:DWORD;
  124.     DefaultCounter:DWORD;
  125.     NumInstances:DWORD;
  126.     CodePage:DWORD;
  127.     PerfTime:LARGE_INTEGER;
  128.     PerfFreq:LARGE_INTEGER;
  129. end;
  130.  
  131.  
  132. type TPERF_INSTANCE_DEFINITION =record
  133.     ByteLength:DWORD;
  134.     ParentObjectTitleIndex:DWORD;
  135.     ParentObjectInstance:DWORD;
  136.     UniqueID:DWORD;
  137.     NameOffset:DWORD;
  138.     NameLength:DWORD;
  139. end;
  140.  
  141. type TPERF_COUNTER_DEFINITION = record
  142.     ByteLength:DWORD;
  143.     CounterNameTitleIndex:DWORD;
  144.     CounterNameTitle:LPWSTR;
  145.     CounterHelpTitleIndex:DWORD;
  146.     CounterHelpTitle:LPWSTR;
  147.     DefaultScale:DWORD;
  148.     DetailLevel:DWORD;
  149.     CounterType:DWORD;
  150.     CounterSize:DWORD;
  151.     CounterOffset:DWORD;
  152. end;
  153.  
  154. type TPERF_COUNTER_BLOCK =record
  155.     ByteLength:DWORD;
  156. end;
  157.  
  158.  
  159. type PPERF_DATA_BLOCK = ^TPERF_DATA_BLOCK;
  160. type PPERF_OBJECT_TYPE = ^TPERF_OBJECT_TYPE;
  161. type PPERF_INSTANCE_DEFINITION = ^TPERF_INSTANCE_DEFINITION;
  162. type PPERF_COUNTER_DEFINITION = ^TPERF_COUNTER_DEFINITION;
  163. type PPERF_COUNTER_BLOCK = ^TPERF_COUNTER_BLOCK;
  164.  
  165. const PERF_NO_INSTANCES = DWORD(-1);
  166.  
  167.  
  168. procedure GetCPUSample(var counter : TLargeInteger; var time100ns : TLargeInteger);
  169. const PROCESS_NAME = '238';
  170. const PROCESS_INT = 238;
  171. const PROCESS_TIME_INT = 6;
  172. var data : PPERF_DATA_BLOCK;
  173.     objs : PPERF_OBJECT_TYPE;
  174.     cd : PPERF_COUNTER_DEFINITION;
  175.     pcb : PPERF_COUNTER_BLOCK;
  176.     pid : PPERF_INSTANCE_DEFINITION;
  177.  
  178.  
  179.     h : HKEY;
  180.     dw, dummydw : DWORD;
  181.     i : integer;
  182.     s : string;
  183.  
  184.     error : boolean;
  185.  
  186.     function GetData(Name : string; var data : PByte) : integer;
  187.     var dw : integer;
  188.         dummydw : integer;
  189.     begin
  190.  
  191.     end;
  192. begin
  193.     if (RegConnectRegistry('', HKEY_PERFORMANCE_DATA, h) = ERROR_SUCCESS) then begin
  194.  
  195.         data := nil;
  196.         dw := 1000;
  197.         dummydw := dw;
  198.         error := true;
  199.         
  200.         repeat
  201.  
  202.             ReallocMem( data, dw );
  203.  
  204.             i := RegQueryValueEx( HKEY_PERFORMANCE_DATA, PROCESS_NAME, nil, nil,
  205.                 PByte(data), @dummydw);
  206.  
  207.             inc(dw, 1000);
  208.             dummydw := dw;
  209.         until (i <> ERROR_MORE_DATA);
  210.  
  211.         if (i = ERROR_SUCCESS) then begin
  212.             // enumerate object and locate object #238
  213.  
  214.             objs := PPERF_OBJECT_TYPE(DWORD(data) + data^.HeaderLength);
  215.             s := 'NumObjectTypes: ' + IntToStr(data^.NumObjectTypes);
  216.             s := s + 'Performance Objects - 238 not found in '#13#10;
  217.  
  218.             for i := 1 to data^.NumObjectTypes do begin
  219.                 s := s + '-' + IntToStr(objs^.ObjectNameTitleIndex);
  220.  
  221.                 if objs^.ObjectNameTitleIndex = PROCESS_INT then begin
  222.  
  223.                     Break;
  224.                 end;
  225.                 objs := PPERF_OBJECT_TYPE(DWORD(objs) + objs^.TotalByteLength);
  226.             end;
  227.             error := not (objs^.ObjectNameTitleIndex = PROCESS_INT);
  228.  
  229.             if (not error) then begin
  230.                 // in the object, enumerate counters and locate #6 for the "definition"
  231.                 error := true;
  232.                 cd := PPERF_Counter_DEFINITION(DWORD(objs) + objs^.HeaderLength);
  233.                 s := 'Counter Index 6 not found in - '#13#10;
  234.                 for i := 1 to objs^.NumCounters do begin
  235.                     s := s + '-' + IntToStr(cd^.CounterNameTitleIndex);
  236.  
  237.                     if (cd^.CounterNameTitleIndex = PROCESS_TIME_INT) then begin
  238.                         break;
  239.                     end;
  240.  
  241.                     cd  := PPERF_COUNTER_DEFINITION(DWORD(cd) + cd^.ByteLength);
  242.                 end;
  243.                 error := not (cd^.CounterNameTitleIndex = PROCESS_TIME_INT);
  244.             end;
  245.  
  246.             if (error) then begin
  247.                 ErrorLog.Add(s);
  248.             end;
  249.  
  250.  
  251.             counter := 0;
  252.             time100ns := 0;
  253.             if (not error) then begin
  254.                 // Collecting counters
  255.  
  256.                 if (objs.NumInstances = PERF_NO_INSTANCES) then begin
  257.                     counter := PInt64(Cardinal(objs) +
  258.                                  objs^.DefinitionLength + cd^.CounterOffset)^;
  259.                 end else begin
  260.                     // just get the first instance
  261.  
  262.                     pid := PPERF_INSTANCE_DEFINITION(DWORD(objs) + objs^.DefinitionLength);
  263.                     pcb := PPERF_COUNTER_BLOCK(DWORD(pid) + pid^.ByteLength );
  264.                     counter := PLargeInteger(DWORD(pcb) + cd^.CounterOffset)^;
  265.                 end;
  266.                 time100ns := data^.PerfTime100nSec.QuadPart;
  267.             end;
  268.  
  269.  
  270.  
  271.             RegCloseKey(h);
  272.             FreeMem(data);
  273.  
  274.             CounterFailed := error;
  275.         end;
  276.  
  277.     end;
  278. end;
  279.  
  280. function GetCPUUsage : double;
  281. var i : integer;
  282.     n0, n1 : TLargeInteger;
  283.     d0, d1 : TLargeInteger;
  284. begin
  285.  
  286. try
  287.     // tickle the counter to init it
  288.     if not IsTickled then StartTickle;
  289.     result := 0;
  290.  
  291.     if (GetWindowsVersion = VERSION_WIN9X) then begin
  292.  
  293.         r.RootKey:= HKEY_DYN_DATA;
  294.         if r.OpenKeyReadOnly('PerfStats\StatData') then begin
  295.             MySleep(200);
  296.             r.ReadBinaryData('KERNEL\CPUUsage', i, SizeOf(i));
  297.             result := i;
  298.             r.CloseKey;
  299.         end;
  300.     end else begin
  301.  
  302.         MySleep(50);
  303.         GetCPUSample(n0, d0);
  304.         MySleep(100);
  305.         GetCPUSample(n1, d1);
  306.  
  307.         try
  308.             result := 100 * (1- (n0 - n1)/(d0 - d1));
  309.         except
  310.             result := 0;
  311.         end;
  312.  
  313.         if (result > 100) then begin
  314.             CounterFailed := true;
  315.             result := 0;
  316.         end;
  317.  
  318.         lastCounter := n0;
  319.         lastTime := d0;
  320.     end;
  321. except
  322.     CounterFailed := true;
  323. end;
  324.     if result < 0 then result := 0;
  325. end;
  326.  
  327.  
  328.  
  329.  
  330. initialization
  331. begin
  332.     r := TMyRegistry.Create;
  333.  
  334.     StartTickle;
  335.     MySleep(100);
  336.     StartTickle;  // workaround - 100% shown always otherwise for CPU on Win9x
  337.     GetCPUSample(lastCounter, lastTime);
  338. end;
  339. finalization
  340. begin
  341.     StopTickle;
  342. end;
  343. end.
  344.