File Coverage

lib/IOMux.pm
Criterion Covered Total %
statement 66 84 78.5
branch 14 42 33.3
condition 3 15 20.0
subroutine 16 20 80.0
pod 10 11 90.9
total 109 172 63.3


line stmt bran cond sub pod time code
1             # Copyrights 2011-2020 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 2.02.
5             # This code is part of distribution IOMux. Meta-POD processed with OODoc
6             # into POD and HTML manual-pages. See README.md
7             # Copyright Mark Overmeer. Licensed under the same terms as Perl itself.
8              
9             package IOMux;
10 8     8   740 use vars '$VERSION';
  8         14  
  8         353  
11             $VERSION = '1.01';
12              
13 8     8   3196 use Log::Report 'iomux';
  8         688618  
  8         48  
14              
15 8     8   1808 use warnings;
  8         15  
  8         206  
16 8     8   35 use strict;
  8         18  
  8         154  
17              
18 8     8   32 use List::Util 'min';
  8         12  
  8         435  
19 8     8   46 use POSIX 'errno_h';
  8         14  
  8         57  
20              
21             $SIG{PIPE} = 'IGNORE'; # pipes are handled in mux
22              
23             use constant
24 8         7041 { LONG_TIMEOUT => 60 # no-one has set a timeout
25 8     8   2710 };
  8         14  
26              
27              
28             sub new(@)
29 7     7 1 3150 { my ($class, %args) = @_;
30              
31 7 50       31 error __x"initiate an extension of {pkg}", pkg => __PACKAGE__
32             if $class eq __PACKAGE__;
33              
34 7         26 (bless {}, $class)->init(\%args);
35             }
36              
37             sub init($)
38 7     7 0 13 { my ($self, $args) = @_;
39 7         28 $self->{IM_handlers} = {};
40 7         12 $self->{IM_timeouts} = {};
41 7         14 $self;
42             }
43              
44             #-------------
45              
46             #-------------
47              
48             # add() is the main user interface to mux, because from then the
49             # user works with connection objects. Therefore, offer some extra
50             # features here.
51              
52             sub add($)
53 12     12 1 7025 { my ($self, $handler) = @_;
54              
55 12 50 0     64 UNIVERSAL::isa($handler, 'IOMux::Handler')
56             or error __x"attempt to add non handler {pkg}"
57             , pkg => (ref $handler || $handler);
58              
59 12         150 $handler->muxInit($self);
60 12         285 $handler;
61             }
62              
63              
64             sub open(@)
65 4     4 1 2618 { my $self = shift;
66 4 50       34 IOMux::Open->can('new')
67             or error __x"IOMux::Open not loaded";
68 4         13 my $conn = IOMux::Open->new(@_);
69 4 50       20 $self->add($conn) if $conn;
70 4         8 $conn;
71             }
72              
73              
74             sub loop(;$)
75 4     4 1 90 { my($self, $heartbeat) = @_;
76 4         16 $self->{IM_endloop} = 0;
77              
78 4         8 my $handlers = $self->{IM_handlers};
79 4 50       23 keys %$handlers
80             or error __x"there are no handlers for the mux loop";
81              
82             LOOP:
83 4   66     63 while(!$self->{IM_endloop} && keys %$handlers)
84             {
85             # while(my($fileno, $conn) = each %$handlers)
86             # { $conn->read
87             # if $conn->usesSSL && $conn->pending;
88             # }
89              
90 12         22 my $timeout = $self->{IM_next_timeout};
91 12 50       35 my $wait = defined $timeout ? $timeout-time : LONG_TIMEOUT;
92              
93             # For negative values, still give select a chance, to avoid
94             # starvation when timeout handling starts consuming all
95             # processor time.
96 12 50       36 $wait = 0.001 if $wait < 0.001;
97              
98 12 50       38 $self->one_go($wait, $heartbeat)
99             or last LOOP;
100              
101 12         65 $self->_checkTimeouts($timeout);
102             }
103              
104             $_->close
105 4         20 for values %$handlers;
106             }
107              
108              
109 0     0 1 0 sub endLoop($) { $_[0]->{IM_endloop} = $_[1] }
110              
111             #-------------
112              
113 0     0 1 0 sub handlers() {values %{shift->{IM_handlers}}}
  0         0  
114 36     36   63 sub _handlers() {shift->{IM_handlers}}
115              
116              
117             sub handler($;$)
118 45     45 1 156 { my $hs = shift->{IM_handlers};
119 45         78 my $fileno = shift;
120 45 100       171 @_ or return $hs->{$fileno};
121 13 50       121 (defined $_[0]) ? ($hs->{$fileno} = shift) : (delete $hs->{$fileno});
122             }
123              
124              
125             sub remove($)
126 13     13 1 36 { my ($self, $fileno) = @_;
127              
128 13 50       41 my $obj = delete $self->{IM_handlers}{$fileno}
129             or return $self;
130              
131 13         53 $self->fdset($fileno, 0, 1, 1, 1);
132 13         84 $obj->muxRemove;
133              
134 13 50       351 if(my $timeout = delete $self->{IM_timeouts}{$fileno})
135             { delete $self->{IM_next_timeout}
136 0 0       0 if $self->{IM_next_timeout}==$timeout;
137             }
138              
139 13         27 $self;
140             }
141              
142              
143 0     0 1 0 sub fdset($$$$$) {panic}
144              
145              
146             sub changeTimeout($$$)
147 0     0 1 0 { my ($self, $fileno, $old, $when) = @_;
148 0 0       0 return if $old==$when;
149              
150 0         0 my $next = $self->{IM_next_timeout};
151 0 0       0 if($old)
152             { # next timeout will be recalculated max once per loop
153 0         0 delete $self->{IM_timeouts}{$fileno};
154 0 0 0     0 $self->{IM_next_timeout} = $next = undef if $next && $next==$old;
155             }
156              
157 0 0       0 if($when)
158 0 0 0     0 { $self->{IM_next_timeout} = $when if !$next || $next > $when;
159 0         0 $self->{IM_timeouts}{$fileno} = $when;
160             }
161             }
162              
163             # handle all timeouts which have expired either during the select
164             # or during the processing of flags.
165             sub _checkTimeouts($)
166 12     12   36 { my ($self, $next) = @_;
167              
168 12         19 my $now = time;
169 12 50 33     40 if($next && $now < $next)
170             { # Even when next is cancelled, none can have expired.
171             # However, a new timeout may have arrived which may expire immediately.
172 0 0       0 return $next if $self->{IM_next_timeout};
173             }
174              
175 12         22 my $timo = $self->{IM_timeouts};
176 12         15 my $hnd = $self->{IM_handlers};
177 12         48 while(my ($fileno, $when) = each %$timo)
178 0 0       0 { $when <= $now or next;
179 0         0 $hnd->{$fileno}->muxTimeout($self);
180 0         0 delete $timo->{$fileno};
181             }
182              
183 12         92 $self->{IM_next_timeout} = min values %$timo;
184             }
185              
186             1;
187              
188             __END__