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

# -*- perl -*-
#
#  Net::Server::Proto::UNIX - Net::Server Protocol module
#
#  Copyright (C) 2001-2017
#
#    Paul Seamons
#
#  This package may be distributed under the terms of either the
#  GNU General Public License
#    or the
#  Perl Artistic License
#
#  All rights reserved.
#
################################################################

package Net::Server::Proto::UNIX;

use strict;
use base qw(IO::Socket::UNIX);
use Socket qw(SOCK_STREAM SOCK_DGRAM);

sub NS_proto { 'UNIX' }
sub NS_port   { my $sock = shift; ${*$sock}{'NS_port'}   = shift if @_; return ${*$sock}{'NS_port'}   }
sub NS_host   { '*' }
sub NS_ipv    { '*' }
sub NS_listen { my $sock = shift; ${*$sock}{'NS_listen'} = shift if @_; return ${*$sock}{'NS_listen'} }
sub NS_unix_type { 'SOCK_STREAM' }
sub NS_unix_path { shift->NS_port } # legacy systems used this

sub object {
    my ($class, $info, $server) = @_;

    if ($class eq __PACKAGE__) {
        $server->configure({
            unix_type => \$server->{'server'}->{'unix_type'},
            unix_path => \$server->{'server'}->{'unix_path'}, # I don't believe this ever worked since a valid port specification also has to exist
        }) if ! exists $server->{'server'}->{'unix_type'};
        my $u_type = uc( defined($info->{'unix_type'}) ? $info->{'unix_type'}
                       : defined($server->{'server'}->{'unix_type'}) ? $server->{'server'}->{'unix_type'}
                       : 'SOCK_STREAM');
        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
            require Net::Server::Proto::UNIXDGRAM;
            return Net::Server::Proto::UNIXDGRAM->object($info, $server);
        } elsif ($u_type ne 'SOCK_STREAM' && $u_type ne ''.SOCK_STREAM()) {
            $server->fatal("Invalid type for UNIX socket ($u_type)... must be SOCK_STREAM or SOCK_DGRAM");
        }
        $info->{'port'} ||= $info->{'unix_path'} = $server->{'server'}->{'unix_path'};
    }

    my $sock = $class->SUPER::new();
    my $port = $info->{'port'} =~ m{^ ([\w\.\-\*\/]+) $ }x ? $1 : $server->fatal("Insecure filename");
    $sock->NS_port($port);
    $sock->NS_listen(defined($info->{'listen'}) ? $info->{'listen'}
                    : defined($server->{'server'}->{'listen'}) ? $server->{'server'}->{'listen'}
                    : Socket::SOMAXCONN());
    return $sock;
}

sub connect {
    my ($sock, $server) = @_;
    my $path = $sock->NS_port;
    $server->fatal("Can't connect to UNIX socket at file $path [$!]") if -e $path && ! unlink $path;

    $sock->SUPER::configure({
        Local  => $path,
        Type   => SOCK_STREAM,
        Listen => $sock->NS_listen,
    }) or $server->fatal("Can't connect to UNIX socket at file $path [$!]");
}

sub log_connect {
    my ($sock, $server) = @_;
    $server->log(2, "Binding to ".$sock->NS_proto." socket file \"".$sock->NS_port."\"");
}

sub reconnect { # connect on a sig -HUP
    my ($sock, $fd, $server) = @_;
    $sock->fdopen($fd, 'w') or $server->fatal("Error opening to file descriptor ($fd) [$!]");
}

sub accept {
    my ($sock, $class) = (@_);
    my ($client, $peername);
    if (wantarray) {
        ($client, $peername) = $sock->SUPER::accept($class);
    } else {
        $client = $sock->SUPER::accept($class);
    }
    if (defined $client) {
        $client->NS_port($sock->NS_port);
    }
    return wantarray ? ($client, $peername) : $client;
}

# a string containing any information necessary for restarting the server
# via a -HUP signal
# a newline is not allowed
# the hup_string must be a unique identifier based on configuration info
sub hup_string {
    my $sock = shift;
    return join "|", $sock->NS_host, $sock->NS_port, $sock->NS_proto, $sock->NS_ipv;
}

sub show {
    my $sock = shift;
    return "Ref = \"".ref($sock). "\" (".$sock->hup_string.")\n";
}

###----------------------------------------------------------------###

sub read_until { # only sips the data - but it allows for compatibility with SSLEAY
    my ($client, $bytes, $end_qr) = @_;
    die "One of bytes or end_qr should be defined for UNIX read_until\n" if !defined($bytes) && !defined($end_qr);
    my $content = '';
    my $ok = 0;
    while (1) {
        $client->read($content, 1, length($content));
        if (defined($bytes) && length($content) >= $bytes) {
            $ok = 2;
            last;
        } elsif (defined($end_qr) && $content =~ $end_qr) {
            $ok = 1;
            last;
        }
    }
    return wantarray ? ($ok, $content) : $content;
}

1;

__END__