dntimerengine.pas

一个国外比较早的IOCP控件

// The contents of this file are used with permission, subject to
// the Mozilla Public License Version 1.1 (the "License"); you may
// not use this file except in compliance with the License. You may
// obtain a copy of the License at
// http://www.mozilla.org/MPL/MPL-1.1.html
//
// Software distributed under the License is distributed on an
// "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
// implied. See the License for the specific language governing
// rights and limitations under the License.
unit DnTimerEngine;

interface
uses
  Classes, SysUtils, Windows, contnrs,
  DnInterfaces, DnRtl, DnConst, DnAbstractTimer;
type

  TDnTimerThread = class;

  TDnTimerEngine = class (TDnAbstractTimerEngine)
  protected
    FGuard:           TDnMutex;
    //FObserverList:    TInterfaceList;
    FObserverList:    TObjectList;
    FCurrentTact:     Cardinal;
    FThread:          TDnTimerThread;
    FNonEmpty:        TDnCondition;
    FRequestArrival:  TDnCondition;
    FStartTime:       TDateTime;

    function  TurnOn: Boolean; override;
    function  TurnOff: Boolean; override;
    procedure MoveUp(newIndex: Integer);
    procedure MoveDown(index: Integer);
    procedure UpdateCurrentTact;
  public
    constructor Create{$IFDEF ROOTISCOMPONENT}(AOwner: TComponent); override{$ENDIF};
    destructor  Destroy; override;
    function    RequestTimerNotify(Channel: IDnChannel; Tacts: Cardinal;
                                    Key: Pointer; Handler: IDnTimerHandler): IDnTimerObserver; override;
    procedure   CancelNotify(Request: IDnTimerObserver); override;
  end;

  TDnTimerThread = class (TDnThread)
  protected
    FTimer: TDnTimerEngine;
    FTerminateSignal: TDnEvent;
    procedure CreateContext; override;
    procedure DestroyContext; override;
    procedure ThreadRoutine; override;
  public
    constructor Create(Timer: TDnTimerEngine);
    destructor Destroy; override;
  end;

  TDnTimerObserver = class (TDnObject, IDnTimerObserver, IDnIOResponse,
                            IDnImplementation)
  protected
    FTimer:       TDnTimerEngine;
    FChannel:     IDnChannel;
    FKey:         Pointer;
    FStartTacts:  Cardinal;
    FTacts:       Cardinal;
    FStartTime:   TDateTime;
    FCancelled:   Boolean;
    FHandler:     IDnTimerHandler;
    FIndex:       Cardinal;
    
    procedure SetTacts(Tacts: Cardinal);
    //IDnTimerObserver
    function FireAt: Cardinal;
    procedure Cancel;
    function  IsCancelled: Boolean;

    //IDnIOResponse
    procedure CallHandler(Context: TDnThreadContext);
    function  Channel: IDnIOTrackerHolder;

    //IDnCancelable
    function GetImplementation: Pointer;

    property    RecIndex: Cardinal read FIndex write FIndex;
  public
    constructor Create( Timer: TDnTimerEngine; Channel: IDnChannel; StartTacts: Cardinal;
                        Tacts: Cardinal; Key: Pointer; Handler: IDnTimerHandler);
    destructor  Destroy; override;
    property    Tacts: Cardinal read FTacts;
  end;

procedure Register;

implementation


constructor TDnTimerEngine.Create{$IFDEF ROOTISCOMPONENT}(AOwner: TComponent){$ENDIF};
begin
  inherited Create{$IFDEF ROOTISCOMPONENT}(AOwner){$ENDIF};
  FCurrentTact := 0;
  FGuard := Nil;
  FNonEmpty := Nil;
  FRequestArrival := Nil;
end;

destructor TDnTimerEngine.Destroy;
begin
  SetActive(False);
  inherited Destroy;
end;

function TDnTimerEngine.TurnOn;
begin
  //inherited TurnOn;
//  FObserverList := TInterfaceList.Create;
  FObserverList := TObjectList.Create(False);
  FObserverList.Capacity := 4096;
  FCurrentTact := 0;
  FGuard := TDnMutex.Create;
  FNonEmpty := TDnCondition.Create;
  FRequestArrival := TDnCondition.Create;
  FStartTime := Now;
  FThread := TDnTimerThread.Create(Self);
  FThread.Priority := tpLowest;
  FThread.Resume;
  UpdateCurrentTact();
  Result := True;
end;

function TDnTimerEngine.TurnOff;
begin
  //inherited TurnOff;
  FThread.Terminate;
  FRequestArrival.Signal;
  FNonEmpty.Signal;
  FreeAndNil(FThread);
  FreeAndNil(FObserverList);
  FreeAndNil(FGuard);
  FreeAndNil(FNonEmpty);
  FreeAndNil(FRequestArrival);

  Result := False;
end;

function TDnTimerEngine.RequestTimerNotify(Channel: IDnChannel; Tacts: Cardinal; Key: Pointer; Handler: IDnTimerHandler): IDnTimerObserver;
var Observer: TDnTimerObserver;
    newIndex: Integer;
begin
  Result := Nil;
  Observer := TDnTimerObserver.Create(Self, Channel, FCurrentTact,
                FCurrentTact + Tacts, Key, Handler);
  try
    FGuard.Acquire;
    //grow list capacity if neccesary
    if FObserverList.Capacity = FObserverList.Count then
      FObserverList.Capacity := FObserverList.Capacity * 2;
    Observer._AddRef; newIndex := FObserverList.Add(Observer);
    Observer.RecIndex := newIndex; //set the index of record
    MoveUp(newIndex);
    if FObserverList.Count = 1 then
      FNonEmpty.Signal;
    Result := Observer;
  finally
    FGuard.Release;
  end;
end;

//I found this idea in java.util.Timer :)
procedure TDnTimerEngine.MoveUp(newIndex: Integer);
var sIndex: Integer;
    //obj: IUnknown;
    Obj: TObject;
begin
  while newIndex > 0 do
  begin
    sIndex := newIndex shr 1;
    if TDnTimerObserver(FObserverList[sIndex]).fireAt <=
       TDnTimerObserver(FObserverList[newIndex]).fireAt then
       break; //task is finished
    Obj := FObserverList[sIndex];
    FObserverList[sIndex] := FObserverList[newIndex];
    TDnTimerObserver(FObserverList[sIndex]).RecIndex := sIndex;
    FObserverList[newIndex] := Obj;
    TDnTimerObserver(FObserverList[newIndex]).RecIndex := newIndex;
    newIndex := sIndex;
  end;
end;

procedure TDnTimerEngine.MoveDown(index: Integer);
var sIndex: Integer;
    //obj: IUnknown;
    Obj: TObject;
begin
  sIndex := index shl 1;
  while (sIndex < FObserverList.Count) do
  begin
    if sIndex < FObserverList.Count-1 then
    begin
      if  TDnTimerObserver(FObserverList[sIndex]).FireAt >
          TDnTimerObserver(FObserverList[sIndex+1]).FireAt then
        Inc(sIndex);
      if  TDnTimerObserver(FObserverList[index]).FireAt <=
          TDnTimerObserver(FObserverList[sIndex]).FireAt then
        break;
      Obj := FObserverList[sIndex];
      FObserverList[sIndex] := FObserverList[index];
      TDnTimerObserver(FObserverList[sIndex]).RecIndex := sIndex;
      FObserverList[index] := Obj;
      TDnTimerObserver(FObserverList[index]).RecIndex := index;
      index := sIndex;
    end;
  end;
end;

procedure TDnTimerEngine.CancelNotify(Request: IDnTimerObserver);
var ObserverImpl: TDnTimerObserver;
begin
  try
    FGuard.Acquire;
    Request.Cancel;
    Request := Nil;
    ObserverImpl := TDnTimerObserver((Request as IDnImplementation).GetImplementation());
    FObserverList.Delete(ObserverImpl.RecIndex);
    ObserverImpl._Release;
  finally
    FGuard.Release;
  end;
end;

procedure TDnTimerEngine.UpdateCurrentTact;
var 
    DiffTime: TDateTime;
begin
  DiffTime := Now - FStartTime;
  FCurrentTact := trunc(DiffTime * 86400 + 0.5);
end;

procedure Register;
begin
  {$IFDEF ROOTISCOMPONENT}
  RegisterComponents('DNet', [TDnTimer]);
  {$ENDIF}
end;

//----------------------------------------------------------------------

constructor TDnTimerObserver.Create(Timer: TDnTimerEngine; Channel: IDnChannel; StartTacts: Cardinal;
                                    Tacts: Cardinal; Key: Pointer; Handler: IDnTimerHandler);
begin
  inherited Create;
  FTimer := Timer;
  FChannel := Channel;
  FTacts := Tacts;
  FStartTacts := StartTacts;
  FKey := Key;
  FCancelled := False;
  FHandler := Handler;
  FRefCount := 0;
end;

procedure TDnTimerObserver.SetTacts(Tacts: Cardinal);
begin
  FTacts := Tacts;
end;

procedure TDnTimerObserver.Cancel;
begin
  FCancelled := True;
  FChannel := Nil;
  FHandler := Nil;
end;

function  TDnTimerObserver.IsCancelled: Boolean;
begin
  Result := FCancelled;
end;

destructor TDnTimerObserver.Destroy;
begin
  FChannel := Nil;
  FHandler := Nil;
  inherited Destroy;
end;

function TDnTimerObserver.GetImplementation: Pointer;
begin
  Result := Pointer(Self);
end;

procedure TDnTimerObserver.CallHandler(Context: TDnThreadContext);
begin
  if not FCancelled then
  try
    FHandler.TimerExpired(Context, FChannel, FTacts - FStartTacts, FKey);
  except
    on E: Exception do
      begin
        if FTimer.FLogger <> Nil then
          FTimer.FLogger.LogMsg(FTimer.FLogLevel, E.Message);
      end;
  end;
end;

function TDnTimerObserver.Channel: IDnIOTrackerHolder;
begin
  if FChannel <> Nil then
    Result := FChannel as IDnIOTrackerHolder
  else
    Result := Nil;
end;

function TDnTimerObserver.FireAt: Cardinal;
begin
  Result := Self.FTacts;
end;

//----------------------------------------------------------------------

constructor TDnTimerThread.Create(Timer: TDnTimerEngine);
begin
  inherited Create;
  FTimer := Timer;
  FTerminateSignal := TDnEvent.Create;
end;

destructor TDnTimerThread.Destroy;
begin
  FTimer := Nil;
  FreeAndNil(FTerminateSignal);
  inherited Destroy;
end;

procedure TDnTimerThread.CreateContext;
begin
end;

procedure TDnTimerThread.DestroyContext;
begin
end;


procedure TDnTimerThread.ThreadRoutine;
var //Obj: IUnknown;
    Obj: TDnTimerObserver;
    response: IDnIOResponse;
    MinTact: Cardinal;
    Observer: IDnTimerObserver;
begin
  with FTimer do
  begin
    while not Terminated do
    begin
      UpdateCurrentTact();

      FGuard.Acquire;
      If FObserverList.Count = 0 then
      begin
        FNonEmpty.WaitFor(FGuard);
        if Terminated then
          Exit;
      end;

      try
        Obj := TDnTimerObserver(FObserverList[0]);
        if not Obj.IsCancelled then
        begin
          //get minimal value
          Observer := Obj as IDnTimerObserver;
          MinTact := Observer.FireAt();
          if MinTact <= FCurrentTact then
          begin //fire event
            Response := Observer as IDnIOResponse;
            FExecutor.PostEvent(Response);
            Response := Nil;
            FObserverList.Delete(0);
            Observer._Release;
          end
          else
            FRequestArrival.WaitFor(FGuard, (MinTact - FCurrentTact) * 1000);
          Observer := Nil;
        end else
          FObserverList.Delete(0);
      finally
        
        Obj := Nil;
        FGuard.Release;
      end;
    end;
  end;
end;

end.