]> git.vpit.fr Git - perl/modules/Scope-Upper.git/blob - t/61-uplevel-args.t
Create the renamed CV as a shallow copy of the original one
[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 + 2 + 6;
7
8 use Scope::Upper qw<uplevel HERE>;
9
10 # Basic
11
12 sub {
13  uplevel { pass 'no @_: callback' };
14  is_deeply \@_, [ 'dummy' ], 'no @_: @_ outside';
15 }->('dummy');
16
17 sub {
18  uplevel { is_deeply \@_, [ ], "no arguments, no context" }
19 }->('dummy');
20
21 sub {
22  uplevel { is_deeply \@_, [ ], "no arguments, with context" } HERE
23 }->('dummy');
24
25 sub {
26  uplevel { is_deeply \@_, [ 1 ], "one const argument" } 1, HERE
27 }->('dummy');
28
29 my $x = 2;
30 sub {
31  uplevel { is_deeply \@_, [ 2 ], "one lexical argument" } $x, HERE
32 }->('dummy');
33
34 our $y = 3;
35 sub {
36  uplevel { is_deeply \@_, [ 3 ], "one global argument" } $y, HERE
37 }->('dummy');
38
39 sub {
40  uplevel { is_deeply \@_, [ 4, 5 ], "two const arguments" } 4, 5, HERE
41 }->('dummy');
42
43 sub {
44  uplevel { is_deeply \@_, [ 1 .. 10 ], "ten const arguments" } 1 .. 10, HERE
45 }->('dummy');
46
47 # Reification of @_
48
49 sub {
50  my @args = (1 .. 10);
51  uplevel {
52   my $r = shift;
53   is        $r,  1,           'shift: result';
54   is_deeply \@_, [ 2 .. 10 ], 'shift: @_ inside';
55  } @args, HERE;
56  is_deeply \@args, [ 1 .. 10 ], 'shift: args';
57  is_deeply \@_,    [ 'dummy' ], 'shift: @_ outside';
58 }->('dummy');
59
60 sub {
61  my @args = (1 .. 10);
62  uplevel {
63   my $r = pop;
64   is        $r,  10,         'pop: result';
65   is_deeply \@_, [ 1 .. 9 ], 'pop: @_ inside';
66  } @args, HERE;
67  is_deeply \@args, [ 1 .. 10 ], 'pop: args';
68  is_deeply \@_,    [ 'dummy' ], 'pop: @_ outside';
69 }->('dummy');
70
71 sub {
72  my @args = (1 .. 10);
73  uplevel {
74   my $r = unshift @_, 0;
75   is        $r,  11,          'unshift: result';
76   is_deeply \@_, [ 0 .. 10 ], 'unshift: @_ inside';
77  } @args, HERE;
78  is_deeply \@args, [ 1 .. 10 ], 'unshift: args';
79  is_deeply \@_,    [ 'dummy' ], 'unshift: @_ outside';
80 }->('dummy');
81
82 sub {
83  my @args = (1 .. 10);
84  uplevel {
85   my $r = push @_, 11;
86   is        $r,  11,          'push: result';
87   is_deeply \@_, [ 1 .. 11 ], 'push: @_ inside';
88  } @args, HERE;
89  is_deeply \@args, [ 1 .. 10 ], 'push: args';
90  is_deeply \@_,    [ 'dummy' ], 'push: @_ outside';
91 }->('dummy');
92
93 sub {
94  my @args = (1 .. 10);
95  uplevel {
96   my ($r) = splice @_, 4, 1;
97   is        $r,  5,                   'splice: result';
98   is_deeply \@_, [ 1 .. 4, 6 .. 10 ], 'splice: @_ inside';
99  } @args, HERE;
100  is_deeply \@args, [ 1 .. 10 ], 'splice: args';
101  is_deeply \@_,    [ 'dummy' ], 'splice: @_ outside';
102 }->('dummy');
103
104 sub {
105  my @args = (1 .. 10);
106  uplevel {
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';
110  } @args, HERE;
111  is_deeply \@args, [ 1 .. 10 ], 'unpack 1: args';
112  is_deeply \@_,    [ 'dummy' ], 'unpack 1: @_ outside';
113 }->('dummy');
114
115 sub {
116  my @args = (1, 2);
117  uplevel {
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';
121  } @args, HERE;
122  is_deeply \@args, [ 1, 2 ],    'unpack 2: args';
123  is_deeply \@_,    [ 'dummy' ], 'unpack 2: @_ outside';
124 }->('dummy');
125
126 # Aliasing
127
128 sub {
129  my $s = 'abc';
130  uplevel {
131   $_[0] = 'xyz';
132  } $s, HERE;
133  is $s, 'xyz', 'aliasing, one layer';
134 }->('dummy');
135
136 sub {
137  my $s = 'abc';
138  sub {
139   uplevel {
140    $_[0] = 'xyz';
141   } $_[0], HERE;
142   is $_[0], 'xyz', 'aliasing, two layers 1';
143  }->($s);
144  is $s, 'xyz', 'aliasing, two layers 2';
145 }->('dummy');
146
147 # Magic
148
149 {
150  package Scope::Upper::TestMagic;
151
152  sub TIESCALAR {
153   my ($class, $cb) = @_;
154   bless { cb => $cb }, $class;
155  }
156
157  sub FETCH { $_[0]->{cb}->(@_) }
158
159  sub STORE { die "Read only magic scalar" }
160 }
161
162 tie my $mg, 'Scope::Upper::TestMagic', sub { $$ };
163 sub {
164  uplevel { is_deeply \@_, [ $$ ], "one magical argument" } $mg, HERE
165 }->('dummy');
166
167 tie my $mg2, 'Scope::Upper::TestMagic', sub { $mg };
168 sub {
169  uplevel { is_deeply \@_, [ $$ ], "one double magical argument" } $mg2, HERE
170 }->('dummy');
171
172 # Destruction
173
174 {
175  package Scope::Upper::TestTimelyDestruction;
176
177  sub new {
178   my ($class, $flag) = @_;
179   $$flag = 0;
180   bless { flag => $flag }, $class;
181  }
182
183  sub DESTROY {
184   ${$_[0]->{flag}}++;
185  }
186 }
187
188 SKIP: {
189  skip 'This fails even with a plain subroutine call on 5.8.0' => 6
190                                                                if "$]" <= 5.008;
191
192  my $destroyed;
193  {
194   my $z = Scope::Upper::TestTimelyDestruction->new(\$destroyed);
195   is $destroyed, 0, 'destruction: not yet 1';
196   sub {
197    is $destroyed, 0, 'destruction: not yet 2';
198    uplevel {
199     is $destroyed, 0, 'destruction: not yet 3';
200    } $z, HERE;
201    is $destroyed, 0, 'destruction: not yet 4';
202   }->('dummy');
203   is $destroyed, 0, 'destruction: not yet 5';
204  }
205  is $destroyed, 1, 'destruction: destroyed';
206 }