{*******************************************************************************

Unité MMTimer2

Copyright CNRS (décembre 2004)
contributeurs : Rémi Humbert, Sylvain Mottet

remi.humbert @ free.fr
sylvain.mottet @ univ-paris5.fr

Ce logiciel est un programme informatique permettant d'utiliser le 'performance
counter' et les 'timer multimedia' de l'API Windows(r) en Delphi.

Ce logiciel est régi par la licence CeCILL-C soumise au droit français et
respectant les principes de diffusion des logiciels libres. Vous pouvez
utiliser, modifier et/ou redistribuer ce programme sous les conditions
de la licence CeCILL-C telle que diffusée par le CEA, le CNRS et l'INRIA
sur le site "http://www.cecill.info".

En contrepartie de l'accessibilité au code source et des droits de copie,
de modification et de redistribution accordés par cette licence, il n'est
offert aux utilisateurs qu'une garantie limitée.  Pour les mêmes raisons,
seule une responsabilité restreinte pèse sur l'auteur du programme, le
titulaire des droits patrimoniaux et les concédants successifs.

A cet égard  l'attention de l'utilisateur est attirée sur les risques
associés au chargement, à l'utilisation, à la modification et/ou au
développement et à la reproduction du logiciel par l'utilisateur étant
donné sa spécificité de logiciel libre, qui peut le rendre complexe à
manipuler et qui le réserve donc à des développeurs et des professionnels
avertis possédant des connaissances informatiques approfondies. Les
utilisateurs sont donc invités à charger et tester l'adéquation du
logiciel à leurs besoins dans des conditions permettant d'assurer la
sécurité de leurs systèmes et ou de leurs données et, plus généralement,
à l'utiliser et l'exploiter dans les mêmes conditions de sécurité.

Le fait que vous puissiez accéder à cet en-tête signifie que vous avez
pris connaissance de la licence CeCILL-C, et que vous en avez accepté les
termes.

********************************************************************************

Historique:
  14 décembre 2004: première version
  5 janvier 2005  : - ajouté la fonction < Wait(n) > qui fait une pause de
                      n millisecondes sans bloquer l'application
                    - corrigé un bug empêchant de relancer un oneshot timer depuis
                      son EventOnTimer (interverti les deux < if > les plus
                      à l'intérieur de timecallback)
                    - ajouté < inherited; > dans TMMTimer.Destroy
                    - ajouté un Assert après TimeSetEvent
  30 mai 2005     : - utilise Sleep(1) dans Wait(n) pour libérer du temps processeur.
  30 mars 2006    : - changé TimerId de Integer à LongWord pour éviter warning
                      dans TimeCallBack
  23 août 2006    : - modifié Wait() pour qu'un ProcessMessages soit toujours
                      effectué même si MilliSecCount = 0
  4 décembre 2006 : - modifié le type retourné par GetCounterPerSecond
                      de Integer en Int64 pour des raisons de cohérence
                    - mise à jour de la référence vers MSDN2

********************************************************************************

Référence:

http://msdn2.microsoft.com/en-gb/library/ms632592.aspx

*******************************************************************************}

unit MMTimer2;

interface

uses
  Classes;

// performance counter functions
  function  GetMicroCounter: Int64; // returns the performance counter value in microseconds
  function  GetMilliCounter: Int64; // returns the performance counter value in milliseconds
  function  GetCountsPerSecond: Int64; // returns the performance counter frequency
  procedure Wait(MilliSecCount: Integer); // waits MSCount milliseconds

// mutlimedia timer object
type
  TTimerMode = (Oneshot, Periodic);

  TMMTimer = class(TObject)
  private
    TimerId: LongWord;
  public
    Interval: Integer;
    TimerMode: TTimerMode;
    EventOnTimer: TNotifyEvent;

    constructor Create;
    destructor  Destroy; override;
    procedure   Start;
    procedure   Stop;
    function    Running: Boolean;
  end;

{******************************************************************************}

implementation

uses
  Forms, //Application.ProcessMessages
  SysUtils,
  Windows,
  MMSystem;

var
  tc: TIMECAPS;
  i64Frequency: Int64;

{* performance counter functions **********************************************}

function GetMicroCounter: Int64;
var
  i64Counter : Int64;
begin
  QueryPerformanceCounter(i64Counter);
  result := i64Counter * 1000000 div i64Frequency;
end;

function GetMilliCounter: Int64;
var
  i64Counter : Int64;
begin
  QueryPerformanceCounter(i64Counter);
  result := i64Counter * 1000 div i64Frequency;
end;

function GetCountsPerSecond: Int64;
begin
  result := i64Frequency;
end;

procedure Wait(MilliSecCount: Integer);
var
  StartTime: Int64;
begin
  Application.ProcessMessages;
  StartTime := GetMilliCounter;
  while ( GetMilliCounter - StartTime < MilliSecCount ) do
  begin
    Sleep(1);
    Application.ProcessMessages;
  end;
end;

{* multimedia timer functions *************************************************}

constructor TMMTimer.Create;
begin
  inherited;
  EventOnTimer := nil;
  TimerMode := Oneshot;
  Interval := 1000; // default value of Delphi TTimer Component
  TimerId := 0;
end;

destructor TMMTimer.Destroy;
begin
  Stop;
  inherited;
end;

procedure timecallback(utimerid, umessage: UINT; dwuser, dw1, dw2: DWORD) stdcall;
begin
  with TMMTimer(pointer(dwuser)) do
    if ( TimerId = utimerid ) then // should prevent callback after object destruction
    begin
      if ( TimerMode = Oneshot ) then
        TimerId := 0;
      if ( Assigned(EventOnTimer) = True ) then
        EventOnTimer(TObject(dwuser));
    end;
end;

procedure TMMTimer.Start;
var
  iMode: Integer;
begin
  Stop;
  iMode := TIME_CALLBACK_FUNCTION; // + TIME_KILL_SYNCHRONOUS; (WinXP only)
  if ( TimerMode = periodic ) then
    iMode := iMode + TIME_PERIODIC
  else
    iMode := iMode + TIME_ONESHOT;
  TimerId := TimeSetEvent(interval, 1, timecallback, dword(Self), iMode);
  Assert(TimerID <> TIMERR_NOERROR, 'TimeSetEvent error');
end;

procedure TMMTimer.Stop;
begin
  if ( TimerId <> 0 ) then
  begin
    TimeKillEvent(TimerId);
    TimerId := 0;
  end;
end;

function TMMTimer.Running: Boolean;
begin
  result := (TimerId <> 0);
end;

{******************************************************************************}

initialization

begin
  // performance counter initialization
  QueryPerformanceFrequency(i64Frequency);
  Assert((i64Frequency <> 0),
         'Installed hardware does not support a high-resolution performance counter.');

  // multimedia timer initialization
  Assert((TimeGetDevCaps(@tc, sizeof(TIMECAPS)) = TIMERR_NOERROR),
         'Multimedia timer initialization error.');
  Assert((tc.wPeriodMin = 1),
         'Multimedia timer precision is not 1ms.');

  timeBeginPeriod(1);
end;

{******************************************************************************}

finalization

begin
  timeEndPeriod(1);
end;

end.