File Coverage

blib/lib/Net/UNIX.pm

Criterion	Covered	Total	%
statement	115	159	72.3
branch	56	94	59.5
condition	29	68	42.6
subroutine	18	23	78.2
pod	8	10	80.0
total	226	354	63.8

# Copyright 1995,2002 Spider Boardman.
# All rights reserved.
#
# Automatic licensing for this software is available.  This software
# can be copied and used under the terms of the GNU Public License,
# version 1 or (at your option) any later version, or under the
# terms of the Artistic license.  Both of these can be found with
# the Perl distribution, which this software is intended to augment.
#
# THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
# WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.

# rcsid: "@(#) $Id: UNIX.dat,v 1.22 2002/03/30 10:11:08 spider Exp $"

package Net::UNIX;
use 5.004_04;			# new minimum Perl version for this package

use strict;
#use Carp;
sub carp { require Carp; goto &Carp::carp; }
sub croak { require Carp; goto &Carp::croak; }
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS *AUTOLOAD);

BEGIN {
    $VERSION = '1.0';
    eval "sub Version { __PACKAGE__ . ' v$VERSION' }";
}

use AutoLoader;
#use Exporter ();
use Net::Gen 1.0 qw(/pack_sockaddr$/ :sockvals :families);

BEGIN {
    @ISA = 'Net::Gen';

# Items to export into callers namespace by default.
# (Move infrequently used names to @EXPORT_OK below.)

    @EXPORT = qw(
    );

    @EXPORT_OK = qw(
	pack_sockaddr_un
	unpack_sockaddr_un
    );

    %EXPORT_TAGS = (
	routines	=> [qw(pack_sockaddr_un unpack_sockaddr_un)],
	ALL		=> [@EXPORT, @EXPORT_OK],
    );
    *AUTOLOAD = \$Net::Gen::AUTOLOAD;
}

;# sub AUTOLOAD inherited from Net::Gen

;# since 5.003_96 will break simple subroutines with inherited autoload, cheat
sub AUTOLOAD
{
    #$Net::Gen::AUTOLOAD = $AUTOLOAD;
    goto &Net::Gen::AUTOLOAD;
}


# Preloaded methods go here.  Autoload methods go after __END__, and are
# processed by the autosplit program.

;# No additional sockopts for UNIX-domain sockets (?)

my $sun_path_len =
    length(Socket::unpack_sockaddr_un(Socket::pack_sockaddr_un('')));

#& _canonpath($path) : returns NUL-padded $path for sun_addr
sub _canonpath ($)
{
    my $path = shift;
    my $ix;
    # extend to proper length
    $ix = index($path, "\0");
    if ($ix >= 0) {
	substr($path,$ix) = "\0" x ($sun_path_len - $ix)
	    if $ix < $sun_path_len;
    }
    else {
	$ix = length($path);
	if ($ix < $sun_path_len) {
	    $path .= "\0" x ($sun_path_len - $ix);
	}
	else {
	    $path .= "\0";
	}
    }
    $path;
}

#& pack_sockaddr_un([$family,] $path) : $packed_addr
sub pack_sockaddr_un ($;$)
{
    my(@args) = @_;
    unshift(@args, AF_UNIX) if @args == 1;
    pack_sockaddr($args[0], _canonpath($args[1]));
}

#& unpack_sockaddr_un($sockaddr_un) : [$fam,] $path
sub unpack_sockaddr_un ($)
{
    my $addr = shift;
    my ($fam,$path) = unpack_sockaddr($addr);
    my $nul = index($path, "\0");
    if ($nul >= 0) {
	substr($path, $nul) = '';
    }
    $fam ||= AF_UNIX;
    wantarray ? ($fam, $path) : $path;
}

my $debug = 0;

#& _debug($this, [$newval]) : oldval
sub _debug : locked
{
    my ($this,$newval) = @_;
    return $this->debug($newval) if ref $this;
    my $prev = $debug;
    $debug = 0+$newval if defined $newval;
    $prev;
}


my %keyhandlers = (thispath => \&_setbindpath,
		   destpath => \&_setconnpath,
		   unbuffered_IO => \&_setbuf_unbuf,
		   unbuffered_io => \&_setbuf_unbuf,
);

my @Keys = qw(unbuffered_input unbuffered_output);

my %Keys;			# for storing the registrations


#& new($class, [\%params]) : {$obj | undef}
sub new : locked
{
    my $whoami = $_[0]->_trace(\@_,1);
    my($class,@Args,$self) = @_;
    $self = $class->SUPER::new(@Args);
    $class = ref $class if ref $class;
    ($self || $class)->_trace(\@_,2,", self" .
			      (defined $self ? "=$self" : " undefined") .
			      " after sub-new");
    if ($self) {
	# register our keys and their handlers
	if (%Keys) {
	    $ {*$self}{Keys} = { %Keys };
	}
	else {
	    $self->register_param_keys(\@Keys) if @Keys;
	    $self->register_param_handlers(\%keyhandlers);
	    %Keys = %{ $ {*$self}{Keys} };
	}
	# register our socket options
	# none for AF_UNIX?
	# set our expected parameters
	$self->setparams({PF => PF_UNIX, AF => AF_UNIX,
			  unbuffered_output => 0,
			  unbuffered_input => 0,
			  type => SOCK_DGRAM},
			 -1);
	if ($class eq __PACKAGE__) {
	    unless ($self->init(@Args)) {
		local $!;	# protect errno
		undef $self;	# from the side-effects of this
		undef $self;	# another statement needed for unwinding
	    }
	}
    }
    if ($debug) {
	if ($self) {
	    print STDERR __PACKAGE__ . "::new returning self=$self\n";
	}
	else {
	    print STDERR __PACKAGE__ . "::new returning undef\n";
	}
    }
    $self;
}

#& _setbindpath($self, 'thispath', $path) : {'' | "carp string"}
sub _setbindpath
{
    my($self,$what,$path) = @_;
    my $ix;
    if (!defined($path)) {
	# removing, so cooperate
	delete $ {*$self}{Parms}{srcaddrlist};
	return '';
    }
    # canonicalize the path to be of the right length, if possible
    $path = _canonpath($path);
    $ix = index($path, "\0");	# check for NUL-termination
    if (!$ix) {			# empty path is not a bind
	delete $ {*$self}{Parms}{srcaddrlist};
	$_[2] = undef;
    }
    else {
	$ {*$self}{Parms}{srcaddrlist} =
	    [pack_sockaddr_un($self->getparam('AF',AF_UNIX,1), $path)];
    }
    '';
}

#& _setconnpath($self, 'destpath', $path) : {'' | "carp string"}
sub _setconnpath
{
    my($self,$what,$path) = @_;
    my $ix;
    if (!defined($path)) {
	# removing, so cooperate
	delete $ {*$self}{Parms}{dstaddrlist};
	return '';
    }
    # canonicalize the path to be of the right length, if possible
    $path = _canonpath($path);
    $ix = index($path, "\0");	# check for NUL-termination
    if (!$ix) {			# empty path?
	"$what parameter has no path: $path";
    }
    else {			# just try it here
	$ {*$self}{Parms}{dstaddrlist} =
	    [pack_sockaddr_un($self->getparam('AF',AF_UNIX,1), $path)];
	'';
    }
}

#& _init($self, whatpath[, $path][, \%params]) : {$self | undef}
sub _init : locked method
{
    my ($self,$what,@args,$path,$parms) = @_;
    if (@args == 1 or @args == 2) {
	$parms = $args[-1];
	$parms = undef
	    unless $parms and ref($parms) eq 'HASH';
	$path = $args[0];
	$path = undef
	    if defined($path) and ref($path);
    }
    croak("Invalid call to " . __PACKAGE__ . "::init(@_)")
	if @args == 2 and !$parms or @args > 2 or !$what;
    $parms ||= {};
    $$parms{$what} = $path if defined $path;
    return undef unless $self->SUPER::init($parms);
    if (scalar %$parms) {
	return undef unless $self->setparams($parms);
    }
    $self->setparams({netgen_fakeconnect=>1},-1) if
	$self->getparam('type') == SOCK_DGRAM;
    if ($self->getparams([qw(srcaddr srcaddrlist dstaddr dstaddrlist)],1) >0) {
	return undef unless $self->isopen or $self->open;
	if ($self->getparams([qw(srcaddr srcaddrlist)],1) > 0) {
	    return undef unless $self->isbound or $self->bind;
	}
	if ($self->getparams([qw(dstaddr dstaddrlist)],1) > 0) {
	    return undef unless $self->isconnected or $self->connect or
		$self->isconnecting and !$self->blocking;
	}
    }
    $self;
}

#& init($self [, $destpath][, \%params]) : {$self | undef}
sub init
{
    my ($self,@args) = @_;
    $self->_init('destpath',@args);
}

#& connect($self [, $destpath] [, \%newparams]) : boolean
sub connect : locked method
{
    my($self,$path,$parms) = @_;
    if (@_ > 3 or @_ == 3 and (!ref($parms) or ref($path))) {
	croak("Invalid arguments to " . __PACKAGE__ . "::connect(@_), called");
    }
    if (@_ == 2 and ref $path) {
	$parms = $path;
	undef $path;
    }
    else {
	$parms ||= {};
    }
    if (defined $path) {
	$$parms{destpath} = $path;
    }
    if (@_ > 1) {
	return unless $self->setparams($parms);
    }
    $self->SUPER::connect;
}

#& format_addr({$class|$obj} , $sockaddr) : $string
sub format_addr
{
    my ($this,$addr) = @_;
    my ($fam,$sdata) = unpack_sockaddr($addr);
    if ($fam == AF_UNIX) {
	$sdata = unpack_sockaddr_un($addr);
    }
    else {
	$sdata = $this->SUPER::format_addr($addr);
    }
    $sdata;
}

1;


# autoloaded methods go after the END token (& pod) below

__END__