一个共享的计时器类封装
QDAC 4.0 中已经包含了此单元,名称改为qdac.timer.share,使用 TQShareTimer 来做相关处理。
这个是一个精度为秒的共享定时器实现,可以秒为单位创建多个共享的定时器,这些定时器的回调的维护和回调都要求在主线程中执行。
这个代码真正想给大家说的是 GetCallbackOwner 函数中,关于匿名函数关联的 Self 的地址获取方式。至于其它实现,实际上大家应该很容易就能看到。
___Parent 成员指向自己的一层匿名函数的实例地址
Self 成员指向关联的 Self 实例地址
通过递归找到 Self
unit Timer.share; interface uses System.Classes, System.Sysutils, System.Generics.Collections, System.Generics.Defaults, System.Rtti, Vcl.ExtCtrls, Winapi.Windows; type PShareTimerItem = ^TShareTimerItem; // 共享定时器项目定义 TShareTimerItem = record // 回调函数 Callback: TMethod; // 末次触发时间 LastTick: UInt64; // 定时器间隔,单位为毫秒(注意添加时用的单位是秒,内部换算成毫秒,以减少1次计算 Interval: Cardinal; // 触发次数 Times: Cardinal; // 引用计数 RefCount: Integer; end; TTimerProc = procedure(const AItem: TShareTimerItem) of object; TTimerProcA = reference to procedure(const AItem: TShareTimerItem); TTimerProcG = procedure(const AItem: TShareTimerItem); TShareTimer = class sealed private class var FCurrent: TShareTimer; class function GetCurrent: TShareTimer; static; protected FCallbacks: TList<PShareTimerItem>; FTimerId: Cardinal; class procedure DoTimer(wnd: HWND; msg: UINT; timerId: UINT_PTR; dwTime: DWORD); static; procedure InternalAdd(const AMethod: TMethod; AInterval: Cardinal); procedure InternalRemove(const AMethod: TMethod); procedure DoListNotify(Sender: TObject; const Item: PShareTimerItem; Action: TCollectionNotification); function DoClear(Owner: TObject): Integer; procedure FreeTimer(ATimer: PShareTimerItem); // 获取定时器关联的所有者对象实例(即回调函数中 Self 对应的值,如果是全局回调,则为空) function GetCallbackOwner(const ATimer: TShareTimerItem): TObject; public constructor Create; overload; destructor Destroy; override; class destructor Destroy; /// <summary>清除所有的定时器<summary> class procedure Clear; overload; /// <summary>清除关联到指定对象的所有定时器</summary> /// <param name="Owner">所有者对象</param> /// <remark>对于对象的成员函数,Owner 为对象的地址,对于匿名函数,则指向对应的回调函数的 Self 成员</remark> class function Clear(Owner: TObject): Integer; overload; /// <summary>添加一个定时器回调</summary> /// <param name="ACallback">定时器回调函数</param> /// <param name="AInterval">定时器间隔,单位为秒</param> class procedure Add(ACallback: TTimerProc; AInterval: Cardinal = 1); overload; /// <summary>添加一个定时器回调</summary> /// <param name="ACallback">定时器回调函数</param> /// <param name="AInterval">定时器间隔,单位为秒</param> class procedure Add(ACallback: TTimerProcG; AInterval: Cardinal = 1); overload; /// <summary>添加一个定时器回调</summary> /// <param name="ACallback">定时器回调函数</param> /// <param name="AInterval">定时器间隔,单位为秒</param> class procedure Add(ACallback: TTimerProcA; AInterval: Cardinal = 1); overload; /// <summary>删除一个定时器回调</summary> /// <param name="ACallback">定时器回调函数</param> class procedure Remove(ACallback: TTimerProc); overload; /// <summary>删除一个定时器回调</summary> /// <param name="ACallback">定时器回调函数</param> class procedure Remove(ACallback: TTimerProcG); overload; /// <summary>删除一个定时器回调</summary> /// <param name="ACallback">定时器回调函数</param> /// <remarks>注意匿名函数是一个接口,每次调用会对应不同的实例,这个需要自己注意管理。 /// 如果要清除一个对象的所有定时器,调用 Clear(对象实例) /// <remarks> class procedure Remove(ACallback: TTimerProcA); overload; /// 全局公共实例 class property Current: TShareTimer read GetCurrent; end; implementation { TShareTimer } class procedure TShareTimer.Add(ACallback: TTimerProc; AInterval: Cardinal); begin Current.InternalAdd(TMethod(ACallback), AInterval * 1000); end; class procedure TShareTimer.Add(ACallback: TTimerProcG; AInterval: Cardinal); var AMethod: TMethod; begin AMethod.Code := @ACallback; AMethod.Data := nil; Current.InternalAdd(AMethod, AInterval * 1000); end; class procedure TShareTimer.Add(ACallback: TTimerProcA; AInterval: Cardinal); var AMethod: TMethod; begin AMethod.Code := nil; AMethod.Data := Pointer(-1); TTimerProcA(AMethod.Code) := ACallback; Current.InternalAdd(AMethod, AInterval * 1000); end; class procedure TShareTimer.Clear; begin Current.FCallbacks.Clear; end; class function TShareTimer.Clear(Owner: TObject): Integer; begin Result := Current.DoClear(Owner); end; constructor TShareTimer.Create; begin inherited Create; FCallbacks := TList<PShareTimerItem>.Create(TComparer<PShareTimerItem>.Construct( function(const L, R: PShareTimerItem): Integer begin Result := IntPtr(L.Callback.Code) - IntPtr(R.Callback.Code); if Result = 0 then Result := IntPtr(L.Callback.Data) - IntPtr(R.Callback.Data); end)); FCallbacks.OnNotify := DoListNotify; end; destructor TShareTimer.Destroy; begin FCallbacks.Clear; FreeAndNil(FCallbacks); inherited; end; class destructor TShareTimer.Destroy; begin if Assigned(FCurrent) then FreeAndNil(FCurrent); end; function TShareTimer.DoClear(Owner: TObject): Integer; var I: Integer; begin I := 0; Result := 0; while I < FCallbacks.Count do begin if GetCallbackOwner(FCallbacks[I]^) = Owner then begin FCallbacks.Delete(I); Inc(Result); continue; end; Inc(I); end; end; procedure TShareTimer.DoListNotify(Sender: TObject; const Item: PShareTimerItem; Action: TCollectionNotification); begin if Action in [cnExtracted, cnRemoved] then FreeTimer(Item); end; class procedure TShareTimer.DoTimer(wnd: HWND; msg: UINT; timerId: UINT_PTR; dwTime: DWORD); var ATick: UInt64; ATimers: TArray<PShareTimerItem>; begin ATick := TThread.GetTickCount64; with TShareTimer.FCurrent do begin ATimers := FCallbacks.ToArray; for var I := 0 to High(ATimers) do Inc(ATimers[I].RefCount); try for var I := 0 to High(ATimers) do begin try if ATick - ATimers[I].LastTick >= ATimers[I].Interval then begin ATimers[I].LastTick := ATick; Inc(ATimers[I].Times); case IntPtr(ATimers[I].Callback.Data) of 0: TTimerProcG(ATimers[I].Callback.Code)(ATimers[I]^); -1: TTimerProcA(ATimers[I].Callback.Code)(ATimers[I]^) else TTimerProc(ATimers[I].Callback)(ATimers[I]^); end; end; except on E: Exception do end; end; finally for var I := 0 to High(ATimers) do FreeTimer(ATimers[I]); end; end; end; procedure TShareTimer.FreeTimer(ATimer: PShareTimerItem); var AProc: TTimerProcA; begin Dec(ATimer.RefCount); if ATimer.RefCount = 0 then begin if (ATimer.Callback.Data = Pointer(-1)) then begin PPointer(@AProc)^ := ATimer.Callback.Code; AProc := nil; // 引用计数 end; Dispose(ATimer); end; end; class function TShareTimer.GetCurrent: TShareTimer; begin if not Assigned(FCurrent) then FCurrent := TShareTimer.Create; Result := FCurrent; end; function TShareTimer.GetCallbackOwner(const ATimer: TShareTimerItem): TObject; function GetObject(AObj: TObject): TObject; var AType: TRttiType; AField: TRttiField; begin Result := nil; AType := TRttiContext.Create.GetType(AObj.ClassType); if Assigned(AType) then begin AField := AType.GetField('___Parent'); if Assigned(AField) then Result := GetObject(AField.GetValue(AObj).AsObject) else begin AField := AType.GetField('Self'); if Assigned(AField) then Result := AField.GetValue(AObj).AsObject; end; end; end; var I: Integer; begin I := 0; if FCallbacks[I].Callback.Data <> nil then begin if FCallbacks[I].Callback.Data = Pointer(-1) then Result := GetObject(IInterface(FCallbacks[I].Callback.Code) as TObject) else Result := FCallbacks[I].Callback.Data; end else Result := nil; end; procedure TShareTimer.InternalAdd(const AMethod: TMethod; AInterval: Cardinal); var AItem: PShareTimerItem; AIndex: Integer; begin New(AItem); AItem.Callback := AMethod; AItem.LastTick := TThread.GetTickCount64; AItem.Interval := AInterval; AItem.RefCount := 1; AItem.Times := 0; if not FCallbacks.BinarySearch(AItem, AIndex) then FCallbacks.Insert(AIndex, AItem); if FTimerId = 0 then FTimerId := SetTimer(0, 0, 1000, TFNTimerProc(@DoTimer)); end; procedure TShareTimer.InternalRemove(const AMethod: TMethod); var AIndex: Integer; ATemp: TShareTimerItem; begin ATemp.Callback := AMethod; if FCallbacks.BinarySearch(@ATemp, AIndex) then FCallbacks.Delete(AIndex); if FCallbacks.Count = 0 then begin KillTimer(0, FTimerId); FTimerId := 0; end; end; class procedure TShareTimer.Remove(ACallback: TTimerProc); begin if Assigned(FCurrent) then FCurrent.InternalRemove(TMethod(ACallback)); end; class procedure TShareTimer.Remove(ACallback: TTimerProcG); var AMethod: TMethod; begin if Assigned(FCurrent) then begin AMethod.Code := @ACallback; AMethod.Data := nil; FCurrent.InternalRemove(AMethod); end; end; class procedure TShareTimer.Remove(ACallback: TTimerProcA); var AMethod: TMethod; begin if Assigned(FCurrent) then begin AMethod.Code := nil; AMethod.Data := Pointer(-1); FCurrent.InternalRemove(AMethod); end; end; end.