6 use Test::More tests => 4 * 3 + 1 + 3 + 7;
11 use Scope::Upper qw<yield leave HERE UP SUB>;
13 # Test timely destruction of values returned from yield()
16 sub guard { VPIT::TestHelpers::Guard->new(sub { ++$destroyed }) }
19 my $desc = 'scalar context, above';
24 is $destroyed, undef, "$desc: not yet destroyed 1";
28 is $destroyed, undef, "$desc: not yet destroyed 2";
30 is $destroyed, 1, "$desc: destroyed 1";
34 my $desc = 'scalar context, below';
39 is $destroyed, undef, "$desc: not yet destroyed 1";
43 is $destroyed, undef, "$desc: not yet destroyed 2";
45 is $destroyed, 1, "$desc: destroyed 1";
49 my $desc = 'void context, above';
54 is $destroyed, undef, "$desc: not yet destroyed 1";
58 is $destroyed, undef, "$desc: not yet destroyed 2";
60 is $destroyed, 1, "$desc: destroyed 1";
64 my $desc = 'void context, below';
68 is $destroyed, undef, "$desc: not yet destroyed 1";
73 is $destroyed, 1, "$desc: destroyed 1";
75 is $destroyed, 1, "$desc: destroyed 2";
78 # Test 'return from do' in special cases
84 my $thing = (777, do {
85 my @stuff = (888, do {
87 map { my $x; $_ x 3 } qw<x y z>
103 is "@res", '1 2 3 4', 'yield() found the op to return to';
113 is "@res", '1 2', 'leave without arguments';
121 is "@res", '1 2 3 4', 'leave with arguments';
125 skip '"eval { $str =~ s/./die q[foo]/e }" breaks havoc on perl 5.8 and below'
126 => 1 if "$]" < 5.010;
130 $s =~ s/./leave; die 'not reached'/e;
133 my $line = __LINE__-3;
135 qr/^leave\(\) can't target a substitution context at \Q$0\E line $line/,
136 'leave() cannot exit subst';
143 package Scope::Upper::TestTimelyDestruction;
146 my ($class, $label) = @_;
147 bless { label => $label }, $class;
150 sub label { $_[0]->{label} }
153 push @destroyed, $_[0]->label;
157 sub SU_TTD () { 'Scope::Upper::TestTimelyDestruction' }
160 my $r = SU_TTD->new('a');
161 my @x = (SU_TTD->new('c'), SU_TTD->new('d'));
162 yield 123, $r, SU_TTD->new('b'), @x, sub { SU_TTD->new('e') }->() => UP SUB;
171 my $desc = sub { "yielding @_ across a sub" };
173 is $res[0], 123, $desc->('a constant literal');
174 is $res[1]->label, 'a', $desc->('a lexical');
175 is $res[2]->label, 'b', $desc->('a temporary object');
176 is $res[3]->label, 'c', $desc->('the contents of a lexical array (1)');
177 is $res[4]->label, 'd', $desc->('the contents of a lexical array (2)');
178 is $res[5]->label, 'e', $desc->('a temporary object returned by a sub');
181 is_deeply \@destroyed, [ qw<e d c b a> ],
182 'all these objects were properly destroyed';