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 123     123   1183 use strict;
  123         200  
  123         5020  
7              
8             # Include common signal handling.
9 123     123   43767 use POE::Loop::PerlSignals;
  122         345  
  122         3536  
10              
11 122     122   602 use vars qw($VERSION);
  122         157  
  122         5730  
12             $VERSION = '1.365'; # 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 122     122   541 use strict;
  122         160  
  122         3407  
24 122     122   470 use Errno qw(EINPROGRESS EWOULDBLOCK EINTR);
  122         177  
  122         136309  
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 172     172 0 276 my $self = shift;
47              
48             # Initialize the vectors as vectors.
49 172         737 @loop_vectors = ( '', '', '' );
50 172         642 vec($loop_vectors[MODE_RD], 0, 1) = 0;
51 172         492 vec($loop_vectors[MODE_WR], 0, 1) = 0;
52 172         498 vec($loop_vectors[MODE_EX], 0, 1) = 0;
53             }
54              
55             sub loop_finalize {
56 116     116 0 266 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         619 my %kernel_modes = (
61             MODE_RD => MODE_RD,
62             MODE_WR => MODE_WR,
63             MODE_EX => MODE_EX,
64             );
65              
66 116         563 while (my ($mode_name, $mode_offset) = each(%kernel_modes)) {
67 348         1265 my $bits = unpack('b*', $loop_vectors[$mode_offset]);
68 348 50       1426 if (index($bits, '1') >= 0) {
69 0         0 POE::Kernel::_warn " LOOP VECTOR LEAK: $mode_name = $bits\a\n";
70             }
71             }
72              
73 116         584 $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 802     802 0 1760 $_next_event_time = $_[1];
93             }
94              
95             sub loop_reset_time_watcher {
96 2031     2031 0 9452 $_next_event_time = $_[1];
97             }
98              
99             sub loop_pause_time_watcher {
100 670     670 0 4088 $_next_event_time = monotime() + 3600;
101             }
102              
103             #------------------------------------------------------------------------------
104             # Maintain filehandle watchers.
105              
106             sub loop_watch_filehandle {
107 903     903 0 1644 my ($self, $handle, $mode) = @_;
108 903         1387 my $fileno = fileno($handle);
109              
110 903         5078 vec($loop_vectors[$mode], $fileno, 1) = 1;
111 903         4004 $loop_filenos{$fileno} |= (1<<$mode);
112             }
113              
114             sub loop_ignore_filehandle {
115 756     756 0 1022 my ($self, $handle, $mode) = @_;
116 756         2118 my $fileno = fileno($handle);
117              
118 756         2434 vec($loop_vectors[$mode], $fileno, 1) = 0;
119 756 100 100     5882 delete $loop_filenos{$fileno} unless (
120             $loop_filenos{$fileno} and $loop_filenos{$fileno} &= ~(1<<$mode)
121             );
122             }
123              
124             sub loop_pause_filehandle {
125 608     608 0 938 my ($self, $handle, $mode) = @_;
126 608         42337 my $fileno = fileno($handle);
127              
128 608         2121 vec($loop_vectors[$mode], $fileno, 1) = 0;
129 608 100 66     5995 delete $loop_filenos{$fileno} unless (
130             $loop_filenos{$fileno} and $loop_filenos{$fileno} &= ~(1<<$mode)
131             );
132             }
133              
134             sub loop_resume_filehandle {
135 448     448 0 778 my ($self, $handle, $mode) = @_;
136 448         672 my $fileno = fileno($handle);
137              
138 448         1507 vec($loop_vectors[$mode], $fileno, 1) = 1;
139 448         1556 $loop_filenos{$fileno} |= (1<<$mode);
140             }
141              
142             #------------------------------------------------------------------------------
143             # The event loop itself.
144              
145             sub loop_do_timeslice {
146 1976     1976 0 2484 my $self = shift;
147              
148             # Check for a hung kernel.
149 1976         7201 $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 1976         3159 my $timeout = $_next_event_time;
158              
159 1976         4539 my $now = monotime();
160 1976 50       4215 if (defined $timeout) {
161 1976         3089 $timeout -= $now;
162 1976 100       5333 $timeout = 0 if $timeout < 0;
163              
164             # Very large timeouts can trigger EINVAL on Mac OSX.
165 1976 50       4427 $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 1976         1851 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 1976         10425 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 1976 100       5871 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 1971         481741975 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 1971         8729 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 1971         40942091 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 1681 100       5961 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 1342         3057 my (@rd_selects, @wr_selects, @ex_selects);
247 680         2690 foreach (keys %loop_filenos) {
248 2068 100       3908 push(@rd_selects, $_) if vec($rout, $_, 1);
249 2071 100       4938 push(@wr_selects, $_) if vec($wout, $_, 1);
250 2237 100       5572 push(@ex_selects, $_) if vec($eout, $_, 1);
251             }
252              
253 1367         2777 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 1691         7387 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 1185 100       7358 @rd_selects and $self->_data_handle_enqueue_ready(MODE_RD, @rd_selects);
289 845 100       2178 @wr_selects and $self->_data_handle_enqueue_ready(MODE_WR, @wr_selects);
290 845 100       3625 @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 1536 100       3184 if ($^O eq 'MSWin32') {
301 1672         3328 sleep($timeout);
302             }
303             else {
304 1672         3315 CORE::select(undef, undef, undef, $timeout);
305             }
306             }
307              
308             # Dispatch whatever events are due.
309 1474         8042 $self->_data_ev_dispatch_due();
310             }
311              
312             sub loop_run {
313 450     127 0 1091 my $self = shift;
314              
315             # Run for as long as there are sessions to service.
316 343         1579 while ($self->_data_ses_count()) {
317 2096         973064 $self->loop_do_timeslice();
318             }
319             }
320              
321 734     117 0 3872 sub loop_halt {
322             # does nothing
323             }
324              
325             1;
326              
327             __END__