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