1 {
2  /***************************************************************************
3                                customtimer.pas
4                                ---------------
5                          Lazarus Component Library TCustomTimer
6 
7  ***************************************************************************/
8 
9  *****************************************************************************
10   This file is part of the Lazarus Component Library (LCL)
11 
12   See the file COPYING.modifiedLGPL.txt, included in this distribution,
13   for details about the license.
14  *****************************************************************************
15 }
16 unit CustomTimer;
17 
18 {$mode objfpc}{$H+}
19 
20 interface
21 
22 uses
23   Classes, SysUtils, LCLProc, LCLStrConsts, LCLType, InterfaceBase;
24 
25 type
26 
27   { TCustomTimer }
28 
29   TCustomTimer = class (TComponent)
30   private
31     FInterval     : Cardinal;
32     FOnStartTimer: TNotifyEvent;
33     FOnStopTimer: TNotifyEvent;
34     FTimerHandle  : THandle;
35     FOnTimer      : TNotifyEvent;
36     FEnabled      : Boolean;
37     procedure Timer;
38   protected
39     procedure SetEnabled(Value: Boolean); virtual;
40     procedure SetInterval(Value: Cardinal); virtual;
41     procedure SetOnTimer(Value: TNotifyEvent); virtual;
42     procedure DoOnTimer; virtual;
43     procedure UpdateTimer; virtual;
44     procedure KillTimer; virtual;
45     procedure Loaded; override;
46   public
47     constructor Create(AOwner: TComponent); override;
48     destructor Destroy; override;
49     property Enabled: Boolean read FEnabled write SetEnabled default True;
50     property Interval: Cardinal read FInterval write SetInterval default 1000;
51     property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
52     property OnStartTimer: TNotifyEvent read FOnStartTimer write FOnStartTimer;
53     property OnStopTimer: TNotifyEvent read FOnStopTimer write FOnStopTimer;
54   end;
55 
56 
57 implementation
58 
59 const
60   cIdNoTimer = THandle(-1);        { timer ID for an invalid timer }
61 
62 {------------------------------------------------------------------------------
63   Method: TCustomTimer.Create
64   Params:  AOwner: the owner of the class
65   Returns: Nothing
66 
67   Constructor for a timer.
68  ------------------------------------------------------------------------------}
69 constructor TCustomTimer.Create(AOwner: TComponent);
70 begin
71   inherited Create(AOwner);
72   FInterval    := 1000;
73   FTimerHandle := cIdNoTimer;
74   FEnabled     := true;
75 end;
76 
77 {------------------------------------------------------------------------------
78   Method: TCustomTimer.Destroy
79   Params:  Nothing
80   Returns: Nothing
81 
82   Destructor for a timer.
83  ------------------------------------------------------------------------------}
84 destructor TCustomTimer.Destroy;
85 begin
86   FOnTimer:=nil;
87   FEnabled:=false;
88   KillTimer;
89   inherited Destroy;
90 end;
91 
92 {------------------------------------------------------------------------------
93   Method: TCustomTimer.KillTimer
94   Params:  Nothing
95   Returns: Nothing
96 
97   Kills the current timer object.
98  ------------------------------------------------------------------------------}
99 procedure TCustomTimer.KillTimer;
100 begin
101   if FTimerHandle <> cIdNoTimer then begin
102     //DebugLn(['TCustomTimer.KillTimer ',dbgsName(Self)]);
103     WidgetSet.DestroyTimer(FTimerHandle);
104     FTimerHandle := cIdNoTimer;
105     if Assigned(OnStopTimer) then OnStopTimer(Self);
106   end;
107 end;
108 
109 procedure TCustomTimer.Loaded;
110 begin
111   inherited Loaded;
112   UpdateTimer;
113 end;
114 
115 {------------------------------------------------------------------------------
116   Method: TCustomTimer.UpdateTimer
117   Params:  Nothing
118   Returns: Nothing
119 
120   Updates the timer to match the current properties.
121  ------------------------------------------------------------------------------}
122 procedure TCustomTimer.UpdateTimer;
123 begin
124   KillTimer;
125   if (FEnabled) and (FInterval > 0)
126   and (([csLoading,csDestroying]*ComponentState=[]))
127   and Assigned (FOnTimer) then begin
128     //DebugLn(['TCustomTimer.UpdateTimer ',dbgsName(Self),' WidgetSet.CreateTimer']);
129     FTimerHandle := WidgetSet.CreateTimer(FInterval, @Timer);
130     if FTimerHandle=0 then begin
131       FTimerHandle:=cIdNoTimer;
132       raise EOutOfResources.Create(SNoTimers);
133     end;
134     if Assigned(OnStartTimer) then OnStartTimer(Self);
135   end;
136 end;
137 
138 {------------------------------------------------------------------------------
139   Method: TCustomTimer.Timer
140   Returns: Nothing
141 
142   Is called when the timer has expired and calls users OnTimer function.
143  ------------------------------------------------------------------------------}
144 procedure TCustomTimer.Timer;
145 begin
146   {$IFDEF VerboseTimer}
147   DebugLn(['TCustomTimer.Timer ',dbgsName(Self),' ',FEnabled,' ',FInterval]);
148   {$ENDIF}
149   if (FEnabled) and (FInterval > 0) then
150     DoOnTimer;
151 end;
152 
153 {------------------------------------------------------------------------------
154   Method: TCustomTimer.SetOnTimer
155   Params:  value - users notification function
156   Returns: Nothing
157 
158   Assigns the users notification callback.
159  ------------------------------------------------------------------------------}
160 procedure TCustomTimer.SetOnTimer (value : TNotifyEvent);
161 begin
162   // Value=FOnTimer only compares code part
163   if CompareByte(Value,FOnTimer,SizeOf(Value))=0 then exit;
164   FOnTimer := value;
165   UpdateTimer;
166 end;
167 
168 {------------------------------------------------------------------------------
169   procedure TCustomTimer.DoOnTimer;
170 
171  ------------------------------------------------------------------------------}
172 procedure TCustomTimer.DoOnTimer;
173 begin
174   if Assigned(FOnTimer) then
175     FOnTimer(Self);
176 end;
177 
178 {------------------------------------------------------------------------------
179   Method: TCustomTimer.SetEnabled
180   Params:  value - new "enabled" state of the timer
181   Returns: Nothing
182 
183   En/Disables the timer
184  ------------------------------------------------------------------------------}
185 procedure TCustomTimer.SetEnabled (value : boolean);
186 begin
187   if (Value <> FEnabled) then
188   begin
189     FEnabled := value;
190     UpdateTimer;
191   end;
192 end;
193 
194 {------------------------------------------------------------------------------
195   Method: TCustomTimer.SetInterval
196   Params:  value - timer interval
197   Returns: Nothing
198 
199   Sets interval for the timer.
200  ------------------------------------------------------------------------------}
201 procedure TCustomTimer.SetInterval (value : cardinal);
202 begin
203   if (value <> FInterval) then
204   begin
205     FInterval := value;
206     UpdateTimer;
207   end;
208 end;
209 
210 end.
211