ppisar pushed to perl-RPC-XML (master). "Add IPv6 support needed for IPv6-capable HTTP::Daemon"

From 60c440812d735e210fc6a62a4124b21834da80f6 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar(a)redhat.com&gt;
Date: Thu, 2 Mar 2017 17:31:03 +0100
Subject: Add IPv6 support needed for IPv6-capable HTTP::Daemon

---
 RPC-XML-0.80-IPv6-support.patch | 417 ++++++++++++++++++++++++++++++++++++++++
 perl-RPC-XML.spec               |  10 +-
 2 files changed, 425 insertions(+), 2 deletions(-)
 create mode 100644 RPC-XML-0.80-IPv6-support.patch

diff --git a/RPC-XML-0.80-IPv6-support.patch b/RPC-XML-0.80-IPv6-support.patch
new file mode 100644
index 0000000..3af04a8
--- /dev/null
+++ b/RPC-XML-0.80-IPv6-support.patch
@@ -0,0 +1,417 @@
+From fb7bfaaf0dd8c192f653160ae0fd08a5aa6d6ef0 Mon Sep 17 00:00:00 2001
+From: =?UTF-8?q?Petr=20P=C3=ADsa=C5=99?= <ppisar(a)redhat.com&gt;
+Date: Wed, 1 Mar 2017 17:43:26 +0100
+Subject: [PATCH] IPv6 support
+MIME-Version: 1.0
+Content-Type: text/plain; charset=UTF-8
+Content-Transfer-Encoding: 8bit
+
+After HTTP::Daemon gains IPv6 support, RPC-XML tests will fail because
+the RPC server will listen on IPv6 socket and clients will connect
+from an IPv6 address on systems where IPv6 is available.
+
+This patch changes tests to handle IPv6 addresses correctly.
+
+This patch also adds "peerfamily" key to RPC::XML::Server connection
+objects because a packed network address in "peeraddr" key is
+umbiguous and cannot be unpacked without previous knowledge of the
+address family that it encodes.
+
+There are still some hard coded AF_INET calls in test to find used or
+unused ports, but the approach is defective by design because of
+a possible race between the check for a port and subsequent use of the
+port. RPC::XML::Server would have to learn how to run on a user-supplied
+socket first to fix the races correctly.
+
+<https://rt.cpan.org/Public/Bug/Display.html?id=120472>
+
+Signed-off-by: Petr Písař <ppisar(a)redhat.com&gt;
+---
+ Makefile.PL             | 17 +++++-----
+ lib/RPC/XML/Server.pm   | 22 +++++++++----
+ t/40_server.t           | 41 +++++++++---------------
+ t/40_server_xmllibxml.t | 41 +++++++++---------------
+ t/41_server_hang.t      |  4 +--
+ t/60_net_server.t       |  2 +-
+ t/util.pl               | 84 +++++++++++++++++++++++++++++++++++++++++++++++++
+ 7 files changed, 141 insertions(+), 70 deletions(-)
+
+diff --git a/Makefile.PL b/Makefile.PL
+index 4e247dc..2a4e30d 100644
+--- a/Makefile.PL
++++ b/Makefile.PL
+@@ -71,13 +71,16 @@ WriteMakefile(
+     EXE_FILES => \@scripts,
+     PM        => \%PM_FILES,
+     PREREQ_PM => {
+-        'File::Spec'   => 0.8,
+-        'constant'     => 1.03,
+-        'Scalar::Util' => 1.33,
+-        'Test::More'   => 0.94,
+-        'LWP'          => 5.834,
+-        'XML::Parser'  => 2.31,
+-        'Module::Load' => 0.24,
++        'Carp'              => 0,
++        'File::Spec'        => 0.8,
++        'constant'          => 1.03,
++        'IO::Socket::IP'    => 0,
++        'Scalar::Util'      => 1.33,
++        'Socket'            => 0,
++        'Test::More'        => 0.94,
++        'LWP'               => 5.834,
++        'XML::Parser'       => 2.31,
++        'Module::Load'      => 0.24,
+     },
+     dist      => { COMPRESS => 'gzip -9f' },
+     clean     => { FILES => $CLEAN },
+diff --git a/lib/RPC/XML/Server.pm b/lib/RPC/XML/Server.pm
+index 0dc8882..00399ef 100644
+--- a/lib/RPC/XML/Server.pm
++++ b/lib/RPC/XML/Server.pm
+@@ -821,9 +821,9 @@ sub process_request ## no critic (ProhibitExcessComplexity)
+     my $conn = shift;
+ 
+     my (
+-        $req,     $reqxml,     $resp,     $respxml,  $do_compress,
+-        $parser,  $com_engine, $length,   $read,     $buf,
+-        $resp_fh, $tmpdir,     $peeraddr, $peerhost, $peerport
++        $req,     $reqxml,     $resp,       $respxml,  $do_compress,
++        $parser,  $com_engine, $length,     $read,     $buf,
++        $resp_fh, $tmpdir,     $peerfamily, $peeraddr, $peerhost, $peerport,
+     );
+ 
+     my $me = ref($self) . '::process_request';
+@@ -856,6 +856,7 @@ sub process_request ## no critic (ProhibitExcessComplexity)
+ 
+     # These will be attached to any and all request objects that are
+     # (successfully) read from $conn.
++    $peerfamily = $conn->sockdomain;
+     $peeraddr = $conn->peeraddr;
+     $peerport = $conn->peerport;
+     $peerhost = $conn->peerhost;
+@@ -986,6 +987,7 @@ sub process_request ## no critic (ProhibitExcessComplexity)
+             {
+                 # Set localized keys on $self, based on the connection info
+                 ## no critic (ProhibitLocalVars)
++                local $self->{peerfamily} = $peerfamily;
+                 local $self->{peeraddr} = $peeraddr;
+                 local $self->{peerhost} = $peerhost;
+                 local $self->{peerport} = $peerport;
+@@ -2293,14 +2295,22 @@ reference containing one or more datatypes, each a simple string.
The first
+ of the datatypes specifies the expected return type. The remainder (if any)
+ refer to the arguments themselves.
+ 
++=item peerfamily
++
++This is the address family, C<AF_INET> or C<AF_INET6>, of a network address
of
++the client that has connected and made the current request. It is required
++for unpacking C<peeraddr> properly.
++
+ =item peeraddr
+ 
+-This is the address part of a packed B<SOCKADDR_IN> structure, as returned by
+-L<Socket/pack_sockaddr_in>, which contains the address of the client that has
++This is the address part of a packed B<SOCKADDR_IN> or B<SOCKADDR_IN6>
++structure, as returned by L<Socket/pack_sockaddr_in> or
++L<Socket/pack_sockaddr_in6>, which contains the address of the client that has
+ connected and made the current request. This is provided "raw" in case you
+ need it. While you could re-create it from C<peerhost>, it is readily
+ available in both this server environment and the B<Apache::RPC::Server>
+-environment and thus included for convenience.
++environment and thus included for convenience. Apply L<Socket/inet_ntop> to
++C<peerfamily> and this value to obtain textual representation of the address.
+ 
+ =item peerhost
+ 
+diff --git a/t/40_server.t b/t/40_server.t
+index 21509f4..d6b3fb1 100644
+--- a/t/40_server.t
++++ b/t/40_server.t
+@@ -13,6 +13,7 @@ use IO::Socket;
+ use File::Spec;
+ use List::Util 'none';
+ use Scalar::Util 'blessed';
++use Socket ();
+ 
+ use Test::More;
+ use LWP::UserAgent;
+@@ -165,25 +166,7 @@ if (! ref $srv)
+     croak "Server allocation failed, cannot continue. Message was: $srv";
+ }
+ $port = $srv->port;
+-# Test the URL the server uses. Allow for "localhost",
"localhost.localdomain"
+-# or the local-net IP address of this host (not always 127.0.0.1).
+-# 22/09/2008 - Just allow for anything the user has attached to this address.
+-#              Aliases keep causing this test to falsely fail.
+-my @localhostinfo = gethostbyname 'localhost';
+-my $local_ip = join q{.} => unpack 'C4', $localhostinfo[4];
+-my @allhosts = ($local_ip, $localhostinfo[0], split q{ } => $localhostinfo[1]);
+-for (@allhosts) { s/[.]/[.]/g }
+-# Per RT 27778: For some reason gethostbyname('localhost') does not return
+-# "localhost" on win32
+-if ($^O eq 'MSWin32' || $^O eq 'cygwin')
+-{
+-    push @allhosts, 'localhost';
+-}
+-if (none { /localdomain/ } @allhosts)
+-{
+-    push @allhosts, 'localhost[.]localdomain';
+-}
+-my $allhosts = join q{|} => @allhosts;
++my $allhosts = alllocalhostre();
+ like($srv->url, qr{http://($allhosts):$port},
+    'RPC::XML::Server::url method (set)'); # This should be non-null this time
+ # Test some of the simpler cases of add_method and get_method
+@@ -269,12 +252,16 @@ $res = $srv->add_method({ name      =>
'perl.test.suite.peeraddr',
+                           sub {
+                               my $server = shift;
+ 
+-                              my $ipaddr = inet_aton($server->{peerhost});
++                              my $peerfamily = RPC_BASE64 $server->{peerfamily};
+                               my $peeraddr = RPC_BASE64 $server->{peeraddr};
+-                              my $packet = pack_sockaddr_in($server->{peerport},
+-                                                            $ipaddr);
++                              my $packet = pack_sockaddr_any(
++                                  $server->{peerfamily},
++                                  $server->{peerhost},
++                                  $server->{peerport}
++                              );
+                               $packet = RPC_BASE64 $packet;
+-                              [ $peeraddr, $packet,
++
++                              [ $peerfamily, $peeraddr, $packet,
+                                 $server->{peerhost}, $server->{peerport} ];
+                           } });
+ $child = start_server $srv;
+@@ -329,12 +316,12 @@ SKIP: {
+         }
+ 
+         $res = $res->value->value;
+-        is($res->[2], inet_ntoa(inet_aton('localhost')),
++        ok(grep({ $_ cmp $res->[3]} resolve($res->[0], 'localhost')),
+            'Third live req: Correct IP addr from peerhost');
+-        is($res->[0], inet_aton($res->[2]),
++        is($res->[1], Socket::inet_pton($res->[0], $res->[3]),
+            'Third request: peeraddr packet matches converted peerhost');
+-        is($res->[1], pack_sockaddr_in($res->[3], inet_aton($res->[2])),
+-           'Third request: pack_sockaddr_in validates all');
++        is($res->[2], pack_sockaddr_any($res->[0], $res->[3], $res->[4]),
++           'Third request: pack_sockaddr_any validates all');
+     }
+ }
+ stop_server $child;
+diff --git a/t/40_server_xmllibxml.t b/t/40_server_xmllibxml.t
+index bb7e32e..1b48cef 100644
+--- a/t/40_server_xmllibxml.t
++++ b/t/40_server_xmllibxml.t
+@@ -13,6 +13,7 @@ use File::Spec;
+ use Module::Load;
+ use List::Util 'none';
+ use Scalar::Util 'blessed';
++use Socket ();
+ use Test::More;
+ 
+ use LWP::UserAgent;
+@@ -87,25 +88,7 @@ if (! ref $srv)
+     croak "Server allocation failed, cannot continue. Message was: $srv";
+ }
+ $port = $srv->port;
+-# Test the URL the server uses. Allow for "localhost",
"localhost.localdomain"
+-# or the local-net IP address of this host (not always 127.0.0.1).
+-# 22/09/2008 - Just allow for anything the user has attached to this address.
+-#              Aliases keep causing this test to falsely fail.
+-my @localhostinfo = gethostbyname 'localhost';
+-my $local_ip = join q{.} => unpack 'C4', $localhostinfo[4];
+-my @allhosts = ($local_ip, $localhostinfo[0], split q{ }, $localhostinfo[1]);
+-for (@allhosts) { s/[.]/\\./g }
+-# Per RT 27778: For some reason gethostbyname('localhost') does not return
+-# "localhost" on win32
+-if ($^O eq 'MSWin32' || $^O eq 'cygwin')
+-{
+-    push @allhosts, 'localhost';
+-}
+-if (none { /localdomain/ } @allhosts)
+-{
+-    push @allhosts, 'localhost\.localdomain';
+-}
+-my $allhosts = join q{|} => @allhosts;
++my $allhosts = alllocalhostre();
+ like($srv->url, qr{http://($allhosts):$port},
+    'RPC::XML::Server::url method (set)'); # This should be non-null this time
+ # Test some of the simpler cases of add_method and get_method
+@@ -166,12 +149,16 @@ $res = $srv->add_method({ name      =>
'perl.test.suite.peeraddr',
+                           sub {
+                               my $server = shift;
+ 
+-                              my $ipaddr = inet_aton($server->{peerhost});
++                              my $peerfamily = RPC_BASE64 $server->{peerfamily};
+                               my $peeraddr = RPC_BASE64 $server->{peeraddr};
+-                              my $packet = pack_sockaddr_in($server->{peerport},
+-                                                            $ipaddr);
++                              my $packet = pack_sockaddr_any(
++                                  $server->{peerfamily},
++                                  $server->{peerhost},
++                                  $server->{peerport}
++                              );
+                               $packet = RPC_BASE64 $packet;
+-                              [ $peeraddr, $packet,
++
++                              [ $peerfamily, $peeraddr, $packet,
+                                 $server->{peerhost}, $server->{peerport} ];
+                           } });
+ $child = start_server $srv;
+@@ -226,12 +213,12 @@ SKIP: {
+         }
+ 
+         $res = $res->value->value;
+-        is($res->[2], inet_ntoa(inet_aton('localhost')),
++        ok(grep({ $_ cmp $res->[3]} resolve($res->[0], 'localhost')),
+            'Third live req: Correct IP addr from peerhost');
+-        is($res->[0], inet_aton($res->[2]),
++        is($res->[1], Socket::inet_pton($res->[0], $res->[3]),
+            'Third request: peeraddr packet matches converted peerhost');
+-        is($res->[1], pack_sockaddr_in($res->[3], inet_aton($res->[2])),
+-           'Third request: pack_sockaddr_in validates all');
++        is($res->[2], pack_sockaddr_any($res->[0], $res->[3], $res->[4]),
++           'Third request: pack_sockaddr_any validates all');
+     }
+ }
+ stop_server $child;
+diff --git a/t/41_server_hang.t b/t/41_server_hang.t
+index 634a2fd..721e032 100644
+--- a/t/41_server_hang.t
++++ b/t/41_server_hang.t
+@@ -12,7 +12,7 @@ use subs qw(start_server);
+ 
+ use Carp qw(carp croak);
+ use File::Spec;
+-use IO::Socket;
++use IO::Socket::IP;
+ use Test::More;
+ 
+ use HTTP::Request;
+@@ -81,7 +81,7 @@ SKIP: {
+     # Create an IO::Socket object for the client-side. In order to fool the
+     # server with a bad Content-Length and terminate early, we have to ditch
+     # LWP and go old-skool.
+-    $socket = IO::Socket::INET->new(Proto => 'tcp', PeerAddr =>
'localhost',
++    $socket = IO::Socket::IP->new(Proto => 'tcp', PeerAddr =>
'localhost',
+                                     PeerPort => $port)
+         or croak "Error creating IO::Socket obj: $!";
+     print {$socket} $req;
+diff --git a/t/60_net_server.t b/t/60_net_server.t
+index f866c1c..0e2f318 100644
+--- a/t/60_net_server.t
++++ b/t/60_net_server.t
+@@ -90,7 +90,7 @@ sleep 1; # Allow time for server to spin up
+ # Unless we see "ok 2", we have a problem
+ ok(-e $pid_file, 'server started, PID file exists');
+ # After this point, we have the obligation of killing the server manually
+-$client = RPC::XML::Client->new("http://localhost:$port");
++$client = RPC::XML::Client->new("http://$srv_hostname:$port");
+ is($client->simple_request('system.identity'), $srv->product_tokens,
+    'system.identity matches $srv->product_tokens');
+ 
+diff --git a/t/util.pl b/t/util.pl
+index 5fefafc..055d99b 100644
+--- a/t/util.pl
++++ b/t/util.pl
+@@ -2,6 +2,8 @@
+ # test suites
+ 
+ use IO::Socket;
++use Socket ();
++use Carp ();
+ 
+ sub start_server
+ {
+@@ -58,4 +60,86 @@ sub find_port
+     return -1;
+ }
+ 
++sub pack_sockaddr_any
++{
++    my ($family, $address, $port) = @_;
++
++    my $packed_address = Socket::inet_pton($family, $address);
++    my $packet;
++    if ($family == Socket::AF_INET) {
++        $packet = Socket::pack_sockaddr_in($port, $packed_address);
++    } elsif ($family == Socket::AF_INET6) {
++        $packet = Socket::pack_sockaddr_in6($port, $packed_address);
++    } else {
++        Carp::croak "Unsupported address family: $family";
++    }
++    return $packet;
++}
++
++sub resolve {
++    my ($family, $hostname) = @_;
++
++    my ($error, @res) = Socket::getaddrinfo($hostname, '',
++        { socktype => Socket::SOCK_STREAM });
++    if ($error) {
++        Carp::croak "Could not resolve $hostname: $error";
++    }
++    my @addresses;
++    while (my $ai = shift @res) {
++        my ($error, $address) = Socket::getnameinfo($ai->{addr},
++            Socket::NI_NUMERICHOST, Socket::NIx_NOSERV);
++        push @addresses, $address;
++    }
++    return @addresses;
++}
++
++# Test the URL the server uses. Allow for "localhost",
"localhost.localdomain"
++# or the local-net IP address of this host (not always 127.0.0.1).
++# 22/09/2008 - Just allow for anything the user has attached to this address.
++#              Aliases keep causing this test to falsely fail.
++sub alllocalhostre {
++    my @allhosts;
++
++    my ($error, @addresses) = Socket::getaddrinfo('localhost', '',
++        { socktype => Socket::SOCK_STREAM });
++    if ($error) {
++        Carp::croak "Could not resolve localhost: $error";
++    }
++    while (my $ai = shift @addresses) {
++        my ($error, $name) = Socket::getnameinfo($ai->{addr},
++            Socket::NI_NUMERICHOST|Socket::NI_NUMERICSERV,
++            Socket::NIx_NOSERV);
++        if ($error) {
++            Carp::croak "Could not format an IP address: $error";
++        }
++        push @allhosts, ($name =~ /:/ ? '[' . $name . ']' : $name);
++        ($error, $name) = Socket::getnameinfo($ai->{addr},
++            Socket::NI_NUMERICSERV,
++            Socket::NIx_NOSERV);
++        if ($error) {
++            Carp::croak "Could not resolve an IP address: $error";
++        }
++        push @allhosts, $name;
++    }
++
++    # Obtain aliases
++    push @allhosts, (split q{ } => (gethostbyname('localhost'))[1]);
++    for (@allhosts) { s/\[/\\[/g; s/\]/\\]/; s/[.]/[.]/g }
++    # Per RT 27778: For some reason gethostbyname('localhost') does not return
++    # "localhost" on win32
++    if ($^O eq 'MSWin32' || $^O eq 'cygwin')
++    {
++        push @allhosts, 'localhost';
++    }
++    if (none { /localdomain/ } @allhosts)
++    {
++        push @allhosts, 'localhost[.]localdomain';
++    }
++
++    # Build regular expression
++    my $allhosts = join q{|} => @allhosts;
++
++    return $allhosts;
++}
++
+ 1;
+-- 
+2.7.4
+
diff --git a/perl-RPC-XML.spec b/perl-RPC-XML.spec
index ff2aabe..855ba98 100644
--- a/perl-RPC-XML.spec
+++ b/perl-RPC-XML.spec
@@ -2,13 +2,15 @@
 
 Name:    perl-%{cpan_name}
 Version: 0.80
-Release: 4%{?dist}
+Release: 5%{?dist}
 Summary: Set of classes for core data, message and XML handling
 Group:   Development/Libraries
 License: Artistic 2.0 or LGPLv2
 URL:     http://search.cpan.org/dist/%{cpan_name}/
 Source0:
http://search.cpan.org/CPAN/authors/id/R/RJ/RJRAY/%{cpan_name}-%{version}...
 Source1:   README.license
+# Add IPv6 support needed for IPv6-capable HTTP::Daemon, CPAN RT#120472
+Patch0:    RPC-XML-0.80-IPv6-support.patch
 BuildArch: noarch
 BuildRequires:  coreutils
 BuildRequires:  findutils
@@ -56,13 +58,13 @@ BuildRequires:  perl(LWP::UserAgent) >= 5.834
 BuildRequires:  perl(Config)
 BuildRequires:  perl(Digest::MD5)
 BuildRequires:  perl(IO::Socket)
+BuildRequires:  perl(IO::Socket::IP)
 BuildRequires:  perl(List::Util)
 BuildRequires:  perl(LWP) >= 5.834
 BuildRequires:  perl(Symbol)
 BuildRequires:  perl(Test::More) >= 0.94
 # Optional tests:
 BuildRequires:  perl(Compress::Zlib)
-# IO::Socket::IP not helpful
 BuildRequires:  perl(Net::Server)
 Requires:       perl(:MODULE_COMPAT_%(eval "`perl -V:version`"; echo
$version))
 Requires:       perl(constant) >= 1.03
@@ -102,6 +104,7 @@ running RPC::XML under mod_perl.
 
 %prep
 %setup -qn %{cpan_name}-%{version}
+%patch0 -p1
 cp -p %{SOURCE1} .
 
 %build
@@ -131,6 +134,9 @@ make test
 %{perl_vendorlib}/Apache
 
 %changelog
+* Thu Mar 02 2017 Petr Pisar <ppisar(a)redhat.com&gt; - 0.80-5
+- Add IPv6 support needed for IPv6-capable HTTP::Daemon (CPAN RT#120472)
+
 * Sat Feb 11 2017 Fedora Release Engineering <releng(a)fedoraproject.org&gt; - 0.80-4
 - Rebuilt for https://fedoraproject.org/wiki/Fedora_26_Mass_Rebuild
 
-- 
cgit v1.1


	https://src.fedoraproject.org/cgit/perl-RPC-XML.git/commit/?h=master&...