r65952 - in /branches/upstream/libtest-tcp-perl/current: Changes MANIFEST META.yml 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:09:40 UTC 2010
Author: carnil
Date: Sat Dec 18 16:09:29 2010
New Revision: 65952
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=65952
Log:
[svn-upgrade] new version libtest-tcp-perl (1.08)
Added:
branches/upstream/libtest-tcp-perl/current/t/10_oo.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/xt/01_podspell.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=65952&op=diff
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/Changes (original)
+++ branches/upstream/libtest-tcp-perl/current/Changes Sat Dec 18 16:09:29 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: branches/upstream/libtest-tcp-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtest-tcp-perl/current/MANIFEST?rev=65952&op=diff
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/MANIFEST (original)
+++ branches/upstream/libtest-tcp-perl/current/MANIFEST Sat Dec 18 16:09:29 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: 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=65952&op=diff
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/META.yml (original)
+++ branches/upstream/libtest-tcp-perl/current/META.yml Sat Dec 18 16:09:29 2010
@@ -24,4 +24,4 @@
perl: 5.8.0
resources:
license: http://dev.perl.org/licenses/
-version: 1.07
+version: 1.08
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=65952&op=diff
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/lib/Test/TCP.pm (original)
+++ branches/upstream/libtest-tcp-perl/current/lib/Test/TCP.pm Sat Dec 18 16:09:29 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
Added: branches/upstream/libtest-tcp-perl/current/t/10_oo.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtest-tcp-perl/current/t/10_oo.t?rev=65952&op=file
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/t/10_oo.t (added)
+++ branches/upstream/libtest-tcp-perl/current/t/10_oo.t Sat Dec 18 16:09:29 2010
@@ -1,0 +1,41 @@
+use warnings;
+use strict;
+use Test::More tests => 22;
+use Test::TCP;
+use IO::Socket::INET;
+use t::Server;
+
+my $server = Test::TCP->new(
+ code => sub {
+ my $port = shift;
+ ok $port, "test case for sharedfork" for 1..10;
+ t::Server->new($port)->run(sub {
+ note "new request";
+ my ($remote, $line, $sock) = @_;
+ print {$remote} $line;
+ });
+ }
+);
+
+ok $server->port, "test case for sharedfork" for 1..10;
+my $sock = IO::Socket::INET->new(
+ PeerPort => $server->port,
+ PeerAddr => '127.0.0.1',
+ Proto => 'tcp'
+) or die "Cannot open client socket: $!";
+
+note "send 1";
+print {$sock} "foo\n";
+my $res = <$sock>;
+is $res, "foo\n";
+
+note "send 2";
+print {$sock} "bar\n";
+my $res2 = <$sock>;
+is $res2, "bar\n";
+
+note "finalize";
+print {$sock} "quit\n";
+
+done_testing;
+
Modified: branches/upstream/libtest-tcp-perl/current/xt/01_podspell.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libtest-tcp-perl/current/xt/01_podspell.t?rev=65952&op=diff
==============================================================================
--- branches/upstream/libtest-tcp-perl/current/xt/01_podspell.t (original)
+++ branches/upstream/libtest-tcp-perl/current/xt/01_podspell.t Sat Dec 18 16:09:29 2010
@@ -32,3 +32,6 @@
TODO
kazuhooku
FAQ
+callback
+OO
+ish
More information about the Pkg-perl-cvs-commits
mailing list