addrinfo.pm | searchcode

/dnssec-tools-1.13/tools/modules/Net-addrinfo/addrinfo.pm

#
Perl | 297 lines | 207 code | 70 blank | 20 comment | 26 complexity | 69ac09b8bf40ce22f415c8921271f5c6 MD5 | raw file
Possible License(s): BSD-3-Clause

#
#    addrinfo.pm -- Perl 5 interface to getaddrinfo(3) and related structs
#
#    written by G. S. Marzot (marz@users.sourceforge.net)
#
#    Copyright (c) 2006-2009 G. S. Marzot. All rights reserved.
#
#    Copyright (c) 2006-2012 SPARTA, Inc.  All rights reserved.
#
#    This program is free software; you can redistribute it and/or
#    modify it under the same terms as Perl itself.
#
package Net::addrinfo;
use Socket qw(:all);
use Carp;

our $VERSION = '1.02';   # current release version number

use Exporter;
use DynaLoader;

sub AUTOLOAD {
    my $sub = $AUTOLOAD;
    (my $constname = $sub) =~ s/.*:://;

    my $val = (exists $LOCAL_CONSTANTS{$constname} ? 
	       $LOCAL_CONSTANTS{$constname} : constant($constname));
    if (not defined $val) {
	croak "Your vendor has not defined constant $constname";
    }
    *$sub = sub { $val }; # same as: eval "sub $sub { $val }";
    goto &$sub;
}

our @ISA = qw(Exporter DynaLoader);

# our @EXPORT = qw( getaddrinfo );

our @AI_FLAGS = qw(AI_NUMERICHOST AI_NUMERICSERV AI_PASSIVE AI_V4MAPPED AI_ADDRCONFIG AI_ALL AI_CANONIDN AI_CANONNAME AI_IDN AI_IDN_ALLOW_UNASSIGNED AI_IDN_USE_STD3_ASCII_RULES);

#hack to make up for missing constants - should be provided with 'Socket'
our %LOCAL_CONSTANTS = qw(IPPROTO_IP 0 IPPROTO_HOPOPTS 0 IPPROTO_ICMP 1 IPPROTO_IGMP 2 IPPROTO_IPIP 4 IPPROTO_EGP 8 IPPROTO_PUP 12 IPPROTO_UDP 17 IPPROTO_IDP 22 IPPROTO_TP 29 IPPROTO_IPV6 41 IPPROTO_ROUTING 43 IPPROTO_FRAGMENT 44 IPPROTO_RSVP 46 IPPROTO_GRE 47 IPPROTO_ESP 50 IPPROTO_AH 51 IPPROTO_ICMPV6 58 IPPROTO_NONE 59 IPPROTO_RAW 255 IPPROTO_DSTOPTS 60 IPPROTO_MTP 92 IPPROTO_ENCAP 98 IPPROTO_PIM 103 IPPROTO_COMP 108 IPPROTO_SCTP 132);

our @EXPORT = qw(getaddrinfo gai_strerror AI_ADDRCONFIG AI_ALL AI_CANONIDN AI_CANONNAME AI_IDN AI_IDN_ALLOW_UNASSIGNED AI_IDN_USE_STD3_ASCII_RULES AI_NUMERICHOST AI_NUMERICSERV AI_PASSIVE AI_V4MAPPED EAI_ADDRFAMILY EAI_AGAIN EAI_ALLDONE EAI_BADFLAGS EAI_CANCELED EAI_FAIL EAI_FAMILY EAI_IDN_ENCODE EAI_INPROGRESS EAI_INTR EAI_MEMORY EAI_NODATA EAI_NONAME EAI_NOTCANCELED EAI_OVERFLOW EAI_SERVICE EAI_SOCKTYPE EAI_BADHINTS EAI_SYSTEM GAI_NOWAIT GAI_WAIT NI_DGRAM NI_IDN NI_IDN_ALLOW_UNASSIGNED NI_IDN_USE_STD3_ASCII_RULES NI_MAXHOST NI_MAXSERV NI_NAMEREQD NI_NOFQDN NI_NUMERICHOST NI_NUMERICSERV IPPROTO_IP IPPROTO_HOPOPTS IPPROTO_ICMP IPPROTO_IGMP IPPROTO_IPIP IPPROTO_EGP IPPROTO_PUP IPPROTO_UDP IPPROTO_IDP IPPROTO_TP IPPROTO_IPV6 IPPROTO_ROUTING IPPROTO_FRAGMENT IPPROTO_RSVP IPPROTO_GRE IPPROTO_ESP IPPROTO_AH IPPROTO_ICMPV6 IPPROTO_NONE IPPROTO_RAW IPPROTO_DSTOPTS IPPROTO_MTP IPPROTO_ENCAP IPPROTO_PIM IPPROTO_COMP IPPROTO_SCTP);

bootstrap Net::addrinfo;

sub new {
    my $type = shift;
    my $self = {flags=>0, family=>0, socktype=>0, protocol=>0, addrlen=>0,
		addr=>undef, cannonname=>undef};
    my %params = @_;
    @$self{keys %params} = values %params;

    bless $self, $type;
}

sub flags {
    my $self = shift;

    if (@_) {
	$self->{flags} = scalar(shift);
    }
    return $self->{flags};
}

sub family {
    my $self = shift;

    if (@_) {
	$self->{family} = int(shift);
    }
    return $self->{family};
}

sub socktype {
    my $self = shift;

    if (@_) {
	$self->{socktype} = int(shift);
    }
    return $self->{socktype};
}

sub protocol {
    my $self = shift;

    if (@_) {
	$self->{protocol} = int(shift);
    }
    return $self->{protocol};
}

sub addrlen {
    my $self = shift;

    if (@_) {
	$self->{addrlen} = int(shift);
    }

    return $self->{addrlen};
}

sub addr {
    my $self = shift;

    if (@_) {
	$self->{addr} = scalar(shift);
    }
    return $self->{addr};
}

sub canonname {
    my $self = shift;

    if (@_) {
	$self->{canonname} = scalar(shift);
    }
    return $self->{canonname};
}

# special accessor sub for val_addrinfo structures in support of DNSSEC
# note: not present ot relevant for non-DNSSEC applications
sub val_status {
    my $self = shift;

    if (@_) {
	$self->{val_status} = scalar(shift);
    }
    return $self->{val_status};
}

sub stringify {
    my $self = shift;
    my $dstr;

    $dstr .= "{\n";
    my $flags = join('|',grep {$self->flags & eval("\&$_;");}@AI_FLAGS);
    $dstr .= "\tai_flags = ($flags)\n";
    my $family = $self->family;
    $family = (($family == AF_UNSPEC) ? "AF_UNSPEC" : 
	       (($family == AF_INET) ? "AF_INET" : 
		(($family == AF_INET6) ? "AF_INET6" : "Unknown")));
    $dstr .= "\tai_family = $family\n"; 
    my $socktype =  $self->socktype;
    $socktype = (($socktype == SOCK_STREAM) ? "SOCK_STREAM" :
		 (($socktype == SOCK_DGRAM) ? "SOCK_DGRAM" :
		  (($socktype == SOCK_RAW) ? "SOCK_RAW" : "Unknown")));
    $dstr .= "\tai_socktype = $socktype\n"; 
    my $protocol = $self->protocol;

    $protocol = (($protocol == IPPROTO_UDP()) ? "IPPROTO_UDP" :
		 (($protocol == IPPROTO_TCP) ? "IPPROTO_TCP" :
		  (($protocol == IPPROTO_IP()) ? "IPPROTO_IP" : "Unknown")));
    $dstr .= "\tai_protocol = $protocol\n";
    my $addrlen = $self->addrlen || length($self->addr);
    $dstr .= "\tai_addrlen = $addrlen\n";
    my $addr;
    if ($self->addr) {
	if ($self->family == AF_INET) { 
	    my ($port,$iaddr) = unpack_sockaddr_in($self->addr);
	    $addr = "($port, " . inet_ntoa($iaddr) . ")";
#	} elsif ($self->family == AF_INET6) {
#	    
# XXX needs implementation
	} else {
	    $addr = "0x" . unpack("H*",$self->addr);
	}
    }
    $dstr .= "\tai_addr = $addr\n";
    my $canonname = (defined $self->canonname ? $self->canonname : "<undef>");
    $dstr .= "\tai_canonname = $canonname\n";
    if (exists $self->{val_status}) {
	my $val_status = $self->val_status;
	$dstr .= "\tai_val_status = $val_status\n";
    }
    $dstr .= "}\n";
    
    return $dstr;
}


sub getaddrinfo { 
    my $node = shift;
    my $service = shift;
    my $hints = shift;

    my $result = Net::addrinfo::_getaddrinfo($node, $service, $hints); 
    
    $result = [$result] unless ref $result eq 'ARRAY';
    
    return (wantarray ? @$result : shift(@$result)); 
}

sub gai_strerror {
    my $errstr = Net::addrinfo::_gai_strerror(@_);

    return $errstr;
}

sub DESTROY {
#    print STDERR "addrinfo:DESTROY\n";
}

1;
__END__

=head1 NAME

Net::addrinfo - interface to POSIX getaddrinfo(3) and related
constants, structures and functions.

=head1 SYNOPSIS

 use Net::addrinfo;
 my $ainfo = getaddrinfo("www.marzot.net");

=head1 DESCRIPTION

This Perl module is designed to implement and export functionality
related to the POSIX getaddrinfo(3) system call. The Net::addrinfo
data object is provided with field name accsessor functions, similarly
named to the the C data structure definition in F<netdb.h>. The
getaddrinfo(3), gai_strerror(3) calls, and related constants are
exported.

The getaddrinfo() routine mimics the POSIX documented funtion (see
system man page getaddrinfo(3)). 

On success the getaddrinfo() will return an array of Net::addrinfo
data objects.

In scalar context getaddrinfo() will return the first element from the
Net::addrinfo array. 

In case of error, a numeric error code is returned.

The error code may be passed to gai_strerror() to get a string
representation of the error.

New Net::addrinfo objects may be created with the package constructor
and any number (or none) of the fields may be specified. 

   flags => scalar integer
   family => scalar integer (e.g., AF_INET,m AF_INET6, etc.)
   socktype => scalar integer (e.g., SOCK_DGRAM, SOCK_STREAM, etc.)
   protocol => scalar integer (e.g., IPPROTO_UDP, IPPROTO_TCP, etc.)
   addrlen => scalar integer (can be computed by length($self->addr))
   addr => packed bytes (e.g., $self->addr(inet_aton("192.168.1.1")); )

Flags may be set in the structure so that it may be used as a 'hint'
parameter to the getaddrinfo() function. See exported @AI_FLAGS for
list of acceptable constants.

(Note: a special scalar integer field, 'val_status', is provided in
support of DNSSEC aware addrinfo results (see Net::DNS::SEC::Validator))


=head1 EXAMPLES

 use Net::addrinfo;
 use Socket qw(:all);

 my $hint = new Net::addrinfo(flags => AI_CANONNAME,
                              family => AF_INET, 
                              socktype => SOCK_DGRAM);

 my (@ainfo) = getaddrinfo("www.marzot.net", "http", $hint);

 foreach $ainfo (@ainfo) {
    if (ref $ainfo eq 'Net::addrinfo') {
       print $ainfo->stringify(), "\n";
       print "addr = ", inet_ntoa($ainfo->addr), "\n";
       ...
       connect(SH, $ainfo->addr);
     } else {
        print "Error($ainfo):", gai_strerror($ainfo), "\n";
     }
 }

=head1 NOTE

One should not rely on the internal representation of this class.

=head1 AUTHOR

G. S. Marzot (marz@users.sourceforge.net)

=head1 COPYRIGHT AND LICENSE

   Copyright (c) 2006 G. S. Marzot. All rights reserved.  This program
   is free software; you can redistribute it and/or modify it under
   the same terms as Perl itself.

   Copyright (c) 2006-2008 SPARTA, Inc.  All Rights Reserved.  This program
   is free software; you can redistribute it and/or modify it under
   the same terms as Perl itself.