home *** CD-ROM | disk | FTP | other *** search
/ PC World 1999 February / PCWorld_1999-02_cd.bin / temacd / HotKeys / TmrPool.pas < prev    next >
Pascal/Delphi Source File  |  1997-02-18  |  5KB  |  221 lines

  1. unit TmrPool;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes;
  7.  
  8. const
  9.   CM_TIMERELAPSED = WM_USER+1010;
  10.  
  11. type
  12.   TCMTimerElapsed = record
  13.     Msg: Word;
  14.     MilliSeconds: Word;
  15.     Count: Longint;
  16.     Result: Longint;
  17.   end;
  18.  
  19.   TObjectTimeInfo = class
  20.     TimeObject : TObject;
  21.     Active     : Boolean;
  22.     Count      : Longint;
  23.   end;
  24.  
  25.   TTimerPool = class;
  26.  
  27.   TTimingThread = class(TThread)
  28.   private
  29.     FTime: DWord;
  30.     FTimerPool: TTimerPool;
  31.     FResolution: Integer;
  32.   protected
  33.     procedure TimerElapsed;
  34.     procedure Execute; override;
  35.   public
  36.     constructor Create(AOwner: TTimerPool; Resolution: integer);
  37.     property Resolution: Integer read FResolution write FResolution;
  38.   end;
  39.  
  40.   TTimerPool = class(TComponent)
  41.   private
  42.     FThread    : TTimingThread;
  43.     FObjects   : TList;
  44.   protected
  45.     procedure TimerElapsed(MSecs: Integer);
  46.     function TimingNeeded: Boolean;
  47.     procedure CheckForTiming;
  48.     function  FindIndex(AObject: TObject): integer;
  49.     function  FindRegisteredComponent(AObject: TObject): TObjectTimeInfo;
  50.     procedure Notification(AComponent: TComponent; AOperation: TOperation); override;
  51.   public
  52.     constructor Create(AOwner: TComponent); override;
  53.     destructor Destroy; override;
  54.     procedure NotifyRegister(AObject: TObject; AActive: Boolean);
  55.     procedure NotifyUnregister(AObject: TObject);
  56.   end;
  57.  
  58. var 
  59.   TimerPool: TTimerPool;
  60.  
  61. implementation
  62.  
  63. uses Forms, mmSystem;
  64.  
  65. { TTimingThread }
  66. constructor TTimingThread.Create(AOwner: TTimerPool; Resolution: Integer);
  67. begin
  68.   inherited Create(False);
  69.   FTimerPool := AOwner;
  70.   FResolution := Resolution;
  71.   FreeOnTerminate := True;
  72. end;
  73.  
  74. procedure TTimingThread.TimerElapsed;
  75. begin
  76.   if Assigned(FTimerPool) then FTimerPool.TimerElapsed(timeGetTime-FTime);
  77. end;
  78.  
  79. procedure TTimingThread.Execute;
  80. begin
  81.   repeat
  82.     FTime := timeGetTime;
  83.     repeat
  84.     until timeGetTime-FTime>=FResolution;
  85.     if not Terminated then Synchronize(TimerElapsed);
  86.   until Terminated;
  87. end;
  88.  
  89. { TTimerPool }
  90. constructor TTimerPool.Create(AOwner: TComponent);
  91. begin
  92.   inherited Create(AOwner);
  93.   FObjects := TList.Create;
  94.   FThread := nil;
  95. end;
  96.  
  97. destructor TTimerPool.Destroy;
  98. begin
  99.   while FObjects.Count>0 do
  100.    NotifyUnregister(TObjectTimeInfo(FObjects[0]).TimeObject);
  101.   if FThread<>nil then FThread.Terminate;
  102.   FThread.Free;
  103.   FObjects.Free;
  104. end;
  105.  
  106. procedure TTimerPool.TimerElapsed(MSecs: Integer);
  107. var
  108.   i    : integer;
  109.   TEMsg: TCMTimerElapsed;
  110. begin
  111.   TEMsg.Msg := CM_TIMERELAPSED;
  112.   for i:=0 to FObjects.Count-1 do
  113.    with TObjectTimeInfo(FObjects[i]) do
  114.     begin
  115.       if Active then
  116.        begin
  117.          inc(Count);
  118.          TEMsg.MilliSeconds := MSecs;
  119.          TEMsg.Count := Count;
  120.          TimeObject.Dispatch(TEMsg);
  121.        end;
  122.     end;
  123. end;
  124.  
  125. function TTimerPool.FindIndex(AObject: TObject): integer;
  126. var
  127.   i : integer;
  128. begin
  129.   Result := -1;
  130.   for i:=0 to FObjects.Count-1 do
  131.    if TObjectTimeInfo(FObjects[i]).TimeObject = AObject then
  132.     begin
  133.       Result := i;
  134.       Exit;
  135.     end;
  136. end;
  137.  
  138. function TTimerPool.FindRegisteredComponent(AObject: TObject): TObjectTimeInfo;
  139. var
  140.   iIndex : integer;
  141. begin
  142.   iIndex := FindIndex(AObject);
  143.   if iIndex=-1 then
  144.    Result := nil
  145.   else
  146.    Result := TObjectTimeInfo(FObjects[iIndex]);
  147. end;
  148.  
  149. function TTimerPool.TimingNeeded: Boolean;
  150. var
  151.   i : integer;
  152. begin
  153.   Result := True;
  154.   for i:=0 to FObjects.Count-1 do
  155.    if TObjectTimeInfo(FObjects[i]).Active then
  156.     Exit;
  157.   Result := False;
  158. end;
  159.  
  160. procedure TTimerPool.CheckForTiming;
  161. begin
  162.   if TimingNeeded and (FThread=nil) then
  163.    FThread := TTimingThread.Create(Self, 5)
  164.   else if not TimingNeeded and (FThread<>nil) then
  165.    begin
  166.      FThread.Terminate;
  167.      FThread := nil;
  168.    end;
  169. end;
  170.  
  171. procedure TTimerPool.NotifyRegister(AObject: TObject; AActive: Boolean);
  172. var
  173.   ObjTimeInfo : TObjectTimeInfo;
  174.   AddNew       : Boolean;
  175. begin
  176.   ObjTimeInfo := FindRegisteredComponent(AObject);
  177.   AddNew := (ObjTimeInfo = nil);
  178.   if AddNew then ObjTimeInfo := TObjectTimeInfo.Create;
  179.   with ObjTimeInfo do
  180.    begin
  181.      TimeObject := AObject;
  182.      Active := AActive;
  183.    end;
  184.   if AddNew then
  185.    begin
  186.      ObjTimeInfo.Count := 0;
  187.      if AObject is TComponent then TComponent(AObject).FreeNotification(Self);
  188.      FObjects.Add(ObjTimeInfo);
  189.    end;
  190.   CheckForTiming;
  191. end;
  192.  
  193. procedure TTimerPool.NotifyUnregister(AObject: TObject);
  194. var
  195.   iIndex : Integer;
  196.   ObjInf : TObjectTimeInfo;
  197. begin
  198.   iIndex := FindIndex(AObject);
  199.   if iIndex<>-1 then
  200.    begin
  201.      ObjInf := TObjectTimeInfo(FObjects[iIndex]);
  202.      FObjects.Delete(iIndex);
  203.      ObjInf.Free;
  204.      CheckForTiming;
  205.    end;
  206. end;
  207.  
  208. procedure TTimerPool.Notification(AComponent: TComponent; AOperation: TOperation);
  209. begin
  210.   if (AOperation=opRemove) and (AComponent is TComponent) then
  211.    NotifyUnregister(AComponent);
  212.   inherited Notification(AComponent, AOperation);
  213. end;
  214.  
  215. initialization
  216.   TimerPool := TTimerPool.Create(nil);
  217. finalization
  218.   TimerPool.Free;
  219.   TimerPool := nil;
  220. end.
  221.