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   use feature 'switch';
 197   local $y;
 198   {
 199    local $x = 1;
 200    given (1) {
 201     local $x = 2;
 202     when (1) {
 203      local $x = 3;
 204      localize '$y' => 1 => UP UP;
 205      is $x, 3,     'given/when - localize at given [not yet - x]';
 206      is $y, undef, 'given/when - localize at given [not yet - y]';
 207     }
 208     fail 'not reached';
 209    }
 210    is $x, 1, 'given/when - localize at given [ok - x]';
 211    is $y, 1, 'given/when - localize at given [ok - y]';
 212   }
 213  GIVEN_TEST_1
 214  fail $@ if $@;
 215
 216  eval <<' GIVEN_TEST_2';
 217   use feature 'switch';
 218   local $y;
 219   {
 220    local $x = 1;
 221    given (1) {
 222     local $x = 2;
 223     when (1) {
 224      local $x = 3;
 225      localize '$y' => 1 => UP UP;
 226      is $x, 3,     'given/when/continue - localize at given [not yet 1 - x]';
 227      is $y, undef, 'given/when/continue - localize at given [not yet 1 - y]';
 228      continue;
 229     }
 230     is $x, 2,     'given/when/continue - localize at given [not yet 2 - x]';
 231     is $y, undef, 'given/when/continue - localize at given [not yet 2 - y]';
 232    }
 233    is $x, 1, 'given/when/continue - localize at given [ok - x]';
 234    is $y, 1, 'given/when/continue - localize at given [ok - y]';
 235   }
 236  GIVEN_TEST_2
 237  fail $@ if $@;
 238
 239  eval <<' GIVEN_TEST_3';
 240   use feature 'switch';
 241   local $y;
 242   {
 243    local $x = 1;
 244    given (1) {
 245     local $x = 2;
 246     default {
 247      local $x = 3;
 248      localize '$y' => 1 => UP UP;
 249      is $x, 3,     'given/default - localize at given [not yet - x]';
 250      is $y, undef, 'given/default - localize at given [not yet - y]';
 251     }
 252     fail 'not reached';
 253    }
 254    is $x, 1, 'given/default - localize at given [ok - x]';
 255    is $y, 1, 'given/default - localize at given [ok - y]';
 256   }
 257  GIVEN_TEST_3
 258  fail $@ if $@;
 259
 260  eval <<' GIVEN_TEST_4';
 261   use feature 'switch';
 262   local $y;
 263   {
 264    local $x = 1;
 265    given (1) {
 266     local $x = 2;
 267     default {
 268      local $x = 3;
 269      localize '$y' => 1 => UP UP;
 270      is $x, 3,     'given/default/continue - localize at given [not yet 1 - x]';
 271      is $y, undef, 'given/default/continue - localize at given [not yet 1 - y]';
 272      continue;
 273     }
 274     is $x, 2,     'given/default/continue - localize at given [not yet 2 - x]';
 275     is $y, undef, 'given/default/continue - localize at given [not yet 2 - y]';
 276    }
 277    is $x, 1, 'given/default/continue - localize at given [ok - x]';
 278    is $y, 1, 'given/default/continue - localize at given [ok - y]';
 279   }
 280  GIVEN_TEST_4
 281  fail $@ if $@;
 282
 283  eval <<' GIVEN_TEST_5';
 284   use feature 'switch';
 285   local $y;
 286   {
 287    local $x = 1;
 288    given (1) {
 289     local $x = 2;
 290     default {
 291      local $x = 3;
 292      given (2) {
 293       local $x = 4;
 294       when (2) {
 295        local $x = 5;
 296        localize '$y' => 1 => UP UP UP;
 297        is $x, 5,     'given/default/given/when - localize at default [not yet 1 - x]';
 298        is $y, undef, 'given/default/given/when - localize at default [not yet 1 - y]';
 299        continue;
 300       }
 301       is $x, 4,     'given/default/given/when - localize at default [not yet 2 - x]';
 302       is $y, undef, 'given/default/given/when - localize at default [not yet 2 - y]';
 303      }
 304      is $x, 3,     'given/default/given/when - localize at default [not yet 3 - x]';
 305      is $y, undef, 'given/default/given/when - localize at default [not yet 3 - y]';
 306      continue;
 307     }
 308     is $x, 2, 'given/default/given/when - localize at default [ok 1 - x]';
 309     is $y, 1, 'given/default/given/when - localize at default [ok 1 - y]';
 310    }
 311    is $x, 1,     'given/default/given/when - localize at default [ok 2 - x]';
 312    is $y, undef, 'given/default/given/when - localize at default [ok 2 - y]';
 313   }
 314  GIVEN_TEST_5
 315  fail $@ if $@;
 316 }