diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Socket.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/Socket.pm | 398 |
1 files changed, 383 insertions, 15 deletions
diff --git a/Master/tlpkg/tlperl/lib/Socket.pm b/Master/tlpkg/tlperl/lib/Socket.pm index 51bf28a333c..aa3fe3fff80 100644 --- a/Master/tlpkg/tlperl/lib/Socket.pm +++ b/Master/tlpkg/tlperl/lib/Socket.pm @@ -1,7 +1,9 @@ package Socket; +use strict; + our($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); -$VERSION = "1.87_01"; +$VERSION = "1.94"; =head1 NAME @@ -112,6 +114,16 @@ Note - does not return a number. Returns the 4-byte 'invalid' ip address. Normally equivalent to inet_aton('255.255.255.255'). +=item IN6ADDR_ANY + +Returns the 16-byte wildcard IPv6 address. Normally equivalent +to inet_pton(AF_INET6, "::") + +=item IN6ADDR_LOOPBACK + +Returns the 16-byte loopback IPv6 address. Normally equivalent +to inet_pton(AF_INET6, "::1") + =item sockaddr_family SOCKADDR Takes a sockaddr structure (as returned by pack_sockaddr_in(), @@ -147,6 +159,29 @@ representing the IP address (you can use inet_ntoa() to convert the address to the four-dotted numeric format). Will croak if the structure does not have AF_INET in the right place. +=item sockaddr_in6 PORT, IP6_ADDRESS, [ SCOPE_ID, [ FLOWINFO ] ] + +=item sockaddr_in6 SOCKADDR_IN6 + +In list context, unpacks its SOCKADDR_IN6 argument according to +unpack_sockaddr_in6(). In scalar context, packs its arguments according to +pack_sockaddr_in6(). + +=item pack_sockaddr_in6 PORT, IP6_ADDRESS, [ SCOPE_ID, [ FLOWINFO ] ] + +Takes two to four arguments, a port number, an opaque string (as returned by +inet_pton()), optionally a scope ID number, and optionally a flow label +number. Returns the sockaddr_in6 structure with those arguments packed in +with AF_INET6 filled in. IPv6 equivalent of pack_sockaddr_in(). + +=item unpack_sockaddr_in6 SOCKADDR_IN6 + +Takes a sockaddr_in6 structure (as returned by pack_sockaddr_in6()) and +returns an array of four elements: the port number, an opaque string +representing the IPv6 address, the scope ID, and the flow label. (You can +use inet_ntop() to convert the address to the usual string format). Will +croak if the structure does not have AF_INET6 in the right place. + =item sockaddr_un PATHNAME =item sockaddr_un SOCKADDR_UN @@ -178,7 +213,7 @@ the name of a host, and translates that to an opaque string (if programming in C, struct in_addr or struct in6_addr depending on the address family passed in). The host string may be a string hostname, such as 'www.perl.org', or an IP address. If using an IP address, the type of -IP address must be consistant with the address family passed into the function. +IP address must be consistent with the address family passed into the function. This function is not exported by default. @@ -190,6 +225,84 @@ translates it to an IPv4 or IPv6 address string. This function is not exported by default. +=item getaddrinfo HOST, SERVICE, [ HINTS ] + +Given at least one of a hostname and a service name, returns a list of address +structures to listen on or connect to. HOST and SERVICE should be plain +strings (or a numerical port number for SERVICE). If present, HINTS should be +a reference to a HASH, where the following keys are recognised: + +=over 8 + +=item flags => INT + +A bitfield containing C<AI_*> constants + +=item family => INT + +Restrict to only generating addresses in this address family + +=item socktype => INT + +Restrict to only generating addresses of this socket type + +=item protocol => INT + +Restrict to only generating addresses for this protocol + +=back + +The return value will be a list; the first value being an error indication, +followed by a list of address structures (if no error occured). + + my ( $err, @results ) = getaddrinfo( ... ); + +The error value will be a dualvar; comparable to the C<EI_*> error constants, +or printable as a human-readable error message string. Each value in the +results list will be a HASH reference containing the following fields: + +=over 8 + +=item family => INT + +The address family (e.g. AF_INET) + +=item socktype => INT + +The socket type (e.g. SOCK_STREAM) + +=item protocol => INT + +The protocol (e.g. IPPROTO_TCP) + +=item addr => STRING + +The address in a packed string (such as would be returned by pack_sockaddr_in) + +=item canonname => STRING + +The canonical name for the host if the C<AI_CANONNAME> flag was provided, or +C<undef> otherwise. This field will only be present on the first returned +address. + +=back + +=item getnameinfo ADDR, FLAGS + +Given a packed socket address (such as from C<getsockname>, C<getpeername>, or +returned by C<getaddrinfo> in a C<addr> field), returns the hostname and +symbolic service name it represents. FLAGS may be a bitmask of C<NI_*> +constants, or defaults to 0 if unspecified. + +The return value will be a list; the first value being an error condition, +followed by the hostname and service name. + + my ( $err, $host, $service ) = getnameinfo( ... ); + +The error value will be a dualvar; comparable to the C<EI_*> error constants, +or printable as a human-readable error message string. The host and service +names will be plain strings. + =back =cut @@ -198,14 +311,18 @@ use Carp; use warnings::register; require Exporter; -use XSLoader (); +require XSLoader; @ISA = qw(Exporter); + +# <@Nicholas> you can't change @EXPORT without breaking the implicit API +# Please put any new constants in @EXPORT_OK! @EXPORT = qw( inet_aton inet_ntoa sockaddr_family pack_sockaddr_in unpack_sockaddr_in pack_sockaddr_un unpack_sockaddr_un - sockaddr_in sockaddr_un + pack_sockaddr_in6 unpack_sockaddr_in6 + sockaddr_in sockaddr_in6 sockaddr_un INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE AF_802 AF_AAL @@ -366,6 +483,26 @@ use XSLoader (); inet_pton inet_ntop + getaddrinfo + getnameinfo + + IN6ADDR_ANY IN6ADDR_LOOPBACK + + AI_CANONNAME + AI_NUMERICHOST + AI_NUMERICSERV + AI_PASSIVE + + EAI_ADDRFAMILY + EAI_AGAIN + EAI_BADFLAGS + EAI_FAIL + EAI_FAMILY + EAI_NODATA + EAI_NONAME + EAI_SERVICE + EAI_SOCKTYPE + IPPROTO_IP IPPROTO_IPV6 IPPROTO_RAW @@ -373,11 +510,28 @@ use XSLoader (); IPPROTO_TCP IPPROTO_UDP + NI_DGRAM + NI_NAMEREQD + NI_NUMERICHOST + NI_NUMERICSERV + TCP_KEEPALIVE TCP_MAXRT TCP_MAXSEG TCP_NODELAY - TCP_STDURG); + TCP_STDURG + TCP_CORK + TCP_KEEPIDLE + TCP_KEEPINTVL + TCP_KEEPCNT + TCP_SYNCNT + TCP_LINGER2 + TCP_DEFER_ACCEPT + TCP_WINDOW_CLAMP + TCP_INFO + TCP_QUICKACK + TCP_CONGESTION + TCP_MD5SIG); %EXPORT_TAGS = ( crlf => [qw(CR LF CRLF $CR $LF $CRLF)], @@ -409,6 +563,17 @@ sub sockaddr_in { } } +sub sockaddr_in6 { + if (wantarray) { + croak "usage: (port,in6addr,scope_id,flowinfo) = sockaddr_in6(sin6_sv)" unless @_ == 1; + unpack_sockaddr_in6(@_); + } + else { + croak "usage: sin6_sv = sockaddr_in6(port,in6addr,[scope_id,[flowinfo]])" unless @_ >= 2 and @_ <= 4; + pack_sockaddr_in6(@_); + } +} + sub sockaddr_un { if (wantarray) { croak "usage: (filename) = sockaddr_un(sun_sv)" unless @_ == 1; @@ -419,18 +584,221 @@ sub sockaddr_un { } } -sub AUTOLOAD { - my($constname); - ($constname = $AUTOLOAD) =~ s/.*:://; - croak "&Socket::constant not defined" if $constname eq 'constant'; - my ($error, $val) = constant($constname); - if ($error) { - croak $error; +XSLoader::load(); + +my %errstr; + +if( defined &getaddrinfo ) { + # These are not part of the API, nothing uses them, and deleting them + # reduces the size of %Socket:: by about 12K + delete $Socket::{fake_getaddrinfo}; + delete $Socket::{fake_getnameinfo}; +} else { + require Scalar::Util; + + *getaddrinfo = \&fake_getaddrinfo; + *getnameinfo = \&fake_getnameinfo; + + # These numbers borrowed from GNU libc's implementation, but since + # they're only used by our emulation, it doesn't matter if the real + # platform's values differ + my %constants = ( + AI_PASSIVE => 1, + AI_CANONNAME => 2, + AI_NUMERICHOST => 4, + # RFC 2553 doesn't define this but Linux does - lets be nice and + # provide it since we can + AI_NUMERICSERV => 1024, + + EAI_BADFLAGS => -1, + EAI_NONAME => -2, + EAI_NODATA => -5, + EAI_FAMILY => -6, + EAI_SERVICE => -8, + + NI_NUMERICHOST => 1, + NI_NUMERICSERV => 2, + NI_NAMEREQD => 8, + NI_DGRAM => 16, + ); + + foreach my $name ( keys %constants ) { + my $value = $constants{$name}; + + no strict 'refs'; + defined &$name or *$name = sub () { $value }; } - *$AUTOLOAD = sub { $val }; - goto &$AUTOLOAD; + + %errstr = ( + # These strings from RFC 2553 + EAI_BADFLAGS() => "invalid value for ai_flags", + EAI_NONAME() => "nodename nor servname provided, or not known", + EAI_NODATA() => "no address associated with nodename", + EAI_FAMILY() => "ai_family not supported", + EAI_SERVICE() => "servname not supported for ai_socktype", + ); } -XSLoader::load 'Socket', $VERSION; +# The following functions are used if the system does not have a +# getaddrinfo(3) function in libc; and are used to emulate it for the AF_INET +# family + +# Borrowed from Regexp::Common::net +my $REGEXP_IPv4_DECIMAL = qr/25[0-5]|2[0-4][0-9]|1?[0-9][0-9]{1,2}/; +my $REGEXP_IPv4_DOTTEDQUAD = qr/$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL/; + +sub fake_makeerr +{ + my ( $errno ) = @_; + my $errstr = $errno == 0 ? "" : ( $errstr{$errno} || $errno ); + return Scalar::Util::dualvar( $errno, $errstr ); +} + +sub fake_getaddrinfo +{ + my ( $node, $service, $hints ) = @_; + + $node = "" unless defined $node; + + $service = "" unless defined $service; + + my ( $family, $socktype, $protocol, $flags ) = @$hints{qw( family socktype protocol flags )}; + + $family ||= Socket::AF_INET(); # 0 == AF_UNSPEC, which we want too + $family == Socket::AF_INET() or return fake_makeerr( EAI_FAMILY() ); + + $socktype ||= 0; + + $protocol ||= 0; + + $flags ||= 0; + + my $flag_passive = $flags & AI_PASSIVE(); $flags &= ~AI_PASSIVE(); + my $flag_canonname = $flags & AI_CANONNAME(); $flags &= ~AI_CANONNAME(); + my $flag_numerichost = $flags & AI_NUMERICHOST(); $flags &= ~AI_NUMERICHOST(); + my $flag_numericserv = $flags & AI_NUMERICSERV(); $flags &= ~AI_NUMERICSERV(); + + $flags == 0 or return fake_makeerr( EAI_BADFLAGS() ); + + $node eq "" and $service eq "" and return fake_makeerr( EAI_NONAME() ); + + my $canonname; + my @addrs; + if( $node ne "" ) { + return fake_makeerr( EAI_NONAME() ) if( $flag_numerichost and $node !~ m/^$REGEXP_IPv4_DOTTEDQUAD$/ ); + ( $canonname, undef, undef, undef, @addrs ) = gethostbyname( $node ); + defined $canonname or return fake_makeerr( EAI_NONAME() ); + + undef $canonname unless $flag_canonname; + } + else { + $addrs[0] = $flag_passive ? Socket::inet_aton( "0.0.0.0" ) + : Socket::inet_aton( "127.0.0.1" ); + } + + my @ports; # Actually ARRAYrefs of [ socktype, protocol, port ] + my $protname = ""; + if( $protocol ) { + $protname = getprotobynumber( $protocol ); + } + + if( $service ne "" and $service !~ m/^\d+$/ ) { + return fake_makeerr( EAI_NONAME() ) if( $flag_numericserv ); + getservbyname( $service, $protname ) or return fake_makeerr( EAI_SERVICE() ); + } + + foreach my $this_socktype ( Socket::SOCK_STREAM(), Socket::SOCK_DGRAM(), Socket::SOCK_RAW() ) { + next if $socktype and $this_socktype != $socktype; + + my $this_protname = "raw"; + $this_socktype == Socket::SOCK_STREAM() and $this_protname = "tcp"; + $this_socktype == Socket::SOCK_DGRAM() and $this_protname = "udp"; + + next if $protname and $this_protname ne $protname; + + my $port; + if( $service ne "" ) { + if( $service =~ m/^\d+$/ ) { + $port = "$service"; + } + else { + ( undef, undef, $port, $this_protname ) = getservbyname( $service, $this_protname ); + next unless defined $port; + } + } + else { + $port = 0; + } + + push @ports, [ $this_socktype, scalar getprotobyname( $this_protname ) || 0, $port ]; + } + + my @ret; + foreach my $addr ( @addrs ) { + foreach my $portspec ( @ports ) { + my ( $socktype, $protocol, $port ) = @$portspec; + push @ret, { + family => $family, + socktype => $socktype, + protocol => $protocol, + addr => Socket::pack_sockaddr_in( $port, $addr ), + canonname => undef, + }; + } + } + + # Only supply canonname for the first result + if( defined $canonname ) { + $ret[0]->{canonname} = $canonname; + } + + return ( fake_makeerr( 0 ), @ret ); +} + +sub fake_getnameinfo +{ + my ( $addr, $flags ) = @_; + + my ( $port, $inetaddr ); + eval { ( $port, $inetaddr ) = Socket::unpack_sockaddr_in( $addr ) } + or return fake_makeerr( EAI_FAMILY() ); + + my $family = Socket::AF_INET(); + + $flags ||= 0; + + my $flag_numerichost = $flags & NI_NUMERICHOST(); $flags &= ~NI_NUMERICHOST(); + my $flag_numericserv = $flags & NI_NUMERICSERV(); $flags &= ~NI_NUMERICSERV(); + my $flag_namereqd = $flags & NI_NAMEREQD(); $flags &= ~NI_NAMEREQD(); + my $flag_dgram = $flags & NI_DGRAM() ; $flags &= ~NI_DGRAM(); + + $flags == 0 or return fake_makeerr( EAI_BADFLAGS() ); + + my $node; + if( $flag_numerichost ) { + $node = Socket::inet_ntoa( $inetaddr ); + } + else { + $node = gethostbyaddr( $inetaddr, $family ); + if( !defined $node ) { + return fake_makeerr( EAI_NONAME() ) if $flag_namereqd; + $node = Socket::inet_ntoa( $inetaddr ); + } + } + + my $service; + if( $flag_numericserv ) { + $service = "$port"; + } + else { + my $protname = $flag_dgram ? "udp" : ""; + $service = getservbyport( $port, $protname ); + if( !defined $service ) { + $service = "$port"; + } + } + + return ( fake_makeerr( 0 ), $node, $service ); +} 1; |