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   use feature 'switch';
 214   my $desc = 'given';
 215   my $base = HERE;
 216   given (1) {
 217    is HERE, $base + 1, "$desc : here" unless $^P;
 218    is TOP,  $top,      "$desc : top";
 219    is UP,   $base,     "$desc : up";
 220    is SUB,  undef,     "$desc : sub";
 221    is EVAL, $base,     "$desc : eval";
 222   }
 223 TEST_GIVEN
 224  diag $@ if $@;
 225
 226  eval <<'TEST_GIVEN_WHEN';
 227   use feature 'switch';
 228   my $desc = 'when in given';
 229   my $base = HERE;
 230   given (1) {
 231    my $given = HERE;
 232    when (1) {
 233     is HERE, $base + 3, "$desc : here" unless $^P;
 234     is TOP,  $top,      "$desc : top";
 235     is UP,   $given,    "$desc : up";
 236     is SUB,  undef,     "$desc : sub";
 237     is EVAL, $base,     "$desc : eval";
 238    }
 239   }
 240 TEST_GIVEN_WHEN
 241  diag $@ if $@;
 242
 243  eval <<'TEST_GIVEN_DEFAULT';
 244   use feature 'switch';
 245   my $desc = 'default in given';
 246   my $base = HERE;
 247   given (1) {
 248    my $given = HERE;
 249    default {
 250     is HERE, $base + 3, "$desc : here" unless $^P;
 251     is TOP,  $top,      "$desc : top";
 252     is UP,   $given,    "$desc : up";
 253     is SUB,  undef,     "$desc : sub";
 254     is EVAL, $base,     "$desc : eval";
 255    }
 256   }
 257 TEST_GIVEN_DEFAULT
 258  diag $@ if $@;
 259
 260  eval <<'TEST_FOR_WHEN';
 261   use feature 'switch';
 262   my $desc = 'when in for';
 263   my $base = HERE;
 264   for (1) {
 265    my $loop = HERE;
 266    when (1) {
 267     is HERE, $base + 2, "$desc : here" unless $^P;
 268     is TOP,  $top,      "$desc : top";
 269     is UP,   $loop,     "$desc : up";
 270     is SUB,  undef,     "$desc : sub";
 271     is EVAL, $base,     "$desc : eval";
 272    }
 273   }
 274 TEST_FOR_WHEN
 275  diag $@ if $@;
 276 }
 277
 278 SKIP: {
 279  skip 'Hardcoded values are wrong under the debugger' => 7 if $^P;
 280
 281  my $base = HERE;
 282
 283  do {
 284   eval {
 285    do {
 286     sub {
 287      eval q[
 288       {
 289        is HERE,           $base + 6, 'mixed : here';
 290        is TOP,            $top,      'mixed : top';
 291        is SUB,            $base + 4, 'mixed : first sub';
 292        is SUB(SUB),       $base + 4, 'mixed : still first sub';
 293        is EVAL,           $base + 5, 'mixed : first eval';
 294        is EVAL(EVAL),     $base + 5, 'mixed : still first eval';
 295        is EVAL(UP(EVAL)), $base + 2, 'mixed : second eval';
 296       }
 297      ];
 298     }->();
 299    }
 300   };
 301  } while (0);
 302 }
 303
 304 {
 305  my $block = HERE;
 306  is SCOPE,     $block, 'block : scope';
 307  is SCOPE(0),  $block, 'block : scope 0';
 308  is SCOPE(1),  $top,   'block : scope 1';
 309  is CALLER,    $top,   'block : caller';
 310  is CALLER(0), $top,   'block : caller 0';
 311  is CALLER(1), $top,   'block : caller 1';
 312  sub {
 313   my $sub = HERE;
 314   is SCOPE,     $sub,   'block sub : scope';
 315   is SCOPE(0),  $sub,   'block sub : scope 0';
 316   is SCOPE(1),  $block, 'block sub : scope 1';
 317   is CALLER,    $sub,   'block sub : caller';
 318   is CALLER(0), $sub,   'block sub : caller 0';
 319   is CALLER(1), $top,   'block sub : caller 1';
 320   for (1) {
 321    my $loop = HERE;
 322    is SCOPE,     $loop,  'block sub for : scope';
 323    is SCOPE(0),  $loop,  'block sub for : scope 0';
 324    is SCOPE(1),  $sub,   'block sub for : scope 1';
 325    is SCOPE(2),  $block, 'block sub for : scope 2';
 326    is CALLER,    $sub,   'block sub for : caller';
 327    is CALLER(0), $sub,   'block sub for : caller 0';
 328    is CALLER(1), $top,   'block sub for : caller 1';
 329    is CALLER(2), $top,   'block sub for : caller 2';
 330    eval {
 331     my $eval = HERE;
 332     is SCOPE,     $eval,  'block sub for eval : scope';
 333     is SCOPE(0),  $eval,  'block sub for eval : scope 0';
 334     is SCOPE(1),  $loop,  'block sub for eval : scope 1';
 335     is SCOPE(2),  $sub,   'block sub for eval : scope 2';
 336     is SCOPE(3),  $block, 'block sub for eval : scope 3';
 337     is CALLER,    $eval,  'block sub for eval : caller';
 338     is CALLER(0), $eval,  'block sub for eval : caller 0';
 339     is CALLER(1), $sub,   'block sub for eval : caller 1';
 340     is CALLER(2), $top,   'block sub for eval : caller 2';
 341     is CALLER(3), $top,   'block sub for eval : caller 3';
 342    }
 343   }
 344  }->();
 345 }