r10707 - in /branches/upstream/libsub-uplevel-perl/current: Build.PL Changes MANIFEST META.yml README lib/Sub/Uplevel.pm t/02_uplevel.t t/03_nested_uplevels.t t/04_honor_later_override.t t/05_honor_prior_override.t

gregoa-guest at users.alioth.debian.org gregoa-guest at users.alioth.debian.org
Sun Dec 2 16:07:28 UTC 2007


Author: gregoa-guest
Date: Sun Dec  2 16:07:28 2007
New Revision: 10707

URL: http://svn.debian.org/wsvn/?sc=1&rev=10707
Log:
[svn-upgrade] Integrating new upstream version, libsub-uplevel-perl (0.18)

Added:
    branches/upstream/libsub-uplevel-perl/current/t/04_honor_later_override.t
    branches/upstream/libsub-uplevel-perl/current/t/05_honor_prior_override.t
Modified:
    branches/upstream/libsub-uplevel-perl/current/Build.PL
    branches/upstream/libsub-uplevel-perl/current/Changes
    branches/upstream/libsub-uplevel-perl/current/MANIFEST
    branches/upstream/libsub-uplevel-perl/current/META.yml
    branches/upstream/libsub-uplevel-perl/current/README
    branches/upstream/libsub-uplevel-perl/current/lib/Sub/Uplevel.pm
    branches/upstream/libsub-uplevel-perl/current/t/02_uplevel.t
    branches/upstream/libsub-uplevel-perl/current/t/03_nested_uplevels.t

Modified: branches/upstream/libsub-uplevel-perl/current/Build.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/Build.PL?rev=10707&op=diff
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/Build.PL (original)
+++ branches/upstream/libsub-uplevel-perl/current/Build.PL Sun Dec  2 16:07:28 2007
@@ -8,7 +8,6 @@
     create_readme       => 1,
     create_makefile_pl  => 'traditional',
     requires        => {
-        perl => 5.006,
         Test::More => 0.47,
     },
 )->create_build_script;

Modified: branches/upstream/libsub-uplevel-perl/current/Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/Changes?rev=10707&op=diff
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/Changes (original)
+++ branches/upstream/libsub-uplevel-perl/current/Changes Sun Dec  2 16:07:28 2007
@@ -1,4 +1,19 @@
 Changes for Sub::Uplevel
+
+0.18 Wed Oct 31 06:56:13 EDT 2007
+    - release version of 0.17_01 changes
+
+0.17_01
+    - removed 5.006-specific language and tested on prerelease 5.00505
+
+0.16 Mon Jul 30 09:54:41 EDT 2007
+    - release version of 0.15_01 changes
+
+0.15_01 Thu Jul  5 22:54:08 EDT 2007
+    - Won't override any existing CORE::GLOBAL::caller when loaded 
+    - Localize global caller() override to the scope of the uplevel() call 
+      so it can play nicer with things like Contextual::Return and
+      Hook::LexWrap that also override caller()
 
 0.14 Sun Nov  5 23:38:46 EST 2006
     - fixed t/99_pod_coverage.t bug

Modified: branches/upstream/libsub-uplevel-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/MANIFEST?rev=10707&op=diff
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/MANIFEST (original)
+++ branches/upstream/libsub-uplevel-perl/current/MANIFEST Sun Dec  2 16:07:28 2007
@@ -10,6 +10,8 @@
 t/01_die_check.t
 t/02_uplevel.t
 t/03_nested_uplevels.t
+t/04_honor_later_override.t
+t/05_honor_prior_override.t
 t/98_pod.t
 t/99_pod_coverage.t
 t/lib/Foo.pm

Modified: branches/upstream/libsub-uplevel-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/META.yml?rev=10707&op=diff
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/META.yml (original)
+++ branches/upstream/libsub-uplevel-perl/current/META.yml Sun Dec  2 16:07:28 2007
@@ -1,6 +1,6 @@
 ---
 name: Sub-Uplevel
-version: 0.14
+version: 0.18
 author:
   - 'David A. Golden <dagolden at cpan.org>'
 abstract: apparently run a function in a higher stack frame
@@ -9,12 +9,11 @@
   license: http://dev.perl.org/licenses/
 requires:
   Test::More: 0.47
-  perl: 5.006
 provides:
   Sub::Uplevel:
     file: lib/Sub/Uplevel.pm
-    version: 0.14
-generated_by: Module::Build version 0.2805
+    version: 0.18
+generated_by: Module::Build version 0.2808
 meta-spec:
   url: http://module-build.sourceforge.net/META-spec-v1.2.html
   version: 1.2

Modified: branches/upstream/libsub-uplevel-perl/current/README
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/README?rev=10707&op=diff
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/README (original)
+++ branches/upstream/libsub-uplevel-perl/current/README Sun Dec  2 16:07:28 2007
@@ -1,5 +1,8 @@
 NAME
     Sub::Uplevel - apparently run a function in a higher stack frame
+
+VERSION
+    This documentation describes version 0.18
 
 SYNOPSIS
       use Sub::Uplevel;
@@ -66,14 +69,16 @@
     If this code frightens you you should not use this module.
 
 BUGS and CAVEATS
-    Sub::Uplevel must be used as early as possible in your program's
-    compilation.
-
     Well, the bad news is uplevel() is about 5 times slower than a normal
     function call. XS implementation anyone?
 
-    Blows over any CORE::GLOBAL::caller you might have (and if you do,
-    you're just sick).
+    Sub::Uplevel overrides CORE::GLOBAL::caller temporarily for the scope of
+    each uplevel call. It does its best to work with any previously existing
+    CORE::GLOBAL::caller (both when Sub::Uplevel is first loaded and within
+    each uplevel call) such as from Contextual::Return or Hook::LexWrap.
+
+    However, if you are routinely using multiple modules that override
+    CORE::GLOBAL::caller, you are probably asking for trouble.
 
 HISTORY
     Those who do not learn from HISTORY are doomed to repeat it.
@@ -90,7 +95,8 @@
     Michael G Schwern <schwern at pobox.com> (original author)
 
 LICENSE
-    Copyright by Michael G Schwern, David A Golden
+    Original code Copyright (c) 2001 to 2007 by Michael G Schwern.
+    Additional code Copyright (c) 2006 to 2007 by David A Golden.
 
     This program is free software; you can redistribute it and/or modify it
     under the same terms as Perl itself.

Modified: branches/upstream/libsub-uplevel-perl/current/lib/Sub/Uplevel.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/lib/Sub/Uplevel.pm?rev=10707&op=diff
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/lib/Sub/Uplevel.pm (original)
+++ branches/upstream/libsub-uplevel-perl/current/lib/Sub/Uplevel.pm Sun Dec  2 16:07:28 2007
@@ -1,13 +1,15 @@
 package Sub::Uplevel;
-
-use 5.006;
 
 use strict;
 use vars qw($VERSION @ISA @EXPORT);
-$VERSION = "0.14";
-
-# We have to do this so the CORE::GLOBAL versions override the builtins
-_setup_CORE_GLOBAL();
+$VERSION = '0.18';
+
+# We must override *CORE::GLOBAL::caller if it hasn't already been 
+# overridden or else Perl won't see our local override later.
+
+if ( not defined *CORE::GLOBAL::caller{CODE} ) {
+    *CORE::GLOBAL::caller = \&_normal_caller;
+}
 
 require Exporter;
 @ISA = qw(Exporter);
@@ -16,6 +18,10 @@
 =head1 NAME
 
 Sub::Uplevel - apparently run a function in a higher stack frame
+
+=head1 VERSION
+
+This documentation describes version 0.18
 
 =head1 SYNOPSIS
 
@@ -72,25 +78,48 @@
 
 =cut
 
-our @Up_Frames; # uplevel stack
+use vars qw/@Up_Frames $Caller_Proxy/;
+# @Up_Frames -- uplevel stack
+# $Caller_Proxy -- whatever caller() override was in effect before uplevel
 
 sub uplevel {
     my($num_frames, $func, @args) = @_;
     
     local @Up_Frames = ($num_frames, @Up_Frames );
+    
+    # backwards compatible version of "no warnings 'redefine'"
+    my $old_W = $^W;
+    $^W = 0;
+
+    # Update the caller proxy if the uplevel override isn't in effect
+    local $Caller_Proxy = *CORE::GLOBAL::caller{CODE}
+        if *CORE::GLOBAL::caller{CODE} != \&_uplevel_caller;
+    local *CORE::GLOBAL::caller = \&_uplevel_caller;
+    
+    # restore old warnings state
+    $^W = $old_W;
+
     return $func->(@args);
 }
 
-
-sub _setup_CORE_GLOBAL {
-    no warnings 'redefine';
-
-    *CORE::GLOBAL::caller = sub(;$) {
-        my $height = $_[0] || 0;
-
-        # shortcut if no uplevels have been called
-        # always add +1 to CORE::caller to skip this function's caller
-        return CORE::caller( $height + 1 ) if ! @Up_Frames;
+sub _normal_caller (;$) {
+    my $height = $_[0];
+    $height++;
+    if( wantarray and !@_ ) {
+        return (CORE::caller($height))[0..2];
+    }
+    else {
+        return CORE::caller($height);
+    }
+}
+
+sub _uplevel_caller (;$) {
+    my $height = $_[0] || 0;
+
+    # shortcut if no uplevels have been called
+    # always add +1 to CORE::caller (proxy caller function)
+    # to skip this function's caller
+    return $Caller_Proxy->( $height + 1 ) if ! @Up_Frames;
 
 =begin _private
 
@@ -142,36 +171,39 @@
         
 =cut
 
-        my $saw_uplevel = 0;
-        my $adjust = 0;
-
-        # walk up the call stack to fight the right package level to return;
-        # look one higher than requested for each call to uplevel found
-        # and adjust by the amount found in the Up_Frames stack for that call
-
-        for ( my $up = 0; $up <= $height + $adjust; $up++ ) {
-            my @caller = CORE::caller($up + 1); 
-            if( defined $caller[0] && $caller[0] eq __PACKAGE__ ) {
-                # add one for each uplevel call seen
-                # and look into the uplevel stack for the offset
-                $adjust += 1 + $Up_Frames[$saw_uplevel];
-                $saw_uplevel++;
-            }
+    my $saw_uplevel = 0;
+    my $adjust = 0;
+
+    # walk up the call stack to fight the right package level to return;
+    # look one higher than requested for each call to uplevel found
+    # and adjust by the amount found in the Up_Frames stack for that call.
+    # We *must* use CORE::caller here since we need the real stack not what 
+    # some other override says the stack looks like, just in case that other
+    # override breaks things in some horrible way
+
+    for ( my $up = 0; $up <= $height + $adjust; $up++ ) {
+        my @caller = CORE::caller($up + 1); 
+        if( defined $caller[0] && $caller[0] eq __PACKAGE__ ) {
+            # add one for each uplevel call seen
+            # and look into the uplevel stack for the offset
+            $adjust += 1 + $Up_Frames[$saw_uplevel];
+            $saw_uplevel++;
         }
-
-        my @caller = CORE::caller($height + $adjust + 1);
-
-        if( wantarray ) {
-            if( !@_ ) {
-                @caller = @caller[0..2];
-            }
-            return @caller;
+    }
+
+    # For returning values, we pass through the call to the proxy caller
+    # function, just at a higher stack level
+    my @caller = $Caller_Proxy->($height + $adjust + 1);
+
+    if( wantarray ) {
+        if( !@_ ) {
+            @caller = @caller[0..2];
         }
-        else {
-            return $caller[0];
-        }
-    }; # sub
-
+        return @caller;
+    }
+    else {
+        return $caller[0];
+    }
 }
 
 =back
@@ -196,15 +228,16 @@
 
 =head1 BUGS and CAVEATS
 
-Sub::Uplevel must be used as early as possible in your program's
-compilation.
-
 Well, the bad news is uplevel() is about 5 times slower than a normal
 function call.  XS implementation anyone?
 
-Blows over any CORE::GLOBAL::caller you might have (and if you do,
-you're just sick).
-
+Sub::Uplevel overrides CORE::GLOBAL::caller temporarily for the scope of
+each uplevel call.  It does its best to work with any previously existing
+CORE::GLOBAL::caller (both when Sub::Uplevel is first loaded and within 
+each uplevel call) such as from Contextual::Return or Hook::LexWrap.  
+
+However, if you are routinely using multiple modules that override 
+CORE::GLOBAL::caller, you are probably asking for trouble.
 
 =head1 HISTORY
 
@@ -213,12 +246,10 @@
 The lesson here is simple:  Don't sit next to a Tcl programmer at the
 dinner table.
 
-
 =head1 THANKS
 
 Thanks to Brent Welch, Damian Conway and Robin Houston.
 
-
 =head1 AUTHORS
 
 David A Golden E<lt>dagolden at cpan.orgE<gt> (current maintainer)
@@ -227,14 +258,14 @@
 
 =head1 LICENSE
 
-Copyright by Michael G Schwern, David A Golden
+Original code Copyright (c) 2001 to 2007 by Michael G Schwern.
+Additional code Copyright (c) 2006 to 2007 by David A Golden.
 
 This program is free software; you can redistribute it and/or modify it
 under the same terms as Perl itself.
 
 See http://www.perl.com/perl/misc/Artistic.html
 
-
 =head1 SEE ALSO
 
 PadWalker (for the similar idea with lexicals), Hook::LexWrap, 

Modified: branches/upstream/libsub-uplevel-perl/current/t/02_uplevel.t
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/t/02_uplevel.t?rev=10707&op=diff
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/t/02_uplevel.t (original)
+++ branches/upstream/libsub-uplevel-perl/current/t/02_uplevel.t Sun Dec  2 16:07:28 2007
@@ -2,7 +2,7 @@
 
 use lib qw(t/lib);
 use strict;
-use Test::More tests => 20;
+use Test::More tests => 22;
 
 BEGIN { use_ok('Sub::Uplevel'); }
 can_ok('Sub::Uplevel', 'uplevel');
@@ -72,14 +72,18 @@
 }
 
 
-my $croak_diag = $] <= 5.006 ? 'require 0' : 'eval {...}';
+# depending on perl version, we could get 'require 0' or 'eval {...}'
+# in the stack. This test used to be 'require 0' for <= 5.006, but
+# it broke on 5.005_05 test release, so we'll just take either
 # line 72
 eval { wrap_croak() };
-is( $@, <<CARP, 'croak() fooled');
+my $croak_regex = quotemeta( <<"CARP" );
 Now we can fool croak! at $0 line 64
 	main::wrap_croak() called at $0 line 72
-	$croak_diag called at $0 line 72
 CARP
+$croak_regex .= '\t(require 0|eval \{\.\.\.\})'
+                . quotemeta( " called at $0 line 72" );
+like( $@, "/$croak_regex/", 'croak() fooled');
 
 #line 79
 ok( !caller,                                "caller() not screwed up" );
@@ -128,6 +132,22 @@
              ['main', $0, 122, 'main::caller_check' ],
     'caller check' );
 
+is( (() = caller_check(0)), (() = core_caller_check(0)) ,
+    "caller() with args returns right number of values"
+);
+
+sub core_caller_no_args {
+    return CORE::caller();
+}
+
+sub caller_no_args {
+    return caller();
+}
+
+is( (() = caller_no_args()), (() = core_caller_no_args()),
+    "caller() with no args returns right number of values"
+);
+
 sub deep_caller {
     return caller(1);
 }
@@ -141,7 +161,7 @@
 
 sub deeper { deep_caller() }        # caller 0
 sub still_deeper { deeper() }       # caller 1 -- should give this line, 137
-sub ever_deeper  { still_deeper }   # caller 2
+sub ever_deeper  { still_deeper() } # caller 2
 
 is_deeply([(ever_deeper)[0..2]], ['main', $0, 137], 'deep caller()' );
 

Modified: branches/upstream/libsub-uplevel-perl/current/t/03_nested_uplevels.t
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/t/03_nested_uplevels.t?rev=10707&op=diff
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/t/03_nested_uplevels.t (original)
+++ branches/upstream/libsub-uplevel-perl/current/t/03_nested_uplevels.t Sun Dec  2 16:07:28 2007
@@ -1,6 +1,5 @@
 #!perl
 use strict;
-use warnings;
 use Test::More;
 
 use Sub::Uplevel;

Added: branches/upstream/libsub-uplevel-perl/current/t/04_honor_later_override.t
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/t/04_honor_later_override.t?rev=10707&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/t/04_honor_later_override.t (added)
+++ branches/upstream/libsub-uplevel-perl/current/t/04_honor_later_override.t Sun Dec  2 16:07:28 2007
@@ -1,0 +1,82 @@
+#!/usr/bin/perl -Tw
+
+use lib qw(t/lib);
+use strict;
+use Test::More tests => 7;
+
+# Goal of these tests: confirm that Sub::Uplevel will honor (use) a
+# CORE::GLOBAL::caller that occurs after Sub::Uplevel is loaded
+
+#--------------------------------------------------------------------------#
+# define a custom caller function that reverses the package name
+#--------------------------------------------------------------------------#
+
+sub _reverse_caller(;$) { 
+    my $height = $_[0];
+    my @caller = CORE::caller(++$height);
+    $caller[0] = reverse $caller[0];
+    if( wantarray and !@_ ) {
+        return @caller[0..2];
+    }
+    elsif (wantarray) {
+        return @caller;
+    }
+    else {
+        return $caller[0];
+    }
+}
+
+#--------------------------------------------------------------------------#
+# load Sub::Uplevel then redefine CORE::GLOBAL::caller
+#--------------------------------------------------------------------------#
+
+BEGIN {
+    ok( ! defined *CORE::GLOBAL::caller{CODE}, 
+        "no global override yet" 
+    );
+
+    use_ok('Sub::Uplevel');
+
+    is( *CORE::GLOBAL::caller{CODE}, \&Sub::Uplevel::_normal_caller,
+        "Sub::Uplevel's normal caller override in place"
+    );
+
+    # old style no warnings 'redefine'
+    my $old_W = $^W;
+    $^W = 0;
+        
+    *CORE::GLOBAL::caller = \&_reverse_caller;
+    $^W = $old_W
+
+}
+
+is( *CORE::GLOBAL::caller{CODE}, \&_reverse_caller, 
+    "added new, custom caller override"
+);
+
+#--------------------------------------------------------------------------#
+# define subs *after* caller has been redefined in BEGIN
+#--------------------------------------------------------------------------#
+
+sub test_caller { return scalar caller }
+
+sub uplevel_caller { return uplevel 1, \&test_caller }
+
+sub test_caller_w_uplevel { return uplevel_caller }
+
+#--------------------------------------------------------------------------#
+# Test for reversed package name both inside and outside an uplevel call
+#--------------------------------------------------------------------------#
+
+is( scalar caller(), '',
+    "caller from main package is empty string"
+);
+
+is( test_caller(), reverse("main"),
+    "caller from subroutine calls custom routine"
+);
+
+is( test_caller_w_uplevel(), reverse("main"),
+    "caller from uplevel subroutine calls custom routine"
+);
+

Added: branches/upstream/libsub-uplevel-perl/current/t/05_honor_prior_override.t
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/t/05_honor_prior_override.t?rev=10707&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/t/05_honor_prior_override.t (added)
+++ branches/upstream/libsub-uplevel-perl/current/t/05_honor_prior_override.t Sun Dec  2 16:07:28 2007
@@ -1,0 +1,84 @@
+#!/usr/bin/perl -Tw
+
+use lib qw(t/lib);
+use strict;
+use Test::More tests => 7;
+
+# Goal of these tests: confirm that Sub::Uplevel will honor (use) a
+# CORE::GLOBAL::caller override that occurs prior to Sub::Uplevel loading
+
+#--------------------------------------------------------------------------#
+# define a custom caller function that reverses the package name
+#--------------------------------------------------------------------------#
+
+sub _reverse_caller(;$) { 
+    my $height = $_[0];
+    my @caller = CORE::caller(++$height);
+    $caller[0] = reverse $caller[0];
+    if( wantarray and !@_ ) {
+        return @caller[0..2];
+    }
+    elsif (wantarray) {
+        return @caller;
+    }
+    else {
+        return $caller[0];
+    }
+}
+
+#--------------------------------------------------------------------------#
+# redefine CORE::GLOBAL::caller then load Sub::Uplevel 
+#--------------------------------------------------------------------------#
+
+BEGIN {
+    ok( ! defined *CORE::GLOBAL::caller{CODE}, 
+        "no global override yet" 
+    );
+
+    {
+        # old style no warnings 'redefine'
+        my $old_W = $^W;
+        $^W = 0;
+        *CORE::GLOBAL::caller = \&_reverse_caller;
+        $^W = $old_W;
+    }
+
+    is( *CORE::GLOBAL::caller{CODE}, \&_reverse_caller,
+        "added custom caller override"
+    );
+
+    use_ok('Sub::Uplevel');
+
+    is( *CORE::GLOBAL::caller{CODE}, \&_reverse_caller,
+        "custom caller override still in place"
+    );
+
+
+}
+
+#--------------------------------------------------------------------------#
+# define subs *after* caller has been redefined in BEGIN
+#--------------------------------------------------------------------------#
+
+sub test_caller { return scalar caller }
+
+sub uplevel_caller { return uplevel 1, \&test_caller }
+
+sub test_caller_w_uplevel { return uplevel_caller }
+
+#--------------------------------------------------------------------------#
+# Test for reversed package name both inside and outside an uplevel call
+#--------------------------------------------------------------------------#
+
+is( scalar caller(), '',
+    "caller from main package is empty string"
+);
+
+is( test_caller(), reverse("main"),
+    "caller from subroutine calls custom routine"
+);
+
+is( test_caller_w_uplevel(), reverse("main"),
+    "caller from uplevel subroutine calls custom routine"
+);
+




More information about the Pkg-perl-cvs-commits mailing list