1#!./perl -w 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6 require './test.pl'; 7} 8 9plan( tests => 36 ); 10 11sub empty_sub {} 12 13is(empty_sub,undef,"Is empty"); 14is(empty_sub(1,2,3),undef,"Is still empty"); 15@test = empty_sub(); 16is(scalar(@test), 0, 'Didnt return anything'); 17@test = empty_sub(1,2,3); 18is(scalar(@test), 0, 'Didnt return anything'); 19 20# RT #63790: calling PL_sv_yes as a sub is special-cased to silently 21# return (so Foo->import() silently fails if import() doesn't exist), 22# But make sure it correctly pops the stack and mark stack before returning. 23 24{ 25 my @a; 26 push @a, 4, 5, main->import(6,7); 27 ok(eq_array(\@a, [4,5]), "import with args"); 28 29 @a = (); 30 push @a, 14, 15, main->import; 31 ok(eq_array(\@a, [14,15]), "import without args"); 32 33 my $x = 1; 34 35 @a = (); 36 push @a, 24, 25, &{$x == $x}(26,27); 37 ok(eq_array(\@a, [24,25]), "yes with args"); 38 39 @a = (); 40 push @a, 34, 35, &{$x == $x}; 41 ok(eq_array(\@a, [34,35]), "yes without args"); 42} 43 44# [perl #81944] return should always copy 45{ 46 $foo{bar} = 7; 47 for my $x ($foo{bar}) { 48 # Pity test.pl doesnt have isn't. 49 isnt \sub { delete $foo{bar} }->(), \$x, 50 'result of delete(helem) is copied when returned'; 51 } 52 $foo{bar} = 7; 53 for my $x ($foo{bar}) { 54 isnt \sub { return delete $foo{bar} }->(), \$x, 55 'result of delete(helem) is copied when explicitly returned'; 56 } 57 my $x; 58 isnt \sub { delete $_[0] }->($x), \$x, 59 'result of delete(aelem) is copied when returned'; 60 isnt \sub { return delete $_[0] }->($x), \$x, 61 'result of delete(aelem) is copied when explicitly returned'; 62 isnt \sub { ()=\@_; shift }->($x), \$x, 63 'result of shift is copied when returned'; 64 isnt \sub { ()=\@_; return shift }->($x), \$x, 65 'result of shift is copied when explicitly returned'; 66} 67 68fresh_perl_is 69 <<'end', "main::foo\n", {}, 'sub redefinition sets CvGV'; 70*foo = \&baz; 71*bar = *foo; 72eval 'sub bar { print +(caller 0)[3], "\n" }'; 73bar(); 74end 75 76fresh_perl_is 77 <<'end', "main::foo\nok\n", {}, 'no double free redefining anon stub'; 78my $sub = sub { 4 }; 79*foo = $sub; 80*bar = *foo; 81undef &$sub; 82eval 'sub bar { print +(caller 0)[3], "\n" }'; 83&$sub; 84undef *foo; 85undef *bar; 86print "ok\n"; 87end 88 89# The outer call sets the scalar returned by ${\""}.${\""} to the current 90# package name. 91# The inner call sets it to "road". 92# Each call records the value twice, the outer call surrounding the inner 93# call. In 5.10-5.18 under ithreads, what gets pushed is 94# qw(main road road road) because the inner call is clobbering the same 95# scalar. If __PACKAGE__ is changed to "main", it works, the last element 96# becoming "main". 97my @scratch; 98sub a { 99 for (${\""}.${\""}) { 100 $_ = $_[0]; 101 push @scratch, $_; 102 a("road",1) unless $_[1]; 103 push @scratch, $_; 104 } 105} 106a(__PACKAGE__); 107require Config; 108is "@scratch", "main road road main", 109 'recursive calls do not share shared-hash-key TARGs'; 110 111# Another test for the same bug, that does not rely on foreach. It depends 112# on ref returning a shared hash key TARG. 113undef @scratch; 114sub b { 115 my ($pack, $depth) = @_; 116 my $o = bless[], $pack; 117 $pack++; 118 push @scratch, (ref $o, $depth||b($pack,$depth+1))[0]; 119} 120b('n',0); 121is "@scratch", "o n", 122 'recursive calls do not share shared-hash-key TARGs (2)'; 123 124# [perl #78194] @_ aliasing op return values 125sub { is \$_[0], \$_[0], 126 '[perl #78194] \$_[0] == \$_[0] when @_ aliases "$x"' } 127 ->("${\''}"); 128 129# The return statement should make no difference in this case: 130sub not_constant () { 42 } 131sub not_constantr() { return 42 } 132use feature 'lexical_subs'; no warnings 'experimental::lexical_subs'; 133my sub not_constantm () { 42 } 134my sub not_constantmr() { return 42 } 135eval { ${\not_constant}++ }; 136is $@, "", 'sub (){42} returns a mutable value'; 137eval { ${\not_constantr}++ }; 138is $@, "", 'sub (){ return 42 } returns a mutable value'; 139eval { ${\not_constantm}++ }; 140is $@, "", 'my sub (){42} returns a mutable value'; 141eval { ${\not_constantmr}++ }; 142is $@, "", 'my sub (){ return 42 } returns a mutable value'; 143is eval { 144 sub Crunchy () { 1 } 145 sub Munchy { $_[0] = 2 } 146 eval "Crunchy"; # test that freeing this op does not turn off PADTMP 147 Munchy(Crunchy); 148} || $@, 2, 'freeing ops does not make sub(){42} immutable'; 149 150# [perl #79908] 151{ 152 my $x = 5; 153 *_79908 = sub (){$x}; 154 $x = 7; 155 TODO: { 156 local $TODO = "Should be fixed with a deprecation cycle, see 'How about having a recommended way to add constant subs dynamically?' on p5p"; 157 is eval "_79908", 7, 'sub(){$x} does not break closures'; 158 } 159 isnt eval '\_79908', \$x, 'sub(){$x} returns a copy'; 160 161 # Test another thing that was broken by $x inlinement 162 my $y; 163 no warnings 'once'; 164 local *time = sub():method{$y}; 165 my $w; 166 local $SIG{__WARN__} = sub { $w .= shift }; 167 eval "()=time"; 168 TODO: { 169 local $TODO = "Should be fixed with a deprecation cycle, see 'How about having a recommended way to add constant subs dynamically?' on p5p"; 170 is $w, undef, 171 '*keyword = sub():method{$y} does not cause ambiguity warnings'; 172 } 173} 174 175# &xsub when @_ has nonexistent elements 176{ 177 no warnings "uninitialized"; 178 local @_ = (); 179 $#_++; 180 &utf8::encode; 181 is @_, 1, 'num of elems in @_ after &xsub with nonexistent $_[0]'; 182 is $_[0], "", 'content of nonexistent $_[0] is modified by &xsub'; 183} 184 185# &xsub when @_ itself does not exist 186undef *_; 187eval { &utf8::encode }; 188# The main thing we are testing is that it did not crash. But make sure 189# *_{ARRAY} was untouched, too. 190is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist'; 191 192# We do not want re.pm loaded at this point. Move this test up or find 193# another XSUB if this fails. 194ok !exists $INC{"re.pm"}, 're.pm not loaded yet'; 195{ 196 sub re::regmust{} 197 bless \&re::regmust; 198 DESTROY { 199 no warnings 'redefine', 'prototype'; 200 my $str1 = "$_[0]"; 201 *re::regmust = sub{}; # GvSV had no refcount, so this freed it 202 my $str2 = "$_[0]"; # used to be UNKNOWN(0x7fdda29310e0) 203 @str = ($str1, $str2); 204 } 205 local $^W; # Suppress redef warnings in XSLoader 206 require re; 207 is $str[1], $str[0], 208 'XSUB clobbering sub whose DESTROY assigns to the glob'; 209} 210{ 211 no warnings 'redefine'; 212 sub foo {} 213 bless \&foo, 'newATTRSUBbug'; 214 sub newATTRSUBbug::DESTROY { 215 my $str1 = "$_[0]"; 216 *foo = sub{}; # GvSV had no refcount, so this freed it 217 my $str2 = "$_[0]"; # used to be UNKNOWN(0x7fdda29310e0) 218 @str = ($str1, $str2); 219 } 220 splice @str; 221 eval "sub foo{}"; 222 is $str[1], $str[0], 223 'Pure-Perl sub clobbering sub whose DESTROY assigns to the glob'; 224} 225 226# RT #124156 death during unwinding causes crash 227# the tie allows us to trigger another die while cleaning up the stack 228# from an earlier die. 229 230{ 231 package RT124156; 232 233 sub TIEHASH { bless({}, $_[0]) } 234 sub EXISTS { 0 } 235 sub FETCH { undef } 236 sub STORE { } 237 sub DELETE { die "outer\n" } 238 239 my @value; 240 eval { 241 @value = sub { 242 @value = sub { 243 my %a; 244 tie %a, "RT124156"; 245 local $a{foo} = "bar"; 246 die "inner"; 247 ("dd2a", "dd2b"); 248 }->(); 249 ("cc3a", "cc3b"); 250 }->(); 251 }; 252 ::is($@, "outer\n", "RT124156 plain"); 253 254 my $destroyed = 0; 255 sub DESTROY { $destroyed = 1 } 256 257 sub f { 258 my $x; 259 my $f = sub { 260 $x = 1; # force closure 261 my %a; 262 tie %a, "RT124156"; 263 local $a{foo} = "bar"; 264 die "inner"; 265 }; 266 bless $f, 'RT124156'; 267 $f->(); 268 } 269 270 eval { f(); }; 271 # as opposed to $@ eq "Can't undef active subroutine" 272 ::is($@, "outer\n", "RT124156 depth"); 273 ::is($destroyed, 1, "RT124156 freed cv"); 274} 275