1#!/usr/bin/perl -Tw 2 3use lib qw(t/lib); 4use strict; 5use Test::More tests => 23; 6 7BEGIN { use_ok('Sub::Uplevel'); } 8can_ok('Sub::Uplevel', 'uplevel'); 9can_ok(__PACKAGE__, 'uplevel'); 10 11#line 11 12ok( !caller, "top-level caller() not screwed up" ); 13 14eval { die }; 15is( $@, "Died at $0 line 13.\n", 'die() not screwed up' ); 16 17sub foo { 18 join " - ", caller; 19} 20 21sub bar { 22 uplevel(1, \&foo); 23} 24 25#line 25 26is( bar(), "main - $0 - 25", 'uplevel()' ); 27 28 29# Sure, but does it fool die? 30sub try_die { 31 die "You must die! I alone am best!"; 32} 33 34sub wrap_die { 35 uplevel(1, \&try_die); 36} 37 38# line 38 39eval { wrap_die() }; 40is( $@, "You must die! I alone am best! at $0 line 30.\n", 'die() fooled' ); 41 42 43# how about warn? 44sub try_warn { 45 warn "HA! You don't fool me!"; 46} 47 48sub wrap_warn { 49 uplevel(1, \&try_warn); 50} 51 52 53my $warning; 54{ 55 local $SIG{__WARN__} = sub { $warning = join '', @_ }; 56#line 56 57 wrap_warn(); 58} 59is( $warning, "HA! You don't fool me! at $0 line 44.\n", 'warn() fooled' ); 60 61 62# Carp? 63use Carp; 64sub try_croak { 65# line 64 66 croak("Now we can fool croak!"); 67} 68 69sub wrap_croak { 70# line 68 71 uplevel(shift, \&try_croak); 72} 73 74 75# depending on perl version, we could get 'require 0' or 'eval {...}' 76# in the stack. This test used to be 'require 0' for <= 5.006, but 77# it broke on 5.005_05 test release, so we'll just take either 78# line 72 79eval { wrap_croak(1) }; 80my $croak_regex = quotemeta( <<"CARP" ); 81Now we can fool croak! at $0 line 64 82 main::wrap_croak(1) called at $0 line 72 83CARP 84$croak_regex .= '\t(require 0|eval \{\.\.\.\})' 85 . quotemeta( " called at $0 line 72" ); 86like( $@, "/$croak_regex/", 'croak() fooled'); 87 88# Try to wrap higher -- this may have been a problem that was exposed on 89# Test Exception 90# line 75 91eval { wrap_croak(2) }; 92$croak_regex = quotemeta( <<"CARP" ); 93Now we can fool croak! at $0 line 64 94CARP 95like( $@, "/$croak_regex/", 'croak() fooled'); 96 97#line 79 98ok( !caller, "caller() not screwed up" ); 99 100eval { die "Dying" }; 101is( $@, "Dying at $0 line 81.\n", 'die() not screwed up' ); 102 103 104 105# how about carp? 106sub try_carp { 107# line 88 108 carp "HA! Even carp is fooled!"; 109} 110 111sub wrap_carp { 112 uplevel(1, \&try_carp); 113} 114 115 116$warning = ''; 117{ 118 local $SIG{__WARN__} = sub { $warning = join '', @_ }; 119#line 98 120 wrap_carp(); 121} 122is( $warning, <<CARP, 'carp() fooled' ); 123HA! Even carp is fooled! at $0 line 88 124 main::wrap_carp() called at $0 line 98 125CARP 126 127 128use Foo; 129can_ok( 'main', 'fooble' ); 130 131#line 114 132sub core_caller_check { 133 return CORE::caller(0); 134} 135 136sub caller_check { 137 return caller(shift); 138} 139 140is_deeply( [ ( caller_check(0), 0, 4 )[0 .. 3] ], 141 ['main', $0, 122, 'main::caller_check' ], 142 'caller check' ); 143 144is( (() = caller_check(0)), (() = core_caller_check(0)) , 145 "caller() with args returns right number of values" 146); 147 148sub core_caller_no_args { 149 return CORE::caller(); 150} 151 152sub caller_no_args { 153 return caller(); 154} 155 156is( (() = caller_no_args()), (() = core_caller_no_args()), 157 "caller() with no args returns right number of values" 158); 159 160sub deep_caller { 161 return caller(1); 162} 163 164sub check_deep_caller { 165 deep_caller(); 166} 167 168#line 134 169is_deeply([(check_deep_caller)[0..2]], ['main', $0, 134], 'shallow caller' ); 170 171sub deeper { deep_caller() } # caller 0 172sub still_deeper { deeper() } # caller 1 -- should give this line, 137 173sub ever_deeper { still_deeper() } # caller 2 174 175is_deeply([(ever_deeper)[0..2]], ['main', $0, 137], 'deep caller()' ); 176 177# This uplevel() should not effect deep_caller's caller(1). 178sub yet_deeper { uplevel( 1, \&ever_deeper) } 179is_deeply([(yet_deeper)[0..2]], ['main', $0, 137], 'deep caller() + uplevel' ); 180 181sub target { caller } 182sub yarrow { uplevel( 1, \&target ) } 183sub hock { uplevel( 1, \&yarrow ) } 184 185is_deeply([(hock)], ['main', $0, 150], 'nested uplevel()s' ); 186 187# Deep caller inside uplevel 188package Delegator; 189# line 159 190sub delegate { main::caller_check(shift) } 191 192package Wrapper; 193use Sub::Uplevel; 194sub wrap { uplevel( 1, \&Delegator::delegate, @_ ) } 195 196package main; 197 198is( (Wrapper::wrap(0))[0], 'Delegator', 199 'deep caller check of parent sees real calling package' 200); 201 202is( (Wrapper::wrap(1))[0], 'main', 203 'deep caller check of grandparent sees package above uplevel' 204); 205 206