r64863 - in /branches/upstream/libtest-tcp-perl/current: Changes MANIFEST META.yml inc/Test/More.pm lib/Test/TCP.pm t/09_fork.t

[carnil at users.alioth.debian.org]

Author: carnil
Date: Sat Nov 13 15:48:34 2010
New Revision: 64863

URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=64863
Log:
[svn-upgrade] new version libtest-tcp-perl (1.07)

Added:
    branches/upstream/libtest-tcp-perl/current/t/09_fork.t
Modified:
    branches/upstream/libtest-tcp-perl/current/Changes
    branches/upstream/libtest-tcp-perl/current/MANIFEST
    branches/upstream/libtest-tcp-perl/current/META.yml
    branches/upstream/libtest-tcp-perl/current/inc/Test/More.pm
    branches/upstream/libtest-tcp-perl/current/lib/Test/TCP.pm

Modified: branches/upstream/libtest-tcp-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtest-tcp-perl/current/Changes?rev=64863&op=diff
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/Changes (original)
+++ branches/upstream/libtest-tcp-perl/current/Changes Sat Nov 13 15:48:34 2010
@@ -1,4 +1,8 @@
 Revision history for Perl extension Test::TCP
+
+1.07
+
+    - allow forking in the client(lestrrat)
 
 1.06
 

Modified: branches/upstream/libtest-tcp-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtest-tcp-perl/current/MANIFEST?rev=64863&op=diff
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/MANIFEST (original)
+++ branches/upstream/libtest-tcp-perl/current/MANIFEST Sat Nov 13 15:48:34 2010
@@ -25,6 +25,7 @@
 t/06_nest.t
 t/07_optional.t
 t/08_exit.t
+t/09_fork.t
 t/Server.pm
 xt/01_podspell.t
 xt/02_perlcritic.t

Modified: branches/upstream/libtest-tcp-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtest-tcp-perl/current/META.yml?rev=64863&op=diff
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/META.yml (original)
+++ branches/upstream/libtest-tcp-perl/current/META.yml Sat Nov 13 15:48:34 2010
@@ -24,4 +24,4 @@
   perl: 5.8.0
 resources:
   license: http://dev.perl.org/licenses/
-version: 1.06
+version: 1.07

Modified: branches/upstream/libtest-tcp-perl/current/inc/Test/More.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtest-tcp-perl/current/inc/Test/More.pm?rev=64863&op=diff
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/inc/Test/More.pm (original)
+++ branches/upstream/libtest-tcp-perl/current/inc/Test/More.pm Sat Nov 13 15:48:34 2010
@@ -1,7 +1,7 @@
 #line 1
 package Test::More;
 
-use 5.008001;
+use 5.006;
 use strict;
 use warnings;
 
@@ -18,7 +18,7 @@
     return warn @_, " at $file line $line\n";
 }
 
-our $VERSION = '2.00_01';
+our $VERSION = '0.97_01';
 $VERSION = eval $VERSION;    ## no critic (BuiltinFunctions::ProhibitStringyEval)
 
 use Test::Builder::Module;

Modified: branches/upstream/libtest-tcp-perl/current/lib/Test/TCP.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtest-tcp-perl/current/lib/Test/TCP.pm?rev=64863&op=diff
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/lib/Test/TCP.pm (original)
+++ branches/upstream/libtest-tcp-perl/current/lib/Test/TCP.pm Sat Nov 13 15:48:34 2010
@@ -2,7 +2,7 @@
 use strict;
 use warnings;
 use 5.00800;
-our $VERSION = '1.06';
+our $VERSION = '1.07';
 use base qw/Exporter/;
 use IO::Socket::INET;
 use Test::SharedFork 0.12;
@@ -117,12 +117,14 @@
         Test::TCP::Guard;
     sub new {
         my ($class, %args) = @_;
-        bless { %args }, $class;
+        bless { %args, _mypid => $$ }, $class;
     }
     sub DESTROY {
         my ($self) = @_;
-        local $@;
-        $self->{code}->();
+        if ($self->{_mypid} == $$) {
+            local $@;
+            $self->{code}->();
+        }
     }
 }
 
@@ -242,6 +244,8 @@
 
 Tatsuhiko Miyagawa
 
+lestrrat
+
 =head1 SEE ALSO
 
 =head1 LICENSE

Added: branches/upstream/libtest-tcp-perl/current/t/09_fork.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtest-tcp-perl/current/t/09_fork.t?rev=64863&op=file
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/t/09_fork.t (added)
+++ branches/upstream/libtest-tcp-perl/current/t/09_fork.t Sat Nov 13 15:48:34 2010
@@ -1,0 +1,52 @@
+use strict;
+use Test::More tests => 6;
+use Test::TCP;
+use t::Server;
+
+test_tcp 
+    client => sub {
+        my $port = shift;
+
+        my $pid = fork();
+        if (! ok defined $pid, "Successfully forked child $pid") {
+            return diag("Could not fork: $!");
+        }
+
+        if (! $pid) {
+            eval {
+                ok 1, "Successfully executed child $$";
+            };
+            my $e = $@;
+            if (! ok !$e, "child exited normally") {
+                diag( "Encountered an error $e" );
+            }
+            exit;
+        }
+
+        waitpid($pid, 0);
+
+        # after the child has exited, we need to make sure that
+        # the server hasn't gone away.
+        my $sock = IO::Socket::INET->new(
+            PeerPort => $port,
+            PeerAddr => '127.0.0.1',
+            Proto    => 'tcp'
+        );
+        if (! ok $sock, "socket is connected") {
+            return diag("Cannot open client socket: $!");
+        }
+
+        print {$sock} "Hello server\n";
+        my $res = <$sock>;
+        is $res, "Hello server\n", "got expected reply";
+    },
+    server => sub {
+        my $port = shift;
+        t::Server->new($port)->run(sub {
+            note "new request";
+            my ($remote, $line, $sock) = @_;
+            print {$remote} $line;
+        });
+    }
+;
+