r10317 - in /branches/upstream/libsub-uplevel-perl: ./ current/ current/examples/ current/lib/ current/lib/Sub/ current/t/ current/t/lib/
vdanjean at users.alioth.debian.org
vdanjean at users.alioth.debian.org
Sat Dec 1 12:15:20 UTC 2007
Author: vdanjean
Date: Sat Dec 1 12:15:20 2007
New Revision: 10317
URL: http://svn.debian.org/wsvn/?sc=1&rev=10317
Log:
[svn-inject] Installing original source of libsub-uplevel-perl
Added:
branches/upstream/libsub-uplevel-perl/
branches/upstream/libsub-uplevel-perl/current/
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/MANIFEST.SKIP
branches/upstream/libsub-uplevel-perl/current/META.yml
branches/upstream/libsub-uplevel-perl/current/Makefile.PL
branches/upstream/libsub-uplevel-perl/current/README
branches/upstream/libsub-uplevel-perl/current/examples/
branches/upstream/libsub-uplevel-perl/current/examples/uplevel-demo.pl (with props)
branches/upstream/libsub-uplevel-perl/current/lib/
branches/upstream/libsub-uplevel-perl/current/lib/Sub/
branches/upstream/libsub-uplevel-perl/current/lib/Sub/Uplevel.pm
branches/upstream/libsub-uplevel-perl/current/t/
branches/upstream/libsub-uplevel-perl/current/t/01_die_check.t
branches/upstream/libsub-uplevel-perl/current/t/02_uplevel.t
branches/upstream/libsub-uplevel-perl/current/t/03_nested_uplevels.t
branches/upstream/libsub-uplevel-perl/current/t/98_pod.t
branches/upstream/libsub-uplevel-perl/current/t/99_pod_coverage.t
branches/upstream/libsub-uplevel-perl/current/t/lib/
branches/upstream/libsub-uplevel-perl/current/t/lib/Foo.pm
Added: branches/upstream/libsub-uplevel-perl/current/Build.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/Build.PL?rev=10317&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/Build.PL (added)
+++ branches/upstream/libsub-uplevel-perl/current/Build.PL Sat Dec 1 12:15:20 2007
@@ -1,0 +1,14 @@
+use Module::Build;
+# See perldoc Module::Build for details of how this works
+
+Module::Build->new(
+ module_name => 'Sub::Uplevel',
+ dist_author => 'David A. Golden <dagolden at cpan.org>',
+ license => 'perl',
+ create_readme => 1,
+ create_makefile_pl => 'traditional',
+ requires => {
+ perl => 5.006,
+ Test::More => 0.47,
+ },
+)->create_build_script;
Added: branches/upstream/libsub-uplevel-perl/current/Changes
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/Changes?rev=10317&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/Changes (added)
+++ branches/upstream/libsub-uplevel-perl/current/Changes Sat Dec 1 12:15:20 2007
@@ -1,0 +1,68 @@
+Changes for Sub::Uplevel
+
+0.14 Sun Nov 5 23:38:46 EST 2006
+ - fixed t/99_pod_coverage.t bug
+ - added examples directory
+
+0.13 Thu Jun 22 19:47:26 EDT 2006
+ - fixed bug in Uplevel.t that caused test failure on FreeBSD for 5.8.0
+ - fixed bug in Uplevel.t that caused test failure on bleadperl-5.9.4
+ - removed ancient Test::More provided in t/lib
+ - switched ok(eq_array()) tests to is_deeper() for better diagnostics
+ - added pod/pod coverage checks
+ - numbered tests
+
+0.12 Fri May 12 18:33:40 EDT 2006
+ - official release of the uplevel stack patch (fixes RT#13893)
+ - added Build.PL and switched to boilerplate generated Makefile.PL
+ - removed SIGNATURE due to recently discovered Module::Signature
+ issues with newline handling and sub-key compatible keyservers
+ - updated/added various meta files
+
+0.11_01 Fri Apr 21 00:49:51 EDT 2006
+ - uplevel now keeps a proper stack of uplevel calls allowing
+ nesting of uplevel and non-uplevel calls
+
+0.10 Thu Apr 20 19:15:20 EDT 2006
+ - Stopped warnings about "undefined" on Perl 5.8.8
+ - DAGOLDEN added as co-maintainer
+
+0.09 Wed Jul 7 14:52:08 EDT 2004
+ - Ok, ok. I'll put a license on this.
+
+0.08 Wed Oct 22 09:02:38 PDT 2003
+ - New die_check.t test was written in a non-portable manner.
+ [Thanks Martin Thurn and cpantesters]
+
+0.07 Tue Mar 18 03:03:22 GMT 2003
+ - Fixed a test bug due to 5.6.0's differing Carp::croak stack output
+
+0.06 Thu Sep 20 08:50:30 EDT 2001
+ * Fixed a bug with deeply nested callers.
+ * Fixed nested uplevel() calls.
+ - Forgot to include Test::More dependency
+ - Added 5.006 dependency to Makefile.PL
+ - Removed unnecessary die and warn overrides
+ - Added DIRE WARNING to the docs.
+
+0.05 Wed Sep 19 06:00:12 EDT 2001
+ * Things were still pretty broken. I *think* I have the tests
+ sorted out now.
+ * Blows over any CORE::GLOBAL::caller, die or warn you might have
+ set. I'll fix this soon.
+
+0.04 Wed Sep 19 04:28:19 EDT 2001
+ * Ooops, we'd broken caller(). Turns out the tests were wrong.
+
+0.03 Wed Sep 19 03:41:59 EDT 2001
+ * Greatly simplified the uplevel logic
+
+0.02 Wed Sep 19 03:03:10 EDT 2001
+ * Fools croak()
+
+0.01 Wed Sep 19 00:19:38 EDT 2001
+ * First working version
+ * Fools caller(), die() and warn().
+ - Needs more work against, say, Carp.
+ - Needs more work to check that it doesn't break the
+ subtleties of caller, die and warn.
Added: branches/upstream/libsub-uplevel-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/MANIFEST?rev=10317&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/MANIFEST (added)
+++ branches/upstream/libsub-uplevel-perl/current/MANIFEST Sat Dec 1 12:15:20 2007
@@ -1,0 +1,15 @@
+Build.PL
+Changes
+examples/uplevel-demo.pl
+lib/Sub/Uplevel.pm
+Makefile.PL
+MANIFEST
+MANIFEST.SKIP
+META.yml Module meta-data (added by MakeMaker)
+README
+t/01_die_check.t
+t/02_uplevel.t
+t/03_nested_uplevels.t
+t/98_pod.t
+t/99_pod_coverage.t
+t/lib/Foo.pm
Added: branches/upstream/libsub-uplevel-perl/current/MANIFEST.SKIP
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/MANIFEST.SKIP?rev=10317&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/MANIFEST.SKIP (added)
+++ branches/upstream/libsub-uplevel-perl/current/MANIFEST.SKIP Sat Dec 1 12:15:20 2007
@@ -1,0 +1,25 @@
+# Version control files and dirs.
+\bRCS\b
+\bCVS\b
+,v$
+.svn/
+
+# ExtUtils::MakeMaker generated files and dirs.
+^MANIFEST\.(?!SKIP)
+^Makefile$
+^blib/
+^blibdirs$
+^PM_to_blib$
+^MakeMaker-\d
+
+# Module::Build
+^Build$
+^_build
+
+# Temp, old, vi and emacs files.
+~$
+\.old$
+^#.*#$
+^\.#
+\.swp$
+\.bak$
Added: branches/upstream/libsub-uplevel-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/META.yml?rev=10317&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/META.yml (added)
+++ branches/upstream/libsub-uplevel-perl/current/META.yml Sat Dec 1 12:15:20 2007
@@ -1,0 +1,20 @@
+---
+name: Sub-Uplevel
+version: 0.14
+author:
+ - 'David A. Golden <dagolden at cpan.org>'
+abstract: apparently run a function in a higher stack frame
+license: perl
+resources:
+ 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
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.2.html
+ version: 1.2
Added: branches/upstream/libsub-uplevel-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/Makefile.PL?rev=10317&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/Makefile.PL (added)
+++ branches/upstream/libsub-uplevel-perl/current/Makefile.PL Sat Dec 1 12:15:20 2007
@@ -1,0 +1,14 @@
+# Note: this file was auto-generated by Module::Build::Compat version 0.03
+use ExtUtils::MakeMaker;
+WriteMakefile
+(
+ 'PL_FILES' => {},
+ 'INSTALLDIRS' => 'site',
+ 'NAME' => 'Sub::Uplevel',
+ 'EXE_FILES' => [],
+ 'VERSION_FROM' => 'lib/Sub/Uplevel.pm',
+ 'PREREQ_PM' => {
+ 'Test::More' => '0.47'
+ }
+ )
+;
Added: branches/upstream/libsub-uplevel-perl/current/README
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/README?rev=10317&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/README (added)
+++ branches/upstream/libsub-uplevel-perl/current/README Sat Dec 1 12:15:20 2007
@@ -1,0 +1,103 @@
+NAME
+ Sub::Uplevel - apparently run a function in a higher stack frame
+
+SYNOPSIS
+ use Sub::Uplevel;
+
+ sub foo {
+ print join " - ", caller;
+ }
+
+ sub bar {
+ uplevel 1, \&foo;
+ }
+
+ #line 11
+ bar(); # main - foo.plx - 11
+
+DESCRIPTION
+ Like Tcl's uplevel() function, but not quite so dangerous. The idea is
+ just to fool caller(). All the really naughty bits of Tcl's uplevel()
+ are avoided.
+
+ THIS IS NOT THE SORT OF THING YOU WANT TO DO EVERYDAY
+
+ uplevel
+ uplevel $num_frames, \&func, @args;
+
+ Makes the given function think it's being executed $num_frames
+ higher than the current stack level. So when they use
+ caller($frames) it will actually give caller($frames + $num_frames)
+ for them.
+
+ "uplevel(1, \&some_func, @_)" is effectively "goto &some_func" but
+ you don't immediately exit the current subroutine. So while you
+ can't do this:
+
+ sub wrapper {
+ print "Before\n";
+ goto &some_func;
+ print "After\n";
+ }
+
+ you can do this:
+
+ sub wrapper {
+ print "Before\n";
+ my @out = uplevel 1, &some_func;
+ print "After\n";
+ return @out;
+ }
+
+EXAMPLE
+ The main reason I wrote this module is so I could write wrappers around
+ functions and they wouldn't be aware they've been wrapped.
+
+ use Sub::Uplevel;
+
+ my $original_foo = \&foo;
+
+ *foo = sub {
+ my @output = uplevel 1, $original_foo;
+ print "foo() returned: @output";
+ return @output;
+ };
+
+ 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).
+
+HISTORY
+ Those who do not learn from HISTORY are doomed to repeat it.
+
+ The lesson here is simple: Don't sit next to a Tcl programmer at the
+ dinner table.
+
+THANKS
+ Thanks to Brent Welch, Damian Conway and Robin Houston.
+
+AUTHORS
+ David A Golden <dagolden at cpan.org> (current maintainer)
+
+ Michael G Schwern <schwern at pobox.com> (original author)
+
+LICENSE
+ Copyright by Michael G Schwern, 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
+
+SEE ALSO
+ PadWalker (for the similar idea with lexicals), Hook::LexWrap, Tcl's
+ uplevel() at http://www.scriptics.com/man/tcl8.4/TclCmd/uplevel.htm
+
Added: branches/upstream/libsub-uplevel-perl/current/examples/uplevel-demo.pl
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/examples/uplevel-demo.pl?rev=10317&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/examples/uplevel-demo.pl (added)
+++ branches/upstream/libsub-uplevel-perl/current/examples/uplevel-demo.pl Sat Dec 1 12:15:20 2007
@@ -1,0 +1,23 @@
+use strict;
+use warnings;
+
+use Sub::Uplevel;
+
+# subroutine A calls subroutine B with uplevel(), so when
+# subroutine B queries caller(), it gets main as the caller (just
+# like subroutine A) instead of getting subroutine A
+
+sub sub_a {
+ print "Entering Subroutine A\n";
+ print "caller() says: ", join( ", ", (caller())[0 .. 2] ), "\n";
+ print "Calling B with uplevel\n";
+ uplevel 1, \&sub_b;
+}
+
+sub sub_b {
+ print "Entering Subroutine B\n";
+ print "caller() says: ", join( ", ", (caller())[0 .. 2] ), "\n";
+}
+
+sub_a();
+
Propchange: branches/upstream/libsub-uplevel-perl/current/examples/uplevel-demo.pl
------------------------------------------------------------------------------
svn:executable =
Added: 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=10317&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/lib/Sub/Uplevel.pm (added)
+++ branches/upstream/libsub-uplevel-perl/current/lib/Sub/Uplevel.pm Sat Dec 1 12:15:20 2007
@@ -1,0 +1,246 @@
+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();
+
+require Exporter;
+ at ISA = qw(Exporter);
+ at EXPORT = qw(uplevel);
+
+=head1 NAME
+
+Sub::Uplevel - apparently run a function in a higher stack frame
+
+=head1 SYNOPSIS
+
+ use Sub::Uplevel;
+
+ sub foo {
+ print join " - ", caller;
+ }
+
+ sub bar {
+ uplevel 1, \&foo;
+ }
+
+ #line 11
+ bar(); # main - foo.plx - 11
+
+=head1 DESCRIPTION
+
+Like Tcl's uplevel() function, but not quite so dangerous. The idea
+is just to fool caller(). All the really naughty bits of Tcl's
+uplevel() are avoided.
+
+B<THIS IS NOT THE SORT OF THING YOU WANT TO DO EVERYDAY>
+
+=over 4
+
+=item B<uplevel>
+
+ uplevel $num_frames, \&func, @args;
+
+Makes the given function think it's being executed $num_frames higher
+than the current stack level. So when they use caller($frames) it
+will actually give caller($frames + $num_frames) for them.
+
+C<uplevel(1, \&some_func, @_)> is effectively C<goto &some_func> but
+you don't immediately exit the current subroutine. So while you can't
+do this:
+
+ sub wrapper {
+ print "Before\n";
+ goto &some_func;
+ print "After\n";
+ }
+
+you can do this:
+
+ sub wrapper {
+ print "Before\n";
+ my @out = uplevel 1, &some_func;
+ print "After\n";
+ return @out;
+ }
+
+
+=cut
+
+our @Up_Frames; # uplevel stack
+
+sub uplevel {
+ my($num_frames, $func, @args) = @_;
+
+ local @Up_Frames = ($num_frames, @Up_Frames );
+ 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;
+
+=begin _private
+
+So it has to work like this:
+
+ Call stack Actual uplevel 1
+CORE::GLOBAL::caller
+Carp::short_error_loc 0
+Carp::shortmess_heavy 1 0
+Carp::croak 2 1
+try_croak 3 2
+uplevel 4
+function_that_called_uplevel 5
+caller_we_want_to_see 6 3
+its_caller 7 4
+
+So when caller(X) winds up below uplevel(), it only has to use
+CORE::caller(X+1) (to skip CORE::GLOBAL::caller). But when caller(X)
+winds up no or above uplevel(), it's CORE::caller(X+1+uplevel+1).
+
+Which means I'm probably going to have to do something nasty like walk
+up the call stack on each caller() to see if I'm going to wind up
+before or after Sub::Uplevel::uplevel().
+
+=end _private
+
+=begin _dagolden
+
+I found the description above a bit confusing. Instead, this is the logic
+that I found clearer when CORE::GLOBAL::caller is invoked and we have to
+walk up the call stack:
+
+* if searching up to the requested height in the real call stack doesn't find
+a call to uplevel, then we can return the result at that height in the
+call stack
+
+* if we find a call to uplevel, we need to keep searching upwards beyond the
+requested height at least by the amount of upleveling requested for that
+call to uplevel (from the Up_Frames stack set during the uplevel call)
+
+* additionally, we need to hide the uplevel subroutine call, too, so we search
+upwards one more level for each call to uplevel
+
+* when we've reached the top of the search, we want to return that frame
+in the call stack, i.e. the requested height plus any uplevel adjustments
+found during the search
+
+=end _dagolden
+
+=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 @caller = CORE::caller($height + $adjust + 1);
+
+ if( wantarray ) {
+ if( !@_ ) {
+ @caller = @caller[0..2];
+ }
+ return @caller;
+ }
+ else {
+ return $caller[0];
+ }
+ }; # sub
+
+}
+
+=back
+
+=head1 EXAMPLE
+
+The main reason I wrote this module is so I could write wrappers
+around functions and they wouldn't be aware they've been wrapped.
+
+ use Sub::Uplevel;
+
+ my $original_foo = \&foo;
+
+ *foo = sub {
+ my @output = uplevel 1, $original_foo;
+ print "foo() returned: @output";
+ return @output;
+ };
+
+If this code frightens you B<you should not use this module.>
+
+
+=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).
+
+
+=head1 HISTORY
+
+Those who do not learn from HISTORY are doomed to repeat it.
+
+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)
+
+Michael G Schwern E<lt>schwern at pobox.comE<gt> (original author)
+
+=head1 LICENSE
+
+Copyright by Michael G Schwern, 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,
+Tcl's uplevel() at http://www.scriptics.com/man/tcl8.4/TclCmd/uplevel.htm
+
+=cut
+
+
+1;
Added: branches/upstream/libsub-uplevel-perl/current/t/01_die_check.t
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/t/01_die_check.t?rev=10317&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/t/01_die_check.t (added)
+++ branches/upstream/libsub-uplevel-perl/current/t/01_die_check.t Sat Dec 1 12:15:20 2007
@@ -1,0 +1,16 @@
+#!/usr/bin/perl -w
+
+# Kirk: How we deal with death is at least as important as how we deal
+# with life, wouldn't you say?
+# Saavik: As I indicated, Admiral, that thought had not occurred to me.
+# Kirk: Well, now you have something new to think about. Carry on.
+
+# XXX DG: Why is this test here? Seems pointless. Oh, well.
+
+use lib qw(t/lib);
+use Test::More tests => 1;
+
+#line 12
+eval { die };
+is( $@, "Died at $0 line 12.\n" );
+
Added: 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=10317&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/t/02_uplevel.t (added)
+++ branches/upstream/libsub-uplevel-perl/current/t/02_uplevel.t Sat Dec 1 12:15:20 2007
@@ -1,0 +1,176 @@
+#!/usr/bin/perl -Tw
+
+use lib qw(t/lib);
+use strict;
+use Test::More tests => 20;
+
+BEGIN { use_ok('Sub::Uplevel'); }
+can_ok('Sub::Uplevel', 'uplevel');
+can_ok(__PACKAGE__, 'uplevel');
+
+#line 11
+ok( !caller, "top-level caller() not screwed up" );
+
+eval { die };
+is( $@, "Died at $0 line 13.\n", 'die() not screwed up' );
+
+sub foo {
+ join " - ", caller;
+}
+
+sub bar {
+ uplevel(1, \&foo);
+}
+
+#line 25
+is( bar(), "main - $0 - 25", 'uplevel()' );
+
+
+# Sure, but does it fool die?
+sub try_die {
+ die "You must die! I alone am best!";
+}
+
+sub wrap_die {
+ uplevel(1, \&try_die);
+}
+
+# line 38
+eval { wrap_die() };
+is( $@, "You must die! I alone am best! at $0 line 30.\n", 'die() fooled' );
+
+
+# how about warn?
+sub try_warn {
+ warn "HA! You don't fool me!";
+}
+
+sub wrap_warn {
+ uplevel(1, \&try_warn);
+}
+
+
+my $warning;
+{
+ local $SIG{__WARN__} = sub { $warning = join '', @_ };
+#line 56
+ wrap_warn();
+}
+is( $warning, "HA! You don't fool me! at $0 line 44.\n", 'warn() fooled' );
+
+
+# Carp?
+use Carp;
+sub try_croak {
+# line 64
+ croak("Now we can fool croak!");
+}
+
+sub wrap_croak {
+# line 68
+ uplevel(1, \&try_croak);
+}
+
+
+my $croak_diag = $] <= 5.006 ? 'require 0' : 'eval {...}';
+# line 72
+eval { wrap_croak() };
+is( $@, <<CARP, 'croak() fooled');
+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
+
+#line 79
+ok( !caller, "caller() not screwed up" );
+
+eval { die "Dying" };
+is( $@, "Dying at $0 line 81.\n", 'die() not screwed up' );
+
+
+
+# how about carp?
+sub try_carp {
+# line 88
+ carp "HA! Even carp is fooled!";
+}
+
+sub wrap_carp {
+ uplevel(1, \&try_carp);
+}
+
+
+$warning = '';
+{
+ local $SIG{__WARN__} = sub { $warning = join '', @_ };
+#line 98
+ wrap_carp();
+}
+is( $warning, <<CARP, 'carp() fooled' );
+HA! Even carp is fooled! at $0 line 88
+ main::wrap_carp() called at $0 line 98
+CARP
+
+
+use Foo;
+can_ok( 'main', 'fooble' );
+
+#line 114
+sub core_caller_check {
+ return CORE::caller(0);
+}
+
+sub caller_check {
+ return caller(shift);
+}
+
+is_deeply( [ ( caller_check(0), 0, 4 )[0 .. 3] ],
+ ['main', $0, 122, 'main::caller_check' ],
+ 'caller check' );
+
+sub deep_caller {
+ return caller(1);
+}
+
+sub check_deep_caller {
+ deep_caller();
+}
+
+#line 134
+is_deeply([(check_deep_caller)[0..2]], ['main', $0, 134], 'shallow caller' );
+
+sub deeper { deep_caller() } # caller 0
+sub still_deeper { deeper() } # caller 1 -- should give this line, 137
+sub ever_deeper { still_deeper } # caller 2
+
+is_deeply([(ever_deeper)[0..2]], ['main', $0, 137], 'deep caller()' );
+
+# This uplevel() should not effect deep_caller's caller(1).
+sub yet_deeper { uplevel( 1, \&ever_deeper) }
+is_deeply([(yet_deeper)[0..2]], ['main', $0, 137], 'deep caller() + uplevel' );
+
+sub target { caller }
+sub yarrow { uplevel( 1, \&target ) }
+sub hock { uplevel( 1, \&yarrow ) }
+
+is_deeply([(hock)], ['main', $0, 150], 'nested uplevel()s' );
+
+# Deep caller inside uplevel
+package Delegator;
+# line 159
+sub delegate { main::caller_check(shift) }
+
+package Wrapper;
+use Sub::Uplevel;
+sub wrap { uplevel( 1, \&Delegator::delegate, @_ ) }
+
+package main;
+
+is( (Wrapper::wrap(0))[0], 'Delegator',
+ 'deep caller check of parent sees real calling package'
+);
+
+is( (Wrapper::wrap(1))[0], 'main',
+ 'deep caller check of grandparent sees package above uplevel'
+);
+
Added: 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=10317&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/t/03_nested_uplevels.t (added)
+++ branches/upstream/libsub-uplevel-perl/current/t/03_nested_uplevels.t Sat Dec 1 12:15:20 2007
@@ -1,0 +1,79 @@
+#!perl
+use strict;
+use warnings;
+use Test::More;
+
+use Sub::Uplevel;
+
+package Wrap;
+use Sub::Uplevel;
+
+sub wrap {
+ my ($n, $f, $depth, $up, @case) = @_;
+
+ if ($n > 1) {
+ $n--;
+ return wrap( $n, $f, $depth, $up, @case );
+ }
+ else {
+ return uplevel( $up , $f, $depth, $up, @case );
+ }
+}
+
+package Call;
+
+sub recurse_call_check {
+ my ($depth, $up, @case) = @_;
+
+ if ( $depth ) {
+ $depth--;
+ my @result;
+ push @result, recurse_call_check($depth, $up, @case, 'Call' );
+ for my $n ( 1 .. $up ) {
+ push @result, Wrap::wrap( $n, \&recurse_call_check,
+ $depth, $n, @case,
+ $n == 1 ? "Wrap(Call)" : "Wrap(Call) x $n" ),
+ ;
+ }
+ return @result;
+ }
+ else {
+ my (@uplevel_callstack, @real_callstack);
+ my $i = 0;
+ while ( defined( my $caller = caller($i++) ) ) {
+ push @uplevel_callstack, $caller;
+ }
+ $i = 0;
+ while ( defined( my $caller = CORE::caller($i++) ) ) {
+ push @real_callstack, $caller;
+ }
+ return [
+ join( q{, }, @case ),
+ join( q{, }, reverse @uplevel_callstack ),
+ join( q{, }, reverse @real_callstack ),
+ ];
+ }
+}
+
+package main;
+
+my $depth = 4;
+my $up = 3;
+my $cases = 104;
+
+plan tests => $cases;
+
+my @results = Call::recurse_call_check( $depth, $up, 'Call' );
+
+is( scalar @results, $cases,
+ "Right number of cases"
+);
+
+my $expected = shift @results;
+
+for my $got ( @results ) {
+ is( $got->[1], $expected->[1],
+ "Case: $got->[0]"
+ ) or diag( "Real callers: $got->[2]" );
+}
+
Added: branches/upstream/libsub-uplevel-perl/current/t/98_pod.t
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/t/98_pod.t?rev=10317&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/t/98_pod.t (added)
+++ branches/upstream/libsub-uplevel-perl/current/t/98_pod.t Sat Dec 1 12:15:20 2007
@@ -1,0 +1,10 @@
+use Test::More;
+plan skip_all => "Skipping author tests" if not $ENV{AUTHOR_TESTING};
+
+my $min_tp = 1.22;
+eval "use Test::Pod $min_tp";
+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
+
+all_pod_files_ok();
+__END__
+use Test::Pod; # Force CPANTS
Added: branches/upstream/libsub-uplevel-perl/current/t/99_pod_coverage.t
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/t/99_pod_coverage.t?rev=10317&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/t/99_pod_coverage.t (added)
+++ branches/upstream/libsub-uplevel-perl/current/t/99_pod_coverage.t Sat Dec 1 12:15:20 2007
@@ -1,0 +1,16 @@
+use Test::More;
+plan skip_all => "Skipping author tests" if not $ENV{AUTHOR_TESTING};
+
+my $min_tpc = 1.08;
+eval "use Test::Pod::Coverage $min_tpc";
+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage"
+ if $@;
+
+my $min_pc = 0.17;
+eval "use Pod::Coverage $min_pc";
+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
+ if $@;
+
+all_pod_coverage_ok();
+__END__
+use Test::Pod::Coverage; # Force CPANTS
Added: branches/upstream/libsub-uplevel-perl/current/t/lib/Foo.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libsub-uplevel-perl/current/t/lib/Foo.pm?rev=10317&op=file
==============================================================================
--- branches/upstream/libsub-uplevel-perl/current/t/lib/Foo.pm (added)
+++ branches/upstream/libsub-uplevel-perl/current/t/lib/Foo.pm Sat Dec 1 12:15:20 2007
@@ -1,0 +1,8 @@
+package Foo;
+
+# Hook::LexWrap does this, Sub::Uplevel appears to interfere.
+sub import { *{caller()."::fooble"} = \&fooble }
+
+sub fooble { 42 }
+
+1;
More information about the Pkg-perl-cvs-commits
mailing list