1 # File: Stem/Event/Perl.pm
3 # This file is part of Stem.
4 # Copyright (C) 1999, 2000, 2001 Stem Systems, Inc.
6 # Stem is free software; you can redistribute it and/or modify
7 # it under the terms of the GNU General Public License as published by
8 # the Free Software Foundation; either version 2 of the License, or
9 # (at your option) any later version.
11 # Stem is distributed in the hope that it will be useful,
12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 # GNU General Public License for more details.
16 # You should have received a copy of the GNU General Public License
17 # along with Stem; if not, write to the Free Software
18 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 # For a license to use the Stem under conditions other than those
21 # described here, to purchase support for this software, or to purchase a
22 # commercial warranty contract, please contact Stem Systems at:
24 # Stem Systems, Inc. 781-643-7504
25 # 79 Everett St. info@stemsystems.com
29 =head1 Stem::Event::Perl
31 This module is a pure Perl event loop. It requires Perl 5.8 (or
32 better) which has safe signal handling. It provides the common event
33 API for the standard classes:
37 package Stem::Event::Perl ;
40 use Stem::Event::Signal ;
42 @Stem::Event::Perl::ISA = qw( Stem::Event ) ;
46 unless ( eval { require Time::HiRes } ) {
48 Time::HiRes->import( qw( time ) ) ;
52 # get the hashes for each of the event types
54 my ( $signal_events, $timer_events, $read_events, $write_events ) =
55 map scalar( Stem::Event::_get_events( $_ )), qw( signal timer
60 #print "PERL START\n" ;
62 while( keys %{$timer_events} ||
63 keys %{$signal_events} ||
64 keys %{$read_events} ||
65 keys %{$write_events} ) {
67 my $timeout = find_min_delay() ;
69 #print "TIMEOUT [$timeout]\n" ;
73 _one_time_loop( $timeout ) ;
75 my $delta_time = time() - $time ;
76 trigger_timer_events( $delta_time ) ;
84 # force a no wait select call if no timeout was passed in
88 #print "ONE TIME $timeout\n" ;
89 # use Carp qw( cluck ) ;
92 # print "\n\n********EVENT LOOP\n\n" ;
93 # print "READ EVENTS\n", map $_->dump(), values %{$read_events} ;
94 # print "WRITE EVENTS\n", map $_->dump(), values %{$write_events} ;
96 my $read_vec = make_select_vec( $read_events ) ;
97 my $write_vec = make_select_vec( $write_events ) ;
99 #print "R BEFORE ", unpack( 'b*', $read_vec), "\n" ;
100 #print "W BEFORE ", unpack( 'b*', $write_vec), "\n" ;
103 my $cnt = select( $read_vec, $write_vec, undef, $timeout ) ;
105 #print "SEL CNT [$cnt]\n" ;
106 #print "R AFTER ", unpack( 'b*', $read_vec), "\n" ;
107 #print "W AFTER ", unpack( 'b*', $write_vec), "\n" ;
109 trigger_select_vec( 'read', $read_events, $read_vec ) ;
110 trigger_select_vec( 'write', $write_events, $write_vec, ) ;
112 #print "\n\n********END EVENT LOOP\n\n" ;
118 $_->cancel() for values %{$signal_events},
119 values %{$timer_events},
120 values %{$read_events},
121 values %{$write_events} ;
128 while( my( undef, $event ) = each %{$timer_events} ) {
130 if ( $event->{'time_left'} < $min_delay || $min_delay == 0 ) {
132 $min_delay = $event->{'time_left'} ;
134 #print "MIN [$min_delay]\n" ;
138 return unless $min_delay ;
143 sub trigger_timer_events {
147 #print "TIMER DELTA $delta\n" ;
149 while( my( undef, $event ) = each %{$timer_events} ) {
151 #print $event->dump() ;
153 next unless $event->{'active'} ;
155 next unless ( $event->{'time_left'} -= $delta ) <= 0 ;
157 $event->timer_triggered() ;
161 sub make_select_vec {
163 my( $io_events ) = @_ ;
165 my $select_vec = '' ;
167 while( my( undef, $event ) = each %{$io_events} ) {
169 #print "make F: [", fileno $event->{'fh'}, "] ACT [$event->{'active'}]\n" ;
171 unless ( defined fileno $event->{'fh'} ) {
173 #print "BAD FH $event->{'fh'}\n" ;
174 print "\n\n***EVENT BAD FH\n", $event->dump() ;
179 next unless $event->{'active'} ;
180 vec( $select_vec, fileno $event->{'fh'}, 1 ) = 1 ;
186 sub trigger_select_vec {
188 my( $event_type, $io_events, $select_vec ) = @_ ;
190 while( my( undef, $event ) = each %{$io_events} ) {
192 next unless $event->{'active'} ;
193 if ( vec( $select_vec, fileno $event->{'fh'}, 1 ) ) {
202 ############################################################################
204 package Stem::Event::Plain ;
207 # right now we trigger plain events when they are created. this should
208 # change to a queue and trigger after i/o and timer events