[教程]一个共享的计时器类封装

• Delphi、教程 • 评论关闭 • •浏览 477 次

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.

分享到：