3 # Test the various op trees that turn sub () { ... } into a constant, and
4 # some variants that don’t.
13 # @tests is an array of hash refs, each of which can have various keys:
15 # nickname - name of the sub to use in test names
16 # generator - a sub returning a code ref to test
17 # finally - sub to run after the other tests
19 # Each of the following gives expected test results. If the key is
20 # omitted, the test is skipped:
22 # retval - the returned code ref’s return value
23 # same_retval - whether the same scalar is returned each time
24 # inlinable - whether the sub is inlinable
25 # deprecated - whether the sub returning a code ref will emit a depreca-
26 # tion warning when called
27 # method - whether the sub has the :method attribute
29 # [perl #63540] Don’t treat sub { if(){.....}; "constant" } as a constant
30 sub blonk { ++$blonk_was_called }
32 nickname => 'sub with null+kids (if-block), then constant',
34 # This used to turn into a constant with the value of $x
36 sub() { if($x){ () = "tralala"; blonk() }; 0 }
43 finally => sub { ok($blonk_was_called, 'RT #63540'); },
48 nickname => 'sub with simple lexical modified elsewhere',
49 generator => sub { my $x = 5; my $ret = sub(){$x}; $x = 7; $ret },
50 retval => 5, # change to 7 when the deprecation cycle is over
58 nickname => 'sub with simple lexical unmodified elsewhere',
59 generator => sub { my $x = 5; sub(){$x} },
68 nickname => 'return $variable modified elsewhere',
69 generator => sub { my $x=5; my $ret = sub(){return $x}; $x = 7; $ret },
78 nickname => 'return $variable unmodified elsewhere',
79 generator => sub { my $x = 5; sub(){return $x} },
88 nickname => 'sub () { 0; $x } with $x modified elsewhere',
89 generator => sub { my $x = 5; my $ret = sub(){0;$x}; $x = 8; $ret },
98 nickname => 'sub () { 0; $x } with $x unmodified elsewhere',
99 generator => sub { my $x = 5; my $y = $x; sub(){0;$x} },
107 # Explicit return after optimised statement, not at end of sub
109 nickname => 'sub () { 0; return $x; ... }',
110 generator => sub { my $x = 5; sub () { 0; return $x; ... } },
118 use feature 'state', 'lexical_subs';
119 no warnings 'experimental::lexical_subs';
122 nickname => 'sub () { my $x; state sub z { $x } $outer }',
125 sub () { my $x; state sub z { $x } $outer }
135 nickname => 'sub:method with simple lexical',
136 generator => sub { my $y; sub():method{$y} },
145 use feature 'refaliasing';
146 no warnings 'experimental::refaliasing';
148 my $nickname = $_{nickname};
150 local $SIG{__WARN__} = sub { $w = shift };
151 my $sub = &{$_{generator}};
152 if (exists $_{deprecated}) {
153 if ($_{deprecated}) {
154 like $w, qr/^Constants from lexical variables potentially (?x:
155 )modified elsewhere are deprecated at /,
156 "$nickname is deprecated";
159 is $w, undef, "$nickname is not deprecated";
162 if (exists $_{retval}) {
163 is &$sub, $_{retval}, "retval of $nickname";
165 if (exists $_{same_retval}) {
166 my $same = $_{same_retval} ? "same" : "different";
167 &{$_{same_retval} ? \&is : \&isnt}(
168 \scalar &$sub(), \scalar &$sub(),
169 "$nickname gives $same retval each call"
172 if (exists $_{inlinable}) {
173 local *temp_inlinability_test = $sub;
175 use warnings 'redefine';
176 *temp_inlinability_test = sub (){};
177 my $S = $_{inlinable} ? "Constant s" : "S";
178 my $not = " not" x! $_{inlinable};
179 like $w, qr/^${S}ubroutine .* redefined at /,
180 "$nickname is$not inlinable";
182 if (exists $_{method}) {
185 use warnings 'ambiguous';
188 is $w, undef, "$nickname has :method attribute";
191 like $w, qr/^Ambiguous call resolved as CORE::time\(\), (?x:
192 )qualify as such or use & at /,
193 "$nickname has no :method attribute";
197 &{$_{finally} or next}