File Coverage

blib/lib/Net/Server/Proto/UNIXDGRAM.pm

Criterion	Covered	Total	%
statement	38	42	90.4
branch	12	22	54.5
condition	1	6	16.6
subroutine	8	9	88.8
pod	1	6	16.6
total	60	85	70.5

# -*- perl -*-
#
#  Net::Server::Proto::UNIXDGRAM - Net::Server Protocol module
#
#  Copyright (C) 2001-2022
#
#    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::UNIXDGRAM;

use strict;
use base qw(Net::Server::Proto::UNIX);
use Socket qw(SOCK_DGRAM);

my @udp_args = qw(
    udp_recv_len
    udp_recv_flags
    udp_broadcast
); # we do broadcast just for caching parallelism with UDP.pm

sub NS_proto { 'UNIXDGRAM' }
sub NS_recv_len   { my $sock = shift; ${*$sock}{'NS_recv_len'}   = shift if @_; return ${*$sock}{'NS_recv_len'}   }
sub NS_recv_flags { my $sock = shift; ${*$sock}{'NS_recv_flags'} = shift if @_; return ${*$sock}{'NS_recv_flags'} }
sub NS_unix_type  { 'SOCK_DGRAM' }

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

    my $udp = $server->{'server'}->{'udp_args'} ||= do {
        my %temp = map {$_ => undef} @udp_args;
        $server->configure({map {$_ => \$temp{$_}} @udp_args});
        \%temp;
    };

    my $len = defined($info->{'udp_recv_len'}) ? $info->{'udp_recv_len'}
            : defined($udp->{'udp_recv_len'})  ? $udp->{'udp_recv_len'}
            : 4096;
    $len = ($len =~ /^(\d+)$/) ? $1 : 4096;

    my $flg = defined($info->{'udp_recv_flags'}) ? $info->{'udp_recv_flags'}
            : defined($udp->{'udp_recv_flags'})  ? $udp->{'udp_recv_flags'}
            : 0;
    $flg = ($flg =~ /^(\d+)$/) ? $1 : 0;

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

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

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

1;

__END__