File Coverage

blib/lib/POE/Loop/IO_Poll.pm
Criterion Covered Total %
statement 126 145 86.9
branch 55 70 78.5
condition 19 32 59.3
subroutine 21 22 95.4
pod 0 14 0.0
total 221 283 78.0


line stmt bran cond sub pod time code
1             # IO::Poll event loop bridge for POE::Kernel. The theory is that this
2             # will be faster for large scale applications. This file is
3             # contributed by Matt Sergeant (baud).
4              
5             # Empty package to appease perl.
6             package POE::Loop::IO_Poll;
7              
8 55     55   883 use vars qw($VERSION);
  55         94  
  55         3284  
9             $VERSION = '1.366'; # NOTE - Should be #.### (three decimal places)
10              
11             # Include common signal handling.
12 55     55   19809 use POE::Loop::PerlSignals;
  54         110  
  54         1834  
13              
14             # Everything plugs into POE::Kernel;
15             package POE::Kernel;
16              
17             =for poe_tests
18              
19             sub skip_tests {
20             return "IO::Poll is not 100% compatible with $^O" if (
21             $^O eq "MSWin32" and not $ENV{POE_DANTIC}
22             );
23             return "IO::Poll tests require the IO::Poll module" if (
24             do { eval "use IO::Poll"; $@ }
25             );
26             }
27              
28             =cut
29              
30 54     54   295 use strict;
  54         80  
  54         1798  
31              
32             # Be sure we're using a contemporary version of IO::Poll. There were
33             # issues with certain versions of IO::Poll prior to 0.05. The latest
34             # version is 0.01, however.
35 54     54   1514 use IO::Poll 0.01;
  54         3292  
  54         6915  
36              
37             # Hand off to POE::Loop::Select if we're running under ActivePerl.
38             BEGIN {
39 54 50 33 54   1206 if ($^O eq "MSWin32" and not $ENV{POE_DANTIC}) {
40 0         0 warn "IO::Poll is defective on $^O. Falling back to IO::Select.\n";
41 0         0 require POE::Loop::Select;
42 0         0 POE::Loop::Select->import();
43 0         0 die "not really dying";
44             }
45             }
46              
47 54     54   266 use Errno qw(EINPROGRESS EWOULDBLOCK EINTR);
  54         69  
  54         3688  
48              
49 54         5493 use IO::Poll qw(
50             POLLRDNORM POLLWRNORM POLLRDBAND POLLERR POLLHUP POLLNVAL
51 54     54   215 );
  54         81  
52              
53             # Many systems' IO::Poll don't define POLLRDNORM.
54             # Usually upgrading IO::Poll helps.
55             BEGIN {
56 54     54   101 my $x = eval { POLLRDNORM };
  54         131  
57 54 50 33     63885 if ($@ or not defined $x) {
58 0         0 warn(
59             "Your IO::Poll doesn't define POLLRDNORM. Falling back to IO::Select.\n"
60             );
61 0         0 require POE::Loop::Select;
62 0         0 POE::Loop::Select->import();
63 0         0 die "not really dying";
64             }
65             }
66              
67             my %poll_fd_masks;
68              
69             # Allow $^T to change without affecting our internals.
70             my $start_time = monotime();
71              
72             #------------------------------------------------------------------------------
73             # Loop construction and destruction.
74              
75             sub loop_initialize {
76 98     98 0 165 my $self = shift;
77 98         281 %poll_fd_masks = ();
78             }
79              
80             sub loop_finalize {
81 74     74 0 156 my $self = shift;
82 74         310 $self->loop_ignore_all_signals();
83             }
84              
85             #------------------------------------------------------------------------------
86             # Signal handler maintenance functions.
87              
88 0     0 0 0 sub loop_attach_uidestroy {
89             # does nothing
90             }
91              
92             #------------------------------------------------------------------------------
93             # Maintain time watchers. For this loop, we simply save the next
94             # event time in a scalar. loop_do_timeslice() will use the saved
95             # value. A "paused" time watcher is just a timeout for some future
96             # time.
97              
98             my $_next_event_time = monotime();
99              
100             sub loop_resume_time_watcher {
101 515     515 0 1009 $_next_event_time = $_[1];
102             }
103              
104             sub loop_reset_time_watcher {
105 536     536 0 2528 $_next_event_time = $_[1];
106             }
107              
108             sub loop_pause_time_watcher {
109 333     333 0 2092 $_next_event_time = monotime() + 3600;
110             }
111              
112             # A static function; not some object method.
113              
114             sub mode_to_poll {
115 1476 100   1476 0 3945 return POLLRDNORM if $_[0] == MODE_RD;
116 871 50       2718 return POLLWRNORM if $_[0] == MODE_WR;
117 0 0       0 return POLLRDBAND if $_[0] == MODE_EX;
118 0         0 croak "unknown I/O mode $_[0]";
119             }
120              
121             #------------------------------------------------------------------------------
122             # Maintain filehandle watchers.
123              
124             sub loop_watch_filehandle {
125 492     492 0 917 my ($self, $handle, $mode) = @_;
126 492         772 my $fileno = fileno($handle);
127              
128 492         2781 my $type = mode_to_poll($mode);
129 492   100     2571 my $current = $poll_fd_masks{$fileno} || 0;
130 492         782 my $new = $current | $type;
131              
132 492         467 if (TRACE_FILES) {
133 492         3254 POE::Kernel::_warn(
134             sprintf(
135             " Watch $fileno: " .
136             "Current mask: 0x%02X - including 0x%02X = 0x%02X\n",
137             $current, $type, $new
138             )
139             );
140             }
141              
142 268         1540 $poll_fd_masks{$fileno} = $new;
143             }
144              
145             sub loop_ignore_filehandle {
146 378     378 0 562 my ($self, $handle, $mode) = @_;
147 378         688 my $fileno = fileno($handle);
148              
149 378         795 my $type = mode_to_poll($mode);
150 378   100     1396 my $current = $poll_fd_masks{$fileno} || 0;
151 378         604 my $new = $current & ~$type;
152              
153 378         342 if (TRACE_FILES) {
154 378         1647 POE::Kernel::_warn(
155             sprintf(
156             " Ignore $fileno: " .
157             ": Current mask: 0x%02X - removing 0x%02X = 0x%02X\n",
158             $current, $type, $new
159             )
160             );
161             }
162              
163 165 100       817 if ($new) {
164 219         531 $poll_fd_masks{$fileno} = $new;
165             }
166             else {
167 158         755 delete $poll_fd_masks{$fileno};
168             }
169             }
170              
171             sub loop_pause_filehandle {
172 335     335 0 500 my ($self, $handle, $mode) = @_;
173 335         450 my $fileno = fileno($handle);
174              
175 335         645 my $type = mode_to_poll($mode);
176 335   50     945 my $current = $poll_fd_masks{$fileno} || 0;
177 335         516 my $new = $current & ~$type;
178              
179 335         270 if (TRACE_FILES) {
180 335         1835 POE::Kernel::_warn(
181             sprintf(
182             " Pause $fileno: " .
183             ": Current mask: 0x%02X - removing 0x%02X = 0x%02X\n",
184             $current, $type, $new
185             )
186             );
187             }
188              
189 283 100       700 if ($new) {
190 161         420 $poll_fd_masks{$fileno} = $new;
191             }
192             else {
193 100         371 delete $poll_fd_masks{$fileno};
194             }
195             }
196              
197             sub loop_resume_filehandle {
198 271     271 0 468 my ($self, $handle, $mode) = @_;
199 271         424 my $fileno = fileno($handle);
200              
201 271         575 my $type = mode_to_poll($mode);
202 271   100     1141 my $current = $poll_fd_masks{$fileno} || 0;
203 271         446 my $new = $current | $type;
204              
205 271         248 if (TRACE_FILES) {
206 271         2166 POE::Kernel::_warn(
207             sprintf(
208             " Resume $fileno: " .
209             "Current mask: 0x%02X - including 0x%02X = 0x%02X\n",
210             $current, $type, $new
211             )
212             );
213             }
214              
215 201         697 $poll_fd_masks{$fileno} = $new;
216             }
217              
218             #------------------------------------------------------------------------------
219             # The event loop itself.
220              
221             sub loop_do_timeslice {
222 786     786 0 1023 my $self = shift;
223              
224             # Check for a hung kernel.
225 786         2611 $self->_test_if_kernel_is_idle();
226              
227             # Set the poll timeout based on current queue conditions. If there
228             # are FIFO events, then the poll timeout is zero and move on.
229             # Otherwise set the poll timeout until the next pending event, if
230             # there are any. If nothing is waiting, set the timeout for some
231             # constant number of seconds.
232              
233 786         1254 my $timeout = $_next_event_time;
234              
235 786         1843 my $now = monotime();
236 786 50       1623 if (defined $timeout) {
237 786         1114 $timeout -= $now;
238 786 100       2026 $timeout = 0 if $timeout < 0;
239             }
240             else {
241 0         0 die "shouldn't happen" if ASSERT_DATA;
242 0         0 $timeout = 3600;
243             }
244              
245 786         891 if (TRACE_EVENTS) {
246 786         7843 POE::Kernel::_warn(
247             ' Kernel::run() iterating. ' .
248             sprintf(
249             "now(%.4f) timeout(%.4f) then(%.4f)\n",
250             $now-$start_time, $timeout, ($now-$start_time)+$timeout
251             )
252             );
253             }
254              
255 786         2118 if (TRACE_FILES) {
256 786         100769457 foreach (sort { $a<=>$b} keys %poll_fd_masks) {
  2907         4416  
257 1875         2373 my @types;
258 1621 100       17644 push @types, "plain-file" if -f;
259 1870 100       4954 push @types, "directory" if -d;
260 1870 100       5727 push @types, "symlink" if -l;
261 1736 100       4265 push @types, "pipe" if -p;
262 1805 100       5092 push @types, "socket" if -S;
263 1746 50       4493 push @types, "block-special" if -b;
264 2194 100       21343 push @types, "character-special" if -c;
265 1828 100       4505 push @types, "tty" if -t;
266 1828         2219 my @modes;
267 1772         2444 my $flags = $poll_fd_masks{$_};
268 1749 100       4078 push @modes, 'r' if $flags & (POLLRDNORM | POLLHUP | POLLERR);
269 1805 100       3274 push @modes, 'w' if $flags & (POLLWRNORM | POLLHUP | POLLERR);
270 1683 50       2931 push @modes, 'x' if $flags & (POLLRDBAND | POLLHUP | POLLERR);
271 1660         7064 POE::Kernel::_warn(
272             " file descriptor $_ = modes(@modes) types(@types)\n"
273             );
274             }
275             }
276              
277             # Avoid looking at filehandles if we don't need to.
278             # TODO The added code to make this sleep is non-optimal. There is a
279             # way to do this in fewer tests.
280              
281 716 50       3334 if (scalar keys %poll_fd_masks) {
    0          
282              
283             # There are filehandles to poll, so do so.
284              
285             # Check filehandles, or wait for a period of time to elapse.
286 527         35785830 my $hits = IO::Poll::_poll($timeout * 1000, my @results = %poll_fd_masks);
287              
288 527         1149 if (ASSERT_FILES) {
289 647 100       2273 if ($hits < 0) {
290 125 100 33     430 POE::Kernel::_trap(" poll returned $hits (error): $!")
      66        
      33        
291             unless ( ($! == EINPROGRESS) or
292             ($! == EWOULDBLOCK) or
293             ($! == EINTR) or
294             ($! == 0) # SIGNAL_PIPE strangeness
295             );
296             }
297             }
298              
299 634         1122 if (TRACE_FILES) {
300 514 100       2172 if ($hits > 0) {
    100          
301 213         981 POE::Kernel::_warn " poll hits = $hits\n";
302             }
303             elsif ($hits == 0) {
304 314         1188 POE::Kernel::_warn " poll timed out...\n";
305             }
306             }
307              
308             # If poll has seen filehandle activity, then gather up the
309             # active filehandles and synchronously dispatch events to the
310             # appropriate handlers.
311              
312 768 100       3595 if ($hits > 0) {
313              
314             # This is where they're gathered.
315              
316 195         278 my (@rd_ready, @wr_ready, @ex_ready);
317 195         2290 my %poll_fd_results = @results;
318 195         933 while (my ($fd, $got_mask) = each %poll_fd_results) {
319 1189 100       3979 next unless $got_mask;
320              
321 414         563 my $watch_mask = $poll_fd_masks{$fd};
322 414 100 100     1922 if (
323             $watch_mask & POLLRDNORM and
324             $got_mask & (POLLRDNORM | POLLHUP | POLLERR | POLLNVAL)
325             ) {
326 225         281 if (TRACE_FILES) {
327 225         736 POE::Kernel::_warn " enqueuing read for fileno $fd";
328             }
329              
330 225         819 push @rd_ready, $fd;
331             }
332              
333 414 100 66     1577 if (
334             $watch_mask & POLLWRNORM and
335             $got_mask & (POLLWRNORM | POLLHUP | POLLERR | POLLNVAL)
336             ) {
337 190         211 if (TRACE_FILES) {
338 190         577 POE::Kernel::_warn " enqueuing write for fileno $fd";
339             }
340              
341 190         998 push @wr_ready, $fd;
342             }
343              
344 414 50 33     1795 if (
345             $watch_mask & POLLRDBAND and
346             $got_mask & (POLLRDBAND | POLLHUP | POLLERR | POLLNVAL)
347             ) {
348 0         0 if (TRACE_FILES) {
349 0         0 POE::Kernel::_warn " enqueuing expedite for fileno $fd";
350             }
351              
352 0         0 push @ex_ready, $fd;
353             }
354             }
355              
356 195 100       4121 @rd_ready and $self->_data_handle_enqueue_ready(MODE_RD, @rd_ready);
357 195 100       752 @wr_ready and $self->_data_handle_enqueue_ready(MODE_WR, @wr_ready);
358 195 50       1390 @ex_ready and $self->_data_handle_enqueue_ready(MODE_EX, @ex_ready);
359             }
360             }
361             elsif ($timeout) {
362              
363             # No filehandles to poll on. Try to sleep instead. Use sleep()
364             # itself on MSWin32. Use a dummy four-argument select() everywhere
365             # else.
366              
367 0 0       0 if ($^O eq 'MSWin32') {
368 0         0 sleep($timeout);
369             }
370             else {
371 0         0 CORE::select(undef, undef, undef, $timeout);
372             }
373             }
374              
375             # Dispatch whatever events are due.
376 514         2128 $self->_data_ev_dispatch_due();
377             }
378              
379             ### Run for as long as there are sessions to service.
380              
381             sub loop_run {
382 74     74 0 237 my $self = shift;
383 74         223 while ($self->_data_ses_count()) {
384 786         1820 $self->loop_do_timeslice();
385             }
386             }
387              
388 74     74 0 135 sub loop_halt {
389             # does nothing
390             }
391              
392             1;
393              
394             __END__