Provide fallback implementation of getaddrinfo and getnameinfo in pure perl if libc doesn't provide one

1 files changed, 200 insertions, 0 deletions

diff --git a/ext/Socket/Socket.pm b/ext/Socket/Socket.pm
index 532e7432b7..e3bd0ba52f 100644
--- a/ext/Socket/Socket.pm
+++ b/ext/Socket/Socket.pm
@@ -579,4 +579,204 @@ sub sockaddr_un {
 
 XSLoader::load();
 
+my %errstr;
+
+if( !defined &getaddrinfo ) {
+   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,
+
+       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{$_};
+      defined &$name or *$name = sub () { $value };
+   }
+
+   %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",
+   );
+}
+
+# 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
+
+use strict;
+
+# 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();
+
+   $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+$/ ) {
+      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 => $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;