mmtimer.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: [phone]               =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/index.html               =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 23.11.98 - 17:38:26 $                                        =}
{========================================================================}
Unit MMTimer;

{$C FIXED PRELOAD PERMANENT}

{$I COMPILER.INC}

Interface

Uses
{$IFDEF WIN32}
    Windows,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    SysUtils,
    MMSystem,
    MMUtils;

const
    TIMERELAPSE = 25;

type
  TMMTimeCallBack = procedure(uTimerID, dwUser: Longint);

function  MMTimeSetEvent(Interval: Cardinal; Suspended: Boolean;
                         lpCallBack: TMMTimeCallBack; dwUser: Longint): Longint;
procedure MMTimeSetInterval(uTimerID: Longint; Interval: Cardinal);
procedure MMTimeSuspendEvent(uTimerID: Longint);
procedure MMTimeResumeEvent(uTimerID: Longint);
procedure MMTimeKillEvent(uTimerID: Longint);

implementation

type
   PMMTimer = ^TMMTimer;
   TMMTimer = record
      dwInterval : Longint;
      dwUserData : Longint;
      lpFunction : TMMTimeCallBack;
      dwSuspended: Longint;
      dwCounter  : Longint;
      lpNext     : PMMTimer;
   end;

   PMMTimerData = ^TMMTimerData;
   TMMTimerData = record
      TimerID    : integer;
      TimerList  : PMMTimer;
      TimerCount : Longint;
      InHandler  : Longint;
   end;

const
   TimerData : TMMTimerData = (TimerID   : 0;
                               TimerList : nil;
                               TimerCount: 0;
                               InHandler : 0);
{$IFDEF WIN32}
var
   DataSection: TRtlCriticalSection;
{$ENDIF}

{------------------------------------------------------------------------}
procedure TimeCallBack(uTimerID, uMessage: UINT; dwUser, dw1, dw2: DWORD);
export;{$IFDEF WIN32}stdcall;{$ENDIF}
var
   pTimer: PMMTimer;
begin
   if (dwUser <> 0) then
   with PMMTimerData(dwUser)^ do
   begin
      inc(InHandler);
      if (InHandler = 1) then
      begin
         {$IFDEF WIN32}
         EnterCriticalSection(DataSection);
         try
         {$ENDIF}
            pTimer := TimerList;
            while (pTimer <> nil) do
            with pTimer^ do
            begin
               if (dwSuspended = 0) then
               begin
                  inc(dwCounter,TIMERELAPSE);
                  if (dwCounter >= dwInterval) then
                  begin
                     asm
                        {$IFDEF WIN32}
                        pushad
                        {$ELSE}
                        db   66h
                        pusha
                        {$ENDIF}
                     end;
                     lpFunction(Longint(pTimer),dwUserData);
                     asm
                        {$IFDEF WIN32}
                        popad
                        {$ELSE}
                        db   66h
                        popa
                        {$ENDIF}
                     end;
                     dwCounter := 0;
                  end;
               end;
               pTimer := pTimer^.lpNext;
            end;

         {$IFDEF WIN32}
         finally
            LeaveCriticalSection(DataSection);
         end;
         {$ENDIF}
      end;
      dec(InHandler);
   end;
end;

{------------------------------------------------------------------------}
function MMTimeSetEvent(Interval: Cardinal; Suspended: Boolean;
                        lpCallBack: TMMTimeCallBack; dwUser: Longint): Longint;
var
{$IFNDEF WIN32}
   TimeCB: TTimeCallBack;
{$ENDIF}
   p,pTimer: PMMTimer;

begin
   with TimerData do
   begin
      inc(TimerCount);
      if (TimerCount = 1) then
      begin
         { create the timer itself }
         TimeBeginPeriod(TIMERELAPSE);
         {$IFDEF WIN32}
         InitializeCriticalSection(DataSection);
         TimerID := TimeSetEvent(TIMERELAPSE, 0, @TimeCallBack, Longint(@TimerData), TIME_PERIODIC);
         {$ELSE}
         TimeCB := TimeCallBack;
         TimerID := TimeSetEvent(TIMERELAPSE, 0, TimeCB, Longint(@TimerData), TIME_PERIODIC);
         {$ENDIF}
         if (TimerID = 0) then
         begin
            Result := 0;
            TimerCount := 0;
            exit;
         end;
      end;

      { create new timer }
      New(pTimer);
      with pTimer^ do
      begin
         dwInterval := Max(Interval,TIMERELAPSE);
         dwUserData := dwUser;
         lpFunction := lpCallBack;
         dwCounter  := 0;
         dwSuspended:= Ord(Suspended);
         lpNext     := nil;
      end;
      {$IFDEF WIN32}
      EnterCriticalSection(DataSection);
      try
      {$ENDIF}
         { insert the new timer in the list }
         if TimerList = nil then TimerList := pTimer
         else
         begin
            { insert at end }
            p := TimerList;
            while (p^.lpNext <> nil) do p := p^.lpNext;
            p^.lpNext := pTimer;
         end;

      {$IFDEF WIN32}
      finally
        LeaveCriticalSection(DataSection);
      end;
      {$ENDIF}
      Result := DWORD(pTimer);
   end;
end;

{------------------------------------------------------------------------}
procedure MMTimeSetInterval(uTimerID: Longint; Interval: Cardinal);
begin
   if (uTimerID <> 0) and (TimerData.TimerCount > 0) then
   begin
      {$IFDEF WIN32}
      EnterCriticalSection(DataSection);
      try
      {$ENDIF}
         with PMMTimer(uTimerID)^ do
         begin
            dwInterval := Max(Interval,TIMERELAPSE);
            dwCounter := 0;
         end;

      {$IFDEF WIN32}
      finally
         LeaveCriticalSection(DataSection);
      end;
      {$ENDIF}
   end;
end;

{------------------------------------------------------------------------}
procedure MMTimeSuspendEvent(uTimerID: Longint);
begin
   if (uTimerID <> 0) and (TimerData.TimerCount > 0) then
   begin
      {$IFDEF WIN32}
      EnterCriticalSection(DataSection);
      try
      {$ENDIF}
         with PMMTimer(uTimerID)^ do
         begin
            inc(dwSuspended);
            dwCounter := 0;
         end;

      {$IFDEF WIN32}
      finally
         LeaveCriticalSection(DataSection);
      end;
      {$ENDIF}
   end;
end;

{------------------------------------------------------------------------}
procedure MMTimeResumeEvent(uTimerID: Longint);
begin
   if (uTimerID <> 0) and (TimerData.TimerCount > 0) then
   begin
      {$IFDEF WIN32}
      EnterCriticalSection(DataSection);
      try
      {$ENDIF}
         with PMMTimer(uTimerID)^ do
         begin
            if (dwSuspended > 0) then dec(dwSuspended);
         end;

      {$IFDEF WIN32}
      finally
         LeaveCriticalSection(DataSection);
      end;
      {$ENDIF}
   end;
end;

{------------------------------------------------------------------------}
procedure MMTimeKillEvent(uTimerID: Longint);
var
   p: PMMTimer;

begin
   if (uTimerID <> 0) and (TimerData.TimerCount > 0) then
   with TimerData do
   begin
      {$IFDEF WIN32}
      EnterCriticalSection(DataSection);
      try
      {$ENDIF}
         if (PMMTimer(uTimerId) = TimerList) then
         begin
            TimerList := TimerList^.lpNext;
            Dispose(Pointer(uTimerID));
            dec(TimerCount);
         end
         else
         begin
            { go trough the list and search the timer }
            p := TimerList;
            while (p <> nil) and (p^.lpNext <> PMMTimer(uTimerID)) do p := p^.lpNext;
            if (p <> nil) then
            begin
               { remove timer from list }
               p^.lpNext := PMMTimer(uTimerID)^.lpNext;
               Dispose(Pointer(uTimerID));
               dec(TimerCount);
            end
            else exit;
         end;

      {$IFDEF WIN32}
      finally
         LeaveCriticalSection(DataSection);
      end;
      {$ENDIF}

      if (TimerCount = 0) then
      begin
        if (TimerID <> 0) then
        begin
           TimeKillEvent(TimerID);
           TimerID := 0;
           TimeEndPeriod(TIMERELAPSE);
           TimerList := nil;
        end;
        {$IFDEF WIN32}
        DeleteCriticalSection(DataSection);
        {$ENDIF}
      end;
   end;
end;

procedure NewExitProc; Far;
begin
   if (TimerData.TimerID <> 0) then
   with TimerData do
   begin
      { make sure the timer is shoot down }
      TimeKillEvent(TimerID);
      TimerID := 0;
      TimeEndPeriod(TIMERELAPSE);
      TimerList := nil;
   end;
end;

initialization
{$IFNDEF WIN32}
   AddExitProc(NewExitProc);
{$ELSE}
finalization
   NewExitProc;
{$ENDIF}
end.