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

   1 #!/usr/bin/perl -Tw
   2
   3 use lib qw(t/lib);
   4 use strict;
   5 use Test::More tests => 22;
   6
   7 BEGIN { use_ok('Sub::Uplevel'); }
   8 can_ok('Sub::Uplevel', 'uplevel');
   9 can_ok(__PACKAGE__, 'uplevel');
  10
  11 #line 11
  12 ok( !caller,                         "top-level caller() not screwed up" );
  13
  14 eval { die };
  15 is( $@, "Died at $0 line 13.\n",           'die() not screwed up' );
  16
  17 sub foo {
  18     join " - ", caller;
  19 }
  20
  21 sub bar {
  22     uplevel(1, \&foo);
  23 }
  24
  25 #line 25
  26 is( bar(), "main - $0 - 25",    'uplevel()' );
  27
  28
  29 # Sure, but does it fool die?
  30 sub try_die {
  31     die "You must die!  I alone am best!";
  32 }
  33
  34 sub wrap_die {
  35     uplevel(1, \&try_die);
  36 }
  37
  38 # line 38
  39 eval { wrap_die() };
  40 is( $@, "You must die!  I alone am best! at $0 line 30.\n", 'die() fooled' );
  41
  42
  43 # how about warn?
  44 sub try_warn {
  45     warn "HA!  You don't fool me!";
  46 }
  47
  48 sub wrap_warn {
  49     uplevel(1, \&try_warn);
  50 }
  51
  52
  53 my $warning;
  54 {
  55     local $SIG{__WARN__} = sub { $warning = join '', @_ };
  56 #line 56
  57     wrap_warn();
  58 }
  59 is( $warning, "HA!  You don't fool me! at $0 line 44.\n", 'warn() fooled' );
  60
  61
  62 # Carp?
  63 use Carp;
  64 sub try_croak {
  65 # line 64
  66     croak("Now we can fool croak!");
  67 }
  68
  69 sub wrap_croak {
  70 # line 68
  71     uplevel(1, \&try_croak);
  72 }
  73
  74
  75 # depending on perl version, we could get 'require 0' or 'eval {...}'
  76 # in the stack. This test used to be 'require 0' for <= 5.006, but
  77 # it broke on 5.005_05 test release, so we'll just take either
  78 # line 72
  79 eval { wrap_croak() };
  80 my $croak_regex = quotemeta( <<"CARP" );
  81 Now we can fool croak! at $0 line 64
  82         main::wrap_croak() called at $0 line 72
  83 CARP
  84 $croak_regex .= '\t(require 0|eval \{\.\.\.\})'
  85                 . quotemeta( " called at $0 line 72" );
  86 like( $@, "/$croak_regex/", 'croak() fooled');
  87
  88 #line 79
  89 ok( !caller,                                "caller() not screwed up" );
  90
  91 eval { die "Dying" };
  92 is( $@, "Dying at $0 line 81.\n",           'die() not screwed up' );
  93
  94
  95
  96 # how about carp?
  97 sub try_carp {
  98 # line 88
  99     carp "HA!  Even carp is fooled!";
 100 }
 101
 102 sub wrap_carp {
 103     uplevel(1, \&try_carp);
 104 }
 105
 106
 107 $warning = '';
 108 {
 109     local $SIG{__WARN__} = sub { $warning = join '', @_ };
 110 #line 98
 111     wrap_carp();
 112 }
 113 is( $warning, <<CARP, 'carp() fooled' );
 114 HA!  Even carp is fooled! at $0 line 88
 115         main::wrap_carp() called at $0 line 98
 116 CARP
 117
 118
 119 use Foo;
 120 can_ok( 'main', 'fooble' );
 121
 122 #line 114
 123 sub core_caller_check {
 124     return CORE::caller(0);
 125 }
 126
 127 sub caller_check {
 128     return caller(shift);
 129 }
 130
 131 is_deeply(   [ ( caller_check(0), 0, 4 )[0 .. 3] ],
 132              ['main', $0, 122, 'main::caller_check' ],
 133     'caller check' );
 134
 135 is( (() = caller_check(0)), (() = core_caller_check(0)) ,
 136     "caller() with args returns right number of values"
 137 );
 138
 139 sub core_caller_no_args {
 140     return CORE::caller();
 141 }
 142
 143 sub caller_no_args {
 144     return caller();
 145 }
 146
 147 is( (() = caller_no_args()), (() = core_caller_no_args()),
 148     "caller() with no args returns right number of values"
 149 );
 150
 151 sub deep_caller {
 152     return caller(1);
 153 }
 154
 155 sub check_deep_caller {
 156     deep_caller();
 157 }
 158
 159 #line 134
 160 is_deeply([(check_deep_caller)[0..2]], ['main', $0, 134], 'shallow caller' );
 161
 162 sub deeper { deep_caller() }        # caller 0
 163 sub still_deeper { deeper() }       # caller 1 -- should give this line, 137
 164 sub ever_deeper  { still_deeper() } # caller 2
 165
 166 is_deeply([(ever_deeper)[0..2]], ['main', $0, 137], 'deep caller()' );
 167
 168 # This uplevel() should not effect deep_caller's caller(1).
 169 sub yet_deeper { uplevel( 1, \&ever_deeper) }
 170 is_deeply([(yet_deeper)[0..2]],  ['main', $0, 137],  'deep caller() + uplevel' );
 171
 172 sub target { caller }
 173 sub yarrow { uplevel( 1, \&target ) }
 174 sub hock   { uplevel( 1, \&yarrow ) }
 175
 176 is_deeply([(hock)], ['main', $0, 150],  'nested uplevel()s' );
 177
 178 # Deep caller inside uplevel
 179 package Delegator;
 180 # line 159
 181 sub delegate { main::caller_check(shift) }
 182
 183 package Wrapper;
 184 use Sub::Uplevel;
 185 sub wrap { uplevel( 1, \&Delegator::delegate, @_ ) }
 186
 187 package main;
 188
 189 is( (Wrapper::wrap(0))[0], 'Delegator',
 190     'deep caller check of parent sees real calling package'
 191 );
 192
 193 is( (Wrapper::wrap(1))[0], 'main',
 194     'deep caller check of grandparent sees package above uplevel'
 195 );
 196