File Coverage

blib/lib/IO/All/Socket.pm
Criterion Covered Total %
statement 56 83 67.4
branch 15 36 41.6
condition n/a
subroutine 11 18 61.1
pod 4 7 57.1
total 86 144 59.7


line stmt bran cond sub pod time code
1 4     4   1121 use strict; use warnings;
  4     4   8  
  4         159  
  4         31  
  4         5  
  4         183  
2             package IO::All::Socket;
3              
4 4     4   21 use IO::All -base;
  4         7  
  4         60  
5 4     4   1771 use IO::Socket;
  4         36967  
  4         47  
6              
7             const type => 'socket';
8             field _listen => undef;
9             option 'fork';
10             const domain_default => 'localhost';
11             chain domain => undef;
12             chain port => undef;
13             proxy_open 'recv';
14             proxy_open 'send';
15              
16             sub socket {
17 3     3 1 11 my $self = shift;
18 3         8 bless $self, __PACKAGE__;
19 3 50       34 $self->name(shift) if @_;
20 3         43 return $self->_init;
21             }
22              
23             sub socket_handle {
24 10     10 0 22 my $self = shift;
25 10         31 bless $self, __PACKAGE__;
26 10 50       65 $self->_handle(shift) if @_;
27 10         29 return $self->_init;
28             }
29              
30             sub accept {
31 10     10 1 93 my $self = shift;
32 4     4   5190 use POSIX ":sys_wait_h";
  4         18006  
  4         36  
33             sub REAPER {
34 0     0 0 0 while (waitpid(-1, WNOHANG) > 0) {}
35 0         0 $SIG{CHLD} = \&REAPER;
36             }
37 10         131 local $SIG{CHLD};
38 10         47 $self->_listen(1);
39 10         29 $self->_assert_open;
40 10         30 my $server = $self->io_handle;
41 10         23 my $socket;
42 10         11 while (1) {
43 10         40 $socket = $server->accept;
44 10 50       984190 last unless $self->_fork;
45 0 0       0 next unless defined $socket;
46 0         0 $SIG{CHLD} = \&REAPER;
47 0         0 my $pid = CORE::fork;
48 0 0       0 $self->throw("Unable to fork for IO::All::accept")
49             unless defined $pid;
50 0 0       0 last unless $pid;
51 0         0 close $socket;
52 0         0 undef $socket;
53             }
54 10 50       33 close $server if $self->_fork;
55 10         115 my $io = ref($self)->new->socket_handle($socket);
56 10         41 $io->io_handle($socket);
57 10         28 $io->is_open(1);
58 10         141 return $io;
59             }
60              
61             sub shutdown {
62 0     0 1 0 my $self = shift;
63 0 0       0 my $how = @_ ? shift : 2;
64 0         0 my $handle = $self->io_handle;
65 0 0       0 $handle->shutdown(2)
66             if defined $handle;
67             }
68              
69             sub _assert_open {
70 20     20   28 my $self = shift;
71 20 100       56 return if $self->is_open;
72 1 50       8 $self->mode(shift) unless $self->mode;
73 1         3 $self->open;
74             }
75              
76             sub open {
77 1     1 1 2 my $self = shift;
78 1 50       4 return if $self->is_open;
79 1         4 $self->is_open(1);
80 1         3 $self->get_socket_domain_port;
81 1 50       3 my @args = $self->_listen
82             ? (
83             LocalAddr => $self->domain,
84             LocalPort => $self->port,
85             Proto => 'tcp',
86             Listen => 1,
87             Reuse => 1,
88             )
89             : (
90             PeerAddr => $self->domain,
91             PeerPort => $self->port,
92             Proto => 'tcp',
93             );
94 1 50       26 my $socket = IO::Socket::INET->new(@args)
95             or $self->throw("Can't open socket");
96 1         1164 $self->io_handle($socket);
97 1         21 $self->_set_binmode;
98             }
99              
100             sub get_socket_domain_port {
101 3     3 0 5 my $self = shift;
102 3         4 my ($domain, $port);
103 3 50       9 ($domain, $port) = split /:/, $self->name
104             if defined $self->name;
105 3 50       11 $self->domain($domain) unless defined $self->domain;
106 3 100       8 $self->domain($self->domain_default) unless $self->domain;
107 3 50       13 $self->port($port) unless defined $self->port;
108 3         8 return $self;
109             }
110              
111             sub _overload_table {
112 0     0     my $self = shift;
113             (
114 0           $self->SUPER::_overload_table(@_),
115             '&{} socket' => '_overload_socket_as_code',
116             )
117             }
118              
119             sub _overload_socket_as_code {
120 0     0     my $self = shift;
121             sub {
122 0     0     my $coderef = shift;
123 0           while ($self->is_open) {
124 0           $_ = $self->getline;
125 0           &$coderef($self);
126             }
127             }
128 0           }
129              
130             sub _overload_any_from_any {
131 0     0     my $self = shift;
132 0           $self->SUPER::_overload_any_from_any(@_);
133 0           $self->close;
134             }
135              
136             sub _overload_any_to_any {
137 0     0     my $self = shift;
138 0           $self->SUPER::_overload_any_to_any(@_);
139 0           $self->close;
140             }
141              
142             1;