File Coverage

blib/lib/Net/Server/Proto/UNIX.pm
Criterion Covered Total %
statement 39 70 55.7
branch 16 42 38.1
condition 4 21 19.0
subroutine 12 18 66.6
pod 3 15 20.0
total 74 166 44.5


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             #
3             # Net::Server::Proto::UNIX - 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::UNIX;
19              
20 1     1   7 use strict;
  1         2  
  1         45  
21 1     1   6 use base qw(IO::Socket::UNIX);
  1         2  
  1         213  
22 1     1   8 use Socket qw(SOCK_STREAM SOCK_DGRAM);
  1         2  
  1         1318  
23              
24 6     6 0 18 sub NS_proto { 'UNIX' }
25 21 100   21 0 38 sub NS_port { my $sock = shift; ${*$sock}{'NS_port'} = shift if @_; return ${*$sock}{'NS_port'} }
  21         49  
  8         22  
  21         31  
  21         66  
26 11     11 0 158 sub NS_host { '*' }
27 11     11 0 58 sub NS_ipv { '*' }
28 6 100   6 0 12 sub NS_listen { my $sock = shift; ${*$sock}{'NS_listen'} = shift if @_; return ${*$sock}{'NS_listen'} }
  6         15  
  4         9  
  6         10  
  6         13  
29 2     2 1 8 sub NS_unix_type { 'SOCK_STREAM' }
30 2     2 1 10 sub NS_unix_path { shift->NS_port } # legacy systems used this
31              
32             sub object {
33 6     6 0 18 my ($class, $info, $server) = @_;
34              
35 6 50       19 if ($class eq __PACKAGE__) {
36             $server->configure({
37             unix_type => \$server->{'server'}->{'unix_type'},
38             unix_path => \$server->{'server'}->{'unix_path'}, # I don't believe this ever worked since a valid port specification also has to exist
39 6 50       48 }) if ! exists $server->{'server'}->{'unix_type'};
40             my $u_type = uc( defined($info->{'unix_type'}) ? $info->{'unix_type'}
41 6 50       28 : defined($server->{'server'}->{'unix_type'}) ? $server->{'server'}->{'unix_type'}
    100          
42             : 'SOCK_STREAM');
43 6 100 66     40 if ($u_type eq 'SOCK_DGRAM' || $u_type eq ''.SOCK_DGRAM()) { # allow for legacy invocations passing unix_type to UNIX - now just use proto UNIXDGRAM
    50 33        
44 2         9 require Net::Server::Proto::UNIXDGRAM;
45 2         13 return Net::Server::Proto::UNIXDGRAM->object($info, $server);
46             } elsif ($u_type ne 'SOCK_STREAM' && $u_type ne ''.SOCK_STREAM()) {
47 0         0 $server->fatal("Invalid type for UNIX socket ($u_type)... must be SOCK_STREAM or SOCK_DGRAM");
48             }
49 4   33     13 $info->{'port'} ||= $info->{'unix_path'} = $server->{'server'}->{'unix_path'};
50             }
51              
52 4         25 my $sock = $class->SUPER::new();
53 4 50       382 my $port = $info->{'port'} =~ m{^ ([\w\.\-\*\/]+) $ }x ? $1 : $server->fatal("Insecure filename");
54 4         16 $sock->NS_port($port);
55             $sock->NS_listen(defined($info->{'listen'}) ? $info->{'listen'}
56 4 50       20 : defined($server->{'server'}->{'listen'}) ? $server->{'server'}->{'listen'}
    100          
57             : Socket::SOMAXCONN());
58 4         21 return $sock;
59             }
60              
61             sub connect {
62 0     0 0 0 my ($sock, $server) = @_;
63 0         0 my $path = $sock->NS_port;
64 0 0 0     0 $server->fatal("Can't connect to UNIX socket at file $path [$!]") if -e $path && ! unlink $path;
65              
66 0 0       0 $sock->SUPER::configure({
67             Local => $path,
68             Type => SOCK_STREAM,
69             Listen => $sock->NS_listen,
70             }) or $server->fatal("Can't connect to UNIX socket at file $path [$!]");
71             }
72              
73             sub log_connect {
74 0     0 0 0 my ($sock, $server) = @_;
75 0         0 $server->log(2, "Binding to ".$sock->NS_proto." socket file \"".$sock->NS_port."\"");
76             }
77              
78             sub reconnect { # connect on a sig -HUP
79 0     0 0 0 my ($sock, $fd, $server) = @_;
80 0 0       0 $sock->fdopen($fd, 'w') or $server->fatal("Error opening to file descriptor ($fd) [$!]");
81             }
82              
83             sub accept {
84 0     0 1 0 my ($sock, $class) = (@_);
85 0         0 my ($client, $peername);
86 0 0       0 if (wantarray) {
87 0         0 ($client, $peername) = $sock->SUPER::accept($class);
88             } else {
89 0         0 $client = $sock->SUPER::accept($class);
90             }
91 0 0       0 if (defined $client) {
92 0         0 $client->NS_port($sock->NS_port);
93             }
94 0 0       0 return wantarray ? ($client, $peername) : $client;
95             }
96              
97             # a string containing any information necessary for restarting the server
98             # via a -HUP signal
99             # a newline is not allowed
100             # the hup_string must be a unique identifier based on configuration info
101             sub hup_string {
102 8     8 0 1828 my $sock = shift;
103 8         23 return join "|", $sock->NS_host, $sock->NS_port, $sock->NS_proto, $sock->NS_ipv;
104             }
105              
106             sub show {
107 0     0 0   my $sock = shift;
108 0           return "Ref = \"".ref($sock). "\" (".$sock->hup_string.")\n";
109             }
110              
111             ###----------------------------------------------------------------###
112              
113             sub read_until { # only sips the data - but it allows for compatibility with SSLEAY
114 0     0 0   my ($client, $bytes, $end_qr) = @_;
115 0 0 0       die "One of bytes or end_qr should be defined for UNIX read_until\n" if !defined($bytes) && !defined($end_qr);
116 0           my $content = '';
117 0           my $ok = 0;
118 0           while (1) {
119 0           $client->read($content, 1, length($content));
120 0 0 0       if (defined($bytes) && length($content) >= $bytes) {
    0 0        
121 0           $ok = 2;
122 0           last;
123             } elsif (defined($end_qr) && $content =~ $end_qr) {
124 0           $ok = 1;
125 0           last;
126             }
127             }
128 0 0         return wantarray ? ($ok, $content) : $content;
129             }
130              
131             1;
132              
133             __END__