lib/Stem/Event/Perl.pm

   1 #  File: Stem/Event/Perl.pm
   2
   3 #  This file is part of Stem.
   4 #  Copyright (C) 1999, 2000, 2001 Stem Systems, Inc.
   5
   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.
  10
  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.
  15
  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
  19
  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:
  23
  24 #       Stem Systems, Inc.              781-643-7504
  25 #       79 Everett St.                  info@stemsystems.com
  26 #       Arlington, MA 02474
  27 #       USA
  28
  29 =head1 Stem::Event::Perl
  30
  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:
  34
  35 =cut
  36
  37 package Stem::Event::Perl ;
  38
  39 use strict ;
  40 use Stem::Event::Signal ;
  41
  42 @Stem::Event::Perl::ISA = qw( Stem::Event ) ;
  43
  44 BEGIN {
  45
  46         unless ( eval { require Time::HiRes } ) {
  47
  48                 Time::HiRes->import( qw( time ) ) ;
  49         }
  50 }
  51
  52 # get the hashes for each of the event types
  53
  54 my ( $signal_events, $timer_events, $read_events, $write_events ) =
  55         map scalar( Stem::Event::_get_events( $_ )), qw( signal timer
  56         read write ) ;
  57
  58 sub _start_loop {
  59
  60 #print "PERL START\n" ;
  61
  62         while( keys %{$timer_events}  ||
  63                keys %{$signal_events} ||
  64                keys %{$read_events}   ||
  65                keys %{$write_events} ) {
  66
  67                 my $timeout = find_min_delay() ;
  68
  69 #print "TIMEOUT [$timeout]\n" ;
  70
  71                 my $time = time() ;
  72
  73                 _one_time_loop( $timeout ) ;
  74
  75                 my $delta_time = time() - $time ;
  76                 trigger_timer_events( $delta_time ) ;
  77         }
  78 }
  79
  80 sub _one_time_loop {
  81
  82         my( $timeout ) = @_ ;
  83
  84 # force a no wait select call if no timeout was passed in
  85
  86         $timeout ||= 0 ;
  87
  88 #print "ONE TIME $timeout\n" ;
  89 # use Carp qw( cluck ) ;
  90 # cluck ;
  91
  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} ;
  95
  96         my $read_vec = make_select_vec( $read_events ) ;
  97         my $write_vec = make_select_vec( $write_events ) ;
  98
  99 #print "R BEFORE ", unpack( 'b*', $read_vec), "\n" ;
 100 #print "W BEFORE ", unpack( 'b*', $write_vec), "\n" ;
 101
 102
 103         my $cnt = select( $read_vec, $write_vec, undef, $timeout ) ;
 104
 105 #print "SEL CNT [$cnt]\n" ;
 106 #print "R AFTER ", unpack( 'b*', $read_vec), "\n" ;
 107 #print "W AFTER ", unpack( 'b*', $write_vec), "\n" ;
 108
 109         trigger_select_vec( 'read',  $read_events, $read_vec ) ;
 110         trigger_select_vec( 'write', $write_events, $write_vec,  ) ;
 111
 112 #print "\n\n********END EVENT LOOP\n\n" ;
 113
 114 }
 115
 116 sub _stop_loop {
 117
 118         $_->cancel() for values %{$signal_events},
 119                          values %{$timer_events},
 120                          values %{$read_events},
 121                          values %{$write_events} ;
 122 }
 123
 124 sub find_min_delay {
 125
 126         my $min_delay = 0 ;
 127
 128         while( my( undef, $event ) = each %{$timer_events} ) {
 129
 130                 if ( $event->{'time_left'} < $min_delay || $min_delay == 0 ) {
 131
 132                         $min_delay = $event->{'time_left'} ;
 133
 134 #print "MIN [$min_delay]\n" ;
 135                 }
 136         }
 137
 138         return unless $min_delay ;
 139
 140         return $min_delay ;
 141 }
 142
 143 sub trigger_timer_events {
 144
 145         my( $delta ) = @_ ;
 146
 147 #print "TIMER DELTA $delta\n" ;
 148
 149         while( my( undef, $event ) = each %{$timer_events} ) {
 150
 151 #print $event->dump() ;
 152
 153                 next unless $event->{'active'} ;
 154
 155                 next unless ( $event->{'time_left'} -= $delta ) <= 0 ;
 156
 157                 $event->timer_triggered() ;
 158         }
 159 }
 160
 161 sub make_select_vec {
 162
 163         my( $io_events ) = @_ ;
 164
 165         my $select_vec = '' ;
 166
 167         while( my( undef, $event ) = each %{$io_events} ) {
 168
 169 #print "make F: [", fileno $event->{'fh'}, "] ACT [$event->{'active'}]\n" ;
 170
 171                 unless ( defined fileno $event->{'fh'} ) {
 172
 173 #print "BAD FH $event->{'fh'}\n" ;
 174 print "\n\n***EVENT BAD FH\n", $event->dump() ;
 175
 176                         $event->cancel() ;
 177                 }
 178
 179                 next unless $event->{'active'} ;
 180                 vec( $select_vec, fileno $event->{'fh'}, 1 ) = 1 ;
 181         }
 182
 183         return $select_vec ;
 184 }
 185
 186 sub trigger_select_vec {
 187
 188         my( $event_type, $io_events, $select_vec ) = @_ ;
 189
 190         while( my( undef, $event ) = each %{$io_events} ) {
 191
 192                 next unless $event->{'active'} ;
 193                 if ( vec( $select_vec, fileno $event->{'fh'}, 1 ) ) {
 194
 195                         $event->trigger() ;
 196                 }
 197         }
 198
 199         return ;
 200 }
 201
 202 ############################################################################
 203
 204 package Stem::Event::Plain ;
 205
 206 ######
 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
 209 ######
 210
 211 sub _build {
 212         my( $self ) = @_ ;
 213         $self->trigger() ;
 214         return ;
 215 }
 216
 217 1 ;