r68584 - in /trunk/libcatalyst-engine-psgi-perl: ./ debian/ inc/Test/ inc/Test/Builder/ inc/Test/SharedFork/ lib/Catalyst/Engine/
ghedo-guest at users.alioth.debian.org
ghedo-guest at users.alioth.debian.org
Mon Feb 14 14:42:32 UTC 2011
Author: ghedo-guest
Date: Mon Feb 14 14:42:08 2011
New Revision: 68584
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=68584
Log:
new upstream release
Modified:
trunk/libcatalyst-engine-psgi-perl/Changes
trunk/libcatalyst-engine-psgi-perl/META.yml
trunk/libcatalyst-engine-psgi-perl/debian/changelog
trunk/libcatalyst-engine-psgi-perl/inc/Test/Builder.pm
trunk/libcatalyst-engine-psgi-perl/inc/Test/Builder/Module.pm
trunk/libcatalyst-engine-psgi-perl/inc/Test/More.pm
trunk/libcatalyst-engine-psgi-perl/inc/Test/Requires.pm
trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork.pm
trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork/Array.pm
trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork/Scalar.pm
trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork/Store.pm
trunk/libcatalyst-engine-psgi-perl/inc/Test/TCP.pm
trunk/libcatalyst-engine-psgi-perl/lib/Catalyst/Engine/PSGI.pm
Modified: trunk/libcatalyst-engine-psgi-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-engine-psgi-perl/Changes?rev=68584&op=diff
==============================================================================
--- trunk/libcatalyst-engine-psgi-perl/Changes (original)
+++ trunk/libcatalyst-engine-psgi-perl/Changes Mon Feb 14 14:42:08 2011
@@ -1,4 +1,7 @@
Revision history for Perl extension Catalyst::Engine::PSGI
+
+0.12 Thu Jan 6 14:37:53 PST 2011
+ - Fix for Catalyst::Runtime >= 5.80030 (pedromelo)
0.11 Fri Jul 30 12:49:46 PDT 2010
- Allows setting a code reference to the $c->res->body as
Modified: trunk/libcatalyst-engine-psgi-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-engine-psgi-perl/META.yml?rev=68584&op=diff
==============================================================================
--- trunk/libcatalyst-engine-psgi-perl/META.yml (original)
+++ trunk/libcatalyst-engine-psgi-perl/META.yml Mon Feb 14 14:42:08 2011
@@ -26,4 +26,4 @@
resources:
license: http://dev.perl.org/licenses/
repository: git://github.com/miyagawa/Catalyst-Engine-PSGI.git
-version: 0.11
+version: 0.12
Modified: trunk/libcatalyst-engine-psgi-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-engine-psgi-perl/debian/changelog?rev=68584&op=diff
==============================================================================
--- trunk/libcatalyst-engine-psgi-perl/debian/changelog (original)
+++ trunk/libcatalyst-engine-psgi-perl/debian/changelog Mon Feb 14 14:42:08 2011
@@ -1,4 +1,4 @@
-libcatalyst-engine-psgi-perl (0.11-1) UNRELEASED; urgency=low
+libcatalyst-engine-psgi-perl (0.12-1) UNRELEASED; urgency=low
* Initial Release (Closes: #608562)
Modified: trunk/libcatalyst-engine-psgi-perl/inc/Test/Builder.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-engine-psgi-perl/inc/Test/Builder.pm?rev=68584&op=diff
==============================================================================
--- trunk/libcatalyst-engine-psgi-perl/inc/Test/Builder.pm (original)
+++ trunk/libcatalyst-engine-psgi-perl/inc/Test/Builder.pm Mon Feb 14 14:42:08 2011
@@ -5,7 +5,7 @@
use strict;
use warnings;
-our $VERSION = '0.94';
+our $VERSION = '0.96';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
BEGIN {
@@ -24,7 +24,7 @@
require threads::shared;
# Hack around YET ANOTHER threads::shared bug. It would
- # occassionally forget the contents of the variable when sharing it.
+ # occasionally forget the contents of the variable when sharing it.
# So we first copy the data, then share, then put our copy back.
*share = sub (\[$@%]) {
my $type = ref $_[0];
@@ -99,25 +99,35 @@
$self->croak("You already have a child named ($self->{Child_Name}) running");
}
+ my $parent_in_todo = $self->in_todo;
+
+ # Clear $TODO for the child.
+ my $orig_TODO = $self->find_TODO(undef, 1, undef);
+
my $child = bless {}, ref $self;
$child->reset;
# Add to our indentation
$child->_indent( $self->_indent . ' ' );
+
$child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH};
+ if ($parent_in_todo) {
+ $child->{Fail_FH} = $self->{Todo_FH};
+ }
# This will be reset in finalize. We do this here lest one child failure
# cause all children to fail.
$child->{Child_Error} = $?;
$? = 0;
$child->{Parent} = $self;
+ $child->{Parent_TODO} = $orig_TODO;
$child->{Name} = $name || "Child of " . $self->name;
$self->{Child_Name} = $child->name;
return $child;
}
-#line 201
+#line 211
sub subtest {
my $self = shift;
@@ -129,27 +139,50 @@
# Turn the child into the parent so anyone who has stored a copy of
# the Test::Builder singleton will get the child.
- my $child = $self->child($name);
- my %parent = %$self;
- %$self = %$child;
-
- my $error;
- if( !eval { $subtests->(); 1 } ) {
- $error = $@;
+ my($error, $child, %parent);
+ {
+ # child() calls reset() which sets $Level to 1, so we localize
+ # $Level first to limit the scope of the reset to the subtest.
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ $child = $self->child($name);
+ %parent = %$self;
+ %$self = %$child;
+
+ my $run_the_subtests = sub {
+ $subtests->();
+ $self->done_testing unless $self->_plan_handled;
+ 1;
+ };
+
+ if( !eval { $run_the_subtests->() } ) {
+ $error = $@;
+ }
}
# Restore the parent and the copied child.
%$child = %$self;
%$self = %parent;
+ # Restore the parent's $TODO
+ $self->find_TODO(undef, 1, $child->{Parent_TODO});
+
# Die *after* we restore the parent.
die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
return $child->finalize;
}
-
-#line 250
+#line 281
+
+sub _plan_handled {
+ my $self = shift;
+ return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All};
+}
+
+
+#line 306
sub finalize {
my $self = shift;
@@ -163,6 +196,7 @@
# XXX This will only be necessary for TAP envelopes (we think)
#$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
my $ok = 1;
$self->parent->{Child_Name} = undef;
if ( $self->{Skip_All} ) {
@@ -190,17 +224,17 @@
return $self->{Indent};
}
-#line 300
+#line 357
sub parent { shift->{Parent} }
-#line 312
+#line 369
sub name { shift->{Name} }
sub DESTROY {
my $self = shift;
- if ( $self->parent ) {
+ if ( $self->parent and $$ == $self->{Original_Pid} ) {
my $name = $self->name;
$self->diag(<<"FAIL");
Child ($name) exited without calling finalize()
@@ -210,7 +244,7 @@
}
}
-#line 336
+#line 393
our $Level;
@@ -227,6 +261,7 @@
$self->{Have_Plan} = 0;
$self->{No_Plan} = 0;
$self->{Have_Output_Plan} = 0;
+ $self->{Done_Testing} = 0;
$self->{Original_Pid} = $$;
$self->{Child_Name} = undef;
@@ -256,7 +291,7 @@
return;
}
-#line 414
+#line 472
my %plan_cmds = (
no_plan => \&no_plan,
@@ -303,8 +338,7 @@
return;
}
-
-#line 470
+#line 527
sub expected_tests {
my $self = shift;
@@ -322,7 +356,7 @@
return $self->{Expected_Tests};
}
-#line 494
+#line 551
sub no_plan {
my($self, $arg) = @_;
@@ -335,8 +369,7 @@
return 1;
}
-
-#line 528
+#line 584
sub _output_plan {
my($self, $max, $directive, $reason) = @_;
@@ -354,7 +387,8 @@
return;
}
-#line 579
+
+#line 636
sub done_testing {
my($self, $num_tests) = @_;
@@ -397,7 +431,7 @@
}
-#line 630
+#line 687
sub has_plan {
my $self = shift;
@@ -407,7 +441,7 @@
return(undef);
}
-#line 647
+#line 704
sub skip_all {
my( $self, $reason ) = @_;
@@ -421,7 +455,7 @@
exit(0);
}
-#line 672
+#line 729
sub exported_to {
my( $self, $pack ) = @_;
@@ -432,7 +466,7 @@
return $self->{Exported_To};
}
-#line 702
+#line 759
sub ok {
my( $self, $test, $name ) = @_;
@@ -592,14 +626,12 @@
return $numval != 0 and $numval ne $val ? 1 : 0;
}
-#line 876
+#line 933
sub is_eq {
my( $self, $got, $expect, $name ) = @_;
local $Level = $Level + 1;
- $self->_unoverload_str( \$got, \$expect );
-
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
@@ -615,8 +647,6 @@
sub is_num {
my( $self, $got, $expect, $name ) = @_;
local $Level = $Level + 1;
-
- $self->_unoverload_num( \$got, \$expect );
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
@@ -675,7 +705,7 @@
DIAGNOSTIC
}
-#line 973
+#line 1026
sub isnt_eq {
my( $self, $got, $dont_expect, $name ) = @_;
@@ -709,7 +739,7 @@
return $self->cmp_ok( $got, '!=', $dont_expect, $name );
}
-#line 1022
+#line 1075
sub like {
my( $self, $this, $regex, $name ) = @_;
@@ -725,7 +755,7 @@
return $self->_regex_ok( $this, $regex, '!~', $name );
}
-#line 1046
+#line 1099
my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
@@ -741,8 +771,9 @@
my($pack, $file, $line) = $self->caller();
+ # This is so that warnings come out at the caller's level
$test = eval qq[
-#line 1 "cmp_ok [from $file line $line]"
+#line $line "(eval in cmp_ok) $file"
\$got $type \$expect;
];
$error = $@;
@@ -805,7 +836,7 @@
return $code;
}
-#line 1145
+#line 1199
sub BAIL_OUT {
my( $self, $reason ) = @_;
@@ -815,14 +846,14 @@
exit 255;
}
-#line 1158
+#line 1212
{
no warnings 'once';
*BAILOUT = \&BAIL_OUT;
}
-#line 1172
+#line 1226
sub skip {
my( $self, $why ) = @_;
@@ -853,7 +884,7 @@
return 1;
}
-#line 1213
+#line 1267
sub todo_skip {
my( $self, $why ) = @_;
@@ -881,7 +912,7 @@
return 1;
}
-#line 1293
+#line 1347
sub maybe_regex {
my( $self, $regex ) = @_;
@@ -961,7 +992,7 @@
# I'm not ready to publish this. It doesn't deal with array return
# values from the code or context.
-#line 1389
+#line 1443
sub _try {
my( $self, $code, %opts ) = @_;
@@ -981,7 +1012,7 @@
return wantarray ? ( $return, $error ) : $return;
}
-#line 1418
+#line 1472
sub is_fh {
my $self = shift;
@@ -995,7 +1026,7 @@
eval { tied($maybe_fh)->can('TIEHANDLE') };
}
-#line 1461
+#line 1515
sub level {
my( $self, $level ) = @_;
@@ -1006,7 +1037,7 @@
return $Level;
}
-#line 1493
+#line 1547
sub use_numbers {
my( $self, $use_nums ) = @_;
@@ -1017,7 +1048,7 @@
return $self->{Use_Nums};
}
-#line 1526
+#line 1580
foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
my $method = lc $attribute;
@@ -1035,7 +1066,7 @@
*{ __PACKAGE__ . '::' . $method } = $code;
}
-#line 1579
+#line 1633
sub diag {
my $self = shift;
@@ -1043,7 +1074,7 @@
$self->_print_comment( $self->_diag_fh, @_ );
}
-#line 1594
+#line 1648
sub note {
my $self = shift;
@@ -1080,7 +1111,7 @@
return 0;
}
-#line 1644
+#line 1698
sub explain {
my $self = shift;
@@ -1099,7 +1130,7 @@
} @_;
}
-#line 1673
+#line 1727
sub _print {
my $self = shift;
@@ -1114,20 +1145,21 @@
return if $^C;
my $msg = join '', @msgs;
+ my $indent = $self->_indent;
local( $\, $", $, ) = ( undef, ' ', '' );
# Escape each line after the first with a # so we don't
# confuse Test::Harness.
- $msg =~ s{\n(?!\z)}{\n# }sg;
+ $msg =~ s{\n(?!\z)}{\n$indent# }sg;
# Stick a newline on the end if it needs it.
$msg .= "\n" unless $msg =~ /\n\z/;
- return print $fh $self->_indent, $msg;
-}
-
-#line 1732
+ return print $fh $indent, $msg;
+}
+
+#line 1787
sub output {
my( $self, $fh ) = @_;
@@ -1246,7 +1278,7 @@
return;
}
-#line 1857
+#line 1912
sub reset_outputs {
my $self = shift;
@@ -1258,7 +1290,7 @@
return;
}
-#line 1883
+#line 1938
sub _message_at_caller {
my $self = shift;
@@ -1279,7 +1311,7 @@
}
-#line 1923
+#line 1978
sub current_test {
my( $self, $num ) = @_;
@@ -1312,7 +1344,7 @@
return $self->{Curr_Test};
}
-#line 1971
+#line 2026
sub is_passing {
my $self = shift;
@@ -1325,7 +1357,7 @@
}
-#line 1993
+#line 2048
sub summary {
my($self) = shift;
@@ -1333,14 +1365,14 @@
return map { $_->{'ok'} } @{ $self->{Test_Results} };
}
-#line 2048
+#line 2103
sub details {
my $self = shift;
return @{ $self->{Test_Results} };
}
-#line 2077
+#line 2132
sub todo {
my( $self, $pack ) = @_;
@@ -1354,19 +1386,21 @@
return '';
}
-#line 2099
+#line 2159
sub find_TODO {
- my( $self, $pack ) = @_;
+ my( $self, $pack, $set, $new_value ) = @_;
$pack = $pack || $self->caller(1) || $self->exported_to;
return unless $pack;
no strict 'refs'; ## no critic
- return ${ $pack . '::TODO' };
-}
-
-#line 2117
+ my $old_value = ${ $pack . '::TODO' };
+ $set and ${ $pack . '::TODO' } = $new_value;
+ return $old_value;
+}
+
+#line 2179
sub in_todo {
my $self = shift;
@@ -1375,7 +1409,7 @@
return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
}
-#line 2167
+#line 2229
sub todo_start {
my $self = shift;
@@ -1390,7 +1424,7 @@
return;
}
-#line 2189
+#line 2251
sub todo_end {
my $self = shift;
@@ -1411,7 +1445,7 @@
return;
}
-#line 2222
+#line 2284
sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
my( $self, $height ) = @_;
@@ -1426,9 +1460,9 @@
return wantarray ? @caller : $caller[0];
}
-#line 2239
-
-#line 2253
+#line 2301
+
+#line 2315
#'#
sub _sanity_check {
@@ -1441,7 +1475,7 @@
return;
}
-#line 2274
+#line 2336
sub _whoa {
my( $self, $check, $desc ) = @_;
@@ -1456,7 +1490,7 @@
return;
}
-#line 2298
+#line 2360
sub _my_exit {
$? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
@@ -1464,7 +1498,7 @@
return 1;
}
-#line 2310
+#line 2372
sub _ending {
my $self = shift;
@@ -1583,7 +1617,7 @@
$Test->_ending if defined $Test;
}
-#line 2498
+#line 2560
1;
Modified: trunk/libcatalyst-engine-psgi-perl/inc/Test/Builder/Module.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-engine-psgi-perl/inc/Test/Builder/Module.pm?rev=68584&op=diff
==============================================================================
--- trunk/libcatalyst-engine-psgi-perl/inc/Test/Builder/Module.pm (original)
+++ trunk/libcatalyst-engine-psgi-perl/inc/Test/Builder/Module.pm Mon Feb 14 14:42:08 2011
@@ -8,7 +8,7 @@
require Exporter;
our @ISA = qw(Exporter);
-our $VERSION = '0.94';
+our $VERSION = '0.96';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
Modified: trunk/libcatalyst-engine-psgi-perl/inc/Test/More.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-engine-psgi-perl/inc/Test/More.pm?rev=68584&op=diff
==============================================================================
--- trunk/libcatalyst-engine-psgi-perl/inc/Test/More.pm (original)
+++ trunk/libcatalyst-engine-psgi-perl/inc/Test/More.pm Mon Feb 14 14:42:08 2011
@@ -18,7 +18,7 @@
return warn @_, " at $file line $line\n";
}
-our $VERSION = '0.94';
+our $VERSION = '0.96';
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
use Test::Builder::Module;
@@ -247,7 +247,7 @@
return $obj;
}
-#line 719
+#line 736
sub subtest($&) {
my ($name, $subtests) = @_;
@@ -256,7 +256,7 @@
return $tb->subtest(@_);
}
-#line 743
+#line 760
sub pass (;$) {
my $tb = Test::More->builder;
@@ -270,7 +270,7 @@
return $tb->ok( 0, @_ );
}
-#line 806
+#line 823
sub use_ok ($;@) {
my( $module, @imports ) = @_;
@@ -332,7 +332,7 @@
return( $eval_result, $eval_error );
}
-#line 875
+#line 892
sub require_ok ($) {
my($module) = shift;
@@ -340,7 +340,7 @@
my $pack = caller;
- # Try to deterine if we've been given a module name or file.
+ # Try to determine if we've been given a module name or file.
# Module names must be barewords, files not.
$module = qq['$module'] unless _is_module_name($module);
@@ -376,7 +376,7 @@
return $module =~ /^[a-zA-Z]\w*$/ ? 1 : 0;
}
-#line 952
+#line 969
our( @Data_Stack, %Refs_Seen );
my $DNE = bless [], 'Does::Not::Exist';
@@ -476,14 +476,14 @@
return '' if !ref $thing;
- for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
+ for my $type (qw(Regexp ARRAY HASH REF SCALAR GLOB CODE)) {
return $type if UNIVERSAL::isa( $thing, $type );
}
return '';
}
-#line 1112
+#line 1129
sub diag {
return Test::More->builder->diag(@_);
@@ -493,13 +493,13 @@
return Test::More->builder->note(@_);
}
-#line 1138
+#line 1155
sub explain {
return Test::More->builder->explain(@_);
}
-#line 1204
+#line 1221
## no critic (Subroutines::RequireFinalReturn)
sub skip {
@@ -527,7 +527,7 @@
last SKIP;
}
-#line 1288
+#line 1305
sub todo_skip {
my( $why, $how_many ) = @_;
@@ -548,7 +548,7 @@
last TODO;
}
-#line 1343
+#line 1360
sub BAIL_OUT {
my $reason = shift;
@@ -557,7 +557,7 @@
$tb->BAIL_OUT($reason);
}
-#line 1382
+#line 1399
#'#
sub eq_array {
@@ -581,6 +581,8 @@
my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
+ next if _equal_nonrefs($e1, $e2);
+
push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [ $e1, $e2 ] };
$ok = _deep_check( $e1, $e2 );
pop @Data_Stack if $ok;
@@ -589,6 +591,21 @@
}
return $ok;
+}
+
+sub _equal_nonrefs {
+ my( $e1, $e2 ) = @_;
+
+ return if ref $e1 or ref $e2;
+
+ if ( defined $e1 ) {
+ return 1 if defined $e2 and $e1 eq $e2;
+ }
+ else {
+ return 1 if !defined $e2;
+ }
+
+ return;
}
sub _deep_check {
@@ -603,9 +620,6 @@
local %Refs_Seen = %Refs_Seen;
{
- # Quiet uninitialized value warnings when comparing undefs.
- no warnings 'uninitialized';
-
$tb->_unoverload_str( \$e1, \$e2 );
# Either they're both references or both not.
@@ -616,7 +630,7 @@
$ok = 0;
}
elsif( !defined $e1 and !defined $e2 ) {
- # Shortcut if they're both defined.
+ # Shortcut if they're both undefined.
$ok = 1;
}
elsif( _dne($e1) xor _dne($e2) ) {
@@ -683,7 +697,7 @@
}
}
-#line 1515
+#line 1546
sub eq_hash {
local @Data_Stack = ();
@@ -706,6 +720,8 @@
my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
+ next if _equal_nonrefs($e1, $e2);
+
push @Data_Stack, { type => 'HASH', idx => $k, vals => [ $e1, $e2 ] };
$ok = _deep_check( $e1, $e2 );
pop @Data_Stack if $ok;
@@ -716,7 +732,7 @@
return $ok;
}
-#line 1572
+#line 1605
sub eq_set {
my( $a1, $a2 ) = @_;
@@ -741,6 +757,6 @@
);
}
-#line 1774
+#line 1807
1;
Modified: trunk/libcatalyst-engine-psgi-perl/inc/Test/Requires.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-engine-psgi-perl/inc/Test/Requires.pm?rev=68584&op=diff
==============================================================================
--- trunk/libcatalyst-engine-psgi-perl/inc/Test/Requires.pm (original)
+++ trunk/libcatalyst-engine-psgi-perl/inc/Test/Requires.pm Mon Feb 14 14:42:08 2011
@@ -2,9 +2,9 @@
package Test::Requires;
use strict;
use warnings;
-our $VERSION = '0.05';
+our $VERSION = '0.06';
use base 'Test::Builder::Module';
-use 5.008000;
+use 5.006000;
sub import {
my $class = shift;
Modified: trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork.pm?rev=68584&op=diff
==============================================================================
--- trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork.pm (original)
+++ trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork.pm Mon Feb 14 14:42:08 2011
@@ -3,36 +3,119 @@
use strict;
use warnings;
use base 'Test::Builder::Module';
-our $VERSION = '0.11';
+our $VERSION = '0.15';
use Test::Builder 0.32; # 0.32 or later is needed
use Test::SharedFork::Scalar;
use Test::SharedFork::Array;
use Test::SharedFork::Store;
+use Config;
use 5.008000;
+
+{
+ package #
+ Test::SharedFork::Contextual;
+
+ sub call {
+ my $code = shift;
+ my $wantarray = [caller(1)]->[5];
+ if ($wantarray) {
+ my @result = $code->();
+ bless {result => \@result, wantarray => $wantarray}, __PACKAGE__;
+ } elsif (defined $wantarray) {
+ my $result = $code->();
+ bless {result => $result, wantarray => $wantarray}, __PACKAGE__;
+ } else {
+ { ; $code->(); } # void context
+ bless {wantarray => $wantarray}, __PACKAGE__;
+ }
+ }
+
+ sub result {
+ my $self = shift;
+ if ($self->{wantarray}) {
+ return @{ $self->{result} };
+ } elsif (defined $self->{wantarray}) {
+ return $self->{result};
+ } else {
+ return;
+ }
+ }
+}
my $STORE;
BEGIN {
- $STORE = Test::SharedFork::Store->new(
- cb => sub {
- my $store = shift;
- tie __PACKAGE__->builder->{Curr_Test}, 'Test::SharedFork::Scalar', 0, $store;
- tie @{ __PACKAGE__->builder->{Test_Results} }, 'Test::SharedFork::Array', $store;
+ my $builder = __PACKAGE__->builder;
+
+ if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
+ die "# Current version of Test::SharedFork does not supports ithreads.";
+ }
+
+ if (Test::Builder->VERSION > 2.00) {
+ # new Test::Builder
+ $STORE = Test::SharedFork::Store->new();
+
+ our $level = 0;
+ for my $class (qw/Test::Builder2::History Test::Builder2::Counter/) {
+ my $meta = $class->meta;
+ my @methods = $meta->get_method_list;
+ my $orig =
+ $class eq 'Test::Builder2::History'
+ ? $builder->{History}
+ : $builder->{History}->counter;
+ $orig->{test_sharedfork_hacked}++;
+ $STORE->set($class => $orig);
+ for my $method (@methods) {
+ next if $method =~ /^_/;
+ next if $method eq 'meta';
+ next if $method eq 'create';
+ next if $method eq 'singleton';
+ $meta->add_around_method_modifier(
+ $method => sub {
+ my ($code, $orig_self, @args) = @_;
+ return $orig_self->$code(@args) if (! ref $orig_self) || ! $orig_self->{test_sharedfork_hacked};
+
+ my $lock = $STORE->get_lock();
+ local $level = $level + 1;
+ my $self =
+ $level == 1 ? $STORE->get($class) : $orig_self;
+
+ my $ret = Test::SharedFork::Contextual::call(sub { $self->$code(@args) });
+ $STORE->set($class => $self);
+ return $ret->result;
+ },
+ );
+ }
}
- );
+ } else {
+ # older Test::Builder
+ $STORE = Test::SharedFork::Store->new(
+ cb => sub {
+ my $store = shift;
+ tie $builder->{Curr_Test}, 'Test::SharedFork::Scalar',
+ $store, 'Curr_Test';
+ tie @{ $builder->{Test_Results} },
+ 'Test::SharedFork::Array', $store, 'Test_Results';
+ },
+ init => +{
+ Test_Results => $builder->{Test_Results},
+ Curr_Test => $builder->{Curr_Test},
+ },
+ );
+ }
+ # make methods atomic.
no strict 'refs';
no warnings 'redefine';
for my $name (qw/ok skip todo_skip current_test/) {
my $orig = *{"Test::Builder::${name}"}{CODE};
*{"Test::Builder::${name}"} = sub {
- local $Test::Builder::Level += 4;
- my @args = @_;
- $STORE->lock_cb(sub {
- $orig->(@args);
- });
+ local $Test::Builder::Level += 3;
+ my $lock = $STORE->get_lock(); # RAII
+ $orig->(@_);
};
};
+
}
{
@@ -45,4 +128,4 @@
1;
__END__
-#line 96
+#line 183
Modified: trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork/Array.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork/Array.pm?rev=68584&op=diff
==============================================================================
--- trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork/Array.pm (original)
+++ trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork/Array.pm Mon Feb 14 14:42:08 2011
@@ -7,15 +7,17 @@
# create new tied array
sub TIEARRAY {
- my ($class, $share) = @_;
- my $self = bless { share => $share }, $class;
+ my ($class, $share, $key) = @_;
+ die "missing key" unless $key;
+ my $self = bless { share => $share, key => $key }, $class;
$self;
}
sub _get {
my $self = shift;
- return $self->{share}->get('array');
+ my $lock = $self->{share}->get_lock();
+ return $self->{share}->get($self->{key});
}
sub FETCH {
my ($self, $index) = @_;
@@ -30,12 +32,12 @@
sub STORE {
my ($self, $index, $val) = @_;
- $self->{share}->lock_cb(sub {
- my $share = $self->{share};
- my $cur = $share->get_nolock('array');
- $cur->[$index] = $val;
- $share->set_nolock(array => $cur);
- });
+ my $lock = $self->{share}->get_lock();
+
+ my $share = $self->{share};
+ my $cur = $share->get($self->{key});
+ $cur->[$index] = $val;
+ $share->set($self->{key} => $cur);
}
1;
Modified: trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork/Scalar.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork/Scalar.pm?rev=68584&op=diff
==============================================================================
--- trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork/Scalar.pm (original)
+++ trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork/Scalar.pm Mon Feb 14 14:42:08 2011
@@ -6,19 +6,22 @@
# create new tied scalar
sub TIESCALAR {
- my ($class, $initial, $share) = @_;
- bless { share => $share }, $class;
+ my ($class, $share, $key) = @_;
+ die "missing key" unless $key;
+ bless { share => $share, key => $key }, $class;
}
sub FETCH {
my $self = shift;
- $self->{share}->get('scalar');
+ my $lock = $self->{share}->get_lock();
+ $self->{share}->get($self->{key});
}
sub STORE {
my ($self, $val) = @_;
my $share = $self->{share};
- $share->set('scalar' => $val);
+ my $lock = $self->{share}->get_lock();
+ $share->set($self->{key} => $val);
}
1;
Modified: trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork/Store.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork/Store.pm?rev=68584&op=diff
==============================================================================
--- trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork/Store.pm (original)
+++ trunk/libcatalyst-engine-psgi-perl/inc/Test/SharedFork/Store.pm Mon Feb 14 14:42:08 2011
@@ -11,14 +11,20 @@
my $class = shift;
my %args = @_;
my $filename = File::Temp::tmpnam();
- my $self = bless {callback_on_open => $args{cb}, filename => $filename, lock => 0, pid => $$, ppid => $$}, $class;
+
+ my $init = Storable::dclone($args{init} || +{});
+
+ my $self = bless {
+ callback_on_open => $args{cb},
+ filename => $filename,
+ lock => 0,
+ pid => $$,
+ ppid => $$,
+ }, $class;
$self->open();
# initialize
- Storable::nstore_fd(+{
- array => [],
- scalar => 0,
- }, $self->{fh}) or die "Cannot write initialize data to $filename";
+ Storable::nstore_fd($init, $self->{fh}) or die "Cannot write initialize data to $filename";
return $self;
}
@@ -41,31 +47,12 @@
sub get {
my ($self, $key) = @_;
-
- $self->_reopen_if_needed;
- my $ret = $self->lock_cb(sub {
- $self->get_nolock($key);
- }, LOCK_SH);
- return $ret;
-}
-
-sub get_nolock {
- my ($self, $key) = @_;
$self->_reopen_if_needed;
seek $self->{fh}, 0, SEEK_SET or die $!;
Storable::fd_retrieve($self->{fh})->{$key};
}
sub set {
- my ($self, $key, $val) = @_;
-
- $self->_reopen_if_needed;
- $self->lock_cb(sub {
- $self->set_nolock($key, $val);
- }, LOCK_EX);
-}
-
-sub set_nolock {
my ($self, $key, $val) = @_;
$self->_reopen_if_needed;
@@ -79,23 +66,9 @@
Storable::nstore_fd($dat => $self->{fh}) or die "Cannot store data to $self->{filename}";
}
-sub lock_cb {
- my ($self, $cb) = @_;
-
- $self->_reopen_if_needed;
-
- if ($self->{lock}++ == 0) {
- flock $self->{fh}, LOCK_EX or die $!;
- }
-
- my $ret = $cb->();
-
- $self->{lock}--;
- if ($self->{lock} == 0) {
- flock $self->{fh}, LOCK_UN or die $!;
- }
-
- $ret;
+sub get_lock {
+ my ($self, ) = @_;
+ Test::SharedFork::Store::Locker->new($self);
}
sub _reopen_if_needed {
@@ -118,4 +91,30 @@
}
}
+package # hide from pause
+ Test::SharedFork::Store::Locker;
+
+use Fcntl ':flock';
+
+sub new {
+ my ($class, $store) = @_;
+
+ $store->_reopen_if_needed;
+
+ if ($store->{lock}++ == 0) {
+ flock $store->{fh}, LOCK_EX or die $!;
+ }
+
+ bless { store => $store }, $class;
+}
+
+sub DESTROY {
+ my ($self) = @_;
+
+ $self->{store}->{lock}--;
+ if ($self->{store}->{lock} == 0) {
+ flock $self->{store}->{fh}, LOCK_UN or die $!;
+ }
+}
+
1;
Modified: trunk/libcatalyst-engine-psgi-perl/inc/Test/TCP.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-engine-psgi-perl/inc/Test/TCP.pm?rev=68584&op=diff
==============================================================================
--- trunk/libcatalyst-engine-psgi-perl/inc/Test/TCP.pm (original)
+++ trunk/libcatalyst-engine-psgi-perl/inc/Test/TCP.pm Mon Feb 14 14:42:08 2011
@@ -3,25 +3,34 @@
use strict;
use warnings;
use 5.00800;
-our $VERSION = '0.16';
+our $VERSION = '1.11';
use base qw/Exporter/;
use IO::Socket::INET;
-use Test::SharedFork;
+use Test::SharedFork 0.12;
use Test::More ();
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 = 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',
@@ -39,55 +48,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 = Test::SharedFork->fork() ) {
- # 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 = $@;
-
- # cleanup
- kill $TERMSIG => $pid;
- 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;
- }
- }
- }
-
- if ($sig) {
- kill $sig, $$; # rethrow signal after cleanup
- }
- if ($err) {
- die $err; # rethrow exception after cleanup.
- }
- }
- 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 {
@@ -118,9 +84,77 @@
die "cannot open port: $port";
}
+# -------------------------------------------------------------------------
+# 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 stop {
+ 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;
+ }
+ }
+ undef $self->{pid};
+}
+
+sub DESTROY {
+ my $self = shift;
+ local $@;
+ $self->stop();
+}
+
1;
__END__
=encoding utf8
-#line 241
+#line 381
Modified: trunk/libcatalyst-engine-psgi-perl/lib/Catalyst/Engine/PSGI.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-engine-psgi-perl/lib/Catalyst/Engine/PSGI.pm?rev=68584&op=diff
==============================================================================
--- trunk/libcatalyst-engine-psgi-perl/lib/Catalyst/Engine/PSGI.pm (original)
+++ trunk/libcatalyst-engine-psgi-perl/lib/Catalyst/Engine/PSGI.pm Mon Feb 14 14:42:08 2011
@@ -2,7 +2,7 @@
use strict;
use 5.008_001;
-our $VERSION = '0.11';
+our $VERSION = '0.12';
use Moose;
extends 'Catalyst::Engine';
@@ -175,6 +175,7 @@
unless $c;
my $body = $c->res->body;
+ $body = '' unless defined $body;
if (!ref $body && $body eq '' && $self->{buffer}) {
$body = [ $self->{buffer} ];
} elsif (ref($body) eq 'GLOB' || (Scalar::Util::blessed($body) && $body->can('getline'))) {
@@ -237,7 +238,7 @@
Alternatively, it is possible to set the body to a code reference,
which will be used to steam content as documented in the
-L<PSGI/Delayed_Reponse_and_Streaming_Body|PSGI spec>.
+L<PSGI spec|PSGI/Delayed_Reponse_and_Streaming_Body>.
=item *
More information about the Pkg-perl-cvs-commits
mailing list