Beschränkung von GetTickCount umgehen

[Dax]

Ich habe mich schon lange über die Beschränkungen von GetTickCount geärgert ung habe deshalb im Zuge der immer stabiler werdenden Betriebsysteme und der immerwährenden Beschränkung von GetTickCount auf 49,7 Tagemeinen eigenen GetTickCount-Algorithmus entwickelt, GetTickCountEx. Er gibt als Ergebnis ein record vom Typ TUpTime(siehe unten) zurück und sollte sicherheitshalber alle 4294967295 Millisekunden ausgeführt werden, da er sonst falsche Ergebnisse liefert (aber solche Zeitdifferenzen kann ich mir sowieso nicht vorstellen) (Ms 0 ist Systemstart, 4294967296 ms sind ~ 49,7 Tage).

Hier der Algo:

Delphi-Quellcode:

type
  TUpTime = record
    MilliSeconds: Word;
    Seconds,
    Minutes,
    Hours,
    Days,
    Months,
    Years       : Byte;
  end;

var
  Ticks: Int64;
  TempTicks: Cardinal;

function GetTickCountEx: TUpTime;
var temp: Cardinal;
begin
  if Ticks = 0 then
    Ticks := GetTickCount
  else
  begin
    temp := TempTicks;
    TempTicks := GetTickCount;
    if TempTicks < Ticks then
      Inc(Ticks, TempTicks - temp)
    else
      Ticks := TempTicks;
  end;
  with Result do
  begin
    MilliSeconds := Ticks mod 1000;
    Seconds := (Ticks div 1000) mod 60;
    Minutes := (Ticks div 60000) mod 60;
    Hours := (Ticks div 3600000) mod 24;
    Days := ((Ticks div 3600000) div 24) mod 30;
    Months := ((Ticks div 3600000) div 24) div 30;
    Years := ((Ticks div 3600000) div 24) div 365;
  end;
end;

Anbei noch eine Demo für das Ganze, dann sollten alle zufrieden sein (dass die Exe nonVCL, hat seine Gründe)

BtW: Dieser Code ist ABSOLUT Freeware. Macht mit ihm, was ihr wollt, aber wenn ihr ihn in euren Programmen nutzt, erwähnt doch bitte in den Credits.

[NicoDE]

Um die tatsächliche 'System Up Time' zu ermitteln, muss Deine Variante von Anfang an auf dem Server (ohne Unterbrechung) laufen und mindestens alle 49,7 Tage aufgerufen werden.

Da schon in http://www.delphipraxis.com/topic746...ootet+ist.html die Frage gestellt wurde, hier die Funktionen, um die gesuchten Performance-Daten auf einem NT-basierten System auszulesen.

Es wird das Registry-Interface benutzt, da die Performance Data Helper (PDH) API nur auf NT-basierten Systemen zur Verfügung steht (und ein dynamisches Laden des Modules würde noch mehr Aufwand bedeuten).

Delphi-Quellcode:

////////////////////////////////////////////////////////////////////////////////
//
//  GetSystemUpTimeNt()
//
//    Uses the registry interface to get the value of the performance counter
//    '\\localhost\System\System Up Time' in milliseconds (returns 0 on error).
//

function GetSystemUpTimeNt(): Int64;
{$IFDEF WIN32}
type
  PPerfDataBlock = ^TPerfDataBlock;
  TPerfDataBlock = packed record
    Signature       : array [0..3] of WCHAR;
    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;
  PPerfObjectType = ^TPerfObjectType;
  TPerfObjectType = packed 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;
  PPerfCounterDefinition = ^TPerfCounterDefinition;
  TPerfCounterDefinition = packed record
    ByteLength           : DWORD;
    CounterNameTitleIndex: DWORD;
    CounterNameTitle     : LPWSTR;
    CounterHelpTitleIndex: DWORD;
    CounterHelpTitle     : LPWSTR;
    DefaultScale         : DWORD;
    DetailLevel          : DWORD;
    CounterType          : DWORD;
    CounterSize          : DWORD;
    CounterOffset        : DWORD;
  end;
  PPerfInstanceDefinition = ^TPerfInstanceDefinition;
  TPerfInstanceDefinition = packed record
    ByteLength            : DWORD;
    ParentObjectTitleIndex: DWORD;
    ParentObjectInstance  : DWORD;
    UniqueID              : DWORD;
    NameOffset            : DWORD;
    NameLength            : DWORD;
  end;
  PLARGE_INTEGER = ^LARGE_INTEGER;
const
  PERF_SIZE_LARGE      = $00000100;
  PERF_TYPE_COUNTER    = $00000400;
  PERF_COUNTER_ELAPSED = $00040000;
  PERF_OBJECT_TIMER    = $00200000;
  PERF_DISPLAY_SECONDS = $30000000;
  PERF_ELAPSED_TIME    = PERF_SIZE_LARGE or PERF_TYPE_COUNTER or
                         PERF_COUNTER_ELAPSED or PERF_OBJECT_TIMER or
                         PERF_DISPLAY_SECONDS;
  PERF_NO_INSTANCES = DWORD(-1);
var
  ValSize: DWORD;
  Counter: PChar;
  CurrIdx: PChar;
  CurrStr: PChar;
  CntrStr: PChar;
  CntrSys: DWORD;
  CntrSUT: DWORD;
  QrySize: DWORD;
  QryData: PPerfDataBlock;
  CurrObj: PPerfObjectType;
  ObjLoop: DWORD;
  CurrDef: PPerfCounterDefinition;
  DefLoop: DWORD;
  ObjInst: PPerfInstanceDefinition;
  CntrVal: PLARGE_INTEGER;
{$ENDIF}
begin
  Result := 0;  // indicates failure
{$IFDEF WIN32}
  ValSize := 0;
  if (RegQueryValueEx(HKEY_PERFORMANCE_DATA, 'Counter 009', nil, nil, nil,
    @ValSize) = ERROR_SUCCESS) then
  try
    Inc(ValSize, 1024);
    Counter := GetMemory(ValSize);
    if (Counter <> nil) then
    try
      if (RegQueryValueEx(HKEY_PERFORMANCE_DATA, 'Counter 009', nil, nil,
        PByte(Counter), @ValSize) = ERROR_SUCCESS) then
      begin
        CntrStr := nil;
        CntrSys := 0;
        CntrSUT := 0;
        CurrIdx := Counter;
        while (CurrIdx[0] <> #0) do
        begin
          CurrStr := PChar(@CurrIdx[StrLen(CurrIdx) + 1]);
          if ((CntrSys = 0) and (StrComp(CurrStr, 'System') = 0)) then
          begin
            CntrStr := CurrIdx;
            CntrSys := StrToInt(string(CurrIdx));
            if (CntrSUT <> 0) then
              Break;
          end;
          if ((CntrSUT = 0) and (StrComp(CurrStr, 'System Up Time') = 0)) then
          begin
            CntrSUT := StrToInt(string(CurrIdx));
            if (CntrSys <> 0) then
              Break;
          end;
          CurrIdx := PChar(@CurrStr[StrLen(CurrStr) + 1]);
        end;
        if ((CntrStr <> nil) and (CntrSys <> 0) and (CntrSUT <> 0)) then
        begin
          QrySize := 0;
          QryData := nil;
          try
            repeat
              Inc(QrySize, 4096);
              QryData := ReallocMemory(QryData, QrySize);
              if (QryData = nil) then
                Break;
              ValSize := QrySize;
            until (RegQueryValueEx(HKEY_PERFORMANCE_DATA, CntrStr, nil, nil,
              PByte(QryData), @ValSize) <> ERROR_MORE_DATA);
            if ((ValSize > 0) and (QryData <> nil)) then
              if (QryData.Signature = 'PERF') then
              begin
                CurrObj := PPerfObjectType(Cardinal(QryData) +
                  QryData.HeaderLength);
                for ObjLoop := 1 to QryData.NumObjectTypes do
                begin
                  if ((CurrObj.ObjectNameTitleIndex = CntrSys) and
                    (CurrObj.NumInstances > 0) and
                    (CurrObj.PerfFreq.QuadPart >= 1000)) then
                  begin
                    CurrDef := PPerfCounterDefinition(Cardinal(CurrObj) +
                      CurrObj.HeaderLength);
                    for DefLoop := 1 to CurrObj.NumCounters do
                    begin
                      if (CurrDef.CounterNameTitleIndex = CntrSUT) and
                        (CurrDef.CounterType = PERF_ELAPSED_TIME) then
                      begin
                        if (CurrObj.NumInstances = PERF_NO_INSTANCES) then
                          CntrVal := PLARGE_INTEGER(Cardinal(CurrObj) +
                             CurrObj.DefinitionLength + CurrDef.CounterOffset)
                        else
                        begin
                          // first instance
                          ObjInst := PPerfInstanceDefinition(Cardinal(CurrObj) +
                            CurrObj.DefinitionLength);
                          CntrVal := PLARGE_INTEGER(Cardinal(ObjInst) +
                             ObjInst.ByteLength + CurrDef.CounterOffset);
                        end;
                        Result :=
                          (CurrObj.PerfTime.QuadPart - CntrVal.QuadPart) div
                          (CurrObj.PerfFreq.QuadPart div 1000);  // milliseconds
                        Break;
                      end;
                      CurrDef := PPerfCounterDefinition(Cardinal(CurrDef) +
                        CurrDef.ByteLength);
                    end;
                    Break;
                  end;
                  CurrObj := PPerfObjectType(Cardinal(CurrObj) +
                    CurrObj.TotalByteLength);
                end;
              end;
          finally
            if (QryData <> nil) then
              FreeMemory(QryData);
          end;
        end;
      end;
    finally
      FreeMemory(Counter);
    end;
  finally
    RegCloseKey(HKEY_PERFORMANCE_DATA);
  end;
{$ENDIF}
end;

////////////////////////////////////////////////////////////////////////////////
//
//  GetSystemUpTime9x()
//
//    Uses GetTickCount() to get the 'System Up Time' in milliseconds.
//    Will wrap around to zero if the system is run continuously for 49.7 days!
//

function GetSystemUpTime9x(): Int64;
begin
{$IFDEF WIN32}
  Result := GetTickCount();
{$ELSE}
  Result := 0;
{$ENDIF}
end;

////////////////////////////////////////////////////////////////////////////////
//
//  GetSystemUpTime()
//
//    Wrapper for GetSystemUpTimeNt() and GetSystemUpTime9x()
//

function GetSystemUpTime(): Int64;
begin
  Result := GetSystemUpTimeNt();
  if (Result = 0) then
    Result := GetSystemUpTime9x();
end;


////////////////////////////////////////////////////////////////////////////////
// Sample

procedure TForm1.Button1Click(Sender: TObject);
var
  UpTimeNt: Int64;
  UpTime9x: Int64;
begin
  UpTime9x := GetSystemUpTime9x();
  UpTimeNt := GetSystemUpTimeNt();
  ShowMessage(Format('GetTickCount: %d day(s) %2.2d:%2.2d:%2.2d.%3.3d'#10 +
    'Perf-Counter: %d day(s) %2.2d:%2.2d:%2.2d.%3.3d', [UpTime9x div 86400000,
    UpTime9x mod 86400000 div 3600000, UpTime9x mod 3600000 div 60000,
    UpTime9x mod 60000 div 1000, UpTime9x mod 1000, UpTimeNt div 86400000,
    UpTimeNt mod 86400000 div 3600000, UpTimeNt mod 3600000 div 60000,
    UpTimeNt mod 60000 div 1000, UpTimeNt mod 1000]));
end;

Hinweise:
* GetSystemUpTimeNt() könnte zur Abfrage entfernter NT-Systeme erweitert werden (RegConnectRegistry)
* GetSystemUpTimeNt() ist langsamer - für 'Timer'-Schleifen ist GetTickCount() also immer noch sinnvoll
* GetSystemUpTimeNt() kann (für lokale Abfragen) durch Sichern der Counter-Indizes beschleunigt werden
(es wurde darauf verzichtet, da in einem Package globale Variablen stören würden)
* wer ohne SysUtils auskommen will, soll es selbst umschreiben

Legal Issues:
Public Domain

Foo:
Wer sein NT-System länger als 49,7 Tage laufen hat, möge die Funktion prüfen - hab gerade keines zur Hand.

[edit] Kommentare erweitert und zusätzliche Sicherheitsabfragen im Code, RegCloseKey vergessen [/edit]

[NicoDE]

Ich hab den Code in eine handliche Unit gepackt, eine Linux-Version hinzugefügt und die Rückgabewerte in Sekunden geändert (höhere Genauigkeit ist nicht notwendig - zumal die Angabe üblicherweise in Sekunden erfolgt).
(siehe Anhang)

Ein Beispiel könnte jetzt so aussehen:

Delphi-Quellcode:

procedure TForm1.Button1Click(Sender: TObject);
var
  UpTime9x: Int64;
  UpTimeNt: Int64;
  UpTimeLx: Int64;
begin
  UpTime9x := GetSystemUpTimeWin9x();
  UpTimeNt := GetSystemUpTimeWinNT();
  UpTimeLx := GetSystemUpTimeLinux();
  ShowMessage(Format(
    'GetTickCount'#9': %d day(s) %2.2d:%2.2d:%2.2d'#10 +
    'Perf-Counter'#9': %d day(s) %2.2d:%2.2d:%2.2d'#10 +
    'sysinfo.uptime'#9': %d day(s) %2.2d:%2.2d:%2.2d', [
    UpTime9x div 86400, UpTime9x mod 86400 div 3600, UpTime9x mod 3600 div 60,
    UpTime9x mod 60,
    UpTimeNt div 86400, UpTimeNt mod 86400 div 3600, UpTimeNt mod 3600 div 60,
    UpTimeNt mod 60,
    UpTimeLx div 86400, UpTimeLx mod 86400 div 3600, UpTimeLx mod 3600 div 60,
    UpTimeLx mod 60]));
end;

Gruß Nico

ps: sorry fürs Pushen, kann nicht mehr editieren...

[edit=Chakotay1308]Neue Version des Anhangs hochgeladen. Mfg, Chakotay1308[/edit]
[edit=Chakotay1308]Neue Version hochgeladen. Mfg, Chakotay1308[/edit]

[CalganX]

Dax hat noch eine kleine Erweiterung geschrieben zum obigen Source:

Delphi-Quellcode:

var
  QPF: Int64 = 0;

function GetTickCountEx: TUpTime;
begin
  if QPF = 0 then
    QueryPerformanceFrequency(QPF);
  QueryPerformanceCounter(Ticks);
  if (QPF = 0) or (Ticks = 0) then
  begin
    Result.Milliseconds := Word(-1);
    Exit;
  end;
  Ticks := Ticks * 1000 div QPF;

  with Result do
  begin
    MilliSeconds := Ticks mod 1000;
    Seconds := (Ticks div 1000) mod 60;
    Minutes := (Ticks div 60000) mod 60;
    Hours := (Ticks div 3600000) mod 24;
    Days := ((Ticks div 3600000) div 24) mod 30;
    Months := ((Ticks div 3600000) div 24) div 30;
    Years := ((Ticks div 3600000) div 24) div 365;
  end;
end;

[edit=Dax]Fehler korrigiert - ist das bis jetzt nur einem aufgefallen? Mfg, Dax[/edit]

[Dax]

Zusätzlich hat himitsu etwas erfreuliches gemeldet: unter Vista gibt es nun GetTickCount64, also mit 64bittigem Rückgabewert statt den 32 Bit bei <=XP:

Delphi-Quellcode:

function GetTickCount64: Int64; StdCall;
  External 'Kernel32.dll' Name 'GetTickCount64';

Regulär ist der Rückgabewert vom Typ UInt64, was aber keinen Unterschied machen sollte und die Kompatibilität zu älteren Delphi-Versionen wahrt.

Dazu eine kleine Unit für die Funktion:

Delphi-Quellcode:

Unit GTCUnit;

// (c) 1997-2007 by FNS Enterprize's (FNSE.de)
//     2003-2007 by himitsu @ Delphi-PRAXiS.de

Interface
  Uses Windows;

  Var GetTickCount64: Function(): UInt64; StdCall;

Implementation
  Function _GetTickCount64: UInt64; StdCall;
    Var Freq, Ticks: UInt64;

    Begin
      If QueryPerformanceFrequency(Int64(Freq))
        and QueryPerformanceCounter(Int64(Ticks))
        and (Int64(Freq) > 0) Then Begin

        If Ticks >= UInt64(-1) div 1000 Then Result := Ticks div (Freq div 1000)
        Else Result := (Ticks * 1000) div Freq;
      End Else Result := 0;
    End;

Initialization
  GetTickCount64 := GetProcAddress(GetModuleHandle('Kernel32.dll'), 'GetTickCount64');
  If @GetTickCount64 = nil Then GetTickCount64 := @_GetTickCount64;

End.

Hier die Version mit UInt64, da die Unit nicht verändert, sondern direkt von himitsu übernommen wurde. Sollte das System GetTickCount64 nicht unterstützen, wird auf einen heutzutage wohl immer funktionierenden Weg über die QueryPerformance*-Funktionen zurückgegriffen.

Kleines Beispiel zur Verwendung, obwohl GetTickCount64 eine Variable ist, kann sie wie eine Funktion benutzt werden:

Delphi-Quellcode:

Uses Windows, GTCUnit;

Var C, C2: UInt64;

Begin
  C  := GetTickCount64();
  Sleep(3000);
  C2 := GetTickCount64();
  Label1.Caption := IntToStr(C2 - C);
End;