1#!./perl 2 3# Regression tests for attributes.pm and the C< : attrs> syntax. 4 5BEGIN { 6 chdir 't' if -d 't'; 7 require './test.pl'; 8 set_up_inc('../lib'); 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 \(eval \d+\) line 1\.$/; 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 \(eval \d+\) line 1\.$/; 68eval q/my $x : Ugly('(');/; 69like $@, qr/^Unterminated attribute parameter in attribute list at \(eval \d+\) line 1\.$/; 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;'; 87is $@, ''; 88 89eval 'my Cat %nap;'; 90is $@, ''; 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(); 164my @invalid = qw(unique locked); 165my %valid; 166$valid{CODE} = {map {$_ => 1} @code}; 167$valid{SCALAR} = {map {$_ => 1} @other}; 168$valid{ARRAY} = $valid{HASH} = $valid{SCALAR}; 169my %deprecated; 170 171our ($scalar, @array, %hash); 172foreach my $value (\&foo, \$scalar, \@array, \%hash) { 173 my $type = ref $value; 174 foreach my $negate ('', '-') { 175 foreach my $attr (@code, @other, @deprecated, @invalid) { 176 my $attribute = $negate . $attr; 177 eval "use attributes __PACKAGE__, \$value, '$attribute'"; 178 if ($deprecated{$type}{$attr}) { 179 like $@, qr/^Attribute "$attr" is deprecated, (?#: 180 )and will disappear in Perl 5.28 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 386package ProtoTest { 387 sub MODIFY_CODE_ATTRIBUTES { $Proto = prototype $_[1]; () } 388 sub foo ($) : gelastic {} 389} 390is $ProtoTest::Proto, '$', 'prototypes are visible in attr handlers'; 391 392{ 393 my $w; 394 local $SIG{__WARN__} = sub { $w = shift }; 395 attributes ->import(__PACKAGE__, \&foo, "const"); 396 like $w, qr/^Useless use of attribute "const" at /, 397 'Warning for useless const via attributes.pm'; 398 $w = ''; 399 attributes ->import(__PACKAGE__, \&foo, "const"); 400 is $w, '', 'no warning for const if already applied'; 401 attributes ->import(__PACKAGE__, \&foo, "-const"); 402 is $w, '', 'no warning for -const with attr already applied'; 403 attributes ->import(__PACKAGE__, \&bar, "-const"); 404 is $w, '', 'no warning for -const with attr not already applied'; 405 package ConstTest; 406 sub MODIFY_CODE_ATTRIBUTES { 407 attributes->import(shift, shift, lc shift) if $_[2]; () 408 } 409 $_ = 32487; 410 my $sub = eval '+sub : Const { $_ }'; 411 ::is $w, '', 412 'no warning for :const applied to closure protosub via attributes.pm'; 413 undef $_; 414 ::is &$sub, 32487, 415 'applying const attr via attributes.pm'; 416} 417 418# [perl #123817] Attributes in list-type operators 419# These tests used to fail an assertion because the list op generated by 420# the lexical attribute declaration was converted to another op type with 421# the OPpLVAL_INTRO flag still set. These op types were not expecting that 422# flag to be set, though it was harmless for non-debugging builds. 423package _123817 { 424 sub MODIFY_SCALAR_ATTRIBUTES {()} 425 eval '{my $x : m}'; 426 eval '[(my $x : m)]'; 427 eval 'formline my $x : m'; 428 eval 'return my $x : m'; 429} 430 431# [perl #126257] 432# attributed lex var as function arg caused assertion failure 433 434package P126257 { 435 sub MODIFY_SCALAR_ATTRIBUTES {} 436 sub MODIFY_ARRAY_ATTRIBUTES {} 437 sub MODIFY_HASH_ATTRIBUTES {} 438 sub MODIFY_CODE_ATTRIBUTES {} 439 sub foo {} 440 eval { foo(my $x : bar); }; 441 ::is $@, "", "RT 126257 scalar"; 442 eval { foo(my @x : bar); }; 443 ::is $@, "", "RT 126257 array"; 444 eval { foo(my %x : bar); }; 445 ::is $@, "", "RT 126257 hash"; 446 eval { foo(sub : bar {}); }; 447 ::is $@, "", "RT 126257 sub"; 448} 449 450# RT #129099 451# Setting an attribute on a BEGIN prototype causes 452# BEGIN { require "attributes"; ... } 453# to be compiled, which caused problems with ops being prematurely 454# freed when CvSTART was transferred from the old BEGIN to the new BEGIN 455 456is runperl( 457 prog => 'package Foo; sub MODIFY_CODE_ATTRIBUTES {()} ' 458 . 'sub BEGIN :Foo; print qq{OK\n}', 459 stderr => 1, 460 ), 461 "OK\n", 462 'RT #129099 BEGIN'; 463is runperl( 464 prog => 'package Foo; sub MODIFY_CODE_ATTRIBUTES {()} ' 465 . 'no warnings q{prototype}; sub BEGIN() :Foo; print qq{OK\n}', 466 stderr => 1, 467 ), 468 "OK\n", 469 'RT #129099 BEGIN()'; 470 471 472#129086 473# When printing error message for an attribute arg without closing ')', 474# if the buffer got reallocated during the scan of the arg, the error 475# message would try to use the old buffer 476fresh_perl_like( 477 'my $abc: abcdefg(' . 'x' x 195 . "\n" . 'x' x 8200 ."\n", 478 qr/^Unterminated attribute parameter in attribute list at - line 1\.$/, 479 { stderr => 1 }, 480 'RT #129086 attr(00000' 481); 482 483TODO: { 484 local $TODO = 'RT #3605: Attribute syntax causes parsing errors near my $var :'; 485 my $out = runperl(prog => <<'EOP', stderr => 1); 486 $ref = \($1 ? my $var : my $othervar); 487EOP 488 unlike($out, qr/Invalid separator character/, 'RT #3605: Errors near attribute colon need a better error message'); 489 is($out, '', 'RT #3605: $a ? my $var : my $othervar is perfectly valid syntax'); 490} 491 492fresh_perl_is('sub dummy {} our $dummy : Dummy', <<EOS, {}, 493Invalid SCALAR attribute: Dummy at - line 1. 494BEGIN failed--compilation aborted at - line 1. 495EOS 496 "attribute on our scalar with sub of same name"); 497 498fresh_perl_is('sub dummy {} our @dummy : Dummy', <<EOS, {}, 499Invalid ARRAY attribute: Dummy at - line 1. 500BEGIN failed--compilation aborted at - line 1. 501EOS 502 "attribute on our array with sub of same name"); 503 504fresh_perl_is('sub dummy {} our %dummy : Dummy', <<EOS, {}, 505Invalid HASH attribute: Dummy at - line 1. 506BEGIN failed--compilation aborted at - line 1. 507EOS 508 "attribute on our hash with sub of same name"); 509 510done_testing(); 511