1#!./perl 2 3# Regression tests for attributes.pm and the C< : attrs> syntax. 4 5BEGIN { 6 chdir 't' if -d 't'; 7 @INC = '../lib'; 8 require './test.pl'; 9 skip_all_if_miniperl("miniperl can't load attributes"); 10} 11 12use warnings; 13 14$SIG{__WARN__} = sub { die @_ }; 15 16sub eval_ok ($;$) { 17 eval shift; 18 is( $@, '', @_); 19} 20 21fresh_perl_is 'use attributes; print "ok"', 'ok', {}, 22 'attributes.pm can load without warnings.pm already loaded'; 23 24our $anon1; eval_ok '$anon1 = sub : method { $_[0]++ }'; 25 26eval 'sub e1 ($) : plugh ;'; 27like $@, qr/^Invalid CODE attributes?: ["']?plugh["']? at/; 28 29eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; 30like $@, qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; 31 32eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; 33like $@, qr/Unterminated attribute parameter in attribute list at/; 34 35eval 'sub e4 ($) : plugh + XYZZY ;'; 36like $@, qr/Invalid separator character '[+]' in attribute list at/; 37 38eval_ok 'my main $x : = 0;'; 39eval_ok 'my $x : = 0;'; 40eval_ok 'my $x ;'; 41eval_ok 'my ($x) : = 0;'; 42eval_ok 'my ($x) ;'; 43eval_ok 'my ($x) : ;'; 44eval_ok 'my ($x,$y) : = 0;'; 45eval_ok 'my ($x,$y) ;'; 46eval_ok 'my ($x,$y) : ;'; 47 48eval 'my ($x,$y) : plugh;'; 49like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; 50 51# bug #16080 52eval '{my $x : plugh}'; 53like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; 54eval '{my ($x,$y) : plugh(})}'; 55like $@, qr/^Invalid SCALAR attribute: ["']?plugh\(}\)["']? at/; 56 57# More syntax tests from the attributes manpage 58eval 'my $x : switch(10,foo(7,3)) : expensive;'; 59like $@, qr/^Invalid SCALAR attributes: ["']?switch\(10,foo\(7,3\)\) : expensive["']? at/; 60eval q/my $x : Ugly('\(") :Bad;/; 61like $@, qr/^Invalid SCALAR attributes: ["']?Ugly\('\\\("\) : Bad["']? at/; 62eval 'my $x : _5x5;'; 63like $@, qr/^Invalid SCALAR attribute: ["']?_5x5["']? at/; 64eval 'my $x : locked method;'; 65like $@, qr/^Invalid SCALAR attributes: ["']?locked : method["']? at/; 66eval 'my $x : switch(10,foo();'; 67like $@, qr/^Unterminated attribute parameter in attribute list at/; 68eval q/my $x : Ugly('(');/; 69like $@, qr/^Unterminated attribute parameter in attribute list at/; 70eval 'my $x : 5x5;'; 71like $@, qr/error/; 72eval 'my $x : Y2::north;'; 73like $@, qr/Invalid separator character ':' in attribute list at/; 74 75sub A::MODIFY_SCALAR_ATTRIBUTES { return } 76eval 'my A $x : plugh;'; 77like $@, qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; 78 79eval 'my A $x : plugh plover;'; 80like $@, qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; 81 82no warnings 'reserved'; 83eval 'my A $x : plugh;'; 84is $@, ''; 85 86eval 'package Cat; my Cat @socks;'; 87like $@, ''; 88 89eval 'my Cat %nap;'; 90like $@, ''; 91 92sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } 93sub X::foo { 1 } 94*Y::bar = \&X::foo; 95*Y::bar = \&X::foo; # second time for -w 96eval 'package Z; sub Y::bar : foo'; 97like $@, qr/^X at /; 98 99@attrs = eval 'attributes::get $anon1'; 100is "@attrs", "method"; 101 102sub Z::DESTROY { } 103sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } 104my $thunk = eval 'bless +sub : method { 1 }, "Z"'; 105is ref($thunk), "Z"; 106 107@attrs = eval 'attributes::get $thunk'; 108is "@attrs", "method Z"; 109 110# Test attributes on predeclared subroutines: 111eval 'package A; sub PS : lvalue'; 112@attrs = eval 'attributes::get \&A::PS'; 113is "@attrs", "lvalue"; 114 115# Test attributes on predeclared subroutines, after definition 116eval 'package A; sub PS : lvalue; sub PS { }'; 117@attrs = eval 'attributes::get \&A::PS'; 118is "@attrs", "lvalue"; 119 120# Test ability to modify existing sub's (or XSUB's) attributes. 121eval 'package A; sub X { $_[0] } sub X : method'; 122@attrs = eval 'attributes::get \&A::X'; 123is "@attrs", "method"; 124 125# Above not with just 'pure' built-in attributes. 126sub Z::MODIFY_CODE_ATTRIBUTES { (); } 127eval 'package Z; sub L { $_[0] } sub L : Z method'; 128@attrs = eval 'attributes::get \&Z::L'; 129is "@attrs", "method Z"; 130 131# Begin testing attributes that tie 132 133{ 134 package Ttie; 135 sub DESTROY {} 136 sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; } 137 sub FETCH { ${$_[0]} } 138 sub STORE { 139 ::pass; 140 ${$_[0]} = $_[1]*2; 141 } 142 package Tloop; 143 sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); } 144} 145 146eval_ok ' 147 package Tloop; 148 for my $i (0..2) { 149 my $x : TieLoop = $i; 150 $x != $i*2 and ::is $x, $i*2; 151 } 152'; 153 154# bug #15898 155eval 'our ${""} : foo = 1'; 156like $@, qr/Can't declare scalar dereference in "our"/; 157eval 'my $$foo : bar = 1'; 158like $@, qr/Can't declare scalar dereference in "my"/; 159 160 161my @code = qw(lvalue method); 162my @other = qw(shared); 163my @deprecated = qw(locked unique); 164my %valid; 165$valid{CODE} = {map {$_ => 1} @code}; 166$valid{SCALAR} = {map {$_ => 1} @other}; 167$valid{ARRAY} = $valid{HASH} = $valid{SCALAR}; 168my %deprecated; 169$deprecated{CODE} = { locked => 1 }; 170$deprecated{ARRAY} = $deprecated{HASH} = $deprecated{SCALAR} = { unique => 1 }; 171 172our ($scalar, @array, %hash); 173foreach my $value (\&foo, \$scalar, \@array, \%hash) { 174 my $type = ref $value; 175 foreach my $negate ('', '-') { 176 foreach my $attr (@code, @other, @deprecated) { 177 my $attribute = $negate . $attr; 178 eval "use attributes __PACKAGE__, \$value, '$attribute'"; 179 if ($deprecated{$type}{$attr}) { 180 like $@, qr/^Attribute "$attr" is deprecated at \(eval \d+\)/, 181 "$type attribute $attribute deprecated"; 182 } elsif ($valid{$type}{$attr}) { 183 if ($attribute eq '-shared') { 184 like $@, qr/^A variable may not be unshared/; 185 } else { 186 is( $@, '', "$type attribute $attribute"); 187 } 188 } else { 189 like $@, qr/^Invalid $type attribute: $attribute/, 190 "Bogus $type attribute $attribute should fail"; 191 } 192 } 193 } 194} 195 196# this will segfault if it fails 197sub PVBM () { 'foo' } 198{ my $dummy = index 'foo', PVBM } 199 200ok !defined(eval 'attributes::get(\PVBM)'), 201 'PVBMs don\'t segfault attributes::get'; 202 203{ 204 # [perl #49472] Attributes + Unknown Error 205 eval ' 206 use strict; 207 sub MODIFY_CODE_ATTRIBUTE{} 208 sub f:Blah {$nosuchvar}; 209 '; 210 211 my $err = $@; 212 like ($err, qr/Global symbol "\$nosuchvar" requires /, 'perl #49472'); 213} 214 215# Test that code attributes always get applied to the same CV that 216# we're left with at the end (bug#66970). 217{ 218 package bug66970; 219 our $c; 220 sub MODIFY_CODE_ATTRIBUTES { $c = $_[1]; () } 221 $c=undef; eval 'sub t0 :Foo'; 222 main::ok $c == \&{"t0"}; 223 $c=undef; eval 'sub t1 :Foo { }'; 224 main::ok $c == \&{"t1"}; 225 $c=undef; eval 'sub t2'; 226 our $t2a = \&{"t2"}; 227 $c=undef; eval 'sub t2 :Foo'; 228 main::ok $c == \&{"t2"} && $c == $t2a; 229 $c=undef; eval 'sub t3'; 230 our $t3a = \&{"t3"}; 231 $c=undef; eval 'sub t3 :Foo { }'; 232 main::ok $c == \&{"t3"} && $c == $t3a; 233 $c=undef; eval 'sub t4 :Foo'; 234 our $t4a = \&{"t4"}; 235 our $t4b = $c; 236 $c=undef; eval 'sub t4 :Foo'; 237 main::ok $c == \&{"t4"} && $c == $t4b && $c == $t4a; 238 $c=undef; eval 'sub t5 :Foo'; 239 our $t5a = \&{"t5"}; 240 our $t5b = $c; 241 $c=undef; eval 'sub t5 :Foo { }'; 242 main::ok $c == \&{"t5"} && $c == $t5b && $c == $t5a; 243} 244 245my @tests = grep {/^[^#]/} split /\n/, <<'EOT'; 246# This one is fine as an empty attribute list 247my $holy_Einstein : = ''; 248# This one is deprecated 249my $krunch := 4; 250our $FWISK_FWISK_FWIZZACH_FWACH_ZACHITTY_ZICH_SHAZZATZ_FWISK := ''; 251state $thump := 'Trumpets'; 252# Lather rinse repeat in my usual obsessive style 253my @holy_perfect_pitch : = (); 254my @zok := (); 255our @GUKGUK := (); 256# state @widget_mark := (); 257my %holy_seditives : = (); 258my %bang := (); 259our %GIGAZING := (); 260# state %hex := (); 261my $holy_giveaways : = ''; 262my $eee_yow := []; 263our $TWOYYOYYOING_THUK_UGH := 1 == 1; 264state $octothorn := 'Tinky Winky'; 265my @holy_Taj_Mahal : = (); 266my @touche := (); 267our @PLAK_DAK_THUK_FRIT := (); 268# state @hash_mark := (); 269my %holy_priceless_collection_of_Etruscan_snoods : = (); 270my %wham_eth := (); 271our %THWUK := (); 272# state %octalthorpe := (); 273my $holy_sewer_pipe : = ''; 274my $thunk := undef; 275our $BLIT := time; 276state $crunch := 'Laa Laa'; 277my @glurpp := (); 278my @holy_harem : = (); 279our @FABADAP := (); 280# state @square := (); 281my %holy_pin_cushions : = (); 282my %swoosh := (); 283our %RRRRR := (); 284# state %scratchmark := (); 285EOT 286 287foreach my $test (@tests) { 288 use feature 'state'; 289 eval $test; 290 if ($test =~ /:=/) { 291 like $@, qr/Use of := for an empty attribute list is not allowed/, 292 "Parse error for q{$test}"; 293 } else { 294 is $@, '', "No error for q{$test}"; 295 } 296} 297 298# [perl #68560] Calling closure prototypes (only accessible via :attr) 299{ 300 package brength; 301 my $proto; 302 sub MODIFY_CODE_ATTRIBUTES { $proto = $_[1]; _: } 303 eval q{ 304 my $x; 305 () = sub :a0 { $x }; 306 }; 307 package main; 308 eval { $proto->() }; # used to crash in pp_entersub 309 like $@, qr/^Closure prototype called/, 310 "Calling closure proto with (no) args"; 311 eval { () = &$proto }; # used to crash in pp_leavesub 312 like $@, qr/^Closure prototype called/, 313 'Calling closure proto with no @_ that returns a lexical'; 314} 315 316# Referencing closure prototypes 317{ 318 package buckbuck; 319 my @proto; 320 sub MODIFY_CODE_ATTRIBUTES { push @proto, $_[1], \&{$_[1]}; _: } 321 my $id; 322 () = sub :buck {$id}; 323 &::is(@proto, 'referencing closure prototype'); 324} 325 326# [perl #68658] Attributes on stately variables 327{ 328 package thwext; 329 sub MODIFY_SCALAR_ATTRIBUTES { () } 330 my $i = 0; 331 my $x_values = ''; 332 eval 'sub foo { use 5.01; state $x :A0 = $i++; $x_values .= $x }'; 333 foo(); foo(); 334 package main; 335 is $x_values, '00', 'state with attributes'; 336} 337 338{ 339 package ningnangnong; 340 sub MODIFY_SCALAR_ATTRIBUTES{} 341 sub MODIFY_ARRAY_ATTRIBUTES{ } 342 sub MODIFY_HASH_ATTRIBUTES{ } 343 my ($cows, @go, %bong) : teapots = qw[ jibber jabber joo ]; 344 ::is $cows, 'jibber', 'list assignment to scalar with attrs'; 345 ::is "@go", 'jabber joo', 'list assignment to array with attrs'; 346} 347 348{ 349 my $w; 350 local $SIG{__WARN__} = sub { $w = shift }; 351 sub ent {} 352 sub lent :lvalue {} 353 my $posmsg = 354 'lvalue attribute applied to already-defined subroutine at ' 355 .'\(eval'; 356 my $negmsg = 357 'lvalue attribute removed from already-defined subroutine at ' 358 .'\(eval'; 359 eval 'use attributes __PACKAGE__, \&ent, "lvalue"'; 360 like $w, qr/^$posmsg/, 'lvalue attr warning on def sub'; 361 is join("",&attributes::get(\&ent)), "lvalue",':lvalue applied anyway'; 362 $w = ''; 363 eval 'use attributes __PACKAGE__, \&lent, "lvalue"; 1' or die; 364 is $w, "", 'no lvalue warning on def lvalue sub'; 365 eval 'use attributes __PACKAGE__, \&lent, "-lvalue"'; 366 like $w, qr/^$negmsg/, '-lvalue attr warning on def sub'; 367 is join("",&attributes::get(\&lent)), "", 368 'lvalue attribute removed anyway'; 369 $w = ''; 370 eval 'use attributes __PACKAGE__, \&lent, "-lvalue"; 1' or die; 371 is $w, "", 'no -lvalue warning on def non-lvalue sub'; 372 no warnings 'misc'; 373 eval 'use attributes __PACKAGE__, \&lent, "lvalue"'; 374 is $w, "", 'no lvalue warnings under no warnings misc'; 375 eval 'use attributes __PACKAGE__, \&ent, "-lvalue"'; 376 is $w, "", 'no -lvalue warnings under no warnings misc'; 377} 378 379unlike runperl( 380 prog => 'BEGIN {$^H{a}=b} sub foo:bar{1}', 381 stderr => 1, 382 ), 383 qr/Unbalanced/, 384 'attribute errors do not cause op trees to leak'; 385 386done_testing(); 387