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