File Coverage

blib/lib/POE/Loop/Select.pm
Criterion Covered Total %
statement 78 82 95.1
branch 28 32 87.5
condition 5 6 83.3
subroutine 17 18 94.4
pod 0 13 0.0
total 128 151 84.7


line stmt bran cond sub pod time code
1             # Select loop bridge for POE::Kernel.
2              
3             # Empty package to appease perl.
4             package POE::Loop::Select;
5              
6 122     122   1157 use strict;
  122         187  
  122         5197  
7              
8             # Include common signal handling.
9 122     122   42244 use POE::Loop::PerlSignals;
  121         273  
  121         3214  
10              
11 121     121   599 use vars qw($VERSION);
  121         173  
  121         5387  
12             $VERSION = '1.366'; # NOTE - Should be #.### (three decimal places)
13              
14             =for poe_tests
15              
16             sub skip_tests { return }
17              
18             =cut
19              
20             # Everything plugs into POE::Kernel.
21             package POE::Kernel;
22              
23 121     121   478 use strict;
  121         195  
  121         3196  
24 121     121   493 use Errno qw(EINPROGRESS EWOULDBLOCK EINTR);
  121         162  
  121         125620  
25              
26             # select() vectors. They're stored in an array so that the MODE_*
27             # offsets can refer to them. This saves some code at the expense of
28             # clock cycles.
29             #
30             # [ $select_read_bit_vector, (MODE_RD)
31             # $select_write_bit_vector, (MODE_WR)
32             # $select_expedite_bit_vector (MODE_EX)
33             # ];
34             my @loop_vectors = ("", "", "");
35              
36             # A record of the file descriptors we are actively watching.
37             my %loop_filenos;
38              
39             # Allow $^T to change without affecting our internals.
40             my $start_time = monotime();
41              
42             #------------------------------------------------------------------------------
43             # Loop construction and destruction.
44              
45             sub loop_initialize {
46 171     171 0 244 my $self = shift;
47              
48             # Initialize the vectors as vectors.
49 171         676 @loop_vectors = ( '', '', '' );
50 171         729 vec($loop_vectors[MODE_RD], 0, 1) = 0;
51 171         418 vec($loop_vectors[MODE_WR], 0, 1) = 0;
52 171         447 vec($loop_vectors[MODE_EX], 0, 1) = 0;
53             }
54              
55             sub loop_finalize {
56 116     116 0 201 my $self = shift;
57              
58             # This is "clever" in that it relies on each symbol on the left to
59             # be stringified by the => operator.
60 116         571 my %kernel_modes = (
61             MODE_RD => MODE_RD,
62             MODE_WR => MODE_WR,
63             MODE_EX => MODE_EX,
64             );
65              
66 116         616 while (my ($mode_name, $mode_offset) = each(%kernel_modes)) {
67 348         1039 my $bits = unpack('b*', $loop_vectors[$mode_offset]);
68 348 50       1429 if (index($bits, '1') >= 0) {
69 0         0 POE::Kernel::_warn " LOOP VECTOR LEAK: $mode_name = $bits\a\n";
70             }
71             }
72              
73 116         602 $self->loop_ignore_all_signals();
74             }
75              
76             #------------------------------------------------------------------------------
77             # Signal handler maintenance functions.
78              
79 0     0 0 0 sub loop_attach_uidestroy {
80             # does nothing
81             }
82              
83             #------------------------------------------------------------------------------
84             # Maintain time watchers. For this loop, we simply save the next
85             # event time in a scalar. loop_do_timeslice() will use the saved
86             # value. A "paused" time watcher is just a timeout for some future
87             # time.
88              
89             my $_next_event_time = monotime();
90              
91             sub loop_resume_time_watcher {
92 801     801 0 1755 $_next_event_time = $_[1];
93             }
94              
95             sub loop_reset_time_watcher {
96 1921     1921 0 9942 $_next_event_time = $_[1];
97             }
98              
99             sub loop_pause_time_watcher {
100 666     666 0 3582 $_next_event_time = monotime() + 3600;
101             }
102              
103             #------------------------------------------------------------------------------
104             # Maintain filehandle watchers.
105              
106             sub loop_watch_filehandle {
107 871     871 0 1257 my ($self, $handle, $mode) = @_;
108 871         1271 my $fileno = fileno($handle);
109              
110 871         4911 vec($loop_vectors[$mode], $fileno, 1) = 1;
111 871         3596 $loop_filenos{$fileno} |= (1<<$mode);
112             }
113              
114             sub loop_ignore_filehandle {
115 756     756 0 1064 my ($self, $handle, $mode) = @_;
116 756         1117 my $fileno = fileno($handle);
117              
118 756         2249 vec($loop_vectors[$mode], $fileno, 1) = 0;
119 756 100 100     5387 delete $loop_filenos{$fileno} unless (
120             $loop_filenos{$fileno} and $loop_filenos{$fileno} &= ~(1<<$mode)
121             );
122             }
123              
124             sub loop_pause_filehandle {
125 597     597 0 33003 my ($self, $handle, $mode) = @_;
126 597         892 my $fileno = fileno($handle);
127              
128 597         1704 vec($loop_vectors[$mode], $fileno, 1) = 0;
129 597 100 66     5567 delete $loop_filenos{$fileno} unless (
130             $loop_filenos{$fileno} and $loop_filenos{$fileno} &= ~(1<<$mode)
131             );
132             }
133              
134             sub loop_resume_filehandle {
135 436     436 0 684 my ($self, $handle, $mode) = @_;
136 436         678 my $fileno = fileno($handle);
137              
138 436         1277 vec($loop_vectors[$mode], $fileno, 1) = 1;
139 436         1342 $loop_filenos{$fileno} |= (1<<$mode);
140             }
141              
142             #------------------------------------------------------------------------------
143             # The event loop itself.
144              
145             sub loop_do_timeslice {
146 1900     1900 0 2763 my $self = shift;
147              
148             # Check for a hung kernel.
149 1900         7075 $self->_test_if_kernel_is_idle();
150              
151             # Set the select timeout based on current queue conditions. If
152             # there are FIFO events, then the timeout is zero to poll select and
153             # move on. Otherwise set the select timeout until the next pending
154             # event, if there are any. If nothing is waiting, set the timeout
155             # for some constant number of seconds.
156              
157 1900         2840 my $timeout = $_next_event_time;
158              
159 1900         4737 my $now = monotime();
160 1900 50       4399 if (defined $timeout) {
161 1900         3290 $timeout -= $now;
162 1900 100       4372 $timeout = 0 if $timeout < 0;
163              
164             # Very large timeouts can trigger EINVAL on Mac OSX.
165 1900 50       4186 $timeout = 3600 if $timeout > 3600;
166             }
167             else {
168 0         0 die "shouldn't happen" if ASSERT_DATA;
169 0         0 $timeout = 3600;
170             }
171              
172             # Tracing is relatively expensive, but it's not for live systems.
173             # We can get away with it being after the timeout calculation.
174 1900         1554 if (TRACE_EVENTS) {
175             POE::Kernel::_warn(
176             ' Kernel::run() iterating. ' .
177             sprintf(
178             "now(%.4f) timeout(%.4f) then(%.4f)\n",
179             $now - $start_time, $timeout, ($now - $start_time) + $timeout
180             )
181             );
182             }
183              
184 1900         11362 if (TRACE_FILES) {
185             POE::Kernel::_warn(
186             " ,----- SELECT BITS IN -----\n",
187             " | READ : ", unpack('b*', $loop_vectors[MODE_RD]), "\n",
188             " | WRITE : ", unpack('b*', $loop_vectors[MODE_WR]), "\n",
189             " | EXPEDITE: ", unpack('b*', $loop_vectors[MODE_EX]), "\n",
190             " `--------------------------\n"
191             );
192             }
193              
194             # Avoid looking at filehandles if we don't need to.
195             # TODO The added code to make this sleep is non-optimal. There is a
196             # way to do this in fewer tests.
197              
198 1900 100       5376 if (scalar keys %loop_filenos) {
    50          
199             # There are filehandles to poll, so do so.
200              
201             # Check filehandles, or wait for a period of time to elapse.
202 1896         456252872 my $hits = CORE::select(
203             my $rout = $loop_vectors[MODE_RD],
204             my $wout = $loop_vectors[MODE_WR],
205             my $eout = $loop_vectors[MODE_EX],
206             $timeout,
207             );
208              
209 1896         9231 if (ASSERT_FILES) {
210             if (
211             $hits < 0 and
212             $! != EINPROGRESS and
213             $! != EWOULDBLOCK and
214             $! != EINTR and
215             $! != 0 # this is caused by SIGNAL_PIPE
216             ) {
217             POE::Kernel::_trap(" select error: $! (hits=$hits)");
218             }
219             }
220              
221 1896         38679270 if (TRACE_FILES) {
222             if ($hits > 0) {
223             POE::Kernel::_warn " select hits = $hits\n";
224             }
225             elsif ($hits == 0) {
226             POE::Kernel::_warn " select timed out...\n";
227             }
228             POE::Kernel::_warn(
229             " ,----- SELECT BITS OUT -----\n",
230             " | READ : ", unpack('b*', $rout), "\n",
231             " | WRITE : ", unpack('b*', $wout), "\n",
232             " | EXPEDITE: ", unpack('b*', $eout), "\n",
233             " `---------------------------\n"
234             );
235             }
236              
237             # If select has seen filehandle activity, then gather up the
238             # active filehandles and synchronously dispatch events to the
239             # appropriate handlers.
240              
241 1612 100       7394 if ($hits > 0) {
242              
243             # This is where they're gathered. It's a variant on a neat
244             # hack Silmaril came up with.
245              
246 1315         3440 my (@rd_selects, @wr_selects, @ex_selects);
247 652         3323 foreach (keys %loop_filenos) {
248 2033 100       4145 push(@rd_selects, $_) if vec($rout, $_, 1);
249 2036 100       4688 push(@wr_selects, $_) if vec($wout, $_, 1);
250 2195 100       5186 push(@ex_selects, $_) if vec($eout, $_, 1);
251             }
252              
253 1336         2800 if (TRACE_FILES) {
254             if (@rd_selects) {
255             POE::Kernel::_warn(
256             " found pending rd selects: ",
257             join( ', ', sort { $a <=> $b } @rd_selects ),
258             "\n"
259             );
260             }
261             if (@wr_selects) {
262             POE::Kernel::_warn(
263             " found pending wr selects: ",
264             join( ', ', sort { $a <=> $b } @wr_selects ),
265             "\n"
266             );
267             }
268             if (@ex_selects) {
269             POE::Kernel::_warn(
270             " found pending ex selects: ",
271             join( ', ', sort { $a <=> $b } @ex_selects ),
272             "\n"
273             );
274             }
275             }
276              
277 1661         6711 if (ASSERT_FILES) {
278             unless (@rd_selects or @wr_selects or @ex_selects) {
279             POE::Kernel::_trap(
280             " found no selects, with $hits hits from select???\n"
281             );
282             }
283             }
284              
285             # Enqueue the gathered selects, and flag them as temporarily
286             # paused. They'll resume after dispatch.
287              
288 1163 100       6557 @rd_selects and $self->_data_handle_enqueue_ready(MODE_RD, @rd_selects);
289 824 100       1764 @wr_selects and $self->_data_handle_enqueue_ready(MODE_WR, @wr_selects);
290 824 100       3646 @ex_selects and $self->_data_handle_enqueue_ready(MODE_EX, @ex_selects);
291             }
292             }
293             elsif ($timeout) {
294             # No filehandles to select on. Four-argument select() fails on
295             # MSWin32 with all undef bitmasks. Use sleep() there instead.
296              
297             # Not unconditionally the Time::HiRes microsleep because
298             # Time::HiRes may not be installed. This is only an issue until
299             # we can require versions of Perl that include Time::HiRes.
300 1568 100       2891 if ($^O eq 'MSWin32') {
301 1703         3023 sleep($timeout);
302             }
303             else {
304 1703         3039 CORE::select(undef, undef, undef, $timeout);
305             }
306             }
307              
308             # Dispatch whatever events are due.
309 1405         9117 $self->_data_ev_dispatch_due();
310             }
311              
312             sub loop_run {
313 452     127 0 1023 my $self = shift;
314              
315             # Run for as long as there are sessions to service.
316 345         1422 while ($self->_data_ses_count()) {
317 2006         982501 $self->loop_do_timeslice();
318             }
319             }
320              
321 729     117 0 2309 sub loop_halt {
322             # does nothing
323             }
324              
325             1;
326              
327             __END__