////////////////////////////////////////////////////////////////////////////////
// Copyright (c) 2001-2023 Alexey Kuryakin daqgroup@mail.ru under MIT license //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// This file is part of the CRW-DAQ project by DaqGroup - component CRWLIB.   //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Purpose:                                                                   //
// Multimedia timer with frequency upto 1 kHz (Win32) or fake thread (Unix).  //
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// History:                                                                   //
// 20060318 - creation & tests                                                //
// 20230501 - Modified for FPC (A.K.)                                         //
////////////////////////////////////////////////////////////////////////////////

unit _crw_mmt; // MultiMedia Timer

{$I _crw_sysdef}

{$IFDEF FPC}{$mode Delphi}{$ENDIF}{$H+}

interface

uses
 _crw_sharemem, // NB: THIS UNIT MUST BE FIRST !!!
 {$IFDEF UNIX} cthreads, dl, {$ENDIF}
 {$IFDEF WINDOWS} windows, mmsystem, {$ENDIF}
 sysutils, classes, math, lcltype,
 _crw_alloc, _crw_rtc, _crw_polling;

 ///////////////////////////////////////////////////////////////////////////////
 // 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);
 TTimeCallbackProc = procedure(uID,uMsg:UINT; dwUser,dw1,dw2:PtrUInt) stdcall;
 TmmTimer = class(TLatch)
 private
  myList      : TList;
  myTimer     : PtrUInt;
  myPeriod    : PtrUInt;
  myCounter   : PtrUInt;
  myThreadId  : PtrUInt;
  function    GetTimer:PtrUInt;
  function    GetPeriod:PtrUInt;
  procedure   SetPeriod(aPeriod:PtrUInt);
  function    GetCounter:PtrUInt;
  function    GetThreadId:PtrUInt;
  procedure   Execute;
 protected
  myPolling   : TPolling;
  myPeriods   : PtrInt;
  myEvents    : PtrInt;
  {$IFNDEF WINDOWS}
  function timeBeginPeriod(uPeriod:UINT):UINT;
  function timeEndPeriod(uPeriod:UINT):UINT;
  function timeSetEvent(uDelay,uResolution:UINT; lpTimeProc:TTimeCallbackProc;
                        dwUser:PtrUInt; fuEvent:UINT):UINT;
  function timeKillEvent(uTimerID:UINT):UINT;
 {$ENDIF  WINDOWS}
 public
  class function  DefaultPriority:TThreadPriority;
  class procedure SetDefaultPriority(aPriority:TThreadPriority);
 public
  constructor Create;
  destructor  Destroy; override;
  function    Add(aAction:TmmTimerAction):Boolean;
  procedure   Remove(aAction:TmmTimerAction);
 public
  property Timer    : PtrUInt read GetTimer;
  property Period   : PtrUInt read GetPeriod write SetPeriod;
  property Counter  : PtrUInt read GetCounter;
  property ThreadId : PtrUInt read GetThreadId;
 end;

const // Period range for mmTimer.Period
 mmTimerPeriodMin = 1;
 mmTimerPeriodMax = 1000;

procedure Kill(var TheObject:TmmTimer); overload;

function mmTimer:TmmTimer;

implementation

 ///////////////////////////////////////////////////////////////////////////////
 // User callback to be call on multimedia timer with period about 1 ms (Win32).
 ///////////////////////////////////////////////////////////////////////////////
procedure myTimerCallBack(uTimerID,uMessage:UINT;dwUser,dw1,dw2:PtrUInt); stdcall;
begin
 if (dwUser<>0) then TmmTimer(PtrUIntToPointer(dwUser)).Execute;
end;

 ///////////////////////////////////////////////////////////////////////////////
 // User callback to simulate multimedia timer by using a polling thread (Unix).
 ///////////////////////////////////////////////////////////////////////////////
procedure mmAction(aPolling:TPolling; var Terminate:Boolean);
var Timer:TTimeCallbackProc;
begin
 if not Assigned(aPolling) then Exit;
 Timer:=aPolling.LinkCustom; if not Assigned(Timer) then Exit;
 Timer(aPolling.Delay,0,PointerToPtrUInt(aPolling.LinkObject),0,0);
end;

 ///////////////////////////////////////////////////////////////////////////////
 // Fake mmsystem timers - simulate with polling threads on non-Windows systems.
 ///////////////////////////////////////////////////////////////////////////////
{$IFNDEF WINDOWS}
type
 PTimeCaps=^TTimeCaps;
 TTimeCaps=record wPeriodMin,wPeriodMax:UINT; end;

const
 TIMERR_NOERROR = 0;
 TIMERR_BASE    = 96;
 TIMERR_NOCANDO = TIMERR_BASE+1;
 TIMERR_STRUCT  = TIMERR_BASE+33;
 TIME_PERIODIC  = 1;

function TmmTimer.timeBeginPeriod(uPeriod:UINT):UINT;
begin
 Result:=TIMERR_NOCANDO;
 if not InRange(uPeriod,mmTimerPeriodMin,mmTimerPeriodMax) then Exit;
 if (LockedInc(myPeriods)>0) then
 if not Assigned(myPolling) then begin
  myPolling:=NewPolling(mmAction,uPeriod,DefaultPriority,false,'System.mmt');
  myPolling.Master:=@myPolling;
 end;
 myPolling.Delay:=uPeriod;
 Result:=TIMERR_NOERROR;
end;

function TmmTimer.timeEndPeriod(uPeriod:UINT):UINT;
begin
 Result:=TIMERR_NOCANDO;
 if (myPeriods<0) then Exit;
 if not InRange(uPeriod,mmTimerPeriodMin,mmTimerPeriodMax) then Exit;
 if (LockedDec(myPeriods)<=0) then
 if Assigned(myPolling) then begin
  Kill(myPolling);
 end;
 Result:=TIMERR_NOERROR;
end;

function TmmTimer.timeSetEvent(uDelay,uResolution:UINT; lpTimeProc:TTimeCallbackProc;
                               dwUser:PtrUInt; fuEvent:UINT):UINT;
begin
 Result:=0;
 if not Assigned(myPolling) then Exit;
 if not InRange(uDelay,mmTimerPeriodMin,mmTimerPeriodMax) then Exit;
 myPolling.Enabled:=false;
 myPolling.LinkCustom:=@lpTimeProc;
 myPolling.LinkObject:=PtrUIntToPointer(dwUser);
 if (LockedInc(myEvents)>0) then myPolling.Enabled:=true;
 Result:=uDelay;
end;

function TmmTimer.timeKillEvent(uTimerID:UINT):UINT;
begin
 Result:=TIMERR_NOCANDO;
 if not Assigned(myPolling) then Exit;
 if not InRange(uTimerID,mmTimerPeriodMin,mmTimerPeriodMax) then Exit;
 if (LockedDec(myEvents)<=0) then myPolling.Enabled:=false;
 Result:=TIMERR_NOERROR;
end;

function  timeGetDevCaps(ptc:PTimeCaps; cbtc:UINT):UINT;
begin
 Result:=TIMERR_STRUCT;
 if (ptc=nil) then Exit;
 if (cbtc<SizeOf(ptc^)) then Exit;
 ptc.wPeriodMin:=mmTimerPeriodMin;
 ptc.wPeriodMax:=mmTimerPeriodMax;
 Result:=TIMERR_NOERROR;
end;
{$ENDIF  WINDOWS}

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

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

function TmmTimer.GetTimer:PtrUInt;
begin
 Result:=0;
 if Assigned(Self) then begin
  Lock;
  Result:=myTimer;
  Unlock;
 end;
end;

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

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

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

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

procedure TmmTimer.Execute;
var i:Integer;
begin
 if Assigned(Self) then
 try
  LockedInc(myCounter);
  if (myThreadId=0) then LockedExchange(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,'Execute');
 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,'Add');
 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,'Remove');
 end;
end;

const
 mmDefaultPriority: TThreadPriority = tpNormal;

class function TmmTimer.DefaultPriority:TThreadPriority;
begin
 Result:=mmDefaultPriority;
end;

class procedure TmmTimer.SetDefaultPriority(aPriority:TThreadPriority);
begin
 mmDefaultPriority:=aPriority;
end;

procedure Kill(var TheObject:TmmTimer); overload;
begin
 try
  FreeAndNil(TheObject);
 except
  on E:Exception do BugReport(E,nil,'Kill');
 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;

///////////////////////////////////////
// Unit initialization and finalization
///////////////////////////////////////

procedure Init_crw_mmt;
begin
 mmTimer.Ok;
end;

procedure Free_crw_mmt;
begin
 Kill(TheTimer);
end;

initialization

 Init_crw_mmt;

finalization

 Free_crw_mmt;

end.

//////////////
// END OF FILE
//////////////

