t/05-words.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7
   8 plan tests => 1 + 23 * ($^P ? 4 : 5) + ($^P ? 1 : 3) + 7 + (32 + 7);
   9
  10 use Scope::Upper qw<:words>;
  11
  12 # Tests with hardcoded values are for internal use only and doesn't imply any
  13 # kind of future compatibility on what the words should actually return.
  14
  15 our $got_warn;
  16 my $warn_catcher = sub {
  17  my $file = __FILE__;
  18  ++$got_warn if $_[0] =~ /^Cannot target a scope outside of the current stack at \Q$file\E line \d+\.$/;
  19  return;
  20 };
  21 my $old_sig_warn;
  22
  23 my $top = HERE;
  24
  25 is $top, 0,      'main : here' unless $^P;
  26 is TOP,  $top,   'main : top';
  27 $old_sig_warn = $SIG{__WARN__};
  28 local ($SIG{__WARN__}, $got_warn) = $warn_catcher;
  29 is UP,  $top,    'main : up';
  30 local $SIG{__WARN__} = $old_sig_warn;
  31 is $got_warn, 1, 'main : up warns';
  32 is SUB,  undef,  'main : sub';
  33 is EVAL, undef,  'main : eval';
  34
  35 {
  36  my $desc = '{ 1 }';
  37  is HERE, 1,     "$desc : here" unless $^P;
  38  is TOP,  $top,  "$desc : top";
  39  is UP,   $top,  "$desc : up";
  40  is SUB,  undef, "$desc : sub";
  41  is EVAL, undef, "$desc : eval";
  42 }
  43
  44 do {
  45  my $desc = 'do { 1 }';
  46  is HERE, 1,     "$desc : here" unless $^P;
  47  is TOP,  $top,  "$desc : top";
  48  is UP,   $top,  "$desc : up";
  49  is SUB,  undef, "$desc : sub";
  50  is EVAL, undef, "$desc : eval";
  51 };
  52
  53 eval {
  54  my $desc = 'eval { 1 }';
  55  is HERE, 1,     "$desc : here" unless $^P;
  56  is TOP,  $top,  "$desc : top";
  57  is UP,   $top,  "$desc : up";
  58  is SUB,  undef, "$desc : sub";
  59  is EVAL, HERE,  "$desc : eval";
  60 };
  61 diag $@ if $@;
  62
  63 eval q[
  64  my $desc = 'eval "1"';
  65  is HERE, 1,     "$desc : here" unless $^P;
  66  is TOP,  $top,  "$desc : top";
  67  is UP,   $top,  "$desc : up";
  68  is SUB,  undef, "$desc : sub";
  69  is EVAL, HERE,  "$desc : eval";
  70 ];
  71 diag $@ if $@;
  72
  73 sub {
  74  my $desc = 'sub { 1 }';
  75  is HERE, 1,     "$desc : here" unless $^P;
  76  is TOP,  $top,  "$desc : top";
  77  is UP,   $top,  "$desc : up";
  78  is SUB,  HERE,  "$desc : sub";
  79  is EVAL, undef, "$desc : eval";
  80 }->();
  81
  82 my $true  = 1;
  83 my $false = !$true;
  84
  85 if ($true) {
  86  my $desc = 'if () { 1 }';
  87  is HERE, 1,     "$desc : here" unless $^P;
  88  is TOP,  $top,  "$desc : top";
  89  is UP,   $top,  "$desc : up";
  90  is SUB,  undef, "$desc : sub";
  91  is EVAL, undef, "$desc : eval";
  92 }
  93
  94 unless ($false) {
  95  my $desc = 'unless () { 1 }';
  96  is HERE, 1,     "$desc : here" unless $^P;
  97  is TOP,  $top,  "$desc : top";
  98  is UP,   $top,  "$desc : up";
  99  is SUB,  undef, "$desc : sub";
 100  is EVAL, undef, "$desc : eval";
 101 }
 102
 103 if ($false) {
 104  fail "false was true : $_" for 1 .. 5;
 105 } else {
 106  my $desc = 'if () { } else { 1 }';
 107  is HERE, 1,     "$desc : here" unless $^P;
 108  is TOP,  $top,  "$desc : top";
 109  is UP,   $top,  "$desc : up";
 110  is SUB,  undef, "$desc : sub";
 111  is EVAL, undef, "$desc : eval";
 112 }
 113
 114 for (1) {
 115  my $desc = 'for (list) { 1 }';
 116  is HERE, 1,     "$desc : here" unless $^P;
 117  is TOP,  $top,  "$desc : top";
 118  is UP,   $top,  "$desc : up";
 119  is SUB,  undef, "$desc : sub";
 120  is EVAL, undef, "$desc : eval";
 121 }
 122
 123 for (1 .. 1) {
 124  my $desc = 'for (num range) { 1 }';
 125  is HERE, 1,     "$desc : here" unless $^P;
 126  is TOP,  $top,  "$desc : top";
 127  is UP,   $top,  "$desc : up";
 128  is SUB,  undef, "$desc : sub";
 129  is EVAL, undef, "$desc : eval";
 130 }
 131
 132 for (1 .. 1) {
 133  my $desc = 'for (pv range) { 1 }';
 134  is HERE, 1,     "$desc : here" unless $^P;
 135  is TOP,  $top,  "$desc : top";
 136  is UP,   $top,  "$desc : up";
 137  is SUB,  undef, "$desc : sub";
 138  is EVAL, undef, "$desc : eval";
 139 }
 140
 141 for (my $i = 0; $i < 1; ++$i) {
 142  my $desc = 'for (;;) { 1 }';
 143  is HERE, 1,     "$desc : here" unless $^P;
 144  is TOP,  $top,  "$desc : top";
 145  is UP,   $top,  "$desc : up";
 146  is SUB,  undef, "$desc : sub";
 147  is EVAL, undef, "$desc : eval";
 148 }
 149
 150 my $flag = 1;
 151 while ($flag) {
 152  $flag = 0;
 153  my $desc = 'while () { 1 }';
 154  is HERE, 1,     "$desc : here" unless $^P;
 155  is TOP,  $top,  "$desc : top";
 156  is UP,   $top,  "$desc : up";
 157  is SUB,  undef, "$desc : sub";
 158  is EVAL, undef, "$desc : eval";
 159 }
 160
 161 my @list = (1);
 162 while (my $thing = shift @list) {
 163  my $desc = 'while (my $thing = ...) { 2 }';
 164  is HERE, 1,     "$desc : here" unless $^P;
 165  is TOP,  $top,  "$desc : top";
 166  is UP,   $top,  "$desc : up";
 167  is SUB,  undef, "$desc : sub";
 168  is EVAL, undef, "$desc : eval";
 169 }
 170
 171 do {
 172  my $desc = 'do { 1 } while (0)';
 173  is HERE, 1,     "$desc : here" unless $^P;
 174  is TOP,  $top,  "$desc : top";
 175  is UP,   $top,  "$desc : up";
 176  is SUB,  undef, "$desc : sub";
 177  is EVAL, undef, "$desc : eval";
 178 } while (0);
 179
 180 map {
 181  my $desc = 'map { 1 } 1';
 182  is HERE, 1,     "$desc : here" unless $^P;
 183  is TOP,  $top,  "$desc : top";
 184  is UP,   $top,  "$desc : up";
 185  is SUB,  undef, "$desc : sub";
 186  is EVAL, undef, "$desc : eval";
 187 } 1;
 188
 189 grep {
 190  my $desc = 'grep { 1 } 1';
 191  is HERE, 1,     "$desc : here" unless $^P;
 192  is TOP,  $top,  "$desc : top";
 193  is UP,   $top,  "$desc : up";
 194  is SUB,  undef, "$desc : sub";
 195  is EVAL, undef, "$desc : eval";
 196 } 1;
 197
 198 my $var = 'a';
 199 $var =~ s{.}{
 200  my $desc = 'subst';
 201  is HERE, 1,     "$desc : here" unless $^P;
 202  is TOP,  $top,  "$desc : top";
 203  is UP,   $top,  "$desc : up";
 204  is SUB,  undef, "$desc : sub";
 205  is EVAL, undef, "$desc : eval";
 206 }e;
 207
 208 $var = 'a';
 209 $var =~ s{.}{UP}e;
 210 is $var, $top, 'subst : fake block';
 211
 212 $var = 'a';
 213 $var =~ s{.}{do { UP }}e;
 214 is $var, 1, 'subst : do block optimized away' unless $^P;
 215
 216 $var = 'a';
 217 $var =~ s{.}{do { my $x; UP }}e;
 218 is $var, 1, 'subst : do block preserved' unless $^P;
 219
 220 SKIP: {
 221  skip 'Perl 5.10 required to test given/when' => 4 * ($^P ? 4 : 5)
 222                                                                 if "$]" < 5.010;
 223
 224  eval <<'TEST_GIVEN';
 225   BEGIN {
 226    if ("$]" >= 5.017_011) {
 227     require warnings;
 228     warnings->unimport('experimental::smartmatch');
 229    }
 230   }
 231   use feature 'switch';
 232   my $desc = 'given';
 233   my $base = HERE;
 234   given (1) {
 235    is HERE, $base + 1, "$desc : here" unless $^P;
 236    is TOP,  $top,      "$desc : top";
 237    is UP,   $base,     "$desc : up";
 238    is SUB,  undef,     "$desc : sub";
 239    is EVAL, $base,     "$desc : eval";
 240   }
 241 TEST_GIVEN
 242  diag $@ if $@;
 243
 244  eval <<'TEST_GIVEN_WHEN';
 245   BEGIN {
 246    if ("$]" >= 5.017_011) {
 247     require warnings;
 248     warnings->unimport('experimental::smartmatch');
 249    }
 250   }
 251   use feature 'switch';
 252   my $desc = 'when in given';
 253   my $base = HERE;
 254   given (1) {
 255    my $given = HERE;
 256    when (1) {
 257     is HERE, $base + 3, "$desc : here" unless $^P;
 258     is TOP,  $top,      "$desc : top";
 259     is UP,   $given,    "$desc : up";
 260     is SUB,  undef,     "$desc : sub";
 261     is EVAL, $base,     "$desc : eval";
 262    }
 263   }
 264 TEST_GIVEN_WHEN
 265  diag $@ if $@;
 266
 267  eval <<'TEST_GIVEN_DEFAULT';
 268   BEGIN {
 269    if ("$]" >= 5.017_011) {
 270     require warnings;
 271     warnings->unimport('experimental::smartmatch');
 272    }
 273   }
 274   use feature 'switch';
 275   my $desc = 'default in given';
 276   my $base = HERE;
 277   given (1) {
 278    my $given = HERE;
 279    default {
 280     is HERE, $base + 3, "$desc : here" unless $^P;
 281     is TOP,  $top,      "$desc : top";
 282     is UP,   $given,    "$desc : up";
 283     is SUB,  undef,     "$desc : sub";
 284     is EVAL, $base,     "$desc : eval";
 285    }
 286   }
 287 TEST_GIVEN_DEFAULT
 288  diag $@ if $@;
 289
 290  eval <<'TEST_FOR_WHEN';
 291   BEGIN {
 292    if ("$]" >= 5.017_011) {
 293     require warnings;
 294     warnings->unimport('experimental::smartmatch');
 295    }
 296   }
 297   use feature 'switch';
 298   my $desc = 'when in for';
 299   my $base = HERE;
 300   for (1) {
 301    my $loop = HERE;
 302    when (1) {
 303     is HERE, $base + 2, "$desc : here" unless $^P;
 304     is TOP,  $top,      "$desc : top";
 305     is UP,   $loop,     "$desc : up";
 306     is SUB,  undef,     "$desc : sub";
 307     is EVAL, $base,     "$desc : eval";
 308    }
 309   }
 310 TEST_FOR_WHEN
 311  diag $@ if $@;
 312 }
 313
 314 SKIP: {
 315  skip 'Hardcoded values are wrong under the debugger' => 7 if $^P;
 316
 317  my $base = HERE;
 318
 319  do {
 320   eval {
 321    do {
 322     sub {
 323      eval q[
 324       {
 325        is HERE,           $base + 6, 'mixed : here';
 326        is TOP,            $top,      'mixed : top';
 327        is SUB,            $base + 4, 'mixed : first sub';
 328        is SUB(SUB),       $base + 4, 'mixed : still first sub';
 329        is EVAL,           $base + 5, 'mixed : first eval';
 330        is EVAL(EVAL),     $base + 5, 'mixed : still first eval';
 331        is EVAL(UP(EVAL)), $base + 2, 'mixed : second eval';
 332       }
 333      ];
 334     }->();
 335    }
 336   };
 337  } while (0);
 338 }
 339
 340 {
 341  my $block = HERE;
 342  is SCOPE,     $block, 'block : scope';
 343  is SCOPE(0),  $block, 'block : scope 0';
 344  is SCOPE(1),  $top,   'block : scope 1';
 345  $old_sig_warn = $SIG{__WARN__};
 346  local ($SIG{__WARN__}, $got_warn) = $warn_catcher;
 347  is SCOPE(2),  $top,   'block : scope 2';
 348  is $got_warn, 1,      'block : scope 2 warns';
 349  local $got_warn;
 350  is CALLER,    $top,   'block : caller';
 351  is $got_warn, 1,      'block : caller warns';
 352  local $got_warn;
 353  is CALLER(0), $top,   'block : caller 0';
 354  is $got_warn, 1,      'block : caller 0 warns';
 355  local $got_warn;
 356  is CALLER(1), $top,   'block : caller 1';
 357  is $got_warn, 1,      'block : caller 1 warns';
 358  local $SIG{__WARN__} = $old_sig_warn;
 359  sub {
 360   my $sub = HERE;
 361   is SCOPE,     $sub,   'block sub : scope';
 362   is SCOPE(0),  $sub,   'block sub : scope 0';
 363   is SCOPE(1),  $block, 'block sub : scope 1';
 364   is SCOPE(2),  $top,   'block sub : scope 2';
 365   is CALLER,    $sub,   'block sub : caller';
 366   is CALLER(0), $sub,   'block sub : caller 0';
 367   $old_sig_warn = $SIG{__WARN__};
 368   local ($SIG{__WARN__}, $got_warn) = $warn_catcher;
 369   is CALLER(1), $top,   'block sub : caller 1';
 370   local $SIG{__WARN__} = $old_sig_warn;
 371   is $got_warn, 1,      'block sub : caller 1 warns';
 372   for (1) {
 373    my $loop = HERE;
 374    is SCOPE,     $loop,  'block sub for : scope';
 375    is SCOPE(0),  $loop,  'block sub for : scope 0';
 376    is SCOPE(1),  $sub,   'block sub for : scope 1';
 377    is SCOPE(2),  $block, 'block sub for : scope 2';
 378    is SCOPE(3),  $top,   'block sub for : scope 3';
 379    is CALLER,    $sub,   'block sub for : caller';
 380    is CALLER(0), $sub,   'block sub for : caller 0';
 381    $old_sig_warn = $SIG{__WARN__};
 382    local ($SIG{__WARN__}, $got_warn) = $warn_catcher;
 383    is CALLER(1), $top,   'block sub for : caller 1';
 384    local $SIG{__WARN__} = $old_sig_warn;
 385    is $got_warn, 1,      'block sub for : caller 1 warns';
 386    eval {
 387     my $eval = HERE;
 388     is SCOPE,     $eval,  'block sub for eval : scope';
 389     is SCOPE(0),  $eval,  'block sub for eval : scope 0';
 390     is SCOPE(1),  $loop,  'block sub for eval : scope 1';
 391     is SCOPE(2),  $sub,   'block sub for eval : scope 2';
 392     is SCOPE(3),  $block, 'block sub for eval : scope 3';
 393     is SCOPE(4),  $top,   'block sub for eval : scope 4';
 394     is CALLER,    $eval,  'block sub for eval : caller';
 395     is CALLER(0), $eval,  'block sub for eval : caller 0';
 396     is CALLER(1), $sub,   'block sub for eval : caller 1';
 397     $old_sig_warn = $SIG{__WARN__};
 398     local ($SIG{__WARN__}, $got_warn) = $warn_catcher;
 399     is CALLER(2), $top,   'block sub for eval : caller 2';
 400     local $SIG{__WARN__} = $old_sig_warn;
 401     is $got_warn, 1,      'block sub for eval : caller 2 warns';
 402    }
 403   }
 404  }->();
 405 }