r61986 - in /branches/upstream/libtest-tcp-perl/current: Changes MANIFEST META.yml lib/Test/TCP.pm t/02_abrt.t t/08_exit.t
poisonbit-guest at users.alioth.debian.org
poisonbit-guest at users.alioth.debian.org
Tue Aug 24 16:25:08 UTC 2010
Author: poisonbit-guest
Date: Tue Aug 24 16:24:42 2010
New Revision: 61986
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=61986
Log:
[svn-upgrade] Integrating new upstream version, libtest-tcp-perl (1.03)
Added:
branches/upstream/libtest-tcp-perl/current/t/08_exit.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/lib/Test/TCP.pm
branches/upstream/libtest-tcp-perl/current/t/02_abrt.t
Modified: branches/upstream/libtest-tcp-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtest-tcp-perl/current/Changes?rev=61986&op=diff
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/Changes (original)
+++ branches/upstream/libtest-tcp-perl/current/Changes Tue Aug 24 16:24:42 2010
@@ -1,4 +1,20 @@
Revision history for Perl extension Test::TCP
+
+1.03
+
+ - release to cpan
+ - fixed win32 issue(charsbar)
+
+1.02_02
+
+ - use randomness on finding empty port(suggested by kazuhooku)
+ - try to connect the port before bind(Tatsuhiko Miyagawa)
+
+1.02_01
+
+ - better cleanup code by RAII pattern.
+ https://rt.cpan.org/Ticket/Display.html?id=60657
+ (reported by dgl)
1.02
Modified: branches/upstream/libtest-tcp-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtest-tcp-perl/current/MANIFEST?rev=61986&op=diff
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/MANIFEST (original)
+++ branches/upstream/libtest-tcp-perl/current/MANIFEST Tue Aug 24 16:24:42 2010
@@ -24,6 +24,7 @@
t/05_sigint.t
t/06_nest.t
t/07_optional.t
+t/08_exit.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=61986&op=diff
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/META.yml (original)
+++ branches/upstream/libtest-tcp-perl/current/META.yml Tue Aug 24 16:24:42 2010
@@ -24,4 +24,4 @@
perl: 5.8.0
resources:
license: http://dev.perl.org/licenses/
-version: 1.02
+version: 1.03
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=61986&op=diff
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/lib/Test/TCP.pm (original)
+++ branches/upstream/libtest-tcp-perl/current/lib/Test/TCP.pm Tue Aug 24 16:24:42 2010
@@ -2,7 +2,7 @@
use strict;
use warnings;
use 5.00800;
-our $VERSION = '1.02';
+our $VERSION = '1.03';
use base qw/Exporter/;
use IO::Socket::INET;
use Test::SharedFork;
@@ -17,10 +17,18 @@
our @EXPORT = qw/ empty_port test_tcp wait_port /;
sub empty_port {
- my $port = shift || 10000;
- $port = 19000 unless $port =~ /^[0-9]+$/ && $port < 19000;
+ my $port = do {
+ if (@_) {
+ my $p = $_[0];
+ $p = 19000 unless $p =~ /^[0-9]+$/ && $p < 19000;
+ $p;
+ } else {
+ 10000 + int(rand()*1000);
+ }
+ };
while ( $port++ < 20000 ) {
+ next if _check_port($port);
my $sock = IO::Socket::INET->new(
Listen => 5,
LocalAddr => '127.0.0.1',
@@ -44,19 +52,11 @@
# parent.
wait_port($port);
- my $sig;
- my $err;
- {
- local $SIG{INT} = sub { $sig = "INT"; die "SIGINT received\n" };
- local $SIG{PIPE} = sub { $sig = "PIPE"; die "SIGPIPE received\n" };
- eval {
- $args{client}->($port, $pid);
- };
- $err = $@;
-
+ my $guard = Test::TCP::Guard->new(code => sub {
# cleanup
kill $TERMSIG => $pid;
- while (1) {
+ local $?; # waitpid modifies original $?.
+ LOOP: while (1) {
my $kid = waitpid( $pid, 0 );
if ($^O ne 'MSWin32') { # i'm not in hell
if (WIFSIGNALED($?)) {
@@ -67,17 +67,12 @@
}
}
if ($kid == 0 || $kid == -1) {
- last;
+ last LOOP;
}
}
- }
-
- if ($sig) {
- kill $sig, $$; # rethrow signal after cleanup
- }
- if ($err) {
- die $err; # rethrow exception after cleanup.
- }
+ });
+
+ $args{client}->($port, $pid);
}
elsif ( $pid == 0 ) {
# child
@@ -115,6 +110,19 @@
Time::HiRes::sleep(0.1);
}
die "cannot open port: $port";
+}
+
+{
+ package # hide from pause
+ Test::TCP::Guard;
+ sub new {
+ my ($class, %args) = @_;
+ bless { %args }, $class;
+ }
+ sub DESTROY {
+ my ($self) = @_;
+ $self->{code}->();
+ }
}
1;
@@ -231,6 +239,8 @@
charsbar
+Tatsuhiko Miyagawa
+
=head1 SEE ALSO
=head1 LICENSE
Modified: branches/upstream/libtest-tcp-perl/current/t/02_abrt.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtest-tcp-perl/current/t/02_abrt.t?rev=61986&op=diff
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/t/02_abrt.t (original)
+++ branches/upstream/libtest-tcp-perl/current/t/02_abrt.t Tue Aug 24 16:24:42 2010
@@ -1,12 +1,13 @@
use strict;
use warnings;
use Test::TCP;
-use Test::More tests => 2;
+use Test::More;
use Socket;
use IO::Socket::INET;
use t::Server;
plan skip_all => "win32 doesn't support embedded function named dump()" if $^O eq 'MSWin32';
+plan tests => 2;
test_tcp(
client => sub {
Added: branches/upstream/libtest-tcp-perl/current/t/08_exit.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtest-tcp-perl/current/t/08_exit.t?rev=61986&op=file
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/t/08_exit.t (added)
+++ branches/upstream/libtest-tcp-perl/current/t/08_exit.t Tue Aug 24 16:24:42 2010
@@ -1,0 +1,55 @@
+use strict;
+use warnings;
+use Test::More tests => 5;
+use Test::TCP;
+use File::Temp ();
+use Fcntl qw/:seek/;
+use t::Server;
+use POSIX;
+
+my $tmp = File::Temp->new();
+
+my $pid = fork();
+die "cannot fork: $!" unless defined $pid;
+if ($pid) { # parent
+ # waiting 'client'
+ SKIP: {
+ waitpid($pid, 0);
+ skip 'not implemented on Win32', 4 if $^O eq 'MSWin32';
+ ok WIFEXITED($?);
+ ok !WIFSIGNALED($?);
+ ok !WIFSTOPPED($?);
+ is WEXITSTATUS($?), 1;
+ }
+
+ # killing 'server'
+ {
+ seek $tmp, 0, SEEK_SET;
+ my $child_pid = do { local $/; <$tmp> };
+ is kill(($^O eq 'MSWin32' ? 'KILL' : 'TERM'), $child_pid), 0;
+ my $kid;
+ do {
+ $kid = waitpid($child_pid, 0);
+ } while $kid > 0;
+ }
+} else { # child
+ test_tcp(
+ client => sub {
+ my $port = shift;
+ note "CLIENT: $$";
+ exit 1;
+ },
+ server => sub {
+ my $port = shift;
+ note "SEVER: $$";
+ print {$tmp} $$;
+ $tmp->close;
+ t::Server->new($port)->run(sub {
+ note "new request";
+ my ($remote, $line, $sock) = @_;
+ print {$remote} $line;
+ });
+ },
+ );
+}
+
More information about the Pkg-perl-cvs-commits
mailing list