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