]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/61-uplevel-args.t
Require Module::ExtractUse 0.24 for the Kwalitee test
[perl/modules/Scope-Upper.git] / t / 61-uplevel-args.t
1 #!perl -T
2
3 use strict;
4 use warnings;
5
6 use Test::More tests => 9 + 4 * 7 + 3 + ((5 * 4 * 4) * 3 + 1) + 5 + 3 + 2 + 6;
7
8 use Scope::Upper qw<uplevel HERE UP>;
9
10 # Basic
11
12 sub {
13  uplevel { pass 'no @_: callback' };
14  is "@_", 'dummy', 'no @_: @_ outside';
15 }->('dummy');
16
17 sub {
18  uplevel { is "@_", '', "no arguments, no context" }
19 }->('dummy');
20
21 sub {
22  uplevel { is "@_", '', "no arguments, with context" } HERE
23 }->('dummy');
24
25 sub {
26  uplevel { is "@_", '1', "one const argument" } 1, HERE
27 }->('dummy');
28
29 my $x = 2;
30 sub {
31  uplevel { is "@_", '2', "one lexical argument" } $x, HERE
32 }->('dummy');
33
34 our $y = 3;
35 sub {
36  uplevel { is "@_", '3', "one global argument" } $y, HERE
37 }->('dummy');
38
39 sub {
40  uplevel { is "@_", '4 5', "two const arguments" } 4, 5, HERE
41 }->('dummy');
42
43 sub {
44  uplevel { is "@_", '1 2 3 4 5 6 7 8 9 10', "ten const arguments" }
45          1 .. 10 => HERE;
46 }->('dummy');
47
48 # Reification of @_
49
50 sub {
51  my @args = (1 .. 10);
52  uplevel {
53   my $r = shift;
54   is        $r,  1,           'shift: result';
55   is_deeply \@_, [ 2 .. 10 ], 'shift: @_ inside';
56  } @args, HERE;
57  is_deeply \@args, [ 1 .. 10 ], 'shift: args';
58  is_deeply \@_,    [ 'dummy' ], 'shift: @_ outside';
59 }->('dummy');
60
61 sub {
62  my @args = (1 .. 10);
63  uplevel {
64   my $r = pop;
65   is        $r,  10,         'pop: result';
66   is_deeply \@_, [ 1 .. 9 ], 'pop: @_ inside';
67  } @args, HERE;
68  is_deeply \@args, [ 1 .. 10 ], 'pop: args';
69  is_deeply \@_,    [ 'dummy' ], 'pop: @_ outside';
70 }->('dummy');
71
72 sub {
73  my @args = (1 .. 10);
74  uplevel {
75   my $r = unshift @_, 0;
76   is        $r,  11,          'unshift: result';
77   is_deeply \@_, [ 0 .. 10 ], 'unshift: @_ inside';
78  } @args, HERE;
79  is_deeply \@args, [ 1 .. 10 ], 'unshift: args';
80  is_deeply \@_,    [ 'dummy' ], 'unshift: @_ outside';
81 }->('dummy');
82
83 sub {
84  my @args = (1 .. 10);
85  uplevel {
86   my $r = push @_, 11;
87   is        $r,  11,          'push: result';
88   is_deeply \@_, [ 1 .. 11 ], 'push: @_ inside';
89  } @args, HERE;
90  is_deeply \@args, [ 1 .. 10 ], 'push: args';
91  is_deeply \@_,    [ 'dummy' ], 'push: @_ outside';
92 }->('dummy');
93
94 sub {
95  my @args = (1 .. 10);
96  uplevel {
97   my ($r) = splice @_, 4, 1;
98   is        $r,  5,                   'splice: result';
99   is_deeply \@_, [ 1 .. 4, 6 .. 10 ], 'splice: @_ inside';
100  } @args, HERE;
101  is_deeply \@args, [ 1 .. 10 ], 'splice: args';
102  is_deeply \@_,    [ 'dummy' ], 'splice: @_ outside';
103 }->('dummy');
104
105 sub {
106  my @args = (1 .. 10);
107  uplevel {
108   my ($r, $s, $t, @rest) = @_;
109   is_deeply [ $r, $s, $t, \@rest ], [ 1 .. 3, [ 4 .. 10 ] ], 'unpack 1: result';
110   is_deeply \@_, [ 1 .. 10 ],                             'unpack 1: @_ inside';
111  } @args, HERE;
112  is_deeply \@args, [ 1 .. 10 ], 'unpack 1: args';
113  is_deeply \@_,    [ 'dummy' ], 'unpack 1: @_ outside';
114 }->('dummy');
115
116 sub {
117  my @args = (1, 2);
118  uplevel {
119   my ($r, $s, $t, @rest) = @_;
120   is_deeply [ $r, $s, $t, \@rest ], [ 1, 2, undef, [ ] ], 'unpack 2: result';
121   is_deeply \@_, [ 1, 2 ],                                'unpack 2: @_ inside';
122  } @args, HERE;
123  is_deeply \@args, [ 1, 2 ],    'unpack 2: args';
124  is_deeply \@_,    [ 'dummy' ], 'unpack 2: @_ outside';
125 }->('dummy');
126
127 # Aliasing
128
129 sub {
130  my $s = 'abc';
131  uplevel {
132   $_[0] = 'xyz';
133  } $s, HERE;
134  is $s, 'xyz', 'aliasing, one layer';
135 }->('dummy');
136
137 sub {
138  my $s = 'abc';
139  sub {
140   uplevel {
141    $_[0] = 'xyz';
142   } $_[0], HERE;
143   is $_[0], 'xyz', 'aliasing, two layers 1';
144  }->($s);
145  is $s, 'xyz', 'aliasing, two layers 2';
146 }->('dummy');
147
148 # goto
149
150 SKIP: {
151  if ("$]" < 5.008) {
152   my $cb = sub { fail 'should not be executed' };
153   local $@;
154   eval { sub { uplevel { goto $cb } HERE }->() };
155   like $@, qr/^uplevel\(\) can't execute code that calls goto before perl 5\.8/,
156            'goto croaks';
157   skip "goto to an uplevel'd stack frame does not work on perl 5\.6"
158                                                    => ((5 * 4 * 4) * 3 + 1) - 1;
159  }
160
161  my @args = (
162   [ [ ],          [ 'm' ]      ],
163   [ [ 'a' ],      [ ]          ],
164   [ [ 'b' ],      [ 'n' ]      ],
165   [ [ 'c' ],      [ 'o', 'p' ] ],
166   [ [ 'd', 'e' ], [ 'q' ]      ],
167  );
168
169  for my $args (@args) {
170   my ($out, $in) = @$args;
171
172   my @out  = @$out;
173   my @in   = @$in;
174
175   for my $reify_out (0, 1) {
176    for my $reify_in (0, 1) {
177     my $desc;
178
179     my $base_test = sub {
180      if ($reify_in) {
181       is_deeply \@_, $in, "$desc: \@_ inside";
182      } else {
183       is "@_", "@in", "$desc: \@_ inside";
184      }
185     };
186
187     my $goto_test         = sub { goto $base_test };
188     my $uplevel_test      = sub { &uplevel($base_test, @_, HERE) };
189     my $goto_uplevel_test = sub { &uplevel($goto_test, @_, HERE) };
190
191     my @tests = (
192      [ 'goto'                    => sub { goto $base_test }         ],
193      [ 'goto in goto'            => sub { goto $goto_test }         ],
194      [ 'uplevel in goto'         => sub { goto $uplevel_test }      ],
195      [ 'goto in uplevel in goto' => sub { goto $goto_uplevel_test } ],
196     );
197
198     for my $test (@tests) {
199      ($desc, my $cb) = @$test;
200      $desc .= ' (' . @out . ' out, ' . @in . ' in';
201      $desc .= ', reify out' if $reify_out;
202      $desc .= ', reify in'  if $reify_in;
203      $desc .= ')';
204
205      local $@;
206      eval {
207       sub {
208        &uplevel($cb, @in, HERE);
209        if ($reify_out) {
210         is_deeply \@_, $out, "$desc: \@_ outside";
211        } else {
212         is "@_", "@out", "$desc: \@_ outside";
213        }
214       }->(@out);
215      };
216      is $@, '', "$desc: no error";
217     }
218    }
219   }
220  }
221
222  sub {
223   my $s  = 'caesar';
224   my $cb = sub {
225    $_[0] = 'brutus';
226   };
227   sub {
228    uplevel {
229     goto $cb;
230    } $_[0], HERE;
231   }->($s);
232   is $s, 'brutus', 'aliasing and goto';
233  }->('dummy');
234 }
235
236 # goto XS
237
238 SKIP: {
239  skip "goto to an uplevel'd stack frame does not work on perl 5\.6" => 5
240                                                                 if "$]" < 5.008;
241
242  my $desc = 'uplevel() calling goto &uplevel';
243  local $@;
244  eval {
245   sub {
246    my $outer_cxt = HERE;
247    sub {
248     my $inner_cxt = HERE;
249     sub {
250      uplevel {
251       is HERE, $inner_cxt, "$desc: context inside first uplevel";
252       is "@_", '1 2 3',    "$desc: arguments inisde first uplevel";
253       unshift @_, 0;
254       push    @_, 4;
255       unshift @_, sub {
256        is HERE, $outer_cxt,  "$desc: context inside second uplevel";
257        is "@_", '0 1 2 3 4', "$desc: arguments inisde second uplevel";
258       };
259       push @_, UP;
260       goto \&uplevel;
261      } 1 .. 3 => UP;
262     }->();
263    }->();
264   }->();
265  };
266  is $@, '', "$desc: no error";
267 }
268
269 # uplevel() to uplevel()
270
271 {
272  my $desc = '\&uplevel as the uplevel() callback';
273  local $@;
274  eval {
275   sub {
276    my $cxt = HERE;
277    sub {
278     sub {
279      # Note that an XS call does not need a context, so after the first uplevel
280      # call UP will point to the scope above the first target.
281      uplevel(\&uplevel => (sub {
282       is "@_", '1 2 3', "$desc: arguments inisde";
283       is HERE, $cxt,    "$desc: context inside";
284      } => 1 .. 3 => UP) => UP);
285     }->(10 .. 19);
286    }->(sub { die 'wut' } => HERE);
287   }->('dummy');
288  };
289  is $@, '', "$desc: no error";
290 }
291
292 # Magic
293
294 {
295  package Scope::Upper::TestMagic;
296
297  sub TIESCALAR {
298   my ($class, $cb) = @_;
299   bless { cb => $cb }, $class;
300  }
301
302  sub FETCH { $_[0]->{cb}->(@_) }
303
304  sub STORE { die "Read only magic scalar" }
305 }
306
307 tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
308 sub {
309  uplevel { is_deeply \@_, [ $$ ], "one magical argument" } $mg, HERE
310 }->('dummy');
311
312 tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
313 sub {
314  uplevel { is_deeply \@_, [ $$ ], "one double magical argument" } $mg2, HERE
315 }->('dummy');
316
317 # Destruction
318
319 {
320  package Scope::Upper::TestTimelyDestruction;
321
322  sub new {
323   my ($class, $flag) = @_;
324   $$flag = 0;
325   bless { flag => $flag }, $class;
326  }
327
328  sub DESTROY {
329   ${$_[0]->{flag}}++;
330  }
331 }
332
333 SKIP: {
334  skip 'This fails even with a plain subroutine call on 5.8.0' => 6
335                                                                if "$]" <= 5.008;
336
337  my $destroyed;
338  {
339   my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
340   is $destroyed, 0, 'destruction: not yet 1';
341   sub {
342    is $destroyed, 0, 'destruction: not yet 2';
343    uplevel {
344     is $destroyed, 0, 'destruction: not yet 3';
345    } $z, HERE;
346    is $destroyed, 0, 'destruction: not yet 4';
347   }->('dummy');
348   is $destroyed, 0, 'destruction: not yet 5';
349  }
350  is $destroyed, 1, 'destruction: destroyed';
351 }