]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/61-uplevel-args.t
a1a72fd0498f01089a4e5af93e86a7ff03c00344
[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 {
151  my @args = (
152   [ [ ],          [ 'm' ]      ],
153   [ [ 'a' ],      [ ]          ],
154   [ [ 'b' ],      [ 'n' ]      ],
155   [ [ 'c' ],      [ 'o', 'p' ] ],
156   [ [ 'd', 'e' ], [ 'q' ]      ],
157  );
158
159  for my $args (@args) {
160   my ($out, $in) = @$args;
161
162   my @out  = @$out;
163   my @in   = @$in;
164
165   for my $reify_out (0, 1) {
166    for my $reify_in (0, 1) {
167     my $desc;
168
169     my $base_test = sub {
170      if ($reify_in) {
171       is_deeply \@_, $in, "$desc: \@_ inside";
172      } else {
173       is "@_", "@in", "$desc: \@_ inside";
174      }
175     };
176
177     my $goto_test         = sub { goto $base_test };
178     my $uplevel_test      = sub { &uplevel($base_test, @_, HERE) };
179     my $goto_uplevel_test = sub { &uplevel($goto_test, @_, HERE) };
180
181     my @tests = (
182      [ 'goto'                    => sub { goto $base_test }         ],
183      [ 'goto in goto'            => sub { goto $goto_test }         ],
184      [ 'uplevel in goto'         => sub { goto $uplevel_test }      ],
185      [ 'goto in uplevel in goto' => sub { goto $goto_uplevel_test } ],
186     );
187
188     for my $test (@tests) {
189      ($desc, my $cb) = @$test;
190      $desc .= ' (' . @out . ' out, ' . @in . ' in';
191      $desc .= ', reify out' if $reify_out;
192      $desc .= ', reify in'  if $reify_in;
193      $desc .= ')';
194
195      local $@;
196      eval {
197       sub {
198        &uplevel($cb, @in, HERE);
199        if ($reify_out) {
200         is_deeply \@_, $out, "$desc: \@_ outside";
201        } else {
202         is "@_", "@out", "$desc: \@_ outside";
203        }
204       }->(@out);
205      };
206      is $@, '', "$desc: no error";
207     }
208    }
209   }
210  }
211
212  sub {
213   my $s  = 'caesar';
214   my $cb = sub {
215    $_[0] = 'brutus';
216   };
217   sub {
218    uplevel {
219     goto $cb;
220    } $_[0], HERE;
221   }->($s);
222   is $s, 'brutus', 'aliasing and goto';
223  }->('dummy');
224 }
225
226 # goto XS
227
228 {
229  my $desc = 'uplevel() calling goto &uplevel';
230  local $@;
231  eval {
232   sub {
233    my $outer_cxt = HERE;
234    sub {
235     my $inner_cxt = HERE;
236     sub {
237      uplevel {
238       is HERE, $inner_cxt, "$desc: context inside first uplevel";
239       is "@_", '1 2 3',    "$desc: arguments inisde first uplevel";
240       unshift @_, 0;
241       push    @_, 4;
242       unshift @_, sub {
243        is HERE, $outer_cxt,  "$desc: context inside second uplevel";
244        is "@_", '0 1 2 3 4', "$desc: arguments inisde second uplevel";
245       };
246       push @_, UP;
247       goto \&uplevel;
248      } 1 .. 3 => UP;
249     }->();
250    }->();
251   }->();
252  };
253  is $@, '', "$desc: no error";
254 }
255
256 # uplevel() to uplevel()
257
258 {
259  my $desc = '\&uplevel as the uplevel() callback';
260  local $@;
261  eval {
262   sub {
263    my $cxt = HERE;
264    sub {
265     sub {
266      # Note that an XS call does not need a context, so after the first uplevel
267      # call UP will point to the scope above the first target.
268      uplevel(\&uplevel => (sub {
269       is "@_", '1 2 3', "$desc: arguments inisde";
270       is HERE, $cxt,    "$desc: context inside";
271      } => 1 .. 3 => UP) => UP);
272     }->(10 .. 19);
273    }->(sub { die 'wut' } => HERE);
274   }->('dummy');
275  };
276  is $@, '', "$desc: no error";
277 }
278
279 # Magic
280
281 {
282  package Scope::Upper::TestMagic;
283
284  sub TIESCALAR {
285   my ($class, $cb) = @_;
286   bless { cb => $cb }, $class;
287  }
288
289  sub FETCH { $_[0]->{cb}->(@_) }
290
291  sub STORE { die "Read only magic scalar" }
292 }
293
294 tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
295 sub {
296  uplevel { is_deeply \@_, [ $$ ], "one magical argument" } $mg, HERE
297 }->('dummy');
298
299 tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
300 sub {
301  uplevel { is_deeply \@_, [ $$ ], "one double magical argument" } $mg2, HERE
302 }->('dummy');
303
304 # Destruction
305
306 {
307  package Scope::Upper::TestTimelyDestruction;
308
309  sub new {
310   my ($class, $flag) = @_;
311   $$flag = 0;
312   bless { flag => $flag }, $class;
313  }
314
315  sub DESTROY {
316   ${$_[0]->{flag}}++;
317  }
318 }
319
320 SKIP: {
321  skip 'This fails even with a plain subroutine call on 5.8.0' => 6
322                                                                if "$]" <= 5.008;
323
324  my $destroyed;
325  {
326   my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
327   is $destroyed, 0, 'destruction: not yet 1';
328   sub {
329    is $destroyed, 0, 'destruction: not yet 2';
330    uplevel {
331     is $destroyed, 0, 'destruction: not yet 3';
332    } $z, HERE;
333    is $destroyed, 0, 'destruction: not yet 4';
334   }->('dummy');
335   is $destroyed, 0, 'destruction: not yet 5';
336  }
337  is $destroyed, 1, 'destruction: destroyed';
338 }