r65955 - in /trunk/libtest-tcp-perl: Changes MANIFEST META.yml debian/changelog lib/Test/TCP.pm t/10_oo.t xt/01_podspell.t
carnil at users.alioth.debian.org
carnil at users.alioth.debian.org
Sat Dec 18 16:14:14 UTC 2010
Author: carnil
Date: Sat Dec 18 16:13:59 2010
New Revision: 65955
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=65955
Log:
* Team upload.
* New upstream release
Added:
trunk/libtest-tcp-perl/t/10_oo.t
- copied unchanged from r65953, branches/upstream/libtest-tcp-perl/current/t/10_oo.t
Modified:
trunk/libtest-tcp-perl/Changes
trunk/libtest-tcp-perl/MANIFEST
trunk/libtest-tcp-perl/META.yml
trunk/libtest-tcp-perl/debian/changelog
trunk/libtest-tcp-perl/lib/Test/TCP.pm
trunk/libtest-tcp-perl/xt/01_podspell.t
Modified: trunk/libtest-tcp-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libtest-tcp-perl/Changes?rev=65955&op=diff
==============================================================================
--- trunk/libtest-tcp-perl/Changes (original)
+++ trunk/libtest-tcp-perl/Changes Sat Dec 18 16:13:59 2010
@@ -1,4 +1,12 @@
Revision history for Perl extension Test::TCP
+
+1.08
+
+ - no feature changes
+
+1.07_01
+
+ - new OO interface!
1.07
Modified: trunk/libtest-tcp-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libtest-tcp-perl/MANIFEST?rev=65955&op=diff
==============================================================================
--- trunk/libtest-tcp-perl/MANIFEST (original)
+++ trunk/libtest-tcp-perl/MANIFEST Sat Dec 18 16:13:59 2010
@@ -26,6 +26,7 @@
t/07_optional.t
t/08_exit.t
t/09_fork.t
+t/10_oo.t
t/Server.pm
xt/01_podspell.t
xt/02_perlcritic.t
Modified: trunk/libtest-tcp-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libtest-tcp-perl/META.yml?rev=65955&op=diff
==============================================================================
--- trunk/libtest-tcp-perl/META.yml (original)
+++ trunk/libtest-tcp-perl/META.yml Sat Dec 18 16:13:59 2010
@@ -24,4 +24,4 @@
perl: 5.8.0
resources:
license: http://dev.perl.org/licenses/
-version: 1.07
+version: 1.08
Modified: trunk/libtest-tcp-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libtest-tcp-perl/debian/changelog?rev=65955&op=diff
==============================================================================
--- trunk/libtest-tcp-perl/debian/changelog (original)
+++ trunk/libtest-tcp-perl/debian/changelog Sat Dec 18 16:13:59 2010
@@ -1,3 +1,10 @@
+libtest-tcp-perl (1.08-1) unstable; urgency=low
+
+ * Team upload.
+ * New upstream release
+
+ -- Salvatore Bonaccorso <carnil at debian.org> Sat, 18 Dec 2010 17:11:52 +0100
+
libtest-tcp-perl (1.07-1) unstable; urgency=low
* Team upload.
Modified: trunk/libtest-tcp-perl/lib/Test/TCP.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libtest-tcp-perl/lib/Test/TCP.pm?rev=65955&op=diff
==============================================================================
--- trunk/libtest-tcp-perl/lib/Test/TCP.pm (original)
+++ trunk/libtest-tcp-perl/lib/Test/TCP.pm Sat Dec 18 16:13:59 2010
@@ -2,7 +2,7 @@
use strict;
use warnings;
use 5.00800;
-our $VERSION = '1.07';
+our $VERSION = '1.08';
use base qw/Exporter/;
use IO::Socket::INET;
use Test::SharedFork 0.12;
@@ -10,11 +10,12 @@
use Config;
use POSIX;
use Time::HiRes ();
+use Carp ();
+
+our @EXPORT = qw/ empty_port test_tcp wait_port /;
# process does not die when received SIGTERM, on win32.
my $TERMSIG = $^O eq 'MSWin32' ? 'KILL' : 'TERM';
-
-our @EXPORT = qw/ empty_port test_tcp wait_port /;
sub empty_port {
my $port = do {
@@ -46,42 +47,12 @@
for my $k (qw/client server/) {
die "missing madatory parameter $k" unless exists $args{$k};
}
- my $port = $args{port} || empty_port();
-
- if ( my $pid = fork() ) {
- # parent.
- wait_port($port);
-
- my $guard = Test::TCP::Guard->new(code => sub {
- # cleanup
- kill $TERMSIG => $pid;
- local $?; # waitpid modifies original $?.
- LOOP: while (1) {
- my $kid = waitpid( $pid, 0 );
- if ($^O ne 'MSWin32') { # i'm not in hell
- if (WIFSIGNALED($?)) {
- my $signame = (split(' ', $Config{sig_name}))[WTERMSIG($?)];
- if ($signame =~ /^(ABRT|PIPE)$/) {
- Test::More::diag("your server received SIG$signame");
- }
- }
- }
- if ($kid == 0 || $kid == -1) {
- last LOOP;
- }
- }
- });
-
- $args{client}->($port, $pid);
- }
- elsif ( $pid == 0 ) {
- # child
- $args{server}->($port);
- exit;
- }
- else {
- die "fork failed: $!";
- }
+ my $server = Test::TCP->new(
+ code => $args{server},
+ port => $args{port} || empty_port(),
+ );
+ $args{client}->($server->port, $server->pid);
+ undef $server; # make sure
}
sub _check_port {
@@ -112,18 +83,63 @@
die "cannot open port: $port";
}
-{
- package # hide from pause
- Test::TCP::Guard;
- sub new {
- my ($class, %args) = @_;
- bless { %args, _mypid => $$ }, $class;
- }
- sub DESTROY {
- my ($self) = @_;
- if ($self->{_mypid} == $$) {
- local $@;
- $self->{code}->();
+# -------------------------------------------------------------------------
+# OO-ish interface
+
+sub new {
+ my $class = shift;
+ my %args = @_==1 ? %{$_[0]} : @_;
+ Carp::croak("missing mandatory parameter 'code'") unless exists $args{code};
+ my $self = bless {
+ auto_start => 1,
+ _my_pid => $$,
+ %args,
+ }, $class;
+ $self->{port} = Test::TCP::empty_port() unless exists $self->{port};
+ $self->start()
+ if $self->{auto_start};
+ return $self;
+}
+
+sub pid { $_[0]->{pid} }
+sub port { $_[0]->{port} }
+
+sub start {
+ my $self = shift;
+ if ( my $pid = fork() ) {
+ # parent.
+ Test::TCP::wait_port($self->port);
+ $self->{pid} = $pid;
+ return;
+ } elsif ($pid == 0) {
+ # child process
+ $self->{code}->($self->port);
+ exit 0;
+ } else {
+ die "fork failed: $!";
+ }
+}
+
+sub DESTROY {
+ my $self = shift;
+
+ return unless defined $self->{pid};
+ return unless $self->{_my_pid} == $$;
+
+ kill $TERMSIG => $self->{pid};
+ local $?; # waitpid modifies original $?.
+ LOOP: while (1) {
+ my $kid = waitpid( $self->{pid}, 0 );
+ if ($^O ne 'MSWin32') { # i'm not in hell
+ if (POSIX::WIFSIGNALED($?)) {
+ my $signame = (split(' ', $Config{sig_name}))[POSIX::WTERMSIG($?)];
+ if ($signame =~ /^(ABRT|PIPE)$/) {
+ Test::More::diag("your server received SIG$signame");
+ }
+ }
+ }
+ if ($kid == 0 || $kid == -1) {
+ last LOOP;
}
}
}
@@ -142,7 +158,7 @@
use Test::TCP;
test_tcp(
client => sub {
- my $port = shift;
+ my ($port, $server_pid) = @_;
# send request to the server
},
server => sub {
@@ -153,6 +169,7 @@
using other server program
+ use Test::TCP;
test_tcp(
client => sub {
my $port = shift;
@@ -163,6 +180,19 @@
},
);
+Or, OO-ish interface
+
+ use Test::TCP;
+
+ my $server = Test::TCP->new(
+ code => sub {
+ my $port = shift;
+ ...
+ },
+ );
+ my $client = MyClient->new(host => '127.0.0.1', port => $server->port);
+ undef $server; # kill child process on DESTROY
+
=head1 DESCRIPTION
Test::TCP is test utilities for TCP/IP program.
@@ -197,6 +227,46 @@
wait_port(8080);
Waits for a particular port is available for connect.
+
+=back
+
+=head1 OO-ish interface
+
+=over 4
+
+=item my $server = Test::TCP->new(%args);
+
+Create new instance of Test::TCP.
+
+Arguments are following:
+
+=over 4
+
+=item $args{auto_start}: Boolean
+
+Call C<< $server->start() >> after create instance.
+
+Default: true
+
+=item $args{code}: CodeRef
+
+The callback function. Argument for callback function is: C<< $code->($pid) >>.
+
+This parameter is required.
+
+=back
+
+=item $server->start()
+
+Start the server process. Normally, you don't need to call this method.
+
+=item my $pid = $server->pid();
+
+Get the pid of child process.
+
+=item my $port = $server->port();
+
+Get the port number of child process.
=back
@@ -228,6 +298,20 @@
},
);
+Or use OO-ish interface instead.
+
+ my $server1 = Test::TCP->new(code => sub {
+ my $port1 = shift;
+ ...
+ });
+ my $server2 = Test::TCP->new(code => sub {
+ my $port2 = shift;
+ ...
+ });
+
+ # your client code here.
+ ...
+
=back
=head1 AUTHOR
Modified: trunk/libtest-tcp-perl/xt/01_podspell.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libtest-tcp-perl/xt/01_podspell.t?rev=65955&op=diff
==============================================================================
--- trunk/libtest-tcp-perl/xt/01_podspell.t (original)
+++ trunk/libtest-tcp-perl/xt/01_podspell.t Sat Dec 18 16:13:59 2010
@@ -32,3 +32,6 @@
TODO
kazuhooku
FAQ
+callback
+OO
+ish
More information about the Pkg-perl-cvs-commits
mailing list