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  my $skip_count = 4 * ($^P ? 4 : 5) + 4;
 343  skip 'Perl 5.10 required to test given/when'
 344       => $skip_count if "$]" < 5.010;
 345  skip 'Not testing deprecated given/when on Perl 5.37.10 or later'
 346       => $skip_count if "$]" >= 5.037010;
 347
 348  eval <<'TEST_GIVEN';
 349   BEGIN {
 350    if ("$]" >= 5.017_011) {
 351     require warnings;
 352     warnings->unimport('experimental::smartmatch');
 353    }
 354   }
 355   use feature 'switch';
 356   my $desc = 'given';
 357   my $base = HERE;
 358   given (1) {
 359    is HERE,     $base + 1,    "$desc : here" unless $^P;
 360    is TOP,      $top,         "$desc : top";
 361    is UP,       $base,        "$desc : up";
 362    $old_sig_warn = $SIG{__WARN__};
 363    local ($SIG{__WARN__}, @warns) = $warn_catcher;
 364    is SUB,      undef,        "$desc : sub";
 365    is "@warns", 'subroutine', "$desc : sub warns";
 366    local $SIG{__WARN__} = $old_sig_warn;
 367    is EVAL,     $base,        "$desc : eval";
 368   }
 369 TEST_GIVEN
 370  diag $@ if $@;
 371
 372  eval <<'TEST_GIVEN_WHEN';
 373   BEGIN {
 374    if ("$]" >= 5.017_011) {
 375     require warnings;
 376     warnings->unimport('experimental::smartmatch');
 377    }
 378   }
 379   use feature 'switch';
 380   my $desc = 'when in given';
 381   my $base = HERE;
 382   given (1) {
 383    my $given = HERE;
 384    when (1) {
 385     is HERE,     $base + 3,    "$desc : here" unless $^P;
 386     is TOP,      $top,         "$desc : top";
 387     is UP,       $given,       "$desc : up";
 388     $old_sig_warn = $SIG{__WARN__};
 389     local ($SIG{__WARN__}, @warns) = $warn_catcher;
 390     is SUB,      undef,        "$desc : sub";
 391     is "@warns", 'subroutine', "$desc : sub warns";
 392     local $SIG{__WARN__} = $old_sig_warn;
 393     is EVAL,     $base,        "$desc : eval";
 394    }
 395   }
 396 TEST_GIVEN_WHEN
 397  diag $@ if $@;
 398
 399  eval <<'TEST_GIVEN_DEFAULT';
 400   BEGIN {
 401    if ("$]" >= 5.017_011) {
 402     require warnings;
 403     warnings->unimport('experimental::smartmatch');
 404    }
 405   }
 406   use feature 'switch';
 407   my $desc = 'default in given';
 408   my $base = HERE;
 409   given (1) {
 410    my $given = HERE;
 411    default {
 412     is HERE,     $base + 3,    "$desc : here" unless $^P;
 413     is TOP,      $top,         "$desc : top";
 414     is UP,       $given,       "$desc : up";
 415     $old_sig_warn = $SIG{__WARN__};
 416     local ($SIG{__WARN__}, @warns) = $warn_catcher;
 417     is SUB,      undef,        "$desc : sub";
 418     is "@warns", 'subroutine', "$desc : sub warns";
 419     local $SIG{__WARN__} = $old_sig_warn;
 420     is EVAL,     $base,        "$desc : eval";
 421    }
 422   }
 423 TEST_GIVEN_DEFAULT
 424  diag $@ if $@;
 425
 426  eval <<'TEST_FOR_WHEN';
 427   BEGIN {
 428    if ("$]" >= 5.017_011) {
 429     require warnings;
 430     warnings->unimport('experimental::smartmatch');
 431    }
 432   }
 433   use feature 'switch';
 434   my $desc = 'when in for';
 435   my $base = HERE;
 436   for (1) {
 437    my $loop = HERE;
 438    when (1) {
 439     is HERE,     $base + 2,    "$desc : here" unless $^P;
 440     is TOP,      $top,         "$desc : top";
 441     is UP,       $loop,        "$desc : up";
 442     $old_sig_warn = $SIG{__WARN__};
 443     local ($SIG{__WARN__}, @warns) = $warn_catcher;
 444     is SUB,      undef,        "$desc : sub";
 445     is "@warns", 'subroutine', "$desc : sub warns";
 446     local $SIG{__WARN__} = $old_sig_warn;
 447     is EVAL,     $base,        "$desc : eval";
 448    }
 449   }
 450 TEST_FOR_WHEN
 451  diag $@ if $@;
 452 }
 453
 454 SKIP: {
 455  skip 'Hardcoded values are wrong under the debugger' => 7 if $^P;
 456
 457  my $base = HERE;
 458
 459  do {
 460   eval {
 461    do {
 462     sub {
 463      eval q[
 464       {
 465        is HERE,           $base + 6, 'mixed : here';
 466        is TOP,            $top,      'mixed : top';
 467        is SUB,            $base + 4, 'mixed : first sub';
 468        is SUB(SUB),       $base + 4, 'mixed : still first sub';
 469        is EVAL,           $base + 5, 'mixed : first eval';
 470        is EVAL(EVAL),     $base + 5, 'mixed : still first eval';
 471        is EVAL(UP(EVAL)), $base + 2, 'mixed : second eval';
 472       }
 473      ];
 474     }->();
 475    }
 476   };
 477  } while (0);
 478 }
 479
 480 {
 481  my $block = HERE;
 482  is SCOPE,     $block,  'block : scope';
 483  is SCOPE(0),  $block,  'block : scope 0';
 484  is SCOPE(1),  $top,    'block : scope 1';
 485  $old_sig_warn = $SIG{__WARN__};
 486  local ($SIG{__WARN__}, @warns) = $warn_catcher;
 487  is SCOPE(2),  $top,    'block : scope 2';
 488  is "@warns",  'smash', 'block : scope 2 warns';
 489  local @warns;
 490  is CALLER,    $top,    'block : caller';
 491  is "@warns",  'smash', 'block : caller warns';
 492  local @warns;
 493  is CALLER(0), $top,    'block : caller 0';
 494  is "@warns",  'smash', 'block : caller 0 warns';
 495  local @warns;
 496  is CALLER(1), $top,    'block : caller 1';
 497  is "@warns",  'smash', 'block : caller 1 warns';
 498  local $SIG{__WARN__} = $old_sig_warn;
 499  sub {
 500   my $sub = HERE;
 501   is SCOPE,     $sub,    'block sub : scope';
 502   is SCOPE(0),  $sub,    'block sub : scope 0';
 503   is SCOPE(1),  $block,  'block sub : scope 1';
 504   is SCOPE(2),  $top,    'block sub : scope 2';
 505   is CALLER,    $sub,    'block sub : caller';
 506   is CALLER(0), $sub,    'block sub : caller 0';
 507   $old_sig_warn = $SIG{__WARN__};
 508   local ($SIG{__WARN__}, @warns) = $warn_catcher;
 509   is CALLER(1), $top,    'block sub : caller 1';
 510   is "@warns",  'smash', 'block sub : caller 1 warns';
 511   local $SIG{__WARN__} = $old_sig_warn;
 512   for (1) {
 513    my $loop = HERE;
 514    is SCOPE,     $loop,   'block sub for : scope';
 515    is SCOPE(0),  $loop,   'block sub for : scope 0';
 516    is SCOPE(1),  $sub,    'block sub for : scope 1';
 517    is SCOPE(2),  $block,  'block sub for : scope 2';
 518    is SCOPE(3),  $top,    'block sub for : scope 3';
 519    is CALLER,    $sub,    'block sub for : caller';
 520    is CALLER(0), $sub,    'block sub for : caller 0';
 521    $old_sig_warn = $SIG{__WARN__};
 522    local ($SIG{__WARN__}, @warns) = $warn_catcher;
 523    is CALLER(1), $top,    'block sub for : caller 1';
 524    is "@warns",  'smash', 'block sub for : caller 1 warns';
 525    local $SIG{__WARN__} = $old_sig_warn;
 526    eval {
 527     my $eval = HERE;
 528     is SCOPE,     $eval,   'block sub for eval : scope';
 529     is SCOPE(0),  $eval,   'block sub for eval : scope 0';
 530     is SCOPE(1),  $loop,   'block sub for eval : scope 1';
 531     is SCOPE(2),  $sub,    'block sub for eval : scope 2';
 532     is SCOPE(3),  $block,  'block sub for eval : scope 3';
 533     is SCOPE(4),  $top,    'block sub for eval : scope 4';
 534     is CALLER,    $eval,   'block sub for eval : caller';
 535     is CALLER(0), $eval,   'block sub for eval : caller 0';
 536     is CALLER(1), $sub,    'block sub for eval : caller 1';
 537     $old_sig_warn = $SIG{__WARN__};
 538     local ($SIG{__WARN__}, @warns) = $warn_catcher;
 539     is CALLER(2), $top,    'block sub for eval : caller 2';
 540     is "@warns",  'smash', 'block sub for eval : caller 2 warns';
 541     local $SIG{__WARN__} = $old_sig_warn;
 542    }
 543   }
 544  }->();
 545 }
 546
 547 is $stray_warnings, 0, 'no stray warnings';