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