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