 {
 ****************************************************************************
 CRW32 project
 Copyright (C) by Kuryakin Alexey, Sarov, Russia, 2006, <kouriakine@mail.ru>
 Multimedia timer. Frequency upto 1 kHz.
 Modifications:
 20060318 - creation & tests
 ****************************************************************************
 }

unit _MMT; { MultiMedia Timer }

{$I _sysdef}

interface

uses SysUtils, Windows, Math, MMSystem, Classes, _alloc;

 ///////////////////////////////////////////////////////////////////////////////
 // The class of fast multimedia timer which activate some callback procedure
 // written by user with period about 1 ms.
 // To start timer, use mmTimer.Period:=1;
 // To stop  timer, use mmTimer.Period:=0;
 ///////////////////////////////////////////////////////////////////////////////
type
 TmmTimer = class;
 TmmTimerAction = procedure(Sender:TmmTimer);
 TmmTimer = class(TLatch)
 private
  myList      : TList;
  myTimer     : Cardinal;
  myPeriod    : Cardinal;
  myCounter   : Cardinal;
  myThreadId  : Cardinal;
  function    GetPeriod:Cardinal;
  procedure   SetPeriod(aPeriod:Cardinal);
  function    GetCounter:Cardinal;
  function    GetThreadId:Cardinal;
  procedure   Execute;
 public
  constructor Create;
  destructor  Destroy; override;
  function    Add(aAction:TmmTimerAction):Boolean;
  procedure   Remove(aAction:TmmTimerAction);
 public
  property Period   : Cardinal read GetPeriod write SetPeriod;
  property Counter  : Cardinal read GetCounter;
  property ThreadId : Cardinal read GetThreadId;
 end;

procedure Kill(var TheObject:TmmTimer); overload;

function mmTimer:TmmTimer;

implementation

 ///////////////////////////////////////////////////////////////////////////////
 // The user callback which will be called with period about 1 ms.
 ///////////////////////////////////////////////////////////////////////////////
procedure myTimerCallBack(uTimerID,uMessage:UINT;dwUser,dw1,dw2:DWORD); stdcall;
begin
 TmmTimer(dwUser).Execute;
end;

 ///////////////////////////////////////////////////////////////////////////////
 // TmmTimer implementation
 ///////////////////////////////////////////////////////////////////////////////
constructor TmmTimer.Create;
begin
 inherited;
 myList:=TList.Create;
end;

destructor TmmTimer.Destroy;
begin
 SetPeriod(0);
 Kill(myList);
 inherited;
end;

function TmmTimer.GetPeriod:Cardinal;
begin
 Result:=0;
 if Assigned(Self) then begin
  Lock;
  Result:=myPeriod;
  Unlock;
 end;
end;

procedure TmmTimer.SetPeriod(aPeriod:Cardinal);
var TimeCaps:TTimeCaps;
begin
 if Assigned(Self) then
 try
  Lock;
  try
   if aPeriod<>myPeriod then begin
    if myTimer<>0 then mmSystem.timeKillEvent(myTimer);
    if myPeriod<>0 then mmSystem.timeEndPeriod(myPeriod);
    myTimer:=0;
    myPeriod:=0;
    LockedExchange(Integer(myCounter),0);
    LockedExchange(Integer(myThreadId),0);
    if aPeriod>0 then
    if mmSystem.timeGetDevCaps(@TimeCaps,SizeOf(TimeCaps))=TIMERR_NOERROR
    then myPeriod:=Max(TimeCaps.wPeriodMin,Min(TimeCaps.wPeriodMax,aPeriod));
    if myPeriod>0 then
    if mmSystem.timeBeginPeriod(myPeriod)=TIMERR_NOERROR then begin
     myTimer:=mmSystem.timeSetEvent(myPeriod,0,myTimerCallBack,DWORD(Self),TIME_PERIODIC);
     if myTimer=0 then mmSystem.timeEndPeriod(myPeriod);
    end;
    if myTimer=0 then myPeriod:=0;
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

function TmmTimer.GetCounter:Cardinal;
begin
 if Assigned(Self) then Result:=myCounter else Result:=0;
end;

function TmmTimer.GetThreadId:Cardinal;
begin
 if Assigned(Self) then Result:=myThreadId else Result:=0;
end;

procedure TmmTimer.Execute;
var
 i : Integer;
begin
 if Assigned(Self) then
 try
  LockedInc(Integer(myCounter));
  if myThreadId=0 then LockedExchange(Integer(myThreadId),GetCurrentThreadId);
  Lock;
  try
   for i:=0 to myList.Count-1 do TmmTimerAction(myList[i])(Self);
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

function TmmTimer.Add(aAction:TmmTimerAction):Boolean;
begin
 Result:=false;
 if Assigned(Self) then 
 if Assigned(aAction) then
 try
  Lock;
  try
   if myList.IndexOf(@aAction)<0 then begin
    myList.Add(@aAction);
    Result:=true;
   end;
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

procedure TmmTimer.Remove(aAction:TmmTimerAction);
begin
 if Assigned(Self) then 
 if Assigned(aAction) then
 try
  Lock;
  try
   myList.Remove(@aAction);
  finally
   Unlock;
  end;
 except
  on E:Exception do BugReport(E,Self);
 end;
end;

procedure Kill(var TheObject:TmmTimer); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E);
 end;
end;

 ///////////////////////////////////////////////////////////////////////////////
 // mmTimer implementation
 ///////////////////////////////////////////////////////////////////////////////
const
 TheTimer : TmmTimer = nil;

function mmTimer:TmmTimer;
begin
 if not Assigned(TheTimer) then begin
  TheTimer:=TmmTimer.Create;
  TheTimer.Master:=TheTimer;
 end;
 Result:=TheTimer;
end;

initialization

 mmTimer.Ok;

finalization

 Kill(TheTimer);

end.
