Commit | Line | Data |
4536f655 |
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 ; |