git.maemo.org Git - pkg-perl/blob - deb-src/libsub-uplevel-perl/libsub-uplevel-perl-0.1901/t/04_honor_later_override.t

   1 #!/usr/bin/perl -Tw
   2
   3 use lib qw(t/lib);
   4 use strict;
   5 use 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
  14 sub _reverse_caller(;$) {
  15     my $height = $_[0];
  16     my @caller = CORE::caller(++$height);
  17     $caller[0] = reverse $caller[0];
  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
  33 BEGIN {
  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
  53 is( *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
  61 sub test_caller { return scalar caller }
  62
  63 sub uplevel_caller { return uplevel 1, \&test_caller }
  64
  65 sub test_caller_w_uplevel { return uplevel_caller }
  66
  67 #--------------------------------------------------------------------------#
  68 # Test for reversed package name both inside and outside an uplevel call
  69 #--------------------------------------------------------------------------#
  70
  71 is( scalar caller(), '',
  72     "caller from main package is empty string"
  73 );
  74
  75 is( test_caller(), reverse("main"),
  76     "caller from subroutine calls custom routine"
  77 );
  78
  79 is( test_caller_w_uplevel(), reverse("main"),
  80     "caller from uplevel subroutine calls custom routine"
  81 );
  82