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