t/05-words.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More;
   7
   8 plan tests => 23 * ($^P ? 4 : 5) + 40 +  ($^P ? 1 : 3) + 7 + (32 + 7) + 1;
   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 my $stray_warnings = 0;
  16 local $SIG{__WARN__} = sub {
  17  ++$stray_warnings;
  18  warn(@_);
  19 };
  20
  21 our @warns;
  22 my $warn_catcher = sub {
  23  my $what;
  24  if ($_[0] =~ /^Cannot target a scope outside of the current stack at /) {
  25   $what = 'smash';
  26  } elsif ($_[0] =~ /^No targetable (subroutine|eval) scope in the current stack at /) {
  27   $what = $1;
  28  }
  29  if (defined $what) {
  30   push @warns, $what;
  31  } else {
  32   warn(@_);
  33  }
  34  return;
  35 };
  36 my $old_sig_warn;
  37
  38 my $top = HERE;
  39
  40 is $top,     0,            'main : here' unless $^P;
  41 is TOP,      $top,         'main : top';
  42 $old_sig_warn = $SIG{__WARN__};
  43 local ($SIG{__WARN__}, @warns) = $warn_catcher;
  44 is UP,       $top,         'main : up';
  45 is "@warns", 'smash',      'main : up warns';
  46 local @warns;
  47 is SUB,      undef,        'main : sub';
  48 is "@warns", 'subroutine', 'main : sub warns';
  49 local @warns;
  50 is EVAL,     undef,        'main : eval';
  51 is "@warns", 'eval',       'main : eval warns';
  52 local $SIG{__WARN__} = $old_sig_warn;
  53
  54 {
  55  my $desc = '{ 1 }';
  56  is HERE,     1,            "$desc : here" unless $^P;
  57  is TOP,      $top,         "$desc : top";
  58  is UP,       $top,         "$desc : up";
  59  $old_sig_warn = $SIG{__WARN__};
  60  local ($SIG{__WARN__}, @warns) = $warn_catcher;
  61  is SUB,      undef,        "$desc : sub";
  62  is "@warns", 'subroutine', "$desc : sub warns";
  63  local @warns;
  64  is EVAL,     undef,        "$desc : eval";
  65  is "@warns", 'eval',       "$desc : eval warns";
  66  local $SIG{__WARN__} = $old_sig_warn;
  67 }
  68
  69 do {
  70  my $desc = 'do { 1 }';
  71  is HERE,     1,            "$desc : here" unless $^P;
  72  is TOP,      $top,         "$desc : top";
  73  is UP,       $top,         "$desc : up";
  74  $old_sig_warn = $SIG{__WARN__};
  75  local ($SIG{__WARN__}, @warns) = $warn_catcher;
  76  is SUB,      undef,        "$desc : sub";
  77  is "@warns", 'subroutine', "$desc : sub warns";
  78  local @warns;
  79  is EVAL,     undef,        "$desc : eval";
  80  is "@warns", 'eval',       "$desc : eval warns";
  81  local $SIG{__WARN__} = $old_sig_warn;
  82 };
  83
  84 eval {
  85  my $desc = 'eval { 1 }';
  86  is HERE,     1,            "$desc : here" unless $^P;
  87  is TOP,      $top,         "$desc : top";
  88  is UP,       $top,         "$desc : up";
  89  $old_sig_warn = $SIG{__WARN__};
  90  local ($SIG{__WARN__}, @warns) = $warn_catcher;
  91  is SUB,      undef,        "$desc : sub";
  92  is "@warns", 'subroutine', "$desc : sub warns";
  93  local $SIG{__WARN__} = $old_sig_warn;
  94  is EVAL,     HERE,         "$desc : eval";
  95 };
  96 diag $@ if $@;
  97
  98 eval q[
  99  my $desc = 'eval "1"';
 100  is HERE,     1,            "$desc : here" unless $^P;
 101  is TOP,      $top,         "$desc : top";
 102  is UP,       $top,         "$desc : up";
 103  $old_sig_warn = $SIG{__WARN__};
 104  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 105  is SUB,      undef,        "$desc : sub";
 106  is "@warns", 'subroutine', "$desc : sub warns";
 107  local $SIG{__WARN__} = $old_sig_warn;
 108  is EVAL,     HERE,         "$desc : eval";
 109 ];
 110 diag $@ if $@;
 111
 112 sub {
 113  my $desc = 'sub { 1 }';
 114  is HERE,     1,      "$desc : here" unless $^P;
 115  is TOP,      $top,   "$desc : top";
 116  is UP,       $top,   "$desc : up";
 117  is SUB,      HERE,   "$desc : sub";
 118  $old_sig_warn = $SIG{__WARN__};
 119  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 120  is EVAL,     undef,  "$desc : eval";
 121  is "@warns", 'eval', "$desc : eval warns";
 122  local $SIG{__WARN__} = $old_sig_warn;
 123 }->();
 124
 125 my $true  = 1;
 126 my $false = !$true;
 127
 128 if ($true) {
 129  my $desc = 'if () { 1 }';
 130  is HERE,     1,            "$desc : here" unless $^P;
 131  is TOP,      $top,         "$desc : top";
 132  is UP,       $top,         "$desc : up";
 133  $old_sig_warn = $SIG{__WARN__};
 134  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 135  is SUB,      undef,        "$desc : sub";
 136  is "@warns", 'subroutine', "$desc : sub warns";
 137  local @warns;
 138  is EVAL,     undef,        "$desc : eval";
 139  is "@warns", 'eval',       "$desc : eval warns";
 140  local $SIG{__WARN__} = $old_sig_warn;
 141 }
 142
 143 unless ($false) {
 144  my $desc = 'unless () { 1 }';
 145  is HERE,     1,            "$desc : here" unless $^P;
 146  is TOP,      $top,         "$desc : top";
 147  is UP,       $top,         "$desc : up";
 148  $old_sig_warn = $SIG{__WARN__};
 149  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 150  is SUB,      undef,        "$desc : sub";
 151  is "@warns", 'subroutine', "$desc : sub warns";
 152  local @warns;
 153  is EVAL,     undef,        "$desc : eval";
 154  is "@warns", 'eval',       "$desc : eval warns";
 155  local $SIG{__WARN__} = $old_sig_warn;
 156 }
 157
 158 if ($false) {
 159  fail "false was true : $_" for 1 .. 5;
 160 } else {
 161  my $desc = 'if () { } else { 1 }';
 162  is HERE,     1,            "$desc : here" unless $^P;
 163  is TOP,      $top,         "$desc : top";
 164  is UP,       $top,         "$desc : up";
 165  $old_sig_warn = $SIG{__WARN__};
 166  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 167  is SUB,      undef,        "$desc : sub";
 168  is "@warns", 'subroutine', "$desc : sub warns";
 169  local @warns;
 170  is EVAL,     undef,        "$desc : eval";
 171  is "@warns", 'eval',       "$desc : eval warns";
 172  local $SIG{__WARN__} = $old_sig_warn;
 173 }
 174
 175 for (1) {
 176  my $desc = 'for (list) { 1 }';
 177  is HERE,     1,            "$desc : here" unless $^P;
 178  is TOP,      $top,         "$desc : top";
 179  is UP,       $top,         "$desc : up";
 180  $old_sig_warn = $SIG{__WARN__};
 181  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 182  is SUB,      undef,        "$desc : sub";
 183  is "@warns", 'subroutine', "$desc : sub warns";
 184  local @warns;
 185  is EVAL,     undef,        "$desc : eval";
 186  is "@warns", 'eval',       "$desc : eval warns";
 187  local $SIG{__WARN__} = $old_sig_warn;
 188 }
 189
 190 for (1 .. 1) {
 191  my $desc = 'for (num range) { 1 }';
 192  is HERE,     1,            "$desc : here" unless $^P;
 193  is TOP,      $top,         "$desc : top";
 194  is UP,       $top,         "$desc : up";
 195  $old_sig_warn = $SIG{__WARN__};
 196  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 197  is SUB,      undef,        "$desc : sub";
 198  is "@warns", 'subroutine', "$desc : sub warns";
 199  local @warns;
 200  is EVAL,     undef,        "$desc : eval";
 201  is "@warns", 'eval',       "$desc : eval warns";
 202  local $SIG{__WARN__} = $old_sig_warn;
 203 }
 204
 205 for (1 .. 1) {
 206  my $desc = 'for (pv range) { 1 }';
 207  is HERE,     1,            "$desc : here" unless $^P;
 208  is TOP,      $top,         "$desc : top";
 209  is UP,       $top,         "$desc : up";
 210  $old_sig_warn = $SIG{__WARN__};
 211  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 212  is SUB,      undef,        "$desc : sub";
 213  is "@warns", 'subroutine', "$desc : sub warns";
 214  local @warns;
 215  is EVAL,     undef,        "$desc : eval";
 216  is "@warns", 'eval',       "$desc : eval warns";
 217  local $SIG{__WARN__} = $old_sig_warn;
 218 }
 219
 220 for (my $i = 0; $i < 1; ++$i) {
 221  my $desc = 'for (;;) { 1 }';
 222  is HERE,     1,            "$desc : here" unless $^P;
 223  is TOP,      $top,         "$desc : top";
 224  is UP,       $top,         "$desc : up";
 225  $old_sig_warn = $SIG{__WARN__};
 226  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 227  is SUB,      undef,        "$desc : sub";
 228  is "@warns", 'subroutine', "$desc : sub warns";
 229  local @warns;
 230  is EVAL,     undef,        "$desc : eval";
 231  is "@warns", 'eval',       "$desc : eval warns";
 232  local $SIG{__WARN__} = $old_sig_warn;
 233 }
 234
 235 my $flag = 1;
 236 while ($flag) {
 237  $flag = 0;
 238  my $desc = 'while () { 1 }';
 239  is HERE,     1,            "$desc : here" unless $^P;
 240  is TOP,      $top,         "$desc : top";
 241  is UP,       $top,         "$desc : up";
 242  $old_sig_warn = $SIG{__WARN__};
 243  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 244  is SUB,      undef,        "$desc : sub";
 245  is "@warns", 'subroutine', "$desc : sub warns";
 246  local @warns;
 247  is EVAL,     undef,        "$desc : eval";
 248  is "@warns", 'eval',       "$desc : eval warns";
 249  local $SIG{__WARN__} = $old_sig_warn;
 250 }
 251
 252 my @list = (1);
 253 while (my $thing = shift @list) {
 254  my $desc = 'while (my $thing = ...) { 2 }';
 255  is HERE,     1,            "$desc : here" unless $^P;
 256  is TOP,      $top,         "$desc : top";
 257  is UP,       $top,         "$desc : up";
 258  $old_sig_warn = $SIG{__WARN__};
 259  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 260  is SUB,      undef,        "$desc : sub";
 261  is "@warns", 'subroutine', "$desc : sub warns";
 262  local @warns;
 263  is EVAL,     undef,        "$desc : eval";
 264  is "@warns", 'eval',       "$desc : eval warns";
 265  local $SIG{__WARN__} = $old_sig_warn;
 266 }
 267
 268 do {
 269  my $desc = 'do { 1 } while (0)';
 270  is HERE,     1,            "$desc : here" unless $^P;
 271  is TOP,      $top,         "$desc : top";
 272  is UP,       $top,         "$desc : up";
 273  $old_sig_warn = $SIG{__WARN__};
 274  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 275  is SUB,      undef,        "$desc : sub";
 276  is "@warns", 'subroutine', "$desc : sub warns";
 277  local @warns;
 278  is EVAL,     undef,        "$desc : eval";
 279  is "@warns", 'eval',       "$desc : eval warns";
 280  local $SIG{__WARN__} = $old_sig_warn;
 281 } while (0);
 282
 283 map {
 284  my $desc = 'map { 1 } 1';
 285  is HERE,     1,            "$desc : here" unless $^P;
 286  is TOP,      $top,         "$desc : top";
 287  is UP,       $top,         "$desc : up";
 288  $old_sig_warn = $SIG{__WARN__};
 289  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 290  is SUB,      undef,        "$desc : sub";
 291  is "@warns", 'subroutine', "$desc : sub warns";
 292  local @warns;
 293  is EVAL,     undef,        "$desc : eval";
 294  is "@warns", 'eval',       "$desc : eval warns";
 295  local $SIG{__WARN__} = $old_sig_warn;
 296 } 1;
 297
 298 grep {
 299  my $desc = 'grep { 1 } 1';
 300  is HERE,     1,            "$desc : here" unless $^P;
 301  is TOP,      $top,         "$desc : top";
 302  is UP,       $top,         "$desc : up";
 303  $old_sig_warn = $SIG{__WARN__};
 304  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 305  is SUB,      undef,        "$desc : sub";
 306  is "@warns", 'subroutine', "$desc : sub warns";
 307  local @warns;
 308  is EVAL,     undef,        "$desc : eval";
 309  is "@warns", 'eval',       "$desc : eval warns";
 310  local $SIG{__WARN__} = $old_sig_warn;
 311 } 1;
 312
 313 my $var = 'a';
 314 $var =~ s[.][
 315  my $desc = 'subst';
 316  is HERE,     1,            "$desc : here" unless $^P;
 317  is TOP,      $top,         "$desc : top";
 318  is UP,       $top,         "$desc : up";
 319  $old_sig_warn = $SIG{__WARN__};
 320  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 321  is SUB,      undef,        "$desc : sub";
 322  is "@warns", 'subroutine', "$desc : sub warns";
 323  local @warns;
 324  is EVAL,     undef,        "$desc : eval";
 325  is "@warns", 'eval',       "$desc : eval warns";
 326  local $SIG{__WARN__} = $old_sig_warn;
 327 ]e;
 328
 329 $var = 'a';
 330 $var =~ s{.}{UP}e;
 331 is $var, $top, 'subst : fake block';
 332
 333 $var = 'a';
 334 $var =~ s{.}{do { UP }}e;
 335 is $var, 1, 'subst : do block optimized away' unless $^P;
 336
 337 $var = 'a';
 338 $var =~ s{.}{do { my $x; UP }}e;
 339 is $var, 1, 'subst : do block preserved' unless $^P;
 340
 341 SKIP: {
 342  skip 'Perl 5.10 required to test given/when' => 4 * ($^P ? 4 : 5) + 4
 343                                                                 if "$]" < 5.010;
 344
 345  eval <<'TEST_GIVEN';
 346   BEGIN {
 347    if ("$]" >= 5.017_011) {
 348     require warnings;
 349     warnings->unimport('experimental::smartmatch');
 350    }
 351   }
 352   use feature 'switch';
 353   my $desc = 'given';
 354   my $base = HERE;
 355   given (1) {
 356    is HERE,     $base + 1,    "$desc : here" unless $^P;
 357    is TOP,      $top,         "$desc : top";
 358    is UP,       $base,        "$desc : up";
 359    $old_sig_warn = $SIG{__WARN__};
 360    local ($SIG{__WARN__}, @warns) = $warn_catcher;
 361    is SUB,      undef,        "$desc : sub";
 362    is "@warns", 'subroutine', "$desc : sub warns";
 363    local $SIG{__WARN__} = $old_sig_warn;
 364    is EVAL,     $base,        "$desc : eval";
 365   }
 366 TEST_GIVEN
 367  diag $@ if $@;
 368
 369  eval <<'TEST_GIVEN_WHEN';
 370   BEGIN {
 371    if ("$]" >= 5.017_011) {
 372     require warnings;
 373     warnings->unimport('experimental::smartmatch');
 374    }
 375   }
 376   use feature 'switch';
 377   my $desc = 'when in given';
 378   my $base = HERE;
 379   given (1) {
 380    my $given = HERE;
 381    when (1) {
 382     is HERE,     $base + 3,    "$desc : here" unless $^P;
 383     is TOP,      $top,         "$desc : top";
 384     is UP,       $given,       "$desc : up";
 385     $old_sig_warn = $SIG{__WARN__};
 386     local ($SIG{__WARN__}, @warns) = $warn_catcher;
 387     is SUB,      undef,        "$desc : sub";
 388     is "@warns", 'subroutine', "$desc : sub warns";
 389     local $SIG{__WARN__} = $old_sig_warn;
 390     is EVAL,     $base,        "$desc : eval";
 391    }
 392   }
 393 TEST_GIVEN_WHEN
 394  diag $@ if $@;
 395
 396  eval <<'TEST_GIVEN_DEFAULT';
 397   BEGIN {
 398    if ("$]" >= 5.017_011) {
 399     require warnings;
 400     warnings->unimport('experimental::smartmatch');
 401    }
 402   }
 403   use feature 'switch';
 404   my $desc = 'default in given';
 405   my $base = HERE;
 406   given (1) {
 407    my $given = HERE;
 408    default {
 409     is HERE,     $base + 3,    "$desc : here" unless $^P;
 410     is TOP,      $top,         "$desc : top";
 411     is UP,       $given,       "$desc : up";
 412     $old_sig_warn = $SIG{__WARN__};
 413     local ($SIG{__WARN__}, @warns) = $warn_catcher;
 414     is SUB,      undef,        "$desc : sub";
 415     is "@warns", 'subroutine', "$desc : sub warns";
 416     local $SIG{__WARN__} = $old_sig_warn;
 417     is EVAL,     $base,        "$desc : eval";
 418    }
 419   }
 420 TEST_GIVEN_DEFAULT
 421  diag $@ if $@;
 422
 423  eval <<'TEST_FOR_WHEN';
 424   BEGIN {
 425    if ("$]" >= 5.017_011) {
 426     require warnings;
 427     warnings->unimport('experimental::smartmatch');
 428    }
 429   }
 430   use feature 'switch';
 431   my $desc = 'when in for';
 432   my $base = HERE;
 433   for (1) {
 434    my $loop = HERE;
 435    when (1) {
 436     is HERE,     $base + 2,    "$desc : here" unless $^P;
 437     is TOP,      $top,         "$desc : top";
 438     is UP,       $loop,        "$desc : up";
 439     $old_sig_warn = $SIG{__WARN__};
 440     local ($SIG{__WARN__}, @warns) = $warn_catcher;
 441     is SUB,      undef,        "$desc : sub";
 442     is "@warns", 'subroutine', "$desc : sub warns";
 443     local $SIG{__WARN__} = $old_sig_warn;
 444     is EVAL,     $base,        "$desc : eval";
 445    }
 446   }
 447 TEST_FOR_WHEN
 448  diag $@ if $@;
 449 }
 450
 451 SKIP: {
 452  skip 'Hardcoded values are wrong under the debugger' => 7 if $^P;
 453
 454  my $base = HERE;
 455
 456  do {
 457   eval {
 458    do {
 459     sub {
 460      eval q[
 461       {
 462        is HERE,           $base + 6, 'mixed : here';
 463        is TOP,            $top,      'mixed : top';
 464        is SUB,            $base + 4, 'mixed : first sub';
 465        is SUB(SUB),       $base + 4, 'mixed : still first sub';
 466        is EVAL,           $base + 5, 'mixed : first eval';
 467        is EVAL(EVAL),     $base + 5, 'mixed : still first eval';
 468        is EVAL(UP(EVAL)), $base + 2, 'mixed : second eval';
 469       }
 470      ];
 471     }->();
 472    }
 473   };
 474  } while (0);
 475 }
 476
 477 {
 478  my $block = HERE;
 479  is SCOPE,     $block,  'block : scope';
 480  is SCOPE(0),  $block,  'block : scope 0';
 481  is SCOPE(1),  $top,    'block : scope 1';
 482  $old_sig_warn = $SIG{__WARN__};
 483  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 484  is SCOPE(2),  $top,    'block : scope 2';
 485  is "@warns",  'smash', 'block : scope 2 warns';
 486  local @warns;
 487  is CALLER,    $top,    'block : caller';
 488  is "@warns",  'smash', 'block : caller warns';
 489  local @warns;
 490  is CALLER(0), $top,    'block : caller 0';
 491  is "@warns",  'smash', 'block : caller 0 warns';
 492  local @warns;
 493  is CALLER(1), $top,    'block : caller 1';
 494  is "@warns",  'smash', 'block : caller 1 warns';
 495  local $SIG{__WARN__} = $old_sig_warn;
 496  sub {
 497   my $sub = HERE;
 498   is SCOPE,     $sub,    'block sub : scope';
 499   is SCOPE(0),  $sub,    'block sub : scope 0';
 500   is SCOPE(1),  $block,  'block sub : scope 1';
 501   is SCOPE(2),  $top,    'block sub : scope 2';
 502   is CALLER,    $sub,    'block sub : caller';
 503   is CALLER(0), $sub,    'block sub : caller 0';
 504   $old_sig_warn = $SIG{__WARN__};
 505   local ($SIG{__WARN__}, @warns) = $warn_catcher;
 506   is CALLER(1), $top,    'block sub : caller 1';
 507   is "@warns",  'smash', 'block sub : caller 1 warns';
 508   local $SIG{__WARN__} = $old_sig_warn;
 509   for (1) {
 510    my $loop = HERE;
 511    is SCOPE,     $loop,   'block sub for : scope';
 512    is SCOPE(0),  $loop,   'block sub for : scope 0';
 513    is SCOPE(1),  $sub,    'block sub for : scope 1';
 514    is SCOPE(2),  $block,  'block sub for : scope 2';
 515    is SCOPE(3),  $top,    'block sub for : scope 3';
 516    is CALLER,    $sub,    'block sub for : caller';
 517    is CALLER(0), $sub,    'block sub for : caller 0';
 518    $old_sig_warn = $SIG{__WARN__};
 519    local ($SIG{__WARN__}, @warns) = $warn_catcher;
 520    is CALLER(1), $top,    'block sub for : caller 1';
 521    is "@warns",  'smash', 'block sub for : caller 1 warns';
 522    local $SIG{__WARN__} = $old_sig_warn;
 523    eval {
 524     my $eval = HERE;
 525     is SCOPE,     $eval,   'block sub for eval : scope';
 526     is SCOPE(0),  $eval,   'block sub for eval : scope 0';
 527     is SCOPE(1),  $loop,   'block sub for eval : scope 1';
 528     is SCOPE(2),  $sub,    'block sub for eval : scope 2';
 529     is SCOPE(3),  $block,  'block sub for eval : scope 3';
 530     is SCOPE(4),  $top,    'block sub for eval : scope 4';
 531     is CALLER,    $eval,   'block sub for eval : caller';
 532     is CALLER(0), $eval,   'block sub for eval : caller 0';
 533     is CALLER(1), $sub,    'block sub for eval : caller 1';
 534     $old_sig_warn = $SIG{__WARN__};
 535     local ($SIG{__WARN__}, @warns) = $warn_catcher;
 536     is CALLER(2), $top,    'block sub for eval : caller 2';
 537     is "@warns",  'smash', 'block sub for eval : caller 2 warns';
 538     local $SIG{__WARN__} = $old_sig_warn;
 539    }
 540   }
 541  }->();
 542 }
 543
 544 is $stray_warnings, 0, 'no stray warnings';