]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/23-localize-ctl.t
Require Module::ExtractUse 0.24 for the Kwalitee test
[perl/modules/Scope-Upper.git] / 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 }