* Alternat implementation based on event, from Derek (Bug ID 28831)

git-svn-id: trunk@33298 -

packages/fcl-base/src/fptimer.pp

@@ -23,12 +23,32 @@
   
   A nice improvement would be an implementation that works
   in all threads, such as the threadedtimer of IBX for linux.
+
+  Replaced SLEEP with TEvent for those platforms supporting threading:
+           Windows, Linux, BSD.
+  On the other platforms, use sleep. This unfortunately has a high overhead
+     resulting in drift.  A five minute timer could be up to 40 seconds late
+     do to entering and returning (linux x64).  MOdified to check the absolute
+     time every minute, has reduced that lag to about 0.100 second.  This is
+     still greater than TEvent, where the delay is only a few milliseconds (0-3).     
 }
 
-unit fpTimer;
+unit fptimer;
 
 {$mode objfpc}{$H+}
 
+{ 
+  Windows, or any platform that uses Cthreads has TEvent with a timed wait
+  which can include android and embedded.
+  You can force the use of the Sleep() based timer by defining USESLEEP
+}
+
+{$IFNDEF USESLEEP}
+{$if Defined(MSWINDOWS) or (Defined(UNIX) and not Defined(BEOS))}
+{$define Has_EventWait}
+{$endif}
+{$ENDIF}
+
 interface
 
 uses
@@ -36,20 +56,25 @@ uses
 
 type
   TFPTimerDriver = Class;
-  
+
+  { TFPCustomTimer }
+
   TFPCustomTimer = class(TComponent)
   private
-    FInterval: Integer;
     FDriver : TFPTimerDriver;
-    FOnTimer: TNotifyEvent;
+    FOnStartTimer : TNotifyEvent;
-    FContinue: Boolean;
+    FOnStopTimer : TNotifyEvent;
-    FRunning: Boolean;
+    FOnTimer : TNotifyEvent;
-    FEnabled: Boolean;
+    FInterval : Cardinal;
-    procedure   SetEnabled(Value: Boolean );
+    FActive : Boolean;
+    FEnabled : Boolean;
+    FUseTimerThread : Boolean;
+    procedure SetEnabled(const AValue: Boolean );
+    procedure SetInterval(const AValue: Cardinal);
   protected
-    property  Continue: Boolean read FContinue write FContinue;
+    property Active: Boolean read FActive write FActive;
-    procedure Timer; virtual;
     Function CreateTimerDriver : TFPTimerDriver;
+    procedure Timer; virtual;
   public
     Constructor Create(AOwner: TComponent); override;
     Destructor Destroy; override;
@@ -57,25 +82,36 @@ type
     procedure StopTimer; virtual;
   protected
     property Enabled: Boolean read FEnabled write SetEnabled;
-    property Interval: Integer read FInterval write FInterval;
+    property Interval: Cardinal read FInterval write SetInterval;
+    property UseTimerThread: Boolean read FUseTimerThread write FUseTimerThread;
     property OnTimer: TNotifyEvent read FOnTimer write FOnTimer;
+    property OnStartTimer: TNotifyEvent read FOnStartTimer write FOnStartTimer;
+    property OnStopTimer: TNotifyEvent read FOnStopTimer write FOnStopTimer;
   end;
 
   TFPTimer = Class(TFPCustomTimer)
   Published
     Property Enabled;
     Property Interval;
+    Property UseTimerThread;
     Property OnTimer;
-  end;  
+    Property OnStartTimer;
+    Property OnStopTimer;
+  end;
+
+  { TFPTimerDriver }
 
   TFPTimerDriver = Class(TObject)
   Protected
     FTimer : TFPCustomTimer;
+    FTimerStarted : Boolean;
+    procedure SetInterval(const AValue: Cardinal); virtual;
   Public
     Constructor Create(ATimer : TFPCustomTimer); virtual;
     Procedure StartTimer; virtual; abstract;
     Procedure StopTimer; virtual; abstract;
     Property Timer : TFPCustomTimer Read FTimer;
+    property TimerStarted: Boolean read FTimerStarted;
   end;
   TFPTimerDriverClass = Class of TFPTimerDriver;
 
@@ -100,9 +136,8 @@ end;
 destructor TFPCustomTimer.Destroy;
 
 begin
-  If FEnabled then
+  StopTimer;
-    StopTimer;
+  FDriver.FTimer:=Nil;
-  FDriver.FTimer:=Nil;  
   FreeAndNil(FDriver);
   Inherited;
 end;
@@ -114,34 +149,59 @@ begin
   Result:=DefaultTimerDriverClass.Create(Self);
 end;
 
-procedure TFPCustomTimer.SetEnabled(Value: Boolean);
+procedure TFPCustomTimer.SetEnabled(const AValue: Boolean);
 begin
-  if Value <> FEnabled then
+  if AValue <> FEnabled then
     begin
-    if Value then
+    FEnabled := AValue;
+    if FEnabled then
       StartTimer
     else
       StopTimer;
     end;
 end;
 
-procedure TFPCustomTimer.StartTimer;
+procedure TFPCustomTimer.SetInterval(const AValue: Cardinal);
 begin
-  If FEnabled then
+  if FInterval <> AValue then
-    Exit;
+    begin
-  FEnabled:=True;
+    fInterval := AValue;
-  FContinue:=True;  
+    if FActive and (fInterval > 0) then
-  If Not (csDesigning in ComponentState) then  
+      FDriver.SetInterval(AValue)  // Allow driver to update Interval
+    else
+      StopTimer;                   // Timer not required
+    end;
+end;
+
+procedure TFPCustomTimer.StartTimer;
+var
+  IsActive: Boolean;
+begin
+  IsActive:=FEnabled and (fInterval > 0) and Assigned(FOnTimer);
+  If IsActive and not fActive and Not (csDesigning in ComponentState) then
+    begin
     FDriver.StartTimer;
+    if FDriver.TimerStarted then
+      begin
+      FActive := True;
+      if Assigned(OnStartTimer) then
+        OnStartTimer(Self);
+      end;
+    end;
 end;
 
 procedure TFPCustomTimer.StopTimer;
 begin
-  If Not FEnabled then 
+  if FActive then
-    Exit;
+    begin
-  FEnabled:=False;
+    FDriver.StopTimer;
-  FContinue:=False;  
+    if not FDriver.TimerStarted then
-  FDriver.StopTimer;
+      begin
+      FActive:=False;
+      if Assigned(OnStopTimer) then
+        OnStopTimer(Self);
+      end;
+    end;
 end;
 
 procedure TFPCustomTimer.Timer;
@@ -149,14 +209,13 @@ procedure TFPCustomTimer.Timer;
 begin
   { We check on FEnabled: If by any chance a tick comes in after it was
     set to false, the user won't notice, since no event is triggered.}
-  If FEnabled and Assigned(FOnTimer) then
+  If FActive and Assigned(FOnTimer) then
     FOnTimer(Self);
 end;
 
 { ---------------------------------------------------------------------
   TFPTimerDriver
   ---------------------------------------------------------------------}
-  
 
 Constructor TFPTimerDriver.Create(ATimer : TFPCustomTimer);
 
@@ -164,116 +223,327 @@ begin
   FTimer:=ATimer;
 end;
 
+procedure TFPTimerDriver.SetInterval(const AValue: Cardinal);
+begin
+  // Default implementation is to restart the timer on Interval change
+  if TimerStarted then
+    begin
+    StopTimer;
+    FTimerStarted := (AValue > 0);
+    if FTimerStarted then
+      StartTimer;
+    end;
+end;
+
 
 { ---------------------------------------------------------------------
     Default implementation. Threaded timer, one thread per timer.
   ---------------------------------------------------------------------}
+
+const
+  cMilliSecs: Extended = 60.0 * 60.0 * 24.0 * 1000.0;
   
 Type
+
+  { TFPTimerThread }
+
   TFPTimerThread = class(TThread)
   private
     FTimerDriver: TFPTimerDriver;
+    FStartTime : TDateTime;
+    {$ifdef Has_EventWait}
+    FWaitEvent: PEventState;
+    {$else}
+    fSignaled: Boolean;
+    {$endif}
+    fInterval: Cardinal;
     Function Timer : TFPCustomTimer;
+    Function GetWakeTime(var AInterval,Counter : Int64; Out WakeInterval : Integer; Out WakeTime : TDateTime) : Boolean;
   public
     procedure Execute; override;
     constructor CreateTimerThread(ATimerDriver: TFPTimerDriver);
+    procedure Terminate;
+    procedure SetInterval(const AValue: Cardinal);
   end;
 
+  { TFPThreadedTimerDriver }
+
   TFPThreadedTimerDriver = Class(TFPTimerDriver)
   Private
     FThread : TFPTimerThread;
-    Procedure DoNilTimer(Sender : TObject);
+  protected
+    Procedure SetInterval(const AValue: cardinal); override;
   Public
     Procedure StartTimer; override;
     Procedure StopTimer; override;
   end;
 
-function _GetTickCount: Cardinal;
-begin
-  Result := Cardinal(Trunc(Now * 24 * 60 * 60 * 1000));
-end;
-
 { ---------------------------------------------------------------------
     TFPTimerThread
   ---------------------------------------------------------------------}
-  
+
 constructor TFPTimerThread.CreateTimerThread(ATimerDriver: TFPTimerDriver);
 begin
   inherited Create(True);
   FTimerDriver:=ATimerDriver;
+  {$ifdef Has_EventWait}
+  FWaitEvent := BasicEventCreate(nil,false,false,'');
+  {$else}
+  fSignaled := False;
+  {$endif}
+  fInterval := ATimerDriver.Timer.Interval;
   FreeOnTerminate := True;
 end;
 
+procedure TFPTimerThread.Terminate;
+begin
+  inherited Terminate;
+  {$ifdef Has_EventWait}
+  BasicEventSetEvent(fWaitEvent);
+  {$else}
+  fSignaled := True;
+  {$endif}
+end;
+
+procedure TFPTimerThread.SetInterval(const AValue: Cardinal);
+begin
+  if fInterval <> AValue then
+    begin
+    fInterval := AValue;
+    {$ifdef Has_EventWait}
+    BasicEventSetEvent(fWaitEvent);   // Wake thread
+    {$else}
+    fSignaled := True;
+    {$endif}
+    end;
+end;
+
 Function TFPTimerThread.Timer : TFPCustomTimer;
 
 begin
   If Assigned(FTimerDriver) Then
     Result:=FTimerDriver.FTimer
   else
-    Result:=Nil;  
+    Result:=Nil;
 end;
 
-procedure TFPTimerThread.Execute;
+Function TFPTimerThread.GetWakeTime(var AInterval,Counter : Int64; Out WakeInterval : Longint; Out WakeTime : TDateTime) : Boolean;
-var
+
-  SleepTime: Integer;
+
-  S,Last: Cardinal;
+Var
-  T : TFPCustomTimer;
+  Diff: Extended;
-  
+   
 begin
-  while Not Terminated do
+    { Use Counter*fInterval to avoid numerical errors resulting from adding
+      small values (AInterval/cMilliSecs) to a large real number (TDateTime),
+      even when using Extended precision }
+  WakeTime := FStartTime + (Counter*AInterval / cMilliSecs);
+  Diff := (WakeTime - Now);
+  if Diff > 0 then
     begin
-    Last := _GetTickCount;
+    WakeInterval := Trunc(Diff * cMilliSecs);
-    T:=Timer;
+    if WakeInterval < 10 then
-    If Assigned(T) then
+      WakeInterval := 10;    // Provide a minimum wait time
-      begin
+    end
-      SleepTime := T.FInterval - (_GetTickCount - Last);
+  else
-      if SleepTime < 10 then
+    begin
-        SleepTime := 10;
+    WakeInterval:=MaxInt;
-      Repeat  
+    // Time has already expired, execute Timer and restart wait loop
-        S:=5;
+    try
-        If S>SleepTime then
+      if not Timer.UseTimerThread then
-          S:=SleepTime;
+        Synchronize(@Timer.Timer)  // Call user event
-        Sleep(S);
+      else
-        Dec(Sleeptime,S);
+        Timer.Timer;
-      until (SleepTime<=0) or Terminated;
+    except
-      T:=Timer;
+      // Trap errors to prevent this thread from terminating
-      If Assigned(T) and not terminated then
+    end;
-        Synchronize(@T.Timer);
+    Inc(Counter);
-      end
+    Result:=True;
-    else
-      Terminate;  
     end;
 end;
 
+{$ifdef Has_EventWait}
+procedure TFPTimerThread.Execute;
+var
+  WakeTime, StartTime: TDateTime;
+  WakeInterval: Integer;
+  Counter: int64; { use Int64 to avoid overflow with Counter*fInterval (~49 days)}
+  AInterval: int64;
+  Diff: Extended;
+  
+Const
+  wrSignaled = 0;
+  wrTimeout  = 1;
+  wrAbandoned= 2;
+  wrError    = 3;
+  
+begin
+  WakeInterval := MaxInt;
+  Counter := 1;
+  AInterval := fInterval;
+  FStartTime := Now;
+  while not Terminated do
+    begin
+    if GetWakeTime(AInterval,Counter,WakeInterval,WakeTime) then 
+      Continue;
+    if not Terminated then
+      case BasicEventWaitFor(WakeInterval,fWaitEvent) of
+      wrTimeout:
+        begin
+        if Terminated then
+          Break
+        else
+          begin
+          try
+            if not Timer.UseTimerThread then
+              // If terminate is called while here, then the Synchronize will be
+              // queued while the stoptimer is being processed.
+              // StopTimer cannot wait until thread completion as this would deadlock
+              Synchronize(@Timer.Timer)  // Call user event
+            else
+              Timer.Timer;
+          except
+            // Trap errors to prevent this thread from terminating
+          end;
+          Inc(Counter);                // Next interval
+          end;
+        end;
+      wrSignaled:
+        begin
+        if Terminated then
+          Break
+        else 
+          begin                      // Interval has changed
+          Counter := 1;              // Restart timer without creating new thread
+          AInterval := fInterval;
+          FStartTime := Now; 
+          end;
+        end;
+      else
+        Break;
+      end
+    end;
+  BasicEventDestroy(fWaitEvent);
+end;
+
+{$ELSE Has_EventWait}
+
+procedure TFPTimerThread.Execute;
+
+var
+  WakeTime, StartTime: TDateTime;
+  WakeInterval: Integer;
+  Counter: int64; { use Int64 to avoid overflow with Counter*fInterval (~49 days)}
+  AInterval: int64;
+  Diff: Extended;
+  S,Last: Cardinal;
+  RecheckTimeCounter: integer;
+  
+const
+  cSleepTime = 500;           // 0.5 second, better than every 5 milliseconds
+  cRecheckTimeCount = 120;    // Recheck clock every minute, as the sleep loop can loose time
+  
+begin
+  WakeInterval := MaxInt;
+  Counter := 1;
+  AInterval := fInterval;
+  FStartTime := Now;
+  while not Terminated do
+    begin
+    if GetWakeTime(AInterval,Counter,WakeInterval,WakeTime) then
+      Continue;
+    if not Terminated then
+      begin
+      RecheckTimeCounter := cRecheckTimeCount;
+      s := cSleepTime;
+      repeat
+        if s > WakeInterval then
+          s := WakeInterval;
+        sleep(s);
+        if fSignaled then            // Terminated or interval has changed
+          begin
+          if not Terminated then
+            begin
+            fSignaled := False;
+            Counter := 1;            // Restart timer
+            AInterval := fInterval;
+            StartTime := Now;
+            end;
+          break;                     // Need to break out of sleep loop
+          end;
+
+        dec(WakeInterval,s);         // Update total wait time
+        dec(RecheckTimeCounter);     // Do we need to recheck current time
+        if (RecheckTimeCounter < 0) and (WakeInterval > 0) then
+          begin
+          Diff := (WakeTime - Now);
+          WakeInterval := Trunc(Diff * cMilliSecs);
+          RecheckTimeCounter := cRecheckTimeCount;
+          s := cSleepTime;
+          end;
+      until (WakeInterval<=0) or Terminated;
+      if WakeInterval <= 0 then
+        try
+          inc(Counter);
+          if not Timer.UseTimerThread then
+            // If terminate is called while here, then the Synchronize will be
+            // queued while the stoptimer is being processed.
+            // StopTimer cannot wait until thread completion as this would deadlock
+            Synchronize(@Timer.Timer)  // Call user event
+          else
+            Timer.Timer;
+        except
+          // Trap errors to prevent this thread from terminating
+        end;
+      end
+    end;
+end;
+{$ENDIF Has_EventWait}
 { ---------------------------------------------------------------------
     TFPThreadedTimerDriver
   ---------------------------------------------------------------------}
 
-Procedure TFPThreadedTimerDriver.DoNilTimer(Sender : TObject);
+procedure TFPThreadedTimerDriver.SetInterval(const AValue: cardinal);
-
 begin
-  FThread:=Nil;
+  if FThread <> nil then
+    begin
+    if AValue > 0 then
+      FThread.SetInterval(AValue)
+    else
+      StopTimer;
+    end;
 end;
 
-Procedure TFPThreadedTimerDriver.StartTimer; 
+Procedure TFPThreadedTimerDriver.StartTimer;
 
 begin
-  FThread:=TFPTimerThread.CreateTimerThread(Self);
+  if FThread = nil then
-  FThread.OnTerminate:=@DoNilTimer;
+    begin
-  FThread.Start;
+    FThread:=TFPTimerThread.CreateTimerThread(Self);
+    FThread.Start;
+    FTimerStarted := True;
+    end;
 end;
 
 Procedure TFPThreadedTimerDriver.StopTimer;
 begin
-  FThread.FTimerDriver:=Nil;
+  if FThread <> nil then
-  FThread.Terminate; // Will free itself.
+    begin
-  CheckSynchronize; // make sure thread is not stuck at synchronize call.
+    try
-  If Assigned(FThread) then
+      // Cannot wait on thread in case
-    Fthread.WaitFor;  
+      // 1.  this is called in a Synchonize method and the FThread is
+      //     about to run a synchronize method. In these cases we would have a deadlock
+      // 2.  In a DLL and this is called as part of DLLMain, which never
+      //     returns endthread (hence WaitFor) until DLLMain is exited
+      FThread.Terminate;   // Will call FThread.Wake;
+    finally
+      FThread := nil;
+    end;
+    FTimerStarted := False;
+    end;
 end;
 
 
 Initialization
   DefaultTimerDriverClass:=TFPThreadedTimerDriver;
 end.
-