| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | # Copyrights 2011 by Mark Overmeer. | 
| 2 |  |  |  |  |  |  | #  For other contributors see ChangeLog. | 
| 3 |  |  |  |  |  |  | # See the manual pages for details on the licensing terms. | 
| 4 |  |  |  |  |  |  | # Pod stripped from pm file by OODoc 1.07. | 
| 5 | 8 |  |  | 8 |  | 5976 | use warnings; | 
|  | 8 |  |  |  |  | 17 |  | 
|  | 8 |  |  |  |  | 326 |  | 
| 6 | 8 |  |  | 8 |  | 43 | use strict; | 
|  | 8 |  |  |  |  | 13 |  | 
|  | 8 |  |  |  |  | 439 |  | 
| 7 |  |  |  |  |  |  |  | 
| 8 |  |  |  |  |  |  | package IOMux::Poll; | 
| 9 | 8 |  |  | 8 |  | 40 | use vars '$VERSION'; | 
|  | 8 |  |  |  |  | 13 |  | 
|  | 8 |  |  |  |  | 507 |  | 
| 10 |  |  |  |  |  |  | $VERSION = '0.12'; | 
| 11 |  |  |  |  |  |  |  | 
| 12 | 8 |  |  | 8 |  | 43 | use base 'IOMux'; | 
|  | 8 |  |  |  |  | 12 |  | 
|  | 8 |  |  |  |  | 2656 |  | 
| 13 |  |  |  |  |  |  |  | 
| 14 | 8 |  |  | 8 |  | 56 | use Log::Report 'iomux'; | 
|  | 8 |  |  |  |  | 27 |  | 
|  | 8 |  |  |  |  | 49 |  | 
| 15 |  |  |  |  |  |  |  | 
| 16 | 8 |  |  | 8 |  | 10283 | use List::Util  'min'; | 
|  | 8 |  |  |  |  | 20 |  | 
|  | 8 |  |  |  |  | 1088 |  | 
| 17 | 8 |  |  | 8 |  | 44 | use POSIX       'errno_h'; | 
|  | 8 |  |  |  |  | 16 |  | 
|  | 8 |  |  |  |  | 47 |  | 
| 18 | 8 |  |  | 8 |  | 3760 | use IO::Poll; | 
|  | 8 |  |  |  |  | 18 |  | 
|  | 8 |  |  |  |  | 736 |  | 
| 19 | 8 |  |  | 8 |  | 46 | use IO::Handle; | 
|  | 8 |  |  |  |  | 17 |  | 
|  | 8 |  |  |  |  | 4792 |  | 
| 20 |  |  |  |  |  |  |  | 
| 21 |  |  |  |  |  |  | $SIG{PIPE} = 'IGNORE';   # pipes are handled in select | 
| 22 |  |  |  |  |  |  |  | 
| 23 |  |  |  |  |  |  |  | 
| 24 |  |  |  |  |  |  | my $poll; | 
| 25 |  |  |  |  |  |  | sub init($) | 
| 26 | 7 |  |  | 7 | 0 | 15 | {   my ($self, $args) = @_; | 
| 27 | 7 |  |  |  |  | 161 | $self->SUPER::init($args); | 
| 28 | 7 |  | 33 |  |  | 93 | $poll ||= IO::Poll->new; | 
| 29 | 7 |  |  |  |  | 130 | $self; | 
| 30 |  |  |  |  |  |  | } | 
| 31 |  |  |  |  |  |  |  | 
| 32 |  |  |  |  |  |  | #------------- | 
| 33 |  |  |  |  |  |  |  | 
| 34 | 0 |  |  | 0 | 1 | 0 | sub poller {$poll} | 
| 35 |  |  |  |  |  |  |  | 
| 36 |  |  |  |  |  |  | #------------- | 
| 37 |  |  |  |  |  |  |  | 
| 38 |  |  |  |  |  |  | sub fdset($$$$$) | 
| 39 | 32 |  |  | 32 | 1 | 68 | {   my ($self, $fileno, $state, $r, $w, $e) = @_; | 
| 40 | 32 | 100 |  |  |  | 253 | my $conn = $self->handler($fileno) or return; | 
| 41 | 19 |  |  |  |  | 174 | my $fh   = $conn->fh; | 
| 42 | 19 |  |  |  |  | 164 | my $mask = $poll->mask($fh); | 
| 43 | 19 | 100 |  |  |  | 243 | if($state==0) | 
| 44 | 6 | 50 |  |  |  | 27 | {   $mask &= ~POLLIN  if $r; | 
| 45 | 6 | 50 |  |  |  | 129 | $mask &= ~POLLOUT if $w; | 
| 46 | 6 | 50 |  |  |  | 31 | $mask &= ~POLLERR if $e; | 
| 47 |  |  |  |  |  |  | } | 
| 48 |  |  |  |  |  |  | else | 
| 49 | 13 | 100 |  |  |  | 39 | {   $mask |=  POLLIN  if $r; | 
| 50 | 13 | 100 |  |  |  | 53 | $mask |=  POLLOUT if $w; | 
| 51 | 13 | 50 |  |  |  | 46 | $mask |=  POLLERR if $e; | 
| 52 |  |  |  |  |  |  | } | 
| 53 | 19 |  |  |  |  | 81 | $poll->mask($fh, $mask); | 
| 54 |  |  |  |  |  |  | } | 
| 55 |  |  |  |  |  |  |  | 
| 56 |  |  |  |  |  |  | sub one_go($$) | 
| 57 | 7073 |  |  | 7073 | 0 | 10242 | {   my ($self, $wait, $heartbeat) = @_; | 
| 58 |  |  |  |  |  |  |  | 
| 59 | 7073 |  |  |  |  | 18904 | my $numready = $poll->poll($wait); | 
| 60 |  |  |  |  |  |  |  | 
| 61 | 7073 | 50 |  |  |  | 271097 | $heartbeat->($self, $numready, undef) | 
| 62 |  |  |  |  |  |  | if $heartbeat; | 
| 63 |  |  |  |  |  |  |  | 
| 64 | 7073 | 50 |  |  |  | 13645 | if($numready < 0) | 
| 65 | 0 | 0 | 0 |  |  | 0 | {   return if $! == EINTR || $! == EAGAIN; | 
| 66 | 0 |  |  |  |  | 0 | alert "Leaving loop with $!"; | 
| 67 | 0 |  |  |  |  | 0 | return 0; | 
| 68 |  |  |  |  |  |  | } | 
| 69 |  |  |  |  |  |  |  | 
| 70 |  |  |  |  |  |  | $numready | 
| 71 | 7073 | 50 |  |  |  | 12540 | or return 1; | 
| 72 |  |  |  |  |  |  |  | 
| 73 | 7073 |  |  |  |  | 15121 | $self->_ready(mux_read_flagged   => POLLIN|POLLHUP); | 
| 74 | 7073 |  |  |  |  | 150904 | $self->_ready(mux_write_flagged  => POLLOUT); | 
| 75 | 7073 |  |  |  |  | 135303 | $self->_ready(mux_except_flagged => POLLERR); | 
| 76 |  |  |  |  |  |  |  | 
| 77 | 7073 |  |  |  |  | 145336 | 1;  # success | 
| 78 |  |  |  |  |  |  | } | 
| 79 |  |  |  |  |  |  |  | 
| 80 |  |  |  |  |  |  | # It would be nice to have an algorithm which is better than O(n) | 
| 81 |  |  |  |  |  |  | sub _ready($$) | 
| 82 | 21219 |  |  | 21219 |  | 36165 | {   my ($self, $call, $mask) = @_; | 
| 83 | 21219 |  |  |  |  | 62893 | my $handlers = $self->_handlers; | 
| 84 | 21219 |  |  |  |  | 52320 | foreach my $fh ($poll->handles($mask)) | 
| 85 | 22 | 100 |  |  |  | 869 | {   my $fileno = $fh->fileno or next;   # close filehandle | 
| 86 | 12 | 50 |  |  |  | 113 | if(my $conn = $handlers->{$fileno}) | 
| 87 |  |  |  |  |  |  | {   # filehandle flagged | 
| 88 | 12 |  |  |  |  | 109 | $conn->$call($fileno); | 
| 89 |  |  |  |  |  |  | } | 
| 90 |  |  |  |  |  |  | else | 
| 91 |  |  |  |  |  |  | {   # Handler administration error, but when write and error it may | 
| 92 |  |  |  |  |  |  | # be caused by read errors. | 
| 93 | 0 | 0 |  |  |  |  | alert "connection for ".$fh->fileno." not registered in $call" | 
| 94 |  |  |  |  |  |  | if $call eq 'mux_read_flagged'; | 
| 95 |  |  |  |  |  |  | } | 
| 96 |  |  |  |  |  |  | } | 
| 97 |  |  |  |  |  |  | } | 
| 98 |  |  |  |  |  |  |  | 
| 99 |  |  |  |  |  |  | 1; | 
| 100 |  |  |  |  |  |  |  | 
| 101 |  |  |  |  |  |  | __END__ |