File Coverage

blib/lib/Net/Server/Proto/UNIX.pm
Criterion Covered Total %
statement 39 62 62.9
branch 16 36 44.4
condition 4 21 19.0
subroutine 12 17 70.5
pod 2 14 14.2
total 73 150 48.6


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   6 use strict;
  1         2  
  1         34  
21 1     1   5 use base qw(IO::Socket::UNIX);
  1         2  
  1         113  
22 1     1   6 use Socket qw(SOCK_STREAM SOCK_DGRAM);
  1         2  
  1         848  
23              
24 6     6 0 21 sub NS_proto { 'UNIX' }
25 21 100   21 0 46 sub NS_port { my $sock = shift; ${*$sock}{'NS_port'} = shift if @_; return ${*$sock}{'NS_port'} }
  21         39  
  8         16  
  21         26  
  21         50  
26 11     11 0 189 sub NS_host { '*' }
27 11     11 0 40 sub NS_ipv { '*' }
28 6 100   6 0 10 sub NS_listen { my $sock = shift; ${*$sock}{'NS_listen'} = shift if @_; return ${*$sock}{'NS_listen'} }
  6         11  
  4         8  
  6         7  
  6         17  
29 2     2 1 10 sub NS_unix_type { 'SOCK_STREAM' }
30 2     2 1 7 sub NS_unix_path { shift->NS_port } # legacy systems used this
31              
32             sub object {
33 6     6 0 14 my ($class, $info, $server) = @_;
34              
35 6 50       10 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       34 }) if ! exists $server->{'server'}->{'unix_type'};
40             my $u_type = uc( defined($info->{'unix_type'}) ? $info->{'unix_type'}
41 6 50       20 : defined($server->{'server'}->{'unix_type'}) ? $server->{'server'}->{'unix_type'}
    100          
42             : 'SOCK_STREAM');
43 6 100 66     24 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         7 require Net::Server::Proto::UNIXDGRAM;
45 2         10 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     8 $info->{'port'} ||= $info->{'unix_path'} = $server->{'server'}->{'unix_path'};
50             }
51              
52 4         16 my $sock = $class->SUPER::new();
53 4 50       281 my $port = $info->{'port'} =~ m{^ ([\w\.\-\*\/]+) $ }x ? $1 : $server->fatal("Insecure filename");
54 4         10 $sock->NS_port($port);
55             $sock->NS_listen(defined($info->{'listen'}) ? $info->{'listen'}
56 4 50       14 : defined($server->{'server'}->{'listen'}) ? $server->{'server'}->{'listen'}
    100          
57             : Socket::SOMAXCONN());
58 4         13 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             # a string containing any information necessary for restarting the server
84             # via a -HUP signal
85             # a newline is not allowed
86             # the hup_string must be a unique identifier based on configuration info
87             sub hup_string {
88 8     8 0 1502 my $sock = shift;
89 8         12 return join "|", $sock->NS_host, $sock->NS_port, $sock->NS_proto, $sock->NS_ipv;
90             }
91              
92             sub show {
93 0     0 0   my $sock = shift;
94 0           return "Ref = \"".ref($sock). "\" (".$sock->hup_string.")\n";
95             }
96              
97             ###----------------------------------------------------------------###
98              
99             sub read_until { # only sips the data - but it allows for compatibility with SSLEAY
100 0     0 0   my ($client, $bytes, $end_qr) = @_;
101 0 0 0       die "One of bytes or end_qr should be defined for UNIX read_until\n" if !defined($bytes) && !defined($end_qr);
102 0           my $content = '';
103 0           my $ok = 0;
104 0           while (1) {
105 0           $client->read($content, 1, length($content));
106 0 0 0       if (defined($bytes) && length($content) >= $bytes) {
    0 0        
107 0           $ok = 2;
108 0           last;
109             } elsif (defined($end_qr) && $content =~ $end_qr) {
110 0           $ok = 1;
111 0           last;
112             }
113             }
114 0 0         return wantarray ? ($ok, $content) : $content;
115             }
116              
117             1;
118              
119             __END__