]> dxcluster.net Git - spider.git/blob - perl/Timer.pm
fix 5.8 ism that does not work on 5.6 (incrementing a subroutine).
[spider.git] / perl / Timer.pm
1 #
2 # Polled Timer handling
3 #
4 # This uses callbacks. BE CAREFUL!!!!
5 #
6 # $Id$
7 #
8 # Copyright (c) 2001 Dirk Koopman G1TLH
9 #
10
11 package Timer;
12
13 use vars qw(@timerchain $notimers $lasttime);
14 use DXDebug;
15
16 @timerchain = ();
17 $notimers = 0;
18
19 use vars qw($VERSION $BRANCH);
20 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
21 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
22 $main::build += $VERSION;
23 $main::branch += $BRANCH;
24
25 $lasttime = 0;
26
27 sub new
28 {
29     my ($pkg, $time, $proc, $recur) = @_;
30         my $obj = ref($pkg);
31         my $class = $obj || $pkg;
32         my $self = bless { t=>$time + time, proc=>$proc }, $class;
33         $self->{interval} = $time if $recur;
34         push @timerchain, $self;
35         $notimers++;
36         dbg("Timer created ($notimers)") if isdbg('connll');
37         return $self;
38 }
39
40 sub del
41 {
42         my $self = shift;
43         delete $self->{proc};
44         @timerchain = grep {$_ != $self} @timerchain;
45 }
46
47 sub handler
48 {
49         my $now = time;
50
51         return unless $now != $lasttime;
52
53         # handle things on the timer chain
54         my $t;
55         foreach $t (@timerchain) {
56                 if ($now >= $t->{t}) {
57                         &{$t->{proc}}();
58                         $t->{t} = $now + $t->{interval} if exists $t->{interval};
59                 }
60         }
61
62         $lasttime = $now;
63 }
64
65 sub DESTROY
66 {
67         dbg("timer destroyed ($Timer::notimers)") if isdbg('connll');
68         $Timer::notimers--;
69 }
70 1;