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