1#!/usr/bin/perl -Tw 2 3use lib qw(t/lib); 4use strict; 5use Test::More tests => 7; 6 7# Goal of these tests: confirm that Sub::Uplevel will honor (use) a 8# CORE::GLOBAL::caller that occurs after Sub::Uplevel is loaded 9 10#--------------------------------------------------------------------------# 11# define a custom caller function that reverses the package name 12#--------------------------------------------------------------------------# 13 14sub _reverse_caller(;$) { 15 my $height = $_[0]; 16 my @caller = CORE::caller(++$height); 17 $caller[0] = defined $caller[0] ? reverse $caller[0] : undef; 18 if( wantarray and !@_ ) { 19 return @caller[0..2]; 20 } 21 elsif (wantarray) { 22 return @caller; 23 } 24 else { 25 return $caller[0]; 26 } 27} 28 29#--------------------------------------------------------------------------# 30# load Sub::Uplevel then redefine CORE::GLOBAL::caller 31#--------------------------------------------------------------------------# 32 33BEGIN { 34 ok( ! defined *CORE::GLOBAL::caller{CODE}, 35 "no global override yet" 36 ); 37 38 use_ok('Sub::Uplevel'); 39 40 is( *CORE::GLOBAL::caller{CODE}, \&Sub::Uplevel::_normal_caller, 41 "Sub::Uplevel's normal caller override in place" 42 ); 43 44 # old style no warnings 'redefine' 45 my $old_W = $^W; 46 $^W = 0; 47 48 *CORE::GLOBAL::caller = \&_reverse_caller; 49 $^W = $old_W 50 51} 52 53is( *CORE::GLOBAL::caller{CODE}, \&_reverse_caller, 54 "added new, custom caller override" 55); 56 57#--------------------------------------------------------------------------# 58# define subs *after* caller has been redefined in BEGIN 59#--------------------------------------------------------------------------# 60 61sub test_caller { return scalar caller } 62 63sub uplevel_caller { return uplevel 1, \&test_caller } 64 65sub test_caller_w_uplevel { return uplevel_caller } 66 67#--------------------------------------------------------------------------# 68# Test for reversed package name both inside and outside an uplevel call 69#--------------------------------------------------------------------------# 70 71is( scalar caller(), undef, 72 "caller from main package is undef" 73); 74 75is( test_caller(), reverse("main"), 76 "caller from subroutine calls custom routine" 77); 78 79is( test_caller_w_uplevel(), reverse("main"), 80 "caller from uplevel subroutine calls custom routine" 81); 82 83