| Current Path : /usr/local/lib/perl5/site_perl/5.8.9/IO/Socket/ |
FreeBSD hs32.drive.ne.jp 9.1-RELEASE FreeBSD 9.1-RELEASE #1: Wed Jan 14 12:18:08 JST 2015 root@hs32.drive.ne.jp:/sys/amd64/compile/hs32 amd64 |
| Current File : //usr/local/lib/perl5/site_perl/5.8.9/IO/Socket/INET6.pm |
# IO::Socket::INET6.pm
#
# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Modified by Rafael Martinez-Torres <rafael.martinez@novagnet.com>
# Euro6IX project (www.euro6ix.org) 2003.
package IO::Socket::INET6;
use strict;
use warnings;
our(@ISA, $VERSION);
use IO::Socket;
use Socket;
# IO::Socket and Socket already import stuff here - possibly AF_INET6
# and PF_INET6 so selectively import things from Socket6.
use Socket6 (
qw(AI_PASSIVE inet_ntop inet_pton getaddrinfo
sockaddr_in6 unpack_sockaddr_in6_all pack_sockaddr_in6_all)
);
use Carp;
use Exporter;
use Errno;
@ISA = qw(IO::Socket);
$VERSION = "2.56";
#Purpose: allow protocol independent protocol and original interface.
my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1;
IO::Socket::INET6->register_domain( AF_INET6 );
my %socket_type = ( tcp => SOCK_STREAM,
udp => SOCK_DGRAM,
icmp => SOCK_RAW
);
sub new {
my $class = shift;
unshift(@_, "PeerAddr") if @_ == 1;
return $class->SUPER::new(@_);
}
#Parsing analisis:
# addr,port,and proto may be sintactically related...
sub _sock_info {
my($addr,$port,$proto) = @_;
my $origport = $port;
my @proto = ();
my @serv = ();
if (defined $addr) {
if (!inet_pton(AF_INET6,$addr)) {
if($addr =~ s,^\[([\da-fA-F:]+)\]:([\w\(\)/]+)$,$1,) {
$port = $2;
} elsif($addr =~ s,^\[(::[\da-fA-F.:]+)\]:([\w\(\)/]+)$,$1,) {
$port = $2;
} elsif($addr =~ s,^\[([\da-fA-F:]+)\],$1,) {
$port = $origport;
} elsif($addr =~ s,:([\w\(\)/]+)$,,) {
$port = $1
}
}
}
# $proto as "string".
if(defined $proto && $proto =~ /\D/) {
if(@proto = getprotobyname($proto)) {
$proto = $proto[2] || undef;
}
else {
$@ = "Bad protocol '$proto'";
return;
}
}
if(defined $port) {
my $defport = ($port =~ s,\((\d+)\)$,,) ? $1 : undef;
my $pnum = ($port =~ m,^(\d+)$,)[0];
@serv = getservbyname($port, $proto[0] || "")
if ($port =~ m,\D,);
$port = $serv[2] || $defport || $pnum;
unless (defined $port) {
$@ = "Bad service '$origport'";
return;
}
$proto = (getprotobyname($serv[3]))[2] || undef
if @serv && !$proto;
}
#printf "Selected port is $port and proto is $proto \n";
return ($addr || undef,
$port || undef,
$proto || undef,
);
}
sub _error {
my $sock = shift;
my $err = shift;
{
local($!);
my $title = ref($sock).": ";
$@ = join("", $_[0] =~ /^$title/ ? "" : $title, @_);
close($sock)
if(defined fileno($sock));
}
$! = $err;
return undef;
}
sub configure {
my($sock,$arg) = @_;
my($lport,$rport,$laddr,$rpoty,$raddr,$family,$proto,$type);
my($lres,$rres);
$arg->{LocalAddr} = $arg->{LocalHost}
if exists $arg->{LocalHost} && !exists $arg->{LocalAddr};
# Syntax Parsing...
($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
$arg->{LocalPort},
$arg->{Proto})
or return _error($sock, $!, "sock_info: $@");
$laddr ||= '';
$lport ||= 0;
$family = $arg->{Domain} || AF_UNSPEC;
# MSWin32 expects at least one of $laddr or $lport to be specified
# and does not accept 0 for $lport if $laddr is specified.
if ($^O eq 'MSWin32') {
if ((!$laddr) && (!$lport)) {
$laddr = ($family == AF_INET) ? '0.0.0.0' : '::';
$lport = '';
} elsif (!$lport) {
$lport = '';
}
}
$proto ||= (getprotobyname('tcp'))[2];
$type = $arg->{Type} || $socket_type{(getprotobynumber($proto))[0]};
$arg->{PeerAddr} = $arg->{PeerHost}
if exists $arg->{PeerHost} && !exists $arg->{PeerAddr};
unless(exists $arg->{Listen}) {
($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},$arg->{PeerPort},
$proto)
or return _error($sock, $!, "sock_info: $@");
}
$sock->blocking($arg->{Blocking}) if defined $arg->{Blocking};
# Previously IO-Socket-INET6 tried to bind even when one side
# is AF_INET and the other AF_INET6 and this cannot work.
#
# The FAMILY_CHECK loop is meant to make sure both sides have
# the same family.
my @families;
if ($family == AF_UNSPEC) {
@families = (AF_INET6, AF_INET);
} else {
@families = ($family);
}
my $ok = 0;
my $msg;
my @lres;
my @rres;
FAMILY_CHECK:
for my $fam (@families) {
@lres = getaddrinfo(
$laddr,$lport,$fam,$type,$proto,AI_PASSIVE
);
if (scalar(@lres) < 5) {
$msg = $lres[0];
next FAMILY_CHECK;
}
if (defined $raddr) {
@rres = getaddrinfo(
$raddr,$rport,$fam,$type,$proto,AI_PASSIVE
);
if (scalar(@rres) >= 5) {
$ok = 1;
last FAMILY_CHECK;
}
else {
$msg = $rres[0];
}
}
else {
$ok = 1;
last FAMILY_CHECK;
}
}
if (! $ok)
{
return _error($sock, $EINVAL, "getaddrinfo: $msg");
}
LOOP_LRES: while(1) {
$family = (exists $arg->{PeerAddr})? ($rres[0]):($lres[0]) ; # One concrete family.
#printf "DEBUG $family \n";
my $fam_listen;
($fam_listen,undef,undef,$lres,undef,@lres) = @lres;
if ($fam_listen != $family)
{
next LOOP_LRES;
}
if ($lres && $family == AF_INET6) {
if ($arg->{LocalFlow} || $arg->{LocalScope}) {
my @sa_in6 = unpack_sockaddr_in6_all($lres);
$sa_in6[1] = $arg->{LocalFlow} || 0;
$sa_in6[3] = _scope_ntohl($arg->{LocalScope}) || 0;
$lres = pack_sockaddr_in6_all(@sa_in6);
}
}
$sock->socket($family, $type, $proto) or
return _error($sock, $!, "socket: $!");
if ($arg->{Reuse} || $arg->{ReuseAddr}) {
$sock->sockopt(SO_REUSEADDR,1) or
return _error($sock, $!, "sockopt: $!");
}
if ($arg->{ReusePort}) {
$sock->sockopt(SO_REUSEPORT,1) or
return _error($sock, $!, "sockopt: $!");
}
if ($arg->{Broadcast}) {
$sock->sockopt(SO_BROADCAST,1) or
return _error($sock, $!, "sockopt: $!");
}
if($lres || exists $arg->{Listen}) {
$sock->bind($lres) or
return _error($sock, $!, "bind: $!");
}
if(exists $arg->{Listen}) {
$sock->listen($arg->{Listen} || 5) or
return _error($sock, $!, "listen: $!");
last;
}
# don't try to connect unless we're given a PeerAddr
last unless exists($arg->{PeerAddr});
(undef ,undef , undef, $rres,undef , @rres) = @rres;
if ($rres && $family == AF_INET6) {
if ($arg->{PeerFlow} || $arg->{PeerScope}) {
my @sa_in6 = unpack_sockaddr_in6_all($rres);
$sa_in6[1] = $arg->{PeerFlow} || 0;
$sa_in6[3] = _scope_ntohl($arg->{PeerScope}) || 0;
$rres = pack_sockaddr_in6_all(@sa_in6);
}
}
last
unless($type == SOCK_STREAM || defined $rres);
# return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'")
# unless (defined $rres);
# my $timeout = ${*$sock}{'io_socket_timeout'};
# my $before = time() if $timeout;
undef $@;
if ($sock->connect($rres)) {
# ${*$sock}{'io_socket_timeout'} = $timeout;
return $sock;
}
#
# GOOD !!!
return _error($sock, $!, $@ || "Timeout")
unless ((scalar(@rres)>=5) && ($arg->{MultiHomed}));
# if ($timeout) {
# my $new_timeout = $timeout - (time() - $before);
# return _error($sock,
# (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL),
# "Timeout") if $new_timeout <= 0;
# ${*$sock}{'io_socket_timeout'} = $new_timeout;
# }
}
$sock;
}
sub _scope_ntohl($)
{
# As of Socket6 0.17 the scope field is incorrectly put into
# network byte order when it should be in host byte order
# in the sockaddr_in6 structure. We correct for that here.
if ((Socket6->VERSION <= 0.17) && (pack('s', 0x1234) ne pack('n', 0x1234)))
{
unpack('N', pack('V', $_[0]));
} else {
$_[0];
}
}
sub sockdomain
{
my $sock = shift;
$sock->SUPER::sockdomain(@_) || AF_INET6;
}
sub accept
{
my $sock = shift;
my ($new, $peer) = $sock->SUPER::accept(@_);
return unless defined($new);
${*$new}{io_socket_domain} = ${*$sock}{io_socket_domain};
${*$new}{io_socket_type} = ${*$sock}{io_socket_type};
${*$new}{io_socket_proto} = ${*$sock}{io_socket_proto};
return wantarray ? ($new, $peer) : $new;
}
sub bind {
@_ == 2 or
croak 'usage: $sock->bind(NAME) ';
my $sock = shift;
return $sock->SUPER::bind( shift );
}
sub connect {
@_ == 2 or
croak 'usage: $sock->connect(NAME) ';
my $sock = shift;
return $sock->SUPER::connect( shift );
}
sub sockaddr {
@_ == 1 or croak 'usage: $sock->sockaddr()';
my ($sock) = @_;
return undef unless (my $name = $sock->sockname);
($sock->sockdomain == AF_INET) ? (sockaddr_in($name))[1] : (sockaddr_in6($name))[1];
}
sub sockport {
@_ == 1 or croak 'usage: $sock->sockport()';
my($sock) = @_;
return undef unless (my $name = $sock->sockname);
($sock->sockdomain == AF_INET) ? (sockaddr_in($name))[0] : (sockaddr_in6($name))[0];
}
sub sockhost {
@_ == 1 or croak 'usage: $sock->sockhost()';
my ($sock) = @_;
return undef unless (my $addr = $sock->sockaddr);
inet_ntop($sock->sockdomain, $addr);
}
sub sockflow
{
@_ == 1 or croak 'usage: $sock->sockflow()';
my ($sock) = @_;
return undef unless (my $name = $sock->sockname);
($sock->sockdomain == AF_INET6) ? (unpack_sockaddr_in6_all($name))[1] : 0;
}
sub sockscope
{
@_ == 1 or croak 'usage: $sock->sockscope()';
my ($sock) = @_;
return undef unless (my $name = $sock->sockname);
_scope_ntohl(($sock->sockdomain == AF_INET6) ? (unpack_sockaddr_in6_all($name))[3] : 0);
}
sub peeraddr {
@_ == 1 or croak 'usage: $sock->peeraddr()';
my ($sock) = @_;
return undef unless (my $name = $sock->peername);
($sock->sockdomain == AF_INET) ? (sockaddr_in($name))[1] : (sockaddr_in6($name))[1];
}
sub peerport {
@_ == 1 or croak 'usage: $sock->peerport()';
my($sock) = @_;
return undef unless (my $name = $sock->peername);
($sock->sockdomain == AF_INET) ? (sockaddr_in($name))[0] : (sockaddr_in6($name))[0];
}
sub peerhost {
@_ == 1 or croak 'usage: $sock->peerhost()';
my ($sock) = @_;
return undef unless (my $addr = $sock->peeraddr);
inet_ntop($sock->sockdomain, $addr);
}
sub peerflow
{
@_ == 1 or croak 'usage: $sock->peerflow()';
my ($sock) = @_;
return undef unless (my $name = $sock->peername);
_scope_ntohl(($sock->sockdomain == AF_INET6) ? (unpack_sockaddr_in6_all($name))[1] : 0);
}
sub peerscope
{
@_ == 1 or croak 'usage: $sock->peerscope()';
my ($sock) = @_;
return undef unless (my $name = $sock->peername);
($sock->sockdomain == AF_INET6) ? (unpack_sockaddr_in6_all($name))[3] : 0;
}
1;
__END__
=head1 NAME
IO::Socket::INET6 - Object interface for AF_INET|AF_INET6 domain sockets
=head1 SYNOPSIS
use IO::Socket::INET6;
=head1 DESCRIPTION
C<IO::Socket::INET6> provides an object interface to creating and using sockets
in either AF_INET or AF_INET6 domains. It is built upon the L<IO::Socket> interface and
inherits all the methods defined by L<IO::Socket>.
=head1 CONSTRUCTOR
=over 4
=item new ( [ARGS] )
Creates an C<IO::Socket::INET6> object, which is a reference to a
newly created symbol (see the C<Symbol> package). C<new>
optionally takes arguments, these arguments are in key-value pairs.
In addition to the key-value pairs accepted by L<IO::Socket>,
C<IO::Socket::INET6> provides.
Domain Address family AF_INET | AF_INET6 | AF_UNSPEC (default)
PeerAddr Remote host address <hostname>[:<port>]
PeerHost Synonym for PeerAddr
PeerPort Remote port or service <service>[(<no>)] | <no>
PeerFlow Remote flow information
PeerScope Remote address scope
LocalAddr Local host bind address hostname[:port]
LocalHost Synonym for LocalAddr
LocalPort Local host bind port <service>[(<no>)] | <no>
LocalFlow Local host flow information
LocalScope Local host address scope
Proto Protocol name (or number) "tcp" | "udp" | ...
Type Socket type SOCK_STREAM | SOCK_DGRAM | ...
Listen Queue size for listen
ReuseAddr Set SO_REUSEADDR before binding
Reuse Set SO_REUSEADDR before binding (deprecated, prefer ReuseAddr)
ReusePort Set SO_REUSEPORT before binding
Broadcast Set SO_BROADCAST before binding
Timeout Timeout value for various operations
MultiHomed Try all adresses for multi-homed hosts
Blocking Determine if connection will be blocking mode
If C<Listen> is defined then a listen socket is created, else if the
socket type, which is derived from the protocol, is SOCK_STREAM then
connect() is called.
Although it is not illegal, the use of C<MultiHomed> on a socket
which is in non-blocking mode is of little use. This is because the
first connect will never fail with a timeout as the connect call
will not block.
The C<PeerAddr> can be a hostname, the IPv6-address on the
"2001:800:40:2a05::10" form , or the IPv4-address on the "213.34.234.245" form.
The C<PeerPort> can be a number or a symbolic
service name. The service name might be followed by a number in
parenthesis which is used if the service is not known by the system.
The C<PeerPort> specification can also be embedded in the C<PeerAddr>
by preceding it with a ":", and closing the IPv6 address on bracktes "[]" if
necessary: "124.678.12.34:23","[2a05:345f::10]:23","any.server.com:23".
If C<Domain> is not given, AF_UNSPEC is assumed, that is, both AF_INET and AF_INET6 will
be both considered when resolving DNS names. AF_INET6 is prioritary.
If you guess you are in trouble not reaching the peer,(the service is not available via
AF_INET6 but AF_INET) you can either try Multihomed (try any address/family until reach)
or concrete your address C<family> (AF_INET, AF_INET6).
If C<Proto> is not given and you specify a symbolic C<PeerPort> port,
then the constructor will try to derive C<Proto> from the service
name. As a last resort C<Proto> "tcp" is assumed. The C<Type>
parameter will be deduced from C<Proto> if not specified.
If the constructor is only passed a single argument, it is assumed to
be a C<PeerAddr> specification.
If C<Blocking> is set to 0, the connection will be in nonblocking mode.
If not specified it defaults to 1 (blocking mode).
Examples:
$sock = IO::Socket::INET6->new(PeerAddr => 'www.perl.org',
PeerPort => 'http(80)',
Proto => 'tcp');
Suppose either you have no IPv6 connectivity or www.perl.org has no http service on IPv6. Then,
(Trying all address/families until reach)
$sock = IO::Socket::INET6->new(PeerAddr => 'www.perl.org',
PeerPort => 'http(80)',
Multihomed => 1 ,
Proto => 'tcp');
(Concrete to IPv4 protocol)
$sock = IO::Socket::INET6->new(PeerAddr => 'www.perl.org',
PeerPort => 'http(80)',
Domain => AF_INET ,
Proto => 'tcp');
$sock = IO::Socket::INET6->new(PeerAddr => 'localhost:smtp(25)');
$sock = IO::Socket::INET6->new(Listen => 5,
LocalAddr => 'localhost',
LocalPort => 9000,
Proto => 'tcp');
$sock = IO::Socket::INET6->new('[::1]:25');
$sock = IO::Socket::INET6->new(PeerPort => 9999,
PeerAddr => inet_ntop(AF_INET6,in6addr_broadcast),
Proto => udp,
LocalAddr => 'localhost',
Broadcast => 1 )
or die "Can't bind : $@\n";
NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
As of VERSION 1.18 all IO::Socket objects have autoflush turned on
by default. This was not the case with earlier releases.
NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE
=back
=head2 METHODS
=over 4
=item accept ()
See L<IO::Socket::INET>.
=item bind ()
See L<IO::Socket::INET>.
=item configure ()
This function exists in this module, but I (= Shlomi Fish) don't know what it
does, or understand it. It's also not tested anywhere. I'll be happy to be
enlightened.
=item connect ()
See L<IO::Socket::INET>.
=item sockaddr ()
Return the address part of the sockaddr structure for the socket
=item sockdomain()
Returns the domain of the socket - AF_INET or AF_INET6 or whatever.
=item sockport ()
Return the port number that the socket is using on the local host
=item sockhost ()
Return the address part of the sockaddr structure for the socket in a
text form ("2001:800:40:2a05::10" or "245.245.13.27")
=item sockflow ()
Return the flow information part of the sockaddr structure for the socket
=item sockscope ()
Return the scope identification part of the sockaddr structure for the socket
=item peeraddr ()
Return the address part of the sockaddr structure for the socket on
the peer host
=item peerport ()
Return the port number for the socket on the peer host.
=item peerhost ()
Return the address part of the sockaddr structure for the socket on the
peer host in a text form ("2001:800:40:2a05::10" or "245.245.13.27")
=item peerflow ()
Return the flow information part of the sockaddr structure for the socket
on the peer host
=item peerscope ()
Return the scope identification part of the sockaddr structure for the socket
on the peer host
=back
=head1 REPOSITORY
The Subversion repository for this module carrying complete version history
and other information is:
L<http://svn.berlios.de/svnroot/repos/web-cpan/IO-Socket-INET6/>
=head1 SEE ALSO
L<Socket>,L<Socket6>, L<IO::Socket>
=head1 AUTHOR
This program is based on L<IO::Socket::INET> by Graham Barr
<gbarr@pobox.com> and currently maintained by the Perl Porters.
Modified by Rafael Martinez Torres <rafael.martinez@novagnet.com> and
Euro6IX project.
Modified further by Shlomi Fish <shlomif@iglu.org.il>, while disclaiming
all copyrights.
=head1 COPYRIGHT
Copyright (c) 2003- Rafael Martinez Torres <rafael.martinez@novagnet.com>.
Copyright (c) 2003- Euro6IX project.
Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>.
All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut