File Coverage

blib/lib/POE/Component/Server/TCP.pm
Criterion Covered Total %
statement 230 273 84.2
branch 96 154 62.3
condition 32 72 44.4
subroutine 24 28 85.7
pod 1 1 100.0
total 383 528 72.5


line stmt bran cond sub pod time code
1             package POE::Component::Server::TCP;
2              
3 14     14   1111 use strict;
  14         22  
  14         631  
4              
5 14     14   58 use vars qw($VERSION);
  14         17  
  14         651  
6             $VERSION = '1.366'; # NOTE - Should be #.### (three decimal places)
7              
8 14     14   56 use Carp qw(carp croak);
  14         14  
  14         770  
9 14     14   57 use Socket qw(INADDR_ANY inet_ntoa inet_aton AF_INET AF_UNIX PF_UNIX);
  14         23  
  14         889  
10 14     14   62 use Errno qw(ECONNABORTED ECONNRESET);
  14         17  
  14         671  
11              
12             BEGIN {
13             # under perl-5.6.2 the warning "leaks" from the eval, while newer versions don't...
14             # it's due to Exporter.pm behaving differently, so we have to shut it up
15 14     14   65 no warnings 'redefine';
  14         16  
  14         1812  
16 14     14   73 local *Carp::carp = sub { die @_ };
  0         0  
17              
18             # Socket::GetAddrInfo provides getaddrinfo where earlier Perls' Socket don't.
19 14         21 eval { Socket->import('getaddrinfo') };
  14         668  
20 14 50       304 if ($@) {
21             # :newapi is legacy, but we include it to be sure in case the user has an old version of GAI
22 0         0 eval { require Socket::GetAddrInfo; Socket::GetAddrInfo->import( qw(:newapi getaddrinfo) ) };
  0         0  
  0         0  
23 0 0       0 if ($@) {
24 0         0 *getaddrinfo = sub { Carp::confess("Unable to use IPv6: Socket::GetAddrInfo not available") };
  0         0  
25             }
26             }
27             }
28              
29             # Explicit use to import the parameter constants.
30 14     14   79 use POE::Session;
  14         18  
  14         118  
31 14     14   5441 use POE::Driver::SysRW;
  14         29  
  14         352  
32 14     14   4824 use POE::Filter::Line;
  14         27  
  14         364  
33 14     14   6248 use POE::Wheel::ReadWrite;
  14         34  
  14         403  
34 14     14   6495 use POE::Wheel::SocketFactory;
  14         30  
  14         40656  
35              
36             sub DEBUG () { 0 }
37              
38             # Create the server. This is just a handy way to encapsulate
39             # POE::Session->create(). Because the states are so small, it uses
40             # real inline coderefs.
41              
42             sub new {
43 20     20 1 25138 my $type = shift;
44              
45             # Helper so we don't have to type it all day. $mi is a name I call
46             # myself.
47 20         51 my $mi = $type . '->new()';
48              
49             # If they give us lemons, tell them to make their own damn
50             # lemonade.
51 20 50       239 croak "$mi requires an even number of parameters" if (@_ & 1);
52 20         121 my %param = @_;
53              
54             # Extract parameters.
55 20         51 my $alias = delete $param{Alias};
56 20         38 my $address = delete $param{Address};
57 20         171 my $hname = delete $param{Hostname};
58 20         36 my $port = delete $param{Port};
59 20   50     121 my $domain = delete($param{Domain}) || AF_INET;
60 20         325 my $concurrency = delete $param{Concurrency};
61              
62 20 100       66 $port = 0 unless defined $port;
63              
64 20         43 foreach (
65             qw(
66             Acceptor Error ClientInput
67             ClientPreConnect ClientConnected ClientDisconnected
68             ClientError ClientFlushed
69             ClientLow ClientHigh
70             )
71             ) {
72 200 50 66     525 croak "$_ must be a coderef"
73             if defined($param{$_}) and ref($param{$_}) ne 'CODE';
74             }
75              
76 20         50 my $high_mark_level = delete $param{HighMark};
77 20         31 my $low_mark_level = delete $param{LowMark};
78 20         164 my $high_event = delete $param{ClientHigh};
79 20         28 my $low_event = delete $param{ClientLow};
80              
81 80         95 my $mark_param_count = (
82 20         36 grep { defined $_ }
83             ($high_mark_level, $low_mark_level, $high_event, $low_event)
84             );
85 20 50 33     105 if ($mark_param_count and $mark_param_count < 4) {
86 0         0 croak "If you use the Mark settings, you must define all four";
87             }
88              
89 20 50   0   105 $high_event = sub { } unless defined $high_event;
  0         0  
90 20 50   0   76 $low_event = sub { } unless defined $low_event;
  0         0  
91              
92 20         75 my $accept_callback = delete $param{Acceptor};
93 20         35 my $error_callback = delete $param{Error};
94              
95 20         199 my $client_input = delete $param{ClientInput};
96              
97             # Acceptor and ClientInput are mutually exclusive.
98 20 50 50     316 croak "$mi needs either an Acceptor or a ClientInput but not both"
99             unless defined($accept_callback) xor defined($client_input);
100              
101             # Make sure ClientXyz are accompanied by ClientInput.
102 20 100       106 unless (defined($client_input)) {
103 8         40 foreach (grep /^Client/, keys %param) {
104 0         0 croak "$_ not permitted without ClientInput";
105             }
106             }
107              
108 20         34 my $client_pre_connect = delete $param{ClientPreConnect};
109 20         32 my $client_connected = delete $param{ClientConnected};
110 20         27 my $client_disconnected = delete $param{ClientDisconnected};
111 20         35 my $client_error = delete $param{ClientError};
112 20         175 my $client_filter = delete $param{ClientFilter};
113 20         32 my $client_infilter = delete $param{ClientInputFilter};
114 20         27 my $client_outfilter = delete $param{ClientOutputFilter};
115 20         22 my $client_flushed = delete $param{ClientFlushed};
116 20         25 my $session_type = delete $param{SessionType};
117 20         23 my $session_params = delete $param{SessionParams};
118 20         31 my $server_started = delete $param{Started};
119 20         26 my $server_stopped = delete $param{Stopped};
120 20         23 my $listener_args = delete $param{ListenerArgs};
121              
122 20 100       47 $listener_args = [] unless defined $listener_args;
123 20 50       80 croak "ListenerArgs must be an array reference"
124             unless ref($listener_args) eq 'ARRAY';
125              
126 20 50       66 if (exists $param{Args}) {
127 0 0       0 if (exists $param{ClientArgs}) {
128 0         0 carp "Args is deprecated, and ignored since ClientArgs is present";
129 0         0 delete $param{Args};
130             }
131             else {
132 0         0 carp "Args is deprecated but allowed for now. Please use ClientArgs";
133             }
134             }
135              
136 20   66     77 my $client_args = delete($param{ClientArgs}) || delete($param{Args});
137              
138 20 50 33     135 if ( (defined $client_infilter and ! defined $client_outfilter) or
      33        
      33        
139             (defined $client_outfilter and ! defined $client_infilter) ) {
140 0         0 croak "ClientInputFilter must be used with ClientOutputFilter";
141             }
142              
143 20 50 66     64 if (defined $client_filter and defined $client_infilter) {
144 0         0 carp "ClientFilter ignored with ClientInputFilter and ClientOutputFilter";
145 0         0 undef $client_filter;
146             }
147              
148             # Defaults.
149              
150 20 100       44 $concurrency = -1 unless defined $concurrency;
151 20         22 my $accept_session_id;
152              
153 20 50 33     66 if (!defined $address && defined $hname) {
154 0         0 $address = inet_aton($hname);
155             }
156 20 50       49 $address = INADDR_ANY unless defined $address;
157              
158 20 50       63 $error_callback = \&_default_server_error unless defined $error_callback;
159              
160 20 50       47 $session_type = 'POE::Session' unless defined $session_type;
161 20 50 33     74 if (defined($session_params) && ref($session_params)) {
162 0 0       0 if (ref($session_params) ne 'ARRAY') {
163 0         0 croak "SessionParams must be an array reference";
164             }
165             } else {
166 20         33 $session_params = [ ];
167             }
168              
169 20 100       62 if (defined $client_input) {
170 12 100       36 $client_error = \&_default_client_error unless defined $client_error;
171 12 100       36 $client_args = [] unless defined $client_args;
172              
173             # Extra states.
174              
175 12         20 my $inline_states = delete $param{InlineStates};
176 12 100       31 $inline_states = {} unless defined $inline_states;
177              
178 12         22 my $package_states = delete $param{PackageStates};
179 12 100       33 $package_states = [] unless defined $package_states;
180              
181 12         23 my $object_states = delete $param{ObjectStates};
182 12 100       30 $object_states = [] unless defined $object_states;
183              
184 12         16 my $shutdown_on_error = 1;
185 12 50       36 if (exists $param{ClientShutdownOnError}) {
186 0         0 $shutdown_on_error = delete $param{ClientShutdownOnError};
187             }
188              
189 12 50       40 croak "InlineStates must be a hash reference"
190             unless ref($inline_states) eq 'HASH';
191              
192 12 50       32 croak "PackageStates must be a list or array reference"
193             unless ref($package_states) eq 'ARRAY';
194              
195 12 50       33 croak "ObjectsStates must be a list or array reference"
196             unless ref($object_states) eq 'ARRAY';
197              
198 12 50       37 croak "ClientArgs must be an array reference"
199             unless ref($client_args) eq 'ARRAY';
200              
201             # Sanity check, thanks to crab@irc for making this mistake, ha!
202             # TODO we could move this to POE::Session and make it a
203             # "sanity checking" sub somehow...
204 12         23 if (POE::Kernel::ASSERT_USAGE) {
205 12         59 my %forbidden_handlers = (
206             _child => 1,
207             _start => 1,
208             _stop => 1,
209             shutdown => 1,
210             tcp_server_got_error => 1,
211             tcp_server_got_flush => 1,
212             tcp_server_got_high => 1,
213             tcp_server_got_input => 1,
214             tcp_server_got_low => 1,
215             );
216              
217 12 50       65 if (
218 62         97 my @forbidden_inline_handlers = (
219             grep { exists $inline_states->{$_} }
220             keys %forbidden_handlers
221             )
222             ) {
223 8         213 croak "These InlineStates aren't allowed: @forbidden_inline_handlers";
224             }
225              
226 14         51 my %handlers = (
227             PackageStates => $package_states,
228             ObjectStates => $object_states,
229             );
230              
231 14         46 while (my ($name, $states) = each(%handlers)) {
232 20         31 my %states_hash = @$states;
233 20         63 my @forbidden_handlers;
234 12         35 while (my ($package, $handlers) = each %states_hash) {
235 8 50       42 croak "Undefined $name member for $package" unless (
236             defined $handlers
237             );
238              
239 0 0       0 if (ref($handlers) eq 'HASH') {
    50          
240 8         9 push(
241             @forbidden_handlers,
242 8         15 grep { exists $handlers->{$_} }
243             keys %forbidden_handlers
244             );
245             }
246             elsif (ref($handlers) eq 'ARRAY') {
247 0         0 push(
248             @forbidden_handlers,
249 8         15 grep { exists $forbidden_handlers{$_} }
250             @$handlers
251             );
252             }
253             else {
254 0         0 croak "Unknown $name member type for $package";
255             }
256             }
257              
258 12 50       52 croak "These $name aren't allowed: @forbidden_handlers" if (
259             @forbidden_handlers
260             );
261             }
262             }
263              
264             # Revise the acceptor callback so it spawns a session.
265              
266 14 100       68 unless (defined $accept_callback) {
267             $accept_callback = sub {
268 38     38   102 my ($socket, $remote_addr, $remote_port) = @_[ARG0, ARG1, ARG2];
269              
270             $session_type->create(
271             @$session_params,
272             inline_states => {
273             _start => sub {
274 30         69 my ( $kernel, $session, $heap ) = @_[KERNEL, SESSION, HEAP];
275              
276 36         91 $heap->{shutdown} = 0;
277 36         76 $heap->{shutdown_on_error} = $shutdown_on_error;
278              
279             # Unofficial UNIX support, suggested by Damir Dzeko.
280             # Real UNIX socket support should go into a separate
281             # module, but if that module only differs by four
282             # lines of code it would be bad to maintain two
283             # modules for the price of one. One solution would be
284             # to pull most of this into a base class and derive
285             # TCP and UNIX versions from that.
286 36 100 33     202 if (
    100          
287             $domain == AF_UNIX or $domain == PF_UNIX
288             ) {
289 4         5 $heap->{remote_ip} = "LOCAL";
290             }
291             elsif (length($remote_addr) == 4) {
292 34         225 $heap->{remote_ip} = inet_ntoa($remote_addr);
293             }
294             else {
295 4         12 $heap->{remote_ip} = ( getaddrinfo($remote_addr) )[1];
296             }
297              
298 34         68 $heap->{remote_port} = $remote_port;
299              
300 34         59 my $socket = $_[ARG0];
301 34 100       76 if ($client_pre_connect) {
302 10         22 $socket = $client_pre_connect->(@_);
303 10 100 33     1399 unless (defined($socket) and ref($socket) and fileno($socket)) {
      33        
304             # TODO - The user ought to know what's going on
305             # here, since it's triggered by something their
306             # callback has done. Should we expose a callback
307             # anyway to avoid potential confusion?
308 8         17 return;
309             }
310             }
311              
312 38 50       231 $heap->{client} = POE::Wheel::ReadWrite->new(
313             Handle => $socket,
314             Driver => POE::Driver::SysRW->new(),
315             _get_filters(
316             $client_filter,
317             $client_infilter,
318             $client_outfilter
319             ),
320             InputEvent => 'tcp_server_got_input',
321             ErrorEvent => 'tcp_server_got_error',
322             FlushedEvent => 'tcp_server_got_flush',
323              
324             (
325             $mark_param_count
326             ? (
327             HighMark => $high_mark_level,
328             HighEvent => 'tcp_server_got_high',
329             LowMark => $low_mark_level,
330             LowEvent => 'tcp_server_got_low',
331             )
332             : ()
333             ),
334             );
335              
336             # Expand the Args constructor array, and place a copy
337             # into @_[ARG0..]. There are only 2 parameters.
338 30         58 splice(@_, ARG0, 2, @{$_[ARG1]});
  30         71  
339              
340 30 50       162 $client_connected and $client_connected->(@_);
341             },
342             tcp_server_got_high => $high_event,
343             tcp_server_got_low => $low_event,
344              
345             # To quiet ASSERT_STATES.
346 6         13 _child => sub { },
347              
348             tcp_server_got_input => sub {
349 38 50       121 return if $_[HEAP]->{shutdown};
350 38         795 $client_input->(@_);
351 38         356 undef;
352             },
353             tcp_server_got_error => sub {
354 24         53 DEBUG and warn(
355             "$$: $alias child Error ARG0=$_[ARG0] ARG1=$_[ARG1]"
356             );
357 24 50 33     72 unless ($_[ARG0] eq 'accept' and $_[ARG1] == ECONNABORTED) {
358 24         79 $client_error->(@_);
359 24 100       83 if ($_[HEAP]->{shutdown_on_error}) {
360 26         45 $_[HEAP]->{got_an_error} = 1;
361 26         61 $_[KERNEL]->yield("shutdown");
362             }
363             }
364             },
365             tcp_server_got_flush => sub {
366 38         84 my $heap = $_[HEAP];
367 30         36 DEBUG and warn "$$: $alias child Flush";
368 38 50       230 $client_flushed and $client_flushed->(@_);
369 36 100       938 if ($heap->{shutdown}) {
370 12         16 DEBUG and warn "$$: $alias child Flush, callback";
371 18 50       77 $client_disconnected and $client_disconnected->(@_);
372 18         753 delete $heap->{client};
373             }
374             },
375             shutdown => sub {
376 54         65 DEBUG and warn "$$: $alias child Shutdown";
377 54         68 my $heap = $_[HEAP];
378 54         111 $heap->{shutdown} = 1;
379 46 100       141 if (defined $heap->{client}) {
380 28 100 100     131 if (
381             $heap->{got_an_error} or
382             not $heap->{client}->get_driver_out_octets()
383             ) {
384 18         19 DEBUG and warn "$$: $alias child Shutdown, callback";
385 26 50       94 $client_disconnected and $client_disconnected->(@_);
386 24         314 delete $heap->{client};
387             }
388             }
389             },
390             _stop => sub {
391             ## concurrency on close
392 36         57 DEBUG and warn(
393             "$$: $alias _stop accept_session = $accept_session_id"
394             );
395 36 50       82 if( defined $accept_session_id ) {
396 36         143 $_[KERNEL]->call( $accept_session_id, 'disconnected' );
397             }
398             else {
399             # This means that the Server::TCP was shutdown before
400             # this connection closed. So it doesn't really matter that
401             # we can't decrement the connection counter.
402 6         12 DEBUG and warn(
403             "$$: $_[HEAP]->{alias} Disconnected from a connection ",
404             "without POE::Component::Server::TCP parent"
405             );
406             }
407 36         93 return;
408             },
409              
410             # User supplied states.
411 38         1085 %$inline_states
412             },
413              
414             # More user supplied states.
415             package_states => $package_states,
416             object_states => $object_states,
417              
418             # XXX - If you change the number of args here, also change
419             # the splice elsewhere.
420             args => [ $socket, $client_args ],
421             );
422 14         56 };
423             }
424             };
425              
426             # Complain about strange things we're given.
427 20         122 foreach (sort keys %param) {
428 6         33 carp "$mi doesn't recognize \"$_\" as a parameter";
429             }
430              
431             ## verify concurrency on accept
432 22         53 my $orig_accept_callback = $accept_callback;
433             $accept_callback = sub {
434 62     62   150 $_[HEAP]->{connections}++;
435 54         66 DEBUG and warn(
436             "$$: $_[HEAP]->{alias} Connection opened ",
437             "($_[HEAP]->{connections} open)"
438             );
439 54 100 66     268 if( $_[HEAP]->{concurrency} != -1 and $_[HEAP]->{listener} ) {
440 44 100       136 if( $_[HEAP]->{connections} >= $_[HEAP]->{concurrency} ) {
441 24         19 DEBUG and warn(
442             "$$: $_[HEAP]->{alias} Concurrent connection limit reached, ",
443             "pausing accept"
444             );
445 24         87 $_[HEAP]->{listener}->pause_accept()
446             }
447             }
448 54         165 $orig_accept_callback->(@_);
449 22         48 };
450              
451             # Create the session, at long last.
452             # This is done inline so that closures can customize it.
453             # We save the accept session's ID to avoid self reference.
454              
455             $accept_session_id = $session_type->create(
456             @$session_params,
457             inline_states => {
458             _start => sub {
459 14 100   20   36 if (defined $alias) {
460 12         33 $_[HEAP]->{alias} = $alias;
461 12         47 $_[KERNEL]->alias_set( $alias );
462             }
463              
464 14         33 $_[HEAP]->{concurrency} = $concurrency;
465 14         40 $_[HEAP]->{connections} = 0;
466              
467 14 50 33     162 $_[HEAP]->{listener} = POE::Wheel::SocketFactory->new(
468             ( ($domain == AF_UNIX or $domain == PF_UNIX)
469             ? ()
470             : ( BindPort => $port )
471             ),
472             BindAddress => $address,
473             SocketDomain => $domain,
474             Reuse => 'yes',
475             SuccessEvent => 'tcp_server_got_connection',
476             FailureEvent => 'tcp_server_got_error',
477             );
478 14 50       79 $server_started and $server_started->(@_);
479             },
480             # Catch an error.
481             tcp_server_got_error => $error_callback,
482              
483             # We accepted a connection. Do something with it.
484             tcp_server_got_connection => $accept_callback,
485              
486             # concurrency on close.
487             disconnected => sub {
488 52     56   110 $_[HEAP]->{connections}--;
489 52         86 DEBUG and warn(
490             "$$: $_[HEAP]->{alias} Connection closed ",
491             "($_[HEAP]->{connections} open)"
492             );
493 54 100       142 if ($_[HEAP]->{connections} < 0) {
494 6         18 warn(
495             "Excessive 'disconnected' event ",
496             "from $_[CALLER_FILE] at line $_[CALLER_LINE]\n"
497             );
498 6         161 $_[HEAP]->{connections} = 0;
499             }
500 54 100 100     274 if( $_[HEAP]->{concurrency} != -1 and $_[HEAP]->{listener} ) {
501 56 100       146 if( $_[HEAP]->{connections} == ($_[HEAP]->{concurrency}-1) ) {
502 28         61 DEBUG and warn(
503             "$$: $_[HEAP]->{alias} Concurrent connection limit ",
504             "reestablished, resuming accept"
505             );
506 22         70 $_[HEAP]->{listener}->resume_accept();
507             }
508             }
509             },
510              
511             set_concurrency => sub {
512 0     0   0 $_[HEAP]->{concurrency} = $_[ARG0];
513 0         0 DEBUG and warn(
514             "$$: $_[HEAP]->{alias} Concurrent connection ",
515             "limit = $_[HEAP]->{concurrency}"
516             );
517 0 0 0     0 if( $_[HEAP]->{concurrency} != -1 and $_[HEAP]->{listener} ) {
518 0 0       0 if( $_[HEAP]->{connections} >= $_[HEAP]->{concurrency} ) {
519 0         0 DEBUG and warn(
520             "$$: $_[HEAP]->{alias} Concurrent connection limit ",
521             "reached, pausing accept"
522             );
523 0         0 $_[HEAP]->{listener}->pause_accept()
524             }
525             else {
526 0         0 DEBUG and warn(
527             "$$: $_[HEAP]->{alias} Concurrent connection limit ",
528             "reestablished, resuming accept"
529             );
530 0         0 $_[HEAP]->{listener}->resume_accept();
531             }
532             }
533             },
534              
535             # Shut down.
536             shutdown => sub {
537 10     14   61 delete $_[HEAP]->{listener};
538 10 50       77 $_[KERNEL]->alias_remove( $_[HEAP]->{alias} )
539             if defined $_[HEAP]->{alias};
540             },
541              
542             # Dummy states to prevent warnings.
543             _stop => sub {
544 14     20   26 DEBUG and warn "$$: $_[HEAP]->{alias} _stop";
545 14 50       47 $server_stopped and $server_stopped->(@_);
546 14         24 undef($accept_session_id);
547 14         49 return 0;
548             },
549 108     132   254 _child => sub { },
550             },
551              
552 14         269 args => $listener_args,
553             )->ID;
554              
555             # Return the session ID.
556 14         122 return $accept_session_id;
557             }
558              
559             sub _get_filters {
560 38     38   57 my ($client_filter, $client_infilter, $client_outfilter) = @_;
561 38 50 33     197 if (defined $client_infilter or defined $client_outfilter) {
    100          
562             return (
563 0         0 "InputFilter" => _load_filter($client_infilter),
564             "OutputFilter" => _load_filter($client_outfilter)
565             );
566             }
567             elsif (defined $client_filter) {
568 6         14 return ( "Filter" => _load_filter($client_filter) );
569             }
570             else {
571 32         190 return ( Filter => POE::Filter::Line->new(), );
572             }
573              
574             }
575              
576             # Get something: either arrayref, ref, or string
577             # Return filter
578             sub _load_filter {
579 6     6   10 my $filter = shift;
580 6 100       23 if (ref ($filter) eq 'ARRAY') {
    50          
581 2         5 my @args = @$filter;
582 2         3 $filter = shift @args;
583 2 50       6 if ( _test_filter($filter) ){
584 2         14 return $filter->new(@args);
585             } else {
586 0         0 return POE::Filter::Line->new(@args);
587             }
588             }
589             elsif (ref $filter) {
590 0         0 return $filter->clone();
591             }
592             else {
593 4 50       8 if ( _test_filter($filter) ) {
594 4         25 return $filter->new();
595             } else {
596 0         0 return POE::Filter::Line->new();
597             }
598             }
599             }
600              
601             # Test if a Filter can be loaded, return success or failure
602             sub _test_filter {
603 6     6   10 my $filter = shift;
604 6         6 my $eval = eval {
605 6         27 (my $mod = $filter) =~ s!::!/!g;
606 6         43 require "$mod.pm";
607 6         10 1;
608             };
609 6 0 33     15 if (!$eval and $@) {
610 0         0 carp(
611             "Failed to load [$filter]\n" .
612             "Reason $@\nUsing default POE::Filter::Line "
613             );
614 0         0 return 0;
615             }
616 6         16 return 1;
617             }
618              
619             # The default server error handler logs to STDERR and shuts down the
620             # server.
621              
622             sub _default_server_error {
623 0     0   0 warn("$$: ".
624             'Server ', $_[SESSION]->ID,
625             " got $_[ARG0] error $_[ARG1] ($_[ARG2])\n"
626             );
627 0         0 delete $_[HEAP]->{listener};
628             }
629              
630             # The default client error handler logs to STDERR
631              
632             sub _default_client_error {
633 4     4   12 my ($syscall, $errno, $error) = @_[ARG0..ARG2];
634 4 50 33     23 unless ($syscall eq "read" and ($errno == 0 or $errno == ECONNRESET)) {
      33        
635 0 0         $error = "(no error)" unless $errno;
636 0           warn("$$: ".
637             'Client session ', $_[SESSION]->ID,
638             " got $syscall error $errno ($error)\n"
639             );
640             }
641             }
642              
643             1;
644              
645             __END__