File Coverage

blib/lib/Net/Server/Proto/TCP.pm
Criterion Covered Total %
statement 72 101 71.2
branch 28 58 48.2
condition 7 18 38.8
subroutine 15 18 83.3
pod 9 14 64.2
total 131 209 62.6


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             #
3             # Net::Server::Proto::TCP - Net::Server Protocol module
4             #
5             # Copyright (C) 2001-2017
6             #
7             # Paul Seamons
8             #
9             # This package may be distributed under the terms of either the
10             # GNU General Public License
11             # or the
12             # Perl Artistic License
13             #
14             # All rights reserved.
15             #
16             ################################################################
17              
18             package Net::Server::Proto::TCP;
19              
20 12     12   101 use strict;
  12         27  
  12         665  
21 12     12   81 use warnings;
  12         31  
  12         1191  
22 12     12   99 use IO::Socket::INET;
  12         27  
  12         999  
23 12     12   15465 use Net::Server::Proto;
  12         30  
  12         18263  
24              
25             our @ISA = qw(IO::Socket::INET); # we may dynamically change this to INET6 based upon our server configuration
26              
27 69     69 0 361 sub NS_proto { 'TCP' }
28 169 100   169 0 288 sub NS_port { my $sock = shift; ${*$sock}{'NS_port'} = shift if @_; return ${*$sock}{'NS_port'} }
  169         385  
  94         262  
  169         234  
  169         442  
29 151 100   151 0 261 sub NS_host { my $sock = shift; ${*$sock}{'NS_host'} = shift if @_; return ${*$sock}{'NS_host'} }
  151         359  
  85         205  
  151         221  
  151         384  
30 151 100   151 0 338 sub NS_ipv { my $sock = shift; ${*$sock}{'NS_ipv'} = shift if @_; return ${*$sock}{'NS_ipv'} }
  151         323  
  85         195  
  151         249  
  151         374  
31 92 100   92 0 601 sub NS_listen { my $sock = shift; ${*$sock}{'NS_listen'} = shift if @_; return ${*$sock}{'NS_listen'} }
  92         234  
  75         164  
  92         187  
  92         187  
32              
33             sub object {
34 75     75 1 178 my ($class, $info, $server) = @_;
35              
36             # we cannot do this at compile time because we have not yet read the configuration then
37 75 50 33     319 @ISA = qw(IO::Socket::INET6) if $ISA[0] eq 'IO::Socket::INET' && Net::Server::Proto->requires_ipv6($server);
38              
39 75         546 my @sock = $class->SUPER::new();
40 75         7970 foreach my $sock (@sock) {
41 75         258 $sock->NS_host($info->{'host'});
42 75         203 $sock->NS_port($info->{'port'});
43 75         196 $sock->NS_ipv( $info->{'ipv'} );
44             $sock->NS_listen(defined($info->{'listen'}) ? $info->{'listen'}
45 75 100       329 : defined($server->{'server'}->{'listen'}) ? $server->{'server'}->{'listen'}
    100          
46             : Socket::SOMAXCONN());
47 75 50       224 ${*$sock}{'NS_orig_port'} = $info->{'orig_port'} if defined $info->{'orig_port'};
  0         0  
48             }
49 75 50       381 return wantarray ? @sock : $sock[0];
50             }
51              
52             sub log_connect {
53 15     15 1 41 my ($sock, $server) = @_;
54 15         44 $server->log(2, "Binding to ".$sock->NS_proto." port ".$sock->NS_port." on host ".$sock->NS_host." with IPv".$sock->NS_ipv);
55             }
56              
57             sub connect {
58 14     14 1 36 my ($sock, $server) = @_;
59 14         46 my $host = $sock->NS_host;
60 14         45 my $port = $sock->NS_port;
61 14         35 my $ipv = $sock->NS_ipv;
62 14         138 my $lstn = $sock->NS_listen;
63              
64 14 50       739 $sock->SUPER::configure({
    0          
    0          
    50          
    50          
65             LocalPort => $port,
66             Proto => 'tcp',
67             Listen => $lstn,
68             ReuseAddr => 1,
69             Reuse => 1,
70             (($host ne '*') ? (LocalAddr => $host) : ()), # * is all
71             ($sock->isa("IO::Socket::INET6") ? (Domain => ($ipv eq '6') ? Socket6::AF_INET6() : ($ipv eq '4') ? Socket::AF_INET() : Socket::AF_UNSPEC()) : ()),
72             }) || $server->fatal("Can't connect to TCP port $port on $host [$!]");
73              
74 14 50 33     5933 if ($port eq '0' and $port = $sock->sockport) {
    50 33        
75 0         0 $server->log(2, " Bound to auto-assigned port $port");
76 0         0 ${*$sock}{'NS_orig_port'} = $sock->NS_port;
  0         0  
77 0         0 $sock->NS_port($port);
78             } elsif ($port =~ /\D/ and $port = $sock->sockport) {
79 0         0 $server->log(2, " Bound to service port ".$sock->NS_port()."($port)");
80 0         0 ${*$sock}{'NS_orig_port'} = $sock->NS_port;
  0         0  
81 0         0 $sock->NS_port($port);
82             }
83             }
84              
85             sub reconnect { # after a sig HUP
86 0     0 1 0 my ($sock, $fd, $server, $port) = @_;
87 0         0 $server->log(3,"Reassociating file descriptor $fd with ".$sock->NS_proto." on [".$sock->NS_host."]:".$sock->NS_port.", using IPv".$sock->NS_ipv);
88 0 0       0 $sock->fdopen($fd, 'w') or $server->fatal("Error opening to file descriptor ($fd) [$!]");
89              
90 0 0       0 if ($sock->isa("IO::Socket::INET6")) {
91 0         0 my $ipv = $sock->NS_ipv;
92 0 0       0 ${*$sock}{'io_socket_domain'} = ($ipv eq '6') ? Socket6::AF_INET6() : ($ipv eq '4') ? Socket::AF_INET() : Socket::AF_UNSPEC();
  0 0       0  
93             }
94              
95 0 0       0 if ($port ne $sock->NS_port) {
96 0         0 $server->log(2, " Re-bound to previously assigned port $port");
97 0         0 ${*$sock}{'NS_orig_port'} = $sock->NS_port;
  0         0  
98 0         0 $sock->NS_port($port);
99             }
100             }
101              
102             sub accept {
103 9     9 1 28 my ($sock, $class) = (@_);
104 9         26 my ($client, $peername);
105 9 50       29 if (wantarray) {
106 0         0 ($client, $peername) = $sock->SUPER::accept($class);
107             } else {
108 9         156 $client = $sock->SUPER::accept($class);
109             }
110 9 50       5444 if (defined $client) {
111 9         50 $client->NS_port($sock->NS_port);
112             }
113 9 50       118 return wantarray ? ($client, $peername) : $client;
114             }
115              
116             sub poll_cb { # implemented for psgi compatibility - TODO - should poll appropriately for Multipex
117 0     0 1 0 my ($self, $cb) = @_;
118 0         0 return $cb->($self);
119             }
120              
121             ###----------------------------------------------------------------###
122              
123             sub read_until { # only sips the data - but it allows for compatibility with SSLEAY
124 2     2 1 8 my ($client, $bytes, $end_qr) = @_;
125 2 0 33     9 die "One of bytes or end_qr should be defined for TCP read_until\n" if !defined($bytes) && !defined($end_qr);
126 2         3 my $content = '';
127 2         6 my $ok = 0;
128 2         3 while (1) {
129 50         143 $client->read($content, 1, length($content));
130 50 50 33     497 if (defined($bytes) && length($content) >= $bytes) {
    100 66        
131 0         0 $ok = 2;
132 0         0 last;
133             } elsif (defined($end_qr) && $content =~ $end_qr) {
134 2         4 $ok = 1;
135 2         6 last;
136             }
137             }
138 2 50       16 return wantarray ? ($ok, $content) : $content;
139             }
140              
141             ###----------------------------------------------------------------###
142              
143             ### a string containing any information necessary for restarting the server
144             ### via a -HUP signal
145             ### a newline is not allowed
146             ### the hup_string must be a unique identifier based on configuration info
147             sub hup_string {
148 30     30 1 5214 my $sock = shift;
149 30 50       58 return join "|", $sock->NS_host, $sock->NS_port, $sock->NS_proto, 'ipv'.$sock->NS_ipv, (defined(${*$sock}{'NS_orig_port'}) ? ${*$sock}{'NS_orig_port'} : ());
  30         177  
  0            
150             }
151              
152             sub show {
153 0     0 1   my $sock = shift;
154 0           return "Ref = \"".ref($sock). "\" (".$sock->hup_string.")\n";
155             }
156              
157             1;
158              
159             __END__