t/07-context_info.t

   1 #!perl -T
   2
   3 my $exp0 = ::expected('block', 0, undef);
   4
   5 use strict;
   6 use warnings;
   7
   8 use Config qw<%Config>;
   9
  10 # We're using Test::Leaner here because Test::More loads overload, which itself
  11 # uses warning::register, which may cause the "all warnings on" bitmask to
  12 # change ; and that doesn't fit well with how we're testing things.
  13
  14 use lib 't/lib';
  15 use Test::Leaner tests => 19 + 6;
  16
  17 use Scope::Upper qw<context_info UP HERE CALLER>;
  18
  19 sub HINT_BLOCK_SCOPE () { 0x100 }
  20
  21 sub expected {
  22  my ($type, $line, $want) = @_;
  23
  24  my $top;
  25
  26  my @caller = caller 1;
  27  my @here   = caller 0;
  28  unless (@caller) {
  29   @caller   = @here;
  30   $top++;
  31  }
  32
  33  my $pkg = $here[0];
  34  my ($file, $eval, $require, $hints, $warnings, $hinthash)
  35                                                    = @caller[1, 6, 7, 8, 9, 10];
  36
  37  $line = $caller[2] unless defined $line;
  38
  39  my ($sub, $hasargs);
  40  if ($type eq 'sub' or $type eq 'eval' or $type eq 'format') {
  41   $sub     = $caller[3];
  42   $hasargs = $caller[4];
  43   $want    = $caller[5];
  44   $want    = '' if defined $want and not $want;
  45  }
  46
  47  if ($top) {
  48   $want      = "$]" < 5.015_001 ? '' : undef;
  49   $hints    &= ~HINT_BLOCK_SCOPE if $Config{usesitecustomize};
  50   $hints    |=  HINT_BLOCK_SCOPE if "$]" >= 5.019003;
  51   $warnings  = sub { use warnings; (caller 0)[9] }->() if  "$]" < 5.007
  52                                                        and not $^W;
  53  }
  54
  55  my @exp = (
  56   $pkg,
  57   $file,
  58   $line,
  59   $sub,
  60   $hasargs,
  61   $want,
  62   $eval,
  63   $require,
  64   $hints,
  65   $warnings,
  66  );
  67  push @exp, $hinthash if "$]" >= 5.010;
  68
  69  return \@exp;
  70 }
  71
  72 sub setup () {
  73  my $pkg = caller;
  74
  75  for my $sub (qw<context_info UP HERE is_deeply expected>) {
  76   no strict 'refs';
  77   *{"${pkg}::$sub"} = \&{"main::$sub"};
  78  }
  79 }
  80
  81 is_deeply [ context_info       ], $exp0, 'main : context_info';
  82 is_deeply [ context_info(HERE) ], $exp0, 'main : context_info HERE';
  83 is_deeply [ context_info(UP)   ], $exp0, 'main : context_info UP';
  84 is_deeply [ context_info(-1)   ], $exp0, 'main : context_info -1';
  85
  86 package Scope::Upper::TestPkg::A; BEGIN { ::setup }
  87 my @a = sub {
  88  my $exp1 = expected('sub', undef);
  89  is_deeply [ context_info ], $exp1, 'sub0 : context_info';
  90  package Scope::Upper::TestPkg::B; BEGIN { ::setup }
  91  {
  92   my $exp2 = expected('block', __LINE__, 1);
  93   is_deeply [ context_info     ], $exp2, 'sub : context_info';
  94   is_deeply [ context_info(UP) ], $exp1, 'sub : context_info UP';
  95   package Scope::Upper::TestPkg::C; BEGIN { ::setup }
  96   for (1) {
  97    my $exp3 = expected('loop', __LINE__ - 1, undef);
  98    is_deeply [ context_info        ], $exp3, 'for : context_info';
  99    is_deeply [ context_info(UP)    ], $exp2, 'for : context_info UP';
 100    is_deeply [ context_info(UP UP) ], $exp1, 'for : context_info UP UP';
 101   }
 102   package Scope::Upper::TestPkg::D; BEGIN { ::setup }
 103   my $eval_line = __LINE__+1;
 104   eval <<'CODE';
 105    my $exp4 = expected('eval', $eval_line);
 106    is_deeply [ context_info        ], $exp4, 'eval string : context_info';
 107    is_deeply [ context_info(UP)    ], $exp2, 'eval string : context_info UP';
 108    is_deeply [ context_info(UP UP) ], $exp1, 'eval string : context_info UP UP';
 109 CODE
 110   die $@ if $@;
 111   package Scope::Upper::TestPkg::E; BEGIN { ::setup }
 112   my $x = eval {
 113    my $exp5 = expected('eval', __LINE__ - 1);
 114    package Scope::Upper::TestPkg::F; BEGIN { ::setup }
 115    do {
 116     my $exp6 = expected('block', __LINE__ - 1, undef);
 117     is_deeply [ context_info        ], $exp6, 'do : context_info';
 118     is_deeply [ context_info(UP)    ], $exp5, 'do : context_info UP';
 119     is_deeply [ context_info(UP UP) ], $exp2, 'do : context_info UP UP';
 120    };
 121    is_deeply [ context_info        ], $exp5, 'eval : context_info';
 122    is_deeply [ context_info(UP)    ], $exp2, 'eval : context_info UP';
 123    is_deeply [ context_info(UP UP) ], $exp1, 'eval : context_info UP UP';
 124   };
 125  }
 126 }->(1);
 127
 128 package main;
 129
 130 sub first {
 131  do {
 132   second(@_);
 133  }
 134 }
 135
 136 my $fourth;
 137
 138 sub second {
 139  my $x = eval {
 140   my @y = $fourth->();
 141  };
 142  die $@ if $@;
 143 }
 144
 145 $fourth = sub {
 146  my $z = do {
 147   my $dummy;
 148   eval q[
 149    call(@_);
 150   ];
 151   die $@ if $@;
 152  }
 153 };
 154
 155 sub call {
 156  for my $depth (0 .. 5) {
 157   my @got = context_info(CALLER $depth);
 158   my @exp = caller $depth;
 159   defined and not $_ and $_ = '' for $exp[5];
 160   is_deeply \@got, \@exp, "context_info vs caller $depth";
 161  }
 162 }
 163
 164 first();