t/23-localize-ctl.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 44 + 30;
   7
   8 use Scope::Upper qw<localize UP HERE>;
   9
  10 our ($x, $y);
  11
  12 {
  13  local $x = 1;
  14  {
  15   local $x = 2;
  16   localize '$y' => 1 => HERE;
  17   is $x, 2, 'last 0 [ok - x]';
  18   is $y, 1, 'last 0 [ok - y]';
  19   last;
  20   $y = 2;
  21  }
  22  is $x, 1,     'last 0 [end - x]';
  23  is $y, undef, 'last 0 [end - y]';
  24 }
  25
  26 {
  27  local $x = 1;
  28 LOOP:
  29  {
  30   local $x = 2;
  31   local $y = 0;
  32   {
  33    local $x = 3;
  34    localize '$y' => 1 => UP;
  35    is $x, 3, 'last 1 [ok - x]';
  36    is $y, 0, 'last 1 [ok - y]';
  37    last LOOP;
  38    $y = 3;
  39   }
  40   $y = 2;
  41  }
  42  is $x, 1,     'last 1 [end - x]';
  43  is $y, undef, 'last 1 [end - y]';
  44 }
  45
  46 {
  47  local $x = 1;
  48  {
  49   local $x = 2;
  50   localize '$y' => 1 => HERE;
  51   is $x, 2, 'next 0 [ok - x]';
  52   is $y, 1, 'next 0 [ok - y]';
  53   next;
  54   $y = 2;
  55  }
  56  is $x, 1,     'next 0 [end - x]';
  57  is $y, undef, 'next 0 [end - y]';
  58 }
  59
  60 {
  61  local $x = 1;
  62 LOOP:
  63  {
  64   local $x = 2;
  65   local $y = 0;
  66   {
  67    local $x = 3;
  68    localize '$y' => 1 => UP;
  69    is $x, 3, 'next 1 [ok - x]';
  70    is $y, 0, 'next 1 [ok - y]';
  71    next LOOP;
  72    $y = 3;
  73   }
  74   $y = 2;
  75  }
  76  is $x, 1,     'next 1 [end - x]';
  77  is $y, undef, 'next 1 [end - y]';
  78 }
  79
  80 {
  81  local $x = 1;
  82  {
  83   local $x = 2;
  84   {
  85    localize '$y' => 1 => UP UP;
  86   }
  87   is $x, 2,     'goto 1 [not yet - x]';
  88   is $y, undef, 'goto 1 [not yet - y]';
  89   {
  90    local $x = 3;
  91    goto OVER1;
  92   }
  93  }
  94  $y = 0;
  95 OVER1:
  96  is $x, 1, 'goto 1 [ok - x]';
  97  is $y, 1, 'goto 1 [ok - y]';
  98 }
  99
 100 $y = undef;
 101 {
 102  local $x = 1;
 103  {
 104   local $x = 2;
 105   {
 106    local $x = 3;
 107    {
 108     localize '$y' => 1 => UP UP UP;
 109    }
 110    is $x, 3,     'goto 2 [not yet - x]';
 111    is $y, undef, 'goto 2 [not yet - y]';
 112    {
 113     local $x = 4;
 114     goto OVER2;
 115    }
 116   }
 117  }
 118  $y = 0;
 119 OVER2:
 120  is $x, 1, 'goto 2 [ok - x]';
 121  is $y, 1, 'goto 2 [ok - y]';
 122 }
 123
 124 $y = undef;
 125 {
 126  local $x = 1;
 127  {
 128   eval {
 129    local $x = 2;
 130    {
 131     {
 132      local $x = 3;
 133      localize '$y' => 1 => UP UP UP UP;
 134      is $x, 3,     'die - localize outside eval [not yet 1 - x]';
 135      is $y, undef, 'die - localize outside eval [not yet 1 - y]';
 136     }
 137     is $x, 2,     'die - localize outside eval [not yet 2 - x]';
 138     is $y, undef, 'die - localize outside eval [not yet 2 - y]';
 139     die;
 140    }
 141   };
 142   is $x, 1,     'die - localize outside eval [not yet 3 - x]';
 143   is $y, undef, 'die - localize outside eval [not yet 3 - y]';
 144  } # should trigger here
 145  is $x, 1, 'die - localize outside eval [ok - x]';
 146  is $y, 1, 'die - localize outside eval [ok - y]';
 147 }
 148
 149 $y = undef;
 150 {
 151  local $x = 1;
 152  eval {
 153   local $x = 2;
 154   {
 155    {
 156     local $x = 3;
 157     localize '$y' => 1 => UP UP UP;
 158     is $x, 3,     'die - localize at eval [not yet 1 - x]';
 159     is $y, undef, 'die - localize at eval [not yet 1 - y]';
 160    }
 161    is $x, 2,     'die - localize at eval [not yet 2 - x]';
 162    is $y, undef, 'die - localize at eval [not yet 2 - y]';
 163    die;
 164   }
 165  }; # should trigger here
 166  is $x, 1, 'die - localize at eval [ok - x]';
 167  is $y, 1, 'die - localize at eval [ok - y]';
 168 }
 169
 170 $y = undef;
 171 {
 172  local $x = 1;
 173  eval {
 174   local $x = 2;
 175   {
 176    {
 177     local $x = 3;
 178     localize '$y' => 1 => UP UP;
 179     is $x, 3,     'die - localize inside eval [not yet 1 - x]';
 180     is $y, undef, 'die - localize inside eval [not yet 1 - y]';
 181    }
 182    is $x, 2,     'die - localize inside eval [not yet 2 - x]';
 183    is $y, undef, 'die - localize inside eval [not yet 2 - y]';
 184    die;
 185   } # should trigger here
 186  };
 187  is $x, 1,     'die - localize inside eval [ok - x]';
 188  is $y, undef, 'die - localize inside eval [ok - y]';
 189 }
 190
 191 SKIP:
 192 {
 193  skip 'Perl 5.10 required to test given/when' => 30 if "$]" < 5.010;
 194
 195  eval <<' GIVEN_TEST_1';
 196   BEGIN {
 197    if ("$]" >= 5.017_011) {
 198     require warnings;
 199     warnings->unimport('experimental::smartmatch');
 200    }
 201   }
 202   use feature 'switch';
 203   local $y;
 204   {
 205    local $x = 1;
 206    given (1) {
 207     local $x = 2;
 208     when (1) {
 209      local $x = 3;
 210      localize '$y' => 1 => UP UP;
 211      is $x, 3,     'given/when - localize at given [not yet - x]';
 212      is $y, undef, 'given/when - localize at given [not yet - y]';
 213     }
 214     fail 'not reached';
 215    }
 216    is $x, 1, 'given/when - localize at given [ok - x]';
 217    is $y, 1, 'given/when - localize at given [ok - y]';
 218   }
 219  GIVEN_TEST_1
 220  fail $@ if $@;
 221
 222  eval <<' GIVEN_TEST_2';
 223   BEGIN {
 224    if ("$]" >= 5.017_011) {
 225     require warnings;
 226     warnings->unimport('experimental::smartmatch');
 227    }
 228   }
 229   use feature 'switch';
 230   local $y;
 231   {
 232    local $x = 1;
 233    given (1) {
 234     local $x = 2;
 235     when (1) {
 236      local $x = 3;
 237      localize '$y' => 1 => UP UP;
 238      is $x, 3,     'given/when/continue - localize at given [not yet 1 - x]';
 239      is $y, undef, 'given/when/continue - localize at given [not yet 1 - y]';
 240      continue;
 241     }
 242     is $x, 2,     'given/when/continue - localize at given [not yet 2 - x]';
 243     is $y, undef, 'given/when/continue - localize at given [not yet 2 - y]';
 244    }
 245    is $x, 1, 'given/when/continue - localize at given [ok - x]';
 246    is $y, 1, 'given/when/continue - localize at given [ok - y]';
 247   }
 248  GIVEN_TEST_2
 249  fail $@ if $@;
 250
 251  eval <<' GIVEN_TEST_3';
 252   BEGIN {
 253    if ("$]" >= 5.017_011) {
 254     require warnings;
 255     warnings->unimport('experimental::smartmatch');
 256    }
 257   }
 258   use feature 'switch';
 259   local $y;
 260   {
 261    local $x = 1;
 262    given (1) {
 263     local $x = 2;
 264     default {
 265      local $x = 3;
 266      localize '$y' => 1 => UP UP;
 267      is $x, 3,     'given/default - localize at given [not yet - x]';
 268      is $y, undef, 'given/default - localize at given [not yet - y]';
 269     }
 270     fail 'not reached';
 271    }
 272    is $x, 1, 'given/default - localize at given [ok - x]';
 273    is $y, 1, 'given/default - localize at given [ok - y]';
 274   }
 275  GIVEN_TEST_3
 276  fail $@ if $@;
 277
 278  eval <<' GIVEN_TEST_4';
 279   BEGIN {
 280    if ("$]" >= 5.017_011) {
 281     require warnings;
 282     warnings->unimport('experimental::smartmatch');
 283    }
 284   }
 285   use feature 'switch';
 286   local $y;
 287   {
 288    local $x = 1;
 289    given (1) {
 290     local $x = 2;
 291     default {
 292      local $x = 3;
 293      localize '$y' => 1 => UP UP;
 294      is $x, 3,     'given/default/continue - localize at given [not yet 1 - x]';
 295      is $y, undef, 'given/default/continue - localize at given [not yet 1 - y]';
 296      continue;
 297     }
 298     is $x, 2,     'given/default/continue - localize at given [not yet 2 - x]';
 299     is $y, undef, 'given/default/continue - localize at given [not yet 2 - y]';
 300    }
 301    is $x, 1, 'given/default/continue - localize at given [ok - x]';
 302    is $y, 1, 'given/default/continue - localize at given [ok - y]';
 303   }
 304  GIVEN_TEST_4
 305  fail $@ if $@;
 306
 307  eval <<' GIVEN_TEST_5';
 308   BEGIN {
 309    if ("$]" >= 5.017_011) {
 310     require warnings;
 311     warnings->unimport('experimental::smartmatch');
 312    }
 313   }
 314   use feature 'switch';
 315   local $y;
 316   {
 317    local $x = 1;
 318    given (1) {
 319     local $x = 2;
 320     default {
 321      local $x = 3;
 322      given (2) {
 323       local $x = 4;
 324       when (2) {
 325        local $x = 5;
 326        localize '$y' => 1 => UP UP UP;
 327        is $x, 5,     'given/default/given/when - localize at default [not yet 1 - x]';
 328        is $y, undef, 'given/default/given/when - localize at default [not yet 1 - y]';
 329        continue;
 330       }
 331       is $x, 4,     'given/default/given/when - localize at default [not yet 2 - x]';
 332       is $y, undef, 'given/default/given/when - localize at default [not yet 2 - y]';
 333      }
 334      is $x, 3,     'given/default/given/when - localize at default [not yet 3 - x]';
 335      is $y, undef, 'given/default/given/when - localize at default [not yet 3 - y]';
 336      continue;
 337     }
 338     is $x, 2, 'given/default/given/when - localize at default [ok 1 - x]';
 339     is $y, 1, 'given/default/given/when - localize at default [ok 1 - y]';
 340    }
 341    is $x, 1,     'given/default/given/when - localize at default [ok 2 - x]';
 342    is $y, undef, 'given/default/given/when - localize at default [ok 2 - y]';
 343   }
 344  GIVEN_TEST_5
 345  fail $@ if $@;
 346 }