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