Preferred bug tracker

Please visit the preferred bug tracker to report your issue.

This queue is for tickets about the Sub-Uplevel CPAN distribution.

Report information
The Basics
Id:
26100
Status:
resolved
Priority:
Low/Low
Queue:

People
Owner:
dagolden [...] cpan.org
Requestors:
mschwern [...] cpan.org
Cc:
AdminCc:

BugTracker
Severity:
Normal
Broken in:
(no value)
Fixed in:
(no value)

Attachments


Subject: Sub::Uplevel and Contextual::Return fight for control of caller()
Both Sub::Uplevel and Contextual::Return override CORE::GLOBAL::caller. If they're used together in the same program the last one to get loaded wins. I don't think Sub::Uplevel needs a global caller override. I believe it can be localized in uplevel().
And here's the patch. It will now work with Contextual::Return. Ironicly it reveals a small but in Contextual::Return's caller() override.
Auto-merging (0, 27908) /local/Sub-Uplevel to /vendor/Sub-Uplevel (base /vendor/Sub-Uplevel:27906). U t/02_uplevel.t U lib/Sub/Uplevel.pm ==== Patch <-> level 1 Source: 9c88509d-e914-0410-b01c-b9530614cbfe:/local/Sub-Uplevel:27908 Target: 9c88509d-e914-0410-b01c-b9530614cbfe:/vendor/Sub-Uplevel:27906 Log: r27907@windhund: schwern | 2007-04-04 11:48:39 -0400 Local copy r27908@windhund: schwern | 2007-04-04 12:59:59 -0400 Fix uplevel() so it no longer needs a global caller override so it can plan nice with things like Contextual::Return. === t/02_uplevel.t ================================================================== --- t/02_uplevel.t (revision 27906) +++ t/02_uplevel.t (patch - level 1) @@ -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'); @@ -128,6 +128,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 +157,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()' ); === lib/Sub/Uplevel.pm ================================================================== --- lib/Sub/Uplevel.pm (revision 27906) +++ lib/Sub/Uplevel.pm (patch - level 1) @@ -6,8 +6,9 @@ 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(); +# We must touch *CORE::GLOBAL::caller or else Perl won't see +# a later override. +*CORE::GLOBAL::caller = \&_normal_caller; require Exporter; @ISA = qw(Exporter); @@ -78,20 +79,31 @@ my($num_frames, $func, @args) = @_; local @Up_Frames = ($num_frames, @Up_Frames ); + + no warnings 'redefine'; + local *CORE::GLOBAL::caller = \&_uplevel_caller; + return $func->(@args); } +sub _normal_caller (;$) { + my $height = $_[0]; + $height++; + if( wantarray and !@_ ) { + return (CORE::caller($height))[0..2]; + } + else { + return CORE::caller($height); + } +} -sub _setup_CORE_GLOBAL { - no warnings 'redefine'; +sub _uplevel_caller (;$) { + my $height = $_[0] || 0; - *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; - # 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; - =begin _private So it has to work like this: @@ -142,36 +154,34 @@ =cut - my $saw_uplevel = 0; - my $adjust = 0; + 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 + # 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++; - } + 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); + my @caller = CORE::caller($height + $adjust + 1); - if( wantarray ) { - if( !@_ ) { - @caller = @caller[0..2]; - } - return @caller; + if( wantarray ) { + if( !@_ ) { + @caller = @caller[0..2]; } - else { - return $caller[0]; - } - }; # sub - + return @caller; + } + else { + return $caller[0]; + } } =back @@ -202,8 +212,7 @@ 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). +If you have your own CORE::GLOBAL::caller() override (such as using Contextual::Return) it won't work inside an uplevel(). =head1 HISTORY ==== BEGIN SVK PATCH BLOCK ==== Version: svk v2.0.1 (darwin) eJyNVktv20YQ5pnouT0VmCZMLFWxzTcpKRbUBEnR1s07uaStsCKXFmuaq5JLyUZpQHkghxYIWqCn Am0vvfTW/sPOLklZSpTYAmGTuzPffjP7zezezh71h0Y5GOilZujlwydf9Xr3CA8mVwy71NyShjFn meaUCZ3RRLPKhB1odpmSI4qzOSuyQLxwkh1QLl7i4JDywcBAOL+CuyUhGliJOiacpbnWlfAjnlGq GaU79MqhJZ6RZnTLnOKMhB1ldBbnMUuRhul1dR9N0N5Afzal6ShjjC+nTOGtl0HCcjoS8ALSEfam hiFJhzDOaICcTnCUS6TGWxraGwwx8Hi8ZippOvVCq4gGcqiArIZhFCdUgPJd3RwVU5nLHS45nQtn VnBylkynycmI02Me0oQTuYRllhHRPc/ybdr1g3Bs2bprWL7h2r5LA9Oy0cZzcS/uKMrvxR9ffvj8 ifK18kz55fjO4vl95fn9X2+8VF5999tHZpy3oNVqwx4EJEloNgomNDhs6e32tWacZXT05iRcUwF/ l6pxtJvHfAK4dTlklBdZiv/jgwmHtDga0wxYBDOSFDS/pLb7qpoX4zXclI2k748StUKAm3cf3Or1 mhX66mnt9x6XNeO3QqtdWptjW5ndFFvKLhYe2p8O7VVFVkqots2zja5vezoJqD4ObEoNx/Ft4jhd Q7c9113qyNkgSE8IcvdhMZaCPVdF9hLMXRel3+DsPq51OT2SS54L6bxXmK6I0HB9O/IMYjoudake +aHlUcO3iDt2UK0exuX5lTL/Vf67uvPzB0qiLLjy0/jZzcWLWHm9+/r64pmn3P3TXQTK/l988eJj 5eXx353FsfJK/Wd2VOQcOCuCCXxaKeTz/bs3PttvlAIsA5rkFO7RLIE5S7c45JSql4FAQrgwmNEs i0O6o24G2INvrqIasiOS1NqQekABzEmWximKYCujIY3ilG715VzC0PAdfCRc3QBqPKyAFdFqUZEG 24PWUOjrTOfrFKDV19q12I9OQJtQqb890EZP9W8rFvVgp1N9xlELGafYUDNyAiQN4ZPhCBqQFQKt tUqrUdrtp/rOjllDn8q/Mq9vuW/0btyaYNYT8P5ooCxBr3N0GfIJy3hQcIxH7EENlMOEzCiMKa2r PqzNSTInJzmQMISOgUJZoye+88N4CnwS5yDyzvGM2crrDqEKLjmZN2yRkN5fkiTh90J7eyvc5iQ5 REYIRyUE5JwEh2KVSAYkxqtGMcVxckChwkWDKnn9Gihh7BBYSmGC1oLnhKRo8gO2FE5DiISoCUpe LsKXWcCJIg1VMd2SHJGL4Cdfru8tE9tp2MuZTmdNBeg3XGp1fTMRpQNGuw+ifDCjguGSS8OhChw3 YolY7wQqTsYVp8hYpKLxqLIkgMQoiyI8+Necm1x39sAQ5B9PR7czvH/kT1e3p9bm0mllqqmBM+2e qs1GvivYN3NVha5uqKXV7ImZN+tK/M5Wqd9Wy+mM1kodDZvmcF7BaQ1gU5xfRHDCiqoi8AVb3Lwp y/VmhIdT0/2glYseSnIocuxpcJOlopcXJOn1Hsh12hDzuoHOWSa2MRd+KMw6ya2N55w8BUKDesRy otDTLcsKSegFnu8YuutHkRtRQ16rTNssIRNHjjecx2k4QS33APJgMqcYZgmmrnvbuo0PGEbP9ntW F/BD11XYlx03YNMTtYLwz4cwe04Xnwbidny8jKQNORPhYoNJWHqA+5ZSGmIbgYOEjUkCzeHSZK8y DwiKfppgStI4oNVFAVuLOCKS+JBuSOqOiqFvDwZmqZlmdVl+JG+8vd7jNEb0nCRX3BLv21PCJ3gH xYswfhRFHIqDe1eeNOLs3q7P7ubQ1iy37Aa+7+jdcJt2DRGyoW+PdSPYHncdCy+IdjCO6KBtlu9c oFvuzmgasmzDCu5FV9Bc40J2vbeD6clQ/gdWVeKl ==== END SVK PATCH BLOCK ====
A ping as this ticket was probably created while RT was not sending out mail.
Fixed in 0.15_01, plus some extra goodies to play nice with other people's CORE::GLOBAL::caller overrides. I'll leave this bug open until I'm sure we've got this nailed and are ready for 0.16.
Fixed in 0.16


This service runs on Request Tracker, is sponsored by The Perl Foundation, and maintained by Best Practical Solutions.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.