Blame t/05_honor_prior_override.t

Packit cde0b4
#!/usr/bin/perl
Packit cde0b4
Packit cde0b4
use strict;
Packit cde0b4
BEGIN { $^W = 1 }
Packit cde0b4
Packit cde0b4
use Test::More tests => 10;
Packit cde0b4
Packit cde0b4
# Goal of these tests: confirm that Sub::Uplevel will honor (use) a
Packit cde0b4
# CORE::GLOBAL::caller override that occurs prior to Sub::Uplevel loading
Packit cde0b4
Packit cde0b4
#--------------------------------------------------------------------------#
Packit cde0b4
# define a custom caller function that increments a counter
Packit cde0b4
#--------------------------------------------------------------------------#
Packit cde0b4
Packit cde0b4
my $caller_counter = 0;
Packit cde0b4
sub _count_caller(;$) { 
Packit cde0b4
    $caller_counter++;
Packit cde0b4
    my $height = $_[0];
Packit cde0b4
    my @caller = CORE::caller(++$height);
Packit cde0b4
    if( wantarray and !@_ ) {
Packit cde0b4
        return @caller[0..2];
Packit cde0b4
    }
Packit cde0b4
    elsif (wantarray) {
Packit cde0b4
        return @caller;
Packit cde0b4
    }
Packit cde0b4
    else {
Packit cde0b4
        return $caller[0];
Packit cde0b4
    }
Packit cde0b4
}
Packit cde0b4
Packit cde0b4
#--------------------------------------------------------------------------#
Packit cde0b4
# redefine CORE::GLOBAL::caller then load Sub::Uplevel 
Packit cde0b4
#--------------------------------------------------------------------------#
Packit cde0b4
Packit cde0b4
BEGIN {
Packit cde0b4
    ok( ! defined *CORE::GLOBAL::caller{CODE}, 
Packit cde0b4
        "no global override yet" 
Packit cde0b4
    );
Packit cde0b4
Packit cde0b4
    {
Packit cde0b4
        # old style no warnings 'redefine'
Packit cde0b4
        my $old_W = $^W;
Packit cde0b4
        $^W = 0;
Packit cde0b4
        *CORE::GLOBAL::caller = \&_count_caller;
Packit cde0b4
        $^W = $old_W;
Packit cde0b4
    }
Packit cde0b4
Packit cde0b4
    is( *CORE::GLOBAL::caller{CODE}, \&_count_caller,
Packit cde0b4
        "added custom caller override"
Packit cde0b4
    );
Packit cde0b4
Packit cde0b4
    use_ok('Sub::Uplevel');
Packit cde0b4
Packit cde0b4
    is( *CORE::GLOBAL::caller{CODE}, \&_count_caller,
Packit cde0b4
        "custom caller override still in place"
Packit cde0b4
    );
Packit cde0b4
Packit cde0b4
Packit cde0b4
}
Packit cde0b4
Packit cde0b4
#--------------------------------------------------------------------------#
Packit cde0b4
# define subs *after* caller has been redefined in BEGIN
Packit cde0b4
#--------------------------------------------------------------------------#
Packit cde0b4
Packit cde0b4
sub test_caller { return scalar caller }
Packit cde0b4
Packit cde0b4
sub uplevel_caller { return uplevel 1, \&test_caller }
Packit cde0b4
Packit cde0b4
sub test_caller_w_uplevel { return uplevel_caller }
Packit cde0b4
Packit cde0b4
#--------------------------------------------------------------------------#
Packit cde0b4
# Test for reversed package name both inside and outside an uplevel call
Packit cde0b4
#--------------------------------------------------------------------------#
Packit cde0b4
Packit cde0b4
my $old_caller_counter; 
Packit cde0b4
Packit cde0b4
$old_caller_counter = $caller_counter;
Packit cde0b4
is( scalar caller(), undef,
Packit cde0b4
    "caller from main package is undef"
Packit cde0b4
);
Packit cde0b4
ok( $caller_counter > $old_caller_counter, "custom caller() was used" );
Packit cde0b4
Packit cde0b4
$old_caller_counter = $caller_counter;
Packit cde0b4
is( test_caller(), "main",
Packit cde0b4
    "caller from subroutine is main"
Packit cde0b4
);
Packit cde0b4
ok( $caller_counter > $old_caller_counter, "custom caller() was used" );
Packit cde0b4
Packit cde0b4
$old_caller_counter = $caller_counter;
Packit cde0b4
is( test_caller_w_uplevel(), "main",
Packit cde0b4
    "caller from uplevel subroutine is main"
Packit cde0b4
);
Packit cde0b4
ok( $caller_counter > $old_caller_counter, "custom caller() was used" );
Packit cde0b4