commit perl-Test-TCP for openSUSE:Factory

22 Apr 2016

Hello community,

here is the log from the commit of package perl-Test-TCP for openSUSE:Factory checked in at 2016-04-22 16:23:12
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/perl-Test-TCP (Old)
 and      /work/SRC/openSUSE:Factory/.perl-Test-TCP.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Package is "perl-Test-TCP"

Changes:
--------

--- /work/SRC/openSUSE:Factory/perl-Test-TCP/perl-Test-TCP.changes	2015-10-08 08:24:32.000000000 +0200
+++ /work/SRC/openSUSE:Factory/.perl-Test-TCP.new/perl-Test-TCP.changes	2016-04-22 16:23:13.000000000 +0200
@@ -1,0 +2,10 @@
+Mon Mar 21 12:05:39 UTC 2016 - coolo@suse.com
+
+- updated to 2.15
+   see /usr/share/doc/packages/perl-Test-TCP/Changes
+
+  2.15 2016-03-15T00:25:52Z
+  
+      - Add listen_socket function and listen option for race-free operation
+
+-------------------------------------------------------------------

Old:
----
  Test-TCP-2.14.tar.gz

New:
----
  Test-TCP-2.15.tar.gz

++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Other differences:
------------------
++++++ perl-Test-TCP.spec ++++++
--- /var/tmp/diff_new_pack.TMG6Xp/_old	2016-04-22 16:23:13.000000000 +0200
+++ /var/tmp/diff_new_pack.TMG6Xp/_new	2016-04-22 16:23:13.000000000 +0200
@@ -1,7 +1,7 @@
 #
 # spec file for package perl-Test-TCP
 #
-# Copyright (c) 2015 SUSE LINUX GmbH, Nuernberg, Germany.
+# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany.
 #
 # All modifications and additions to the file contributed by third parties
 # remain the property of their copyright owners, unless otherwise agreed
@@ -17,7 +17,7 @@
 
 
 Name:           perl-Test-TCP
-Version:        2.14
+Version:        2.15
 Release:        0
 %define cpan_name Test-TCP
 Summary:        Testing Tcp Program

++++++ Test-TCP-2.14.tar.gz -> Test-TCP-2.15.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Test-TCP-2.14/Changes new/Test-TCP-2.15/Changes
--- old/Test-TCP-2.14/Changes	2015-09-30 00:38:45.000000000 +0200
+++ new/Test-TCP-2.15/Changes	2016-03-15 01:26:52.000000000 +0100
@@ -1,5 +1,9 @@
 Revision history for Perl module Test::TCP
 
+2.15 2016-03-15T00:25:52Z
+
+    - Add listen_socket function and listen option for race-free operation
+
 2.14 2015-09-29T22:36:44Z
 
     - Fix race condition in t/10_oo.t(exodist)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Test-TCP-2.14/MANIFEST new/Test-TCP-2.15/MANIFEST
--- old/Test-TCP-2.14/MANIFEST	2015-09-30 00:38:45.000000000 +0200
+++ new/Test-TCP-2.15/MANIFEST	2016-03-15 01:26:52.000000000 +0100
@@ -22,6 +22,7 @@
 t/11_net_empty_port.t
 t/12_pass_wait_port_options.t
 t/13_undef_port.t
+t/14_listen.t
 t/Server.pm
 xt/02_perlcritic.t
 xt/04_dependents.t
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Test-TCP-2.14/META.json new/Test-TCP-2.15/META.json
--- old/Test-TCP-2.14/META.json	2015-09-30 00:38:45.000000000 +0200
+++ new/Test-TCP-2.15/META.json	2016-03-15 01:26:52.000000000 +0100
@@ -67,7 +67,7 @@
       },
       "Test::TCP" : {
          "file" : "lib/Test/TCP.pm",
-         "version" : "2.14"
+         "version" : "2.15"
       },
       "Test::TCP::CheckPort" : {
          "file" : "lib/Test/TCP/CheckPort.pm"
@@ -84,7 +84,7 @@
          "web" : "https://github.com/tokuhirom/Test-TCP"
       }
    },
-   "version" : "2.14",
+   "version" : "2.15",
    "x_contributors" : [
       "tokuhirom <tokuhirom@d0d07461-0603-4401-acd4-de1884942a52>",
       "mattn <mattn@d0d07461-0603-4401-acd4-de1884942a52>",
@@ -105,7 +105,8 @@
       "Christian Walde <walde.christian@googlemail.com>",
       "Tatsuhiko Miyagawa <miyagawa@gmail.com>",
       "Tatsuhiko Miyagawa <miyagawa@bulknews.net>",
-      "Chad Granum <exodist7@gmail.com>"
+      "Chad Granum <exodist7@gmail.com>",
+      "Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>"
    ],
    "x_serialization_backend" : "JSON::PP version 2.27300"
 }
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Test-TCP-2.14/META.yml new/Test-TCP-2.15/META.yml
--- old/Test-TCP-2.14/META.yml	2015-09-30 00:38:45.000000000 +0200
+++ new/Test-TCP-2.15/META.yml	2016-03-15 01:26:52.000000000 +0100
@@ -30,7 +30,7 @@
     file: lib/Net/EmptyPort.pm
   Test::TCP:
     file: lib/Test/TCP.pm
-    version: '2.14'
+    version: '2.15'
   Test::TCP::CheckPort:
     file: lib/Test/TCP/CheckPort.pm
 requires:
@@ -44,7 +44,7 @@
   bugtracker: https://github.com/tokuhirom/Test-TCP/issues
   homepage: https://github.com/tokuhirom/Test-TCP
   repository: git://github.com/tokuhirom/Test-TCP.git
-version: '2.14'
+version: '2.15'
 x_contributors:
   - 'tokuhirom <tokuhirom@d0d07461-0603-4401-acd4-de1884942a52>'
   - 'mattn <mattn@d0d07461-0603-4401-acd4-de1884942a52>'
@@ -66,4 +66,5 @@
   - 'Tatsuhiko Miyagawa <miyagawa@gmail.com>'
   - 'Tatsuhiko Miyagawa <miyagawa@bulknews.net>'
   - 'Chad Granum <exodist7@gmail.com>'
+  - 'Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>'
 x_serialization_backend: 'CPAN::Meta::YAML version 0.017'
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Test-TCP-2.14/Makefile.PL new/Test-TCP-2.15/Makefile.PL
--- old/Test-TCP-2.14/Makefile.PL	2015-09-30 00:38:45.000000000 +0200
+++ new/Test-TCP-2.15/Makefile.PL	2016-03-15 01:26:52.000000000 +0100
@@ -12,7 +12,7 @@
 my %WriteMakefileArgs = (
     NAME     => 'Test::TCP',
     DISTNAME => 'Test-TCP',
-    VERSION  => '2.14',
+    VERSION  => '2.15',
     EXE_FILES => [glob('script/*'), glob('bin/*')],
     CONFIGURE_REQUIRES => {
   "ExtUtils::MakeMaker" => 0
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Test-TCP-2.14/README.md new/Test-TCP-2.15/README.md
--- old/Test-TCP-2.14/README.md	2015-09-30 00:38:45.000000000 +0200
+++ new/Test-TCP-2.15/README.md	2016-03-15 01:26:52.000000000 +0100
@@ -7,15 +7,16 @@
     use Test::TCP;
 
     my $server = Test::TCP->new(
+        listen => 1,
         code => sub {
-            my $port = shift;
+            my $socket = shift;
             ...
         },
     );
     my $client = MyClient->new(host => '127.0.0.1', port => $server->port);
     undef $server; # kill child process on DESTROY
 
-Using memcached:
+If using a server that can only accept a port number, e.g. memcached:
 
     use Test::TCP;
 
@@ -30,17 +31,32 @@
     my $memd = Cache::Memcached->new({servers => ['127.0.0.1:' . $memcached->port]});
     ...
 
+**N.B.**: This is vulnerable to race conditions, if another process binds
+to the same port after [Net::EmptyPort](https://metacpan.org/pod/Net::EmptyPort) found it available.
+
 And functional interface is available:
 
     use Test::TCP;
     test_tcp(
+        listen => 1,
+        client => sub {
+            my ($port, $server_pid) = @_;
+            # send request to the server
+        },
+        server => sub {
+            my $socket = shift;
+            # run server, calling $socket->accept
+        },
+    );
+
+    test_tcp(
         client => sub {
             my ($port, $server_pid) = @_;
             # send request to the server
         },
         server => sub {
             my $port = shift;
-            # run server
+            # run server, binding to $port
         },
     );
 
@@ -55,12 +71,13 @@
     Functional interface.
 
         test_tcp(
+            listen => 1,
             client => sub {
                 my $port = shift;
                 # send request to the server
             },
             server => sub {
-                my $port = shift;
+                my $socket = shift;
                 # run server
             },
             # optional
@@ -69,6 +86,9 @@
             max_wait => 3, # seconds
         );
 
+    If `listen` is false, `server` is instead passed a port number that
+    was free before it was called.
+
 - wait\_port
 
         wait_port(8080);
@@ -91,7 +111,9 @@
 
     - $args{code}: CodeRef
 
-        The callback function. Argument for callback function is: `$code->($pid)`.
+        The callback function. Argument for callback function is:
+        `$code->($socket)` or `$code->($port)`,
+        depending on the value of `listen`.
 
         This parameter is required.
 
@@ -103,6 +125,11 @@
 
         _Default: 10_
 
+    - $args{listen} : Boolean
+
+        If true, open a listening socket and pass this to the callback.
+        Otherwise find a free port and pass the number of it to the callback.
+
 - $server->start()
 
     Start the server process. Normally, you don't need to call this method.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Test-TCP-2.14/lib/Net/EmptyPort.pm new/Test-TCP-2.15/lib/Net/EmptyPort.pm
--- old/Test-TCP-2.14/lib/Net/EmptyPort.pm	2015-09-30 00:38:45.000000000 +0200
+++ new/Test-TCP-2.15/lib/Net/EmptyPort.pm	2016-03-15 01:26:52.000000000 +0100
@@ -6,12 +6,18 @@
 use Time::HiRes ();
 
 our @EXPORT = qw/ can_bind empty_port check_port wait_port /;
+our @EXPORT_OK = qw/ listen_socket /;
 
 sub can_bind {
     my ($host, $port, $proto) = @_;
-    $port ||= 0;
+    defined _listen_socket($host, $port, $proto);
+}
+
+sub _listen_socket {
+    my ($host, $port, $proto) = @_;
+    $port  ||= 0;
     $proto ||= 'tcp';
-    my $s = IO::Socket::IP->new(
+    IO::Socket::IP->new(
         (($proto eq 'udp') ? () : (Listen => 5)),
         LocalAddr => $host,
         LocalPort => $port,
@@ -19,7 +25,12 @@
         V6Only    => 1,
         (($^O eq 'MSWin32') ? () : (ReuseAddr => 1)),
     );
-    defined $s;
+}
+
+sub listen_socket {
+    my ($host, $proto) = @{$_[0]}{qw(host proto)};
+    $host = '127.0.0.1' unless defined $host;
+    return _listen_socket($host, undef, $proto);
 }
 
 # get a empty port on 49152 .. 65535
@@ -131,6 +142,9 @@
 
     use Net::EmptyPort qw(empty_port check_port);
 
+    # get a socket listening on a random free port
+    my $socket = listen_socket();
+
     # get a random free port
     my $port = empty_port();
 
@@ -147,6 +161,30 @@
 
 =over 4
 
+=item C<< listen_socket() >>
+
+=item C<< listen_socket(\%args) >>
+
+
+    my $socket = listen_socket();
+
+Returns a socket listening on a free port.
+
+The function recognizes the following keys in the hashref argument.
+
+=over 4
+
+=item C<< host >>
+
+The address on which to listen.  Default is C<< 127.0.0.1 >>.
+
+=item C<< proto >>
+
+Name of the protocol.  Default is C<< tcp >>.
+You can get an UDP socket by specifying C<< udp >>.
+
+=back
+
 =item C<< empty_port() >>
 
 =item C<< empty_port(\%args) >>
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Test-TCP-2.14/lib/Test/TCP.pm new/Test-TCP-2.15/lib/Test/TCP.pm
--- old/Test-TCP-2.14/lib/Test/TCP.pm	2015-09-30 00:38:45.000000000 +0200
+++ new/Test-TCP-2.15/lib/Test/TCP.pm	2016-03-15 01:26:52.000000000 +0100
@@ -2,9 +2,8 @@
 use strict;
 use warnings;
 use 5.00800;
-our $VERSION = '2.14';
+our $VERSION = '2.15';
 use base qw/Exporter/;
-use IO::Socket::INET;
 use Test::SharedFork 0.12;
 use Test::More ();
 use Config;
@@ -69,7 +68,16 @@
         _my_pid    => $$,
         %args,
     }, $class;
-    $self->{port} ||= empty_port({ host => $self->{host} });
+    if ($self->{listen}) {
+        $self->{socket} ||= Net::EmptyPort::listen_socket({
+            host => $self->{host},
+            proto => $self->{proto},
+        }) or die "Cannot listen: $!";
+        $self->{port} = $self->{socket}->sockport;
+    }
+    else {
+        $self->{port} ||= empty_port({ host => $self->{host} });
+    }
     $self->start()
       if $self->{auto_start};
     return $self;
@@ -85,10 +93,11 @@
 
     if ( $pid ) { # parent process.
         $self->{pid} = $pid;
-        Test::TCP::wait_port({ host => $self->{host}, port => $self->port, max_wait => $self->{max_wait} });
+        Test::TCP::wait_port({ host => $self->{host}, port => $self->port, max_wait => $self->{max_wait} })
+            unless $self->{socket};
         return;
     } else { # child process
-        $self->{code}->($self->port);
+        $self->{code}->($self->{socket} || $self->port);
         # should not reach here
         if (kill 0, $self->{_my_pid}) { # warn only parent process still exists
             warn("[Test::TCP] Child process does not block(PID: $$, PPID: $self->{_my_pid})");
@@ -159,15 +168,16 @@
     use Test::TCP;
 
     my $server = Test::TCP->new(
+        listen => 1,
         code => sub {
-            my $port = shift;
+            my $socket = shift;
             ...
         },
     );
     my $client = MyClient->new(host => '127.0.0.1', port => $server->port);
     undef $server; # kill child process on DESTROY
 
-Using memcached:
+If using a server that can only accept a port number, e.g. memcached:
 
     use Test::TCP;
 
@@ -182,17 +192,32 @@
     my $memd = Cache::Memcached->new({servers => ['127.0.0.1:' . $memcached->port]});
     ...
 
+B<N.B.>: This is vulnerable to race conditions, if another process binds
+to the same port after L<Net::EmptyPort> found it available.
+
 And functional interface is available:
 
     use Test::TCP;
     test_tcp(
+        listen => 1,
+        client => sub {
+            my ($port, $server_pid) = @_;
+            # send request to the server
+        },
+        server => sub {
+            my $socket = shift;
+            # run server, calling $socket->accept
+        },
+    );
+
+    test_tcp(
         client => sub {
             my ($port, $server_pid) = @_;
             # send request to the server
         },
         server => sub {
             my $port = shift;
-            # run server
+            # run server, binding to $port
         },
     );
 
@@ -209,12 +234,13 @@
 Functional interface.
 
     test_tcp(
+        listen => 1,
         client => sub {
             my $port = shift;
             # send request to the server
         },
         server => sub {
-            my $port = shift;
+            my $socket = shift;
             # run server
         },
         # optional
@@ -223,6 +249,8 @@
         max_wait => 3, # seconds
     );
 
+If C<listen> is false, C<server> is instead passed a port number that
+was free before it was called.
 
 =item wait_port
 
@@ -252,7 +280,9 @@
 
 =item $args{code}: CodeRef
 
-The callback function. Argument for callback function is: C<< $code->($pid) >>.
+The callback function. Argument for callback function is:
+C<< $code->($socket) >> or C<< $code->($port) >>,
+depending on the value of C<listen>.
 
 This parameter is required.
 
@@ -264,6 +294,11 @@
 
 I<Default: 10>
 
+=item $args{listen} : Boolean
+
+If true, open a listening socket and pass this to the callback.
+Otherwise find a free port and pass the number of it to the callback.
+
 =back
 
 =item $server->start()
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/Test-TCP-2.14/t/14_listen.t new/Test-TCP-2.15/t/14_listen.t
--- old/Test-TCP-2.14/t/14_listen.t	1970-01-01 01:00:00.000000000 +0100
+++ new/Test-TCP-2.15/t/14_listen.t	2016-03-15 01:26:52.000000000 +0100
@@ -0,0 +1,32 @@
+use warnings;
+use strict;
+use Test::More;
+use Test::TCP;
+use Test::SharedFork;
+use IO::Socket::IP;
+
+test_tcp(
+    client => sub {
+        my ($port, $pid) = @_;
+        ok $port, 'got port';
+        ok my $sock = IO::Socket::IP->new(
+            PeerPort => $port,
+            PeerHost => '127.0.0.1',
+            Proto    => 'tcp',
+            V6Only   => 1,
+        ), 'connected' or die "Cannot open client socket: $!";
+
+        ok($sock->print("foo\n"), "send 1");
+        is(<$sock>, "foo\n", "recv 1");
+    },
+    server => sub {
+        my ($sock) = @_;
+        while (my $remote = $sock->accept) {
+            note "new request";
+            $remote->print(scalar <$remote>);
+        }
+    },
+    listen => 1,
+);
+
+done_testing;

    

commit perl-Test-TCP for openSUSE:Factory

root＠hilbert.suse.de