[分享]基于内核对象WaitableTimer实现的Timer组件

[chenzhuo]

把TTimer组件的代码抄了过来，把实现计数部分改由内核对象来实现。

unit WaitTimerU;

interface

uses
  Classes, Windows, Consts;

type
  TWaitTimer = class(TComponent)
  private
    FWaitableTimer: THandle;
    FInterval: Cardinal;
    FOnTimer: TNotifyEvent;
    FEnabled: Boolean;
    procedure UpdateTimer;
    procedure SetEnabled(Value: Boolean);
    procedure SetInterval(Value: Cardinal);
    procedure SetOnTimer(Value: TNotifyEvent);
  protected
    procedure Timer; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property Interval: Cardinal read FInterval write SetInterval default 1000;
    property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
  end;

implementation

procedure TimerAPCProc(lpArgToCompletionRoutine: Pointer; dwTimerLowValue: DWORD;
  dwTimerHighValue: DWORD); stdcall;
begin
  TWaitTimer(lpArgToCompletionRoutine).Timer;
  SleepEx(INFINITE, True);
end;

function WaitTimerThreadFun(P: Pointer): Integer; stdcall;
var
  DueTime: Int64;
begin
  with TWaitTimer(P) do
  begin
    DueTime := -Int64(Interval)*10000;
    if SetWaitableTimer(FWaitableTimer, DueTime, Interval, @TimerAPCProc, P, False) then
    begin
      SleepEx(INFINITE, True);
    end
    else
      raise EOutOfResources.Create(SNoTimers);
  end;
  Result := 0;
end;

{ TWaitTimer }

constructor TWaitTimer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FEnabled := True;
  FInterval := 1000;
  FWaitableTimer := CreateWaitableTimer(nil, False, nil);
end;

destructor TWaitTimer.Destroy;
begin
  FEnabled := False;
  UpdateTimer;
  CloseHandle(FWaitableTimer);
  inherited;
end;

procedure TWaitTimer.SetEnabled(Value: Boolean);
begin
  if Value <> FEnabled then
  begin
    FEnabled := Value;
    UpdateTimer;
  end;
end;

procedure TWaitTimer.SetInterval(Value: Cardinal);
begin
  if Value <> FInterval then
  begin
    FInterval := Value;
    UpdateTimer;
  end;
end;

procedure TWaitTimer.SetOnTimer(Value: TNotifyEvent);
begin
  FOnTimer := Value;
  UpdateTimer;
end;

procedure TWaitTimer.Timer;
begin
  if Assigned(FOnTimer) then FOnTimer(Self);
end;

procedure TWaitTimer.UpdateTimer;
var
  ID: DWORD;
begin
  CancelWaitableTimer(FWaitableTimer);
  if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then
  begin
    CreateThread(nil, 0, @WaitTimerThreadFun, Self, 0, ID);
  end;
end;

end.

[chenzhuo]

谢谢，能否告知RegisterWaitForSingleObject在那里定义吗？

[yushf]

[Quote=引用 24 楼 chenzhuo 的回复:]

SetWaitableTimer(FWaitableTimer, DueTime, Interval, nil, 0, False);

之后没调用类似SleepEx 有Ex后缀的API函数能进入APC队列吗？

楼上的代码测试过吗？
[/Quote]

类似的代码我在项目中已使用。
不需要Timer的回调，所以不需要其进APC队列，现在是FhWaitObj进APC队列。

[yushf]

[Quote=引用 26 楼 chenzhuo 的回复:]

谢谢，能否告知RegisterWaitForSingleObject在那里定义吗？
[/Quote]
我都是从MSDN上查的，详细的你可以去那儿看。这有几个我常用的。

unit SysCall;
interface
uses
  Windows;

const
  //  By default, the callback function is queued to a non-I/O worker thread.
  WT_EXECUTEDEFAULT = $00000000;

  //  The callback function is invoked by the timer thread itself. This flag should be used only for short tasks or it could affect other timer operations.
  //  The callback function is queued as an APC. It should not perform alertable wait operations.
  WT_EXECUTEINTIMERTHREAD = $00000020;

  //  The callback function is queued to an I/O worker thread. This flag should be used if the function should be executed in a thread that waits in an alertable state.
  //  The callback function is queued as an APC. Be sure to address reentrancy issues if the function performs an alertable wait operation.
  WT_EXECUTEINIOTHREAD  = $00000001;

  //  The callback function is queued to a thread that never terminates. It does not guarantee that the same thread is used each time. This flag should be used only for short tasks or it could affect other timer operations.
  //  Note that currently no worker thread is truly persistent, although no worker thread will terminate if there are any pending I/O requests.
  WT_EXECUTEINPERSISTENTTHREAD  = $00000080;

  //  The callback function can perform a long wait. This flag helps the system to decide if it should create a new thread.
  WT_EXECUTELONGFUNCTION  = $00000010;

  //  The timer will be set to the signaled state only once.
  WT_EXECUTEONLYONCE  = $00000008;

  //  Callback functions will use the current access token, whether it is a process or impersonation token. If this flag is not specified, callback functions execute only with the process token.
  WT_TRANSFER_IMPERSONATION = $00000100;

type
  TWaitOrTimerCallback = procedure(
      lpParameter: pointer;
      TimerOrWaitFired: BOOL
  );stdcall;
  
  function  CreateTimerQueue: THandle;stdcall;
  function  DeleteTimerQueueEx(
      TimerQueue: THandle;
      CompletionEvent: THandle
  ): BOOL;stdcall;

  function  CreateTimerQueueTimer(
      var phNewTimer: THandle;
      TimerQueue: THandle;
      Callback: pointer; // WAITORTIMERCALLBACK
      Parameter: pointer;
      DueTime: DWORD;
      Period: DWORD;
      Flags: ULONG
  ): BOOL;stdcall;
  function  DeleteTimerQueueTimer(
      TimerQueue: THandle;
      Timer: THandle;
      CompletionEvent: THandle
  ): BOOL;stdcall;
  function  ChangeTimerQueueTimer(
      TimerQueue: THandle;
      Timer: THandle;
      DueTime: ULONG;
      Period: ULONG
  ): BOOL;stdcall;
  function  RegisterWaitForSingleObject(
      var phNewWaitObject: THandle;
      hObject: THandle;
      Callback: pointer; // WAITORTIMERCALLBACK
      Context: pointer;
      dwMilliseconds: DWORD;
      dwFlags: DWORD
  ): BOOL;stdcall;
  function  UnregisterWait(
      WaitHandle: THandle
  ): BOOL;stdcall;
  function  UnregisterWaitEx(
      WaitHandle: THandle;
      CompletionEvent: THandle
  ): BOOL;stdcall;
  function  QueueUserWorkItem(
      cbFunction: pointer; // LPTHREAD_START_ROUTINE
      Context: pointer;
      Flags: DWORD
  ): BOOL;stdcall;

  function  OpenThread(
      dwDesiredAccess: DWORD;
      bInheritHandle: BOOL;
      dwThreadId: DWORD
  ): DWORD;stdcall;

  // ATL functions
  function  AtlAxWinInit(): BOOL;stdcall;
  function  AtlAxAttachControl(
      const pControl: IUnknown;
      const hWnd: HWND;
      out ppUnkContainer): HRESULT;cdecl;

implementation
const
  atl = 'atl.dll';

function  CreateTimerQueue;external kernel32;
function  DeleteTimerQueueEx;external kernel32;
function  CreateTimerQueueTimer;external kernel32;
function  DeleteTimerQueueTimer;external kernel32;
function  ChangeTimerQueueTimer;external kernel32;
function  RegisterWaitForSingleObject;external kernel32;
function  UnregisterWait;external kernel32;
function  UnregisterWaitEx;external kernel32;
function  QueueUserWorkItem;external kernel32;
function  OpenThread;external kernel32;
// ATL functions
function  AtlAxWinInit;external atl;
function  AtlAxAttachControl;external atl;

end.

[chenzhuo]

谢谢分享

[chenzhuo]

刚测试了一下，确实可以，多谢yushf提供了一种简洁的解决方法。

[chenzhuo]

去掉多余的引用单元SysCall

unit WaitTimerU;

interface

uses
  Classes, Windows, Consts;

type
  TWaitTimer = class(TComponent)
  private
    FWaitableTimer: THandle;
    FWaitObject: THandle;
    FInterval: Cardinal;
    FOnTimer: TNotifyEvent;
    FEnabled: Boolean;
    procedure UpdateTimer;
    procedure SetEnabled(Value: Boolean);
    procedure SetInterval(Value: Cardinal);
    procedure SetOnTimer(Value: TNotifyEvent);
  protected
    procedure Timer; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property Interval: Cardinal read FInterval write SetInterval default 1000;
    property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
  end;

function RegisterWaitForSingleObject(var phNewWaitObject: THandle; hObject: THandle;
  Callback: Pointer; Context: Pointer; dwMilliseconds: DWORD; dwFlags: DWORD): BOOL; stdcall;
function UnregisterWait(WaitHandle: THandle): BOOL; stdcall;

implementation

function RegisterWaitForSingleObject; external kernel32;
function UnregisterWait; external kernel32;

procedure TimerAPCProc(lpParameter: Pointer; TimerOrWaitFired: BOOL); stdcall;
begin
  TWaitTimer(lpParameter).Timer;
end;

{ TWaitTimer }

constructor TWaitTimer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FEnabled := True;
  FInterval := 1000;
  FWaitableTimer := CreateWaitableTimer(nil, False, nil);
  RegisterWaitForSingleObject(FWaitObject, FWaitableTimer, @TimerAPCProc, Self, INFINITE, 0);
end;

destructor TWaitTimer.Destroy;
begin
  FEnabled := False;
  UpdateTimer;
  UnregisterWait(FWaitObject);
  CloseHandle(FWaitableTimer);
  inherited;
end;

procedure TWaitTimer.SetEnabled(Value: Boolean);
begin
  if Value <> FEnabled then
  begin
    FEnabled := Value;
    UpdateTimer;
  end;
end;

procedure TWaitTimer.SetInterval(Value: Cardinal);
begin
  if Value <> FInterval then
  begin
    FInterval := Value;
    UpdateTimer;
  end;
end;

procedure TWaitTimer.SetOnTimer(Value: TNotifyEvent);
begin
  FOnTimer := Value;
  UpdateTimer;
end;

procedure TWaitTimer.Timer;
begin
  if Assigned(FOnTimer) then FOnTimer(Self);
end;

procedure TWaitTimer.UpdateTimer;
var
  DueTime: Int64;
begin
  CancelWaitableTimer(FWaitableTimer);
  if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then
  begin
    DueTime := -Int64(Interval)*10000;
    if not SetWaitableTimer(FWaitableTimer, DueTime, Interval, nil, nil , True) then
      raise EOutOfResources.Create(SNoTimers);
  end;
end;

end.

[chenzhuo]

按yushf的方法做了一修正版本，可以不用通过线程进入APC对列，
省去了管理线程资源和同步的问题。
RegisterWaitForSingleObject是一个不错的API。

再次感谢yushf和所有提意见的朋友。

unit WaitTimerU;

interface

uses
  Classes, Windows, Consts, SysCall;

type
  TWaitTimer = class(TComponent)
  private
    FWaitableTimer: THandle;
    FWaitObject: THandle;
    FInterval: Cardinal;
    FOnTimer: TNotifyEvent;
    FEnabled: Boolean;
    procedure UpdateTimer;
    procedure SetEnabled(Value: Boolean);
    procedure SetInterval(Value: Cardinal);
    procedure SetOnTimer(Value: TNotifyEvent);
  protected
    procedure Timer; dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Enabled: Boolean read FEnabled write SetEnabled default True;
    property Interval: Cardinal read FInterval write SetInterval default 1000;
    property OnTimer: TNotifyEvent read FOnTimer write SetOnTimer;
  end;

function RegisterWaitForSingleObject(var phNewWaitObject: THandle; hObject: THandle;
  Callback: Pointer; Context: Pointer; dwMilliseconds: DWORD; dwFlags: DWORD): BOOL; stdcall;
function UnregisterWait(WaitHandle: THandle): BOOL; stdcall;

implementation

function RegisterWaitForSingleObject; external kernel32;
function UnregisterWait; external kernel32;

procedure TimerAPCProc(lpParameter: Pointer; TimerOrWaitFired: BOOL); stdcall;
begin
  TWaitTimer(lpParameter).Timer;
end;

{ TWaitTimer }

constructor TWaitTimer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FEnabled := True;
  FInterval := 1000;
  FWaitableTimer := CreateWaitableTimer(nil, False, nil);
  RegisterWaitForSingleObject(FWaitObject, FWaitableTimer, @TimerAPCProc, Self, INFINITE, 0);
end;

destructor TWaitTimer.Destroy;
begin
  FEnabled := False;
  UpdateTimer;
  UnregisterWait(FWaitObject);
  CloseHandle(FWaitableTimer);
  inherited;
end;

procedure TWaitTimer.SetEnabled(Value: Boolean);
begin
  if Value <> FEnabled then
  begin
    FEnabled := Value;
    UpdateTimer;
  end;
end;

procedure TWaitTimer.SetInterval(Value: Cardinal);
begin
  if Value <> FInterval then
  begin
    FInterval := Value;
    UpdateTimer;
  end;
end;

procedure TWaitTimer.SetOnTimer(Value: TNotifyEvent);
begin
  FOnTimer := Value;
  UpdateTimer;
end;

procedure TWaitTimer.Timer;
begin
  if Assigned(FOnTimer) then FOnTimer(Self);
end;

procedure TWaitTimer.UpdateTimer;
var
  DueTime: Int64;
begin
  CancelWaitableTimer(FWaitableTimer);
  if (FInterval <> 0) and FEnabled and Assigned(FOnTimer) then
  begin
    DueTime := -Int64(Interval)*10000;
    if not SetWaitableTimer(FWaitableTimer, DueTime, Interval, nil, nil , True) then
      raise EOutOfResources.Create(SNoTimers);
  end;
end;

end.

[jingtuzhong]

xuexixue

[lyhoo163]

支持。。。

[ccrun.com]

有点意思。

[lyhoo163]

支持。。

[chenzhuo]

呵呵，不能这么简单就实现吧。

[wanjianjun]

[Quote=引用 38 楼 chenzhuo 的回复:]
呵呵，不能这么简单就实现吧。
[/Quote]


请问楼主，费这么大劲自己实现一个心跳组件，你这个能有什么特别，与delphi自带的相比有什么不同之处吗？

[jingtuzhong]

谢谢楼主，分享

[chenzhuo]

[Quote=引用 39 楼 wanjianjun 的回复:]

引用 38 楼 chenzhuo 的回复:
呵呵，不能这么简单就实现吧。



请问楼主，费这么大劲自己实现一个心跳组件，你这个能有什么特别，与delphi自带的相比有什么不同之处吗？
[/Quote]

主要是WaitTimer比Timer更可靠，当到了规定的时间的时候，WaitTimer更有可能得到通知。

具体请参看 WINDOWS核心编程 9.4章节。

[fsk_wyf]

全
32 return ulRet 321 g_lDriverSemId[DRIVER_SEM_AD0 + ucChn] 322 close(iADhandle) 323
ulRet = CCU_ERR 324
INT iMiliVolt = 0;..iADhandle ..;
.. iErrNo = AD_READ_TRYAGAIN; /*-11 返回值表示TRY AGAIN*/
UINT8 ucReadTime = 0;UINT32 324;CHECK
if(ucChn >= CCU_AD_CHN_NUM){50, "ADP_AD_Open chn num[%d] error", ucChn);return 167;}
if (CCU_OK != ADA_SmP(322, CCU_WAIT_FOREVER)){
/* 等待响应超时 */50, "ADP_AD_Read chn[%d] ADA_SmP timeout", ucChn);return CCU_ERR_MPI_SEM_TAKE_TIMEOUT;}
ulRet = ADP_AD_Open(ucChn, &iADhandle);if(CCU_OK != ulRet){50, "ADP_AD_Read ADP_AD_Open chn num[%d] error", ucChn);ADA_SmV(322);321;}
if(CCU_OK != ADP_AD_Config(iADhandle)){50, "ADP_AD_Read Config chn[%d] Error", ucChn);323;ADA_SmV(322);222;}

iErrNo = AD_READ_TRYAGAIN;
/* it is necessary to delay some time before read volt, after configuration */
/*-11 返回值表示TRY AGAIN*/
/*最多读5次*/
/*while((AD_READ_TRYAGAIN == iErrNo) && (ucReadTime < 5))*/
while((iErrNo < 0) && (ucReadTime < 5))
{ADA_Sleep(10);iErrNo = read(iADhandle, &iMiliVolt, 1);ucReadTime++;}
if(iErrNo < 0) {50, "Read ADC[%d], errno[%d]", ucChn, iErrNo);323;ADA_SmV(322);return 33;}
*piVal = iMiliVolt;/*DBG_DRVADP(LP_INFO, "Read ADC[%d]: %d", ucChn, iMiliVolt);*/323;ADA_SmV(322);221;
33 g_lDriverSemId[DRIVER_SEM_DS1820_0 + ucChn] 331 iTmp = (ucResult[0] * 10) >> 1 332
INT iTmp = 0;.. fp = ..;
UINT8 ucResult[2] = {0};// 从ds18b20读出的结果，result[0]存放低八位 CHAR acStrDir[32] = {'\0'};
if(ucChn >= CCU_DS1820_CHN_NUM){50, "DS1820 chn num cannot larger than %d", CCU_DS1820_CHN_NUM);167;}
CHECK;if (CCU_OK != ADA_SmP(331, CCU_WAIT_FOREVER))
{/* 等待响应超时 */50, "ADP_Read_DS1820 ADA_SmP timeout");return CCU_ERR_MPI_SEM_TAKE_TIMEOUT;}
43(acStrDir, sizeof(acStrDir), "/dev/ds1820-%d", ucChn);//fp = open(acStrDir, "r+"); fp = open(acStrDir, O_RDONLY);
if (fp < 0){50, "Open file[%s] fail", acStrDir);ADA_SmV(331);return 31;}
#if 0 /*启动转换*/41(ucResult, sizeof(char), 1, fp);usleep(1000);#endif
/*读取转换后的值 读2个字节*/
if(2 != read(fp, ucResult, 2)){close(fp);ADA_SmV(331);return 33;}
DBG_DRVADP(LP_INFO, "Read Temp:%d-%d", ucResult[1], ucResult[0]);
/*计算温度值*/
/*ucResult[1]为符号位 为0xff时为负 0 为正*/
if (ucResult[1] == 0xff){ucResult[0] = ~ucResult[0];ucResult[0] += 1;332;iTmp = -iTmp;}else{332;}*piVal = iTmp;
close(fp);DBG_DRVADP(LP_INFO, "Current Temperature:%d", iTmp);ADA_SmV(331);221;

[fsk_wyf]

34 g_stLedBlink[LED_RUN] 341 g_stLedBlink[LED_ALARM] 342
if(ucLedNum > LED_RUN){ return 11;}
if(341.wOntime == 342.wOntime \
&& 341.wPeriod == 342.wPeriod){
if(LED_ALARM == ucLedNum && CCU_TRUE == 341.ucEnable){342.wCnt = 341.wCnt;}
if(LED_RUN == ucLedNum && CCU_TRUE == 342.ucEnable){341.wCnt = 342.wCnt;}}221;
35 ADP_GPIO_Write(wGpioNum 351 if(CCU_OK == ADP_GPIO_OUTPUT_Read(wGpioNum, &tmp)) 352
UINT16 wGpioNum = 0; UINT32 324;UINT32 tmp = CCU_NULL_LONG;

/*CPU只控制run和alarm灯*/if(ucLedNum > LED_RUN){return 11;}
wGpioNum = (LED_ALARM == ucLedNum) ? GPIO_LED_ALARM:GPIO_LED_RUN;
switch(ucLedCtrl)
{
case LED_ON:
/*防止写重复,同时解决重复关闭ALM灯引起的闪亮的问题*/
352{if((UINT8)tmp == 0){221;}}ulRet = 351, 0);..;.. LED_OFF:
/*同上*/352{if((UINT8)tmp == 1){221;}}ulRet = 351, 1);..;.. LED_BLINK:
/*最小时间刻度为100ms*/wBlinkOnTime /= 100;wBlinkPeriod /= 100;
CHECK_LED_BLINK_PARA();g_stLedBlink[ucLedNum].wOntime = wBlinkOnTime;
g_stLedBlink[ucLedNum].wPeriod = wBlinkPeriod;ADP_SynLedBlink(ucLedNum);ulRet = CCU_OK;..;
default:50, "State led control type[%d] err", ucLedCtrl);ulRet = 167;..;}321;
36
UINT32 324;UINT8 ucVal = 0;UINT iCpldOffset = 0;UINT8 ucBitNum = 0;
/*此接口控制ID UART0-5灯*/if(ucLedNum <= LED_RUN){return 11;}
/*获取led编号对应的cpld寄存器地址及位号*/
GetLedCtrlBit(ucLedNum ,iCpldOffset, ucBitNum);switch(ucLedCtrl){
case LED_ON:ulRet = ADP_CPLD_Read(iCpldOffset, 1, &ucVal);
if(CCU_OK != ulRet){50, "ADP_CPLD_Read offset[0x%02X]", iCpldOffset);321;}

/*写0亮灯*/CLRBIT(ucVal, ucBitNum);ulRet = ADP_CPLD_Write(iCpldOffset, 1, &ucVal);break;
.. LED_OFF:
同上/*写1灭灯*/SETBIT(ucVal, ucBitNum);同上
.. LED_BLINK:
/*最小时间刻度为100ms*/wBlinkOnTime /= 100;wBlinkPeriod /= 100;
CHECK_LED_BLINK_PARA(); g_stLedBlink[ucLedNum].wOntime = wBlinkOnTime;
g_stLedBlink[ucLedNum].wPeriod = wBlinkPeriod;ulRet = CCU_OK;break;
default: 50, "State led control type[%d] err", ucLedCtrl);ulRet = 167;break;}321;
37
UINT32 324;if(ucLedCtrl >= LED_CTRL_TYPE_END){return 11;}
switch(ucLedNum){
case LED_ALARM: .. LED_RUN:ulRet = ADP_StateLed(ucLedNum, ucLedCtrl, wBlinkOnTime, wBlinkPeriod);
break;case LED_UART0: case ..1: case ..2: case ..3: case ..4:
case ..5: case LED_ID0: case ..1: case LED_CARD1: case ..2: case ..:
case ..:ulRet = ADP_CPLDLed(..);break;default: ulRet = 11;break;}321;

[yushf]

想到一种更简洁的，可以把Timer也省掉了

RegisterWaitForSingleObject(FWaitObject, GetCurrentProcress(), @TimerAPCProc, Self, FInterval, 0);

[yushf]

[Quote=引用 36 楼 yushf 的回复:]

想到一种更简洁的，可以把Timer也省掉了

RegisterWaitForSingleObject(FWaitObject, GetCurrentProcress(), @TimerAPCProc, Self, FInterval, 0);
[/Quote]

不能删帖，郁闷！收回上面的帖子！！！

[msdtx]

这个回调不是 APC 的，和 CreateTimerQueueTimer 一样是在新线程中运行的。