6 use Test::More tests => 9 + 4 * 7 + 3 + ((5 * 4 * 4) * 3 + 1) + 2 + 6;
8 use Scope::Upper qw<uplevel HERE>;
13 uplevel { pass 'no @_: callback' };
14 is_deeply \@_, [ 'dummy' ], 'no @_: @_ outside';
18 uplevel { is_deeply \@_, [ ], "no arguments, no context" }
22 uplevel { is_deeply \@_, [ ], "no arguments, with context" } HERE
26 uplevel { is_deeply \@_, [ 1 ], "one const argument" } 1, HERE
31 uplevel { is_deeply \@_, [ 2 ], "one lexical argument" } $x, HERE
36 uplevel { is_deeply \@_, [ 3 ], "one global argument" } $y, HERE
40 uplevel { is_deeply \@_, [ 4, 5 ], "two const arguments" } 4, 5, HERE
44 uplevel { is_deeply \@_, [ 1 .. 10 ], "ten const arguments" } 1 .. 10, HERE
53 is $r, 1, 'shift: result';
54 is_deeply \@_, [ 2 .. 10 ], 'shift: @_ inside';
56 is_deeply \@args, [ 1 .. 10 ], 'shift: args';
57 is_deeply \@_, [ 'dummy' ], 'shift: @_ outside';
64 is $r, 10, 'pop: result';
65 is_deeply \@_, [ 1 .. 9 ], 'pop: @_ inside';
67 is_deeply \@args, [ 1 .. 10 ], 'pop: args';
68 is_deeply \@_, [ 'dummy' ], 'pop: @_ outside';
74 my $r = unshift @_, 0;
75 is $r, 11, 'unshift: result';
76 is_deeply \@_, [ 0 .. 10 ], 'unshift: @_ inside';
78 is_deeply \@args, [ 1 .. 10 ], 'unshift: args';
79 is_deeply \@_, [ 'dummy' ], 'unshift: @_ outside';
86 is $r, 11, 'push: result';
87 is_deeply \@_, [ 1 .. 11 ], 'push: @_ inside';
89 is_deeply \@args, [ 1 .. 10 ], 'push: args';
90 is_deeply \@_, [ 'dummy' ], 'push: @_ outside';
96 my ($r) = splice @_, 4, 1;
97 is $r, 5, 'splice: result';
98 is_deeply \@_, [ 1 .. 4, 6 .. 10 ], 'splice: @_ inside';
100 is_deeply \@args, [ 1 .. 10 ], 'splice: args';
101 is_deeply \@_, [ 'dummy' ], 'splice: @_ outside';
105 my @args = (1 .. 10);
107 my ($r, $s, $t, @rest) = @_;
108 is_deeply [ $r, $s, $t, \@rest ], [ 1 .. 3, [ 4 .. 10 ] ], 'unpack 1: result';
109 is_deeply \@_, [ 1 .. 10 ], 'unpack 1: @_ inside';
111 is_deeply \@args, [ 1 .. 10 ], 'unpack 1: args';
112 is_deeply \@_, [ 'dummy' ], 'unpack 1: @_ outside';
118 my ($r, $s, $t, @rest) = @_;
119 is_deeply [ $r, $s, $t, \@rest ], [ 1, 2, undef, [ ] ], 'unpack 2: result';
120 is_deeply \@_, [ 1, 2 ], 'unpack 2: @_ inside';
122 is_deeply \@args, [ 1, 2 ], 'unpack 2: args';
123 is_deeply \@_, [ 'dummy' ], 'unpack 2: @_ outside';
133 is $s, 'xyz', 'aliasing, one layer';
142 is $_[0], 'xyz', 'aliasing, two layers 1';
144 is $s, 'xyz', 'aliasing, two layers 2';
151 my $cb = sub { fail "should not be executed" };
153 eval { sub { uplevel { goto $cb } HERE }->() };
154 like $@, qr/^Can't goto to an uplevel'd stack frame on perl 5\.6/,
156 skip "goto to an uplevel'd stack frame does not work on perl 5\.6"
157 => ((5 * 4 * 4) * 3 + 1) - 1;
163 [ [ 'b' ], [ 'n' ] ],
164 [ [ 'c' ], [ 'o', 'p' ] ],
165 [ [ 'd', 'e' ], [ 'q' ] ],
168 for my $args (@args) {
169 my ($out, $in) = @$args;
174 for my $reify_out (0, 1) {
175 for my $reify_in (0, 1) {
178 my $base_test = sub {
180 is_deeply \@_, $in, "$desc: \@_ inside";
182 is "@_", "@in", "$desc: \@_ inside";
186 my $goto_test = sub { goto $base_test };
187 my $uplevel_test = sub { &uplevel($base_test, @_, HERE) };
188 my $goto_uplevel_test = sub { &uplevel($goto_test, @_, HERE) };
191 [ 'goto' => sub { goto $base_test } ],
192 [ 'goto in goto' => sub { goto $goto_test } ],
193 [ 'uplevel in goto' => sub { goto $uplevel_test } ],
194 [ 'goto in uplevel in goto' => sub { goto $goto_uplevel_test } ],
197 for my $test (@tests) {
198 ($desc, my $cb) = @$test;
199 $desc .= ' (' . @out . ' out, ' . @in . ' in';
200 $desc .= ', reify out' if $reify_out;
201 $desc .= ', reify in' if $reify_in;
207 &uplevel($cb, @in, HERE);
209 is_deeply \@_, $out, "$desc: \@_ outside";
211 is "@_", "@out", "$desc: \@_ outside";
215 is $@, '', "$desc: no error";
231 is $s, 'brutus', 'aliasing and goto';
238 package Scope::Upper::TestMagic;
241 my ($class, $cb) = @_;
242 bless { cb => $cb }, $class;
245 sub FETCH { $_[0]->{cb}->(@_) }
247 sub STORE { die "Read only magic scalar" }
250 tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
252 uplevel { is_deeply \@_, [ $$ ], "one magical argument" } $mg, HERE
255 tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
257 uplevel { is_deeply \@_, [ $$ ], "one double magical argument" } $mg2, HERE
263 package Scope::Upper::TestTimelyDestruction;
266 my ($class, $flag) = @_;
268 bless { flag => $flag }, $class;
277 skip 'This fails even with a plain subroutine call on 5.8.0' => 6
282 my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
283 is $destroyed, 0, 'destruction: not yet 1';
285 is $destroyed, 0, 'destruction: not yet 2';
287 is $destroyed, 0, 'destruction: not yet 3';
289 is $destroyed, 0, 'destruction: not yet 4';
291 is $destroyed, 0, 'destruction: not yet 5';
293 is $destroyed, 1, 'destruction: destroyed';