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# Multiple attributes at once 116eval 'package A; sub PS2 : lvalue method'; 117@attrs = eval 'attributes::get \&A::PS2'; 118is "@attrs", "lvalue method", 'Multiple builtin attributes can be set at once'; 119 120# Test attributes on predeclared subroutines, after definition 121eval 'package A; sub PS : lvalue; sub PS { }'; 122@attrs = eval 'attributes::get \&A::PS'; 123is "@attrs", "lvalue"; 124 125# Test ability to modify existing sub's (or XSUB's) attributes. 126eval 'package A; sub X { $_[0] } sub X : method'; 127@attrs = eval 'attributes::get \&A::X'; 128is "@attrs", "method"; 129 130# Above not with just 'pure' built-in attributes. 131sub Z::MODIFY_CODE_ATTRIBUTES { (); } 132eval 'package Z; sub L { $_[0] } sub L : Z method'; 133@attrs = eval 'attributes::get \&Z::L'; 134is "@attrs", "method Z"; 135 136# Begin testing attributes that tie 137 138{ 139 package Ttie; 140 sub DESTROY {} 141 sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; } 142 sub FETCH { ${$_[0]} } 143 sub STORE { 144 ::pass; 145 ${$_[0]} = $_[1]*2; 146 } 147 package Tloop; 148 sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); } 149} 150 151eval_ok ' 152 package Tloop; 153 for my $i (0..2) { 154 my $x : TieLoop = $i; 155 $x != $i*2 and ::is $x, $i*2; 156 } 157'; 158 159# bug #15898 160eval 'our ${""} : foo = 1'; 161like $@, qr/Can't declare scalar dereference in "our"/; 162eval 'my $$foo : bar = 1'; 163like $@, qr/Can't declare scalar dereference in "my"/; 164 165 166my @code = qw(lvalue method); 167my @other = qw(shared); 168my @deprecated = qw(); 169my @invalid = qw(unique locked); 170my %valid; 171$valid{CODE} = {map {$_ => 1} @code}; 172$valid{SCALAR} = {map {$_ => 1} @other}; 173$valid{ARRAY} = $valid{HASH} = $valid{SCALAR}; 174my %deprecated; 175 176our ($scalar, @array, %hash); 177foreach my $value (\&foo, \$scalar, \@array, \%hash) { 178 my $type = ref $value; 179 foreach my $negate ('', '-') { 180 foreach my $attr (@code, @other, @deprecated, @invalid) { 181 my $attribute = $negate . $attr; 182 eval "use attributes __PACKAGE__, \$value, '$attribute'"; 183 if ($deprecated{$type}{$attr}) { 184 like $@, qr/^Attribute "$attr" is deprecated, (?#: 185 )and will disappear in Perl 5.28 at \(eval \d+\)/, 186 "$type attribute $attribute deprecated"; 187 } elsif ($valid{$type}{$attr}) { 188 if ($attribute eq '-shared') { 189 like $@, qr/^A variable may not be unshared/; 190 } else { 191 is( $@, '', "$type attribute $attribute"); 192 } 193 } else { 194 like $@, qr/^Invalid $type attribute: $attribute/, 195 "Bogus $type attribute $attribute should fail"; 196 } 197 } 198 } 199} 200 201# this will segfault if it fails 202sub PVBM () { 'foo' } 203{ my $dummy = index 'foo', PVBM } 204 205ok !defined(eval 'attributes::get(\PVBM)'), 206 'PVBMs don\'t segfault attributes::get'; 207 208{ 209 # [perl #49472] Attributes + Unknown Error 210 eval ' 211 use strict; 212 sub MODIFY_CODE_ATTRIBUTE{} 213 sub f:Blah {$nosuchvar}; 214 '; 215 216 my $err = $@; 217 like ($err, qr/Global symbol "\$nosuchvar" requires /, 'perl #49472'); 218} 219 220# Test that code attributes always get applied to the same CV that 221# we're left with at the end (bug#66970). 222{ 223 package bug66970; 224 our $c; 225 sub MODIFY_CODE_ATTRIBUTES { $c = $_[1]; () } 226 $c=undef; eval 'sub t0 :Foo'; 227 main::ok $c == \&{"t0"}; 228 $c=undef; eval 'sub t1 :Foo { }'; 229 main::ok $c == \&{"t1"}; 230 $c=undef; eval 'sub t2'; 231 our $t2a = \&{"t2"}; 232 $c=undef; eval 'sub t2 :Foo'; 233 main::ok $c == \&{"t2"} && $c == $t2a; 234 $c=undef; eval 'sub t3'; 235 our $t3a = \&{"t3"}; 236 $c=undef; eval 'sub t3 :Foo { }'; 237 main::ok $c == \&{"t3"} && $c == $t3a; 238 $c=undef; eval 'sub t4 :Foo'; 239 our $t4a = \&{"t4"}; 240 our $t4b = $c; 241 $c=undef; eval 'sub t4 :Foo'; 242 main::ok $c == \&{"t4"} && $c == $t4b && $c == $t4a; 243 $c=undef; eval 'sub t5 :Foo'; 244 our $t5a = \&{"t5"}; 245 our $t5b = $c; 246 $c=undef; eval 'sub t5 :Foo { }'; 247 main::ok $c == \&{"t5"} && $c == $t5b && $c == $t5a; 248} 249 250my @tests = grep {/^[^#]/} split /\n/, <<'EOT'; 251# This one is fine as an empty attribute list 252my $holy_Einstein : = ''; 253# This one is deprecated 254my $krunch := 4; 255our $FWISK_FWISK_FWIZZACH_FWACH_ZACHITTY_ZICH_SHAZZATZ_FWISK := ''; 256state $thump := 'Trumpets'; 257# Lather rinse repeat in my usual obsessive style 258my @holy_perfect_pitch : = (); 259my @zok := (); 260our @GUKGUK := (); 261# state @widget_mark := (); 262my %holy_seditives : = (); 263my %bang := (); 264our %GIGAZING := (); 265# state %hex := (); 266my $holy_giveaways : = ''; 267my $eee_yow := []; 268our $TWOYYOYYOING_THUK_UGH := 1 == 1; 269state $octothorn := 'Tinky Winky'; 270my @holy_Taj_Mahal : = (); 271my @touche := (); 272our @PLAK_DAK_THUK_FRIT := (); 273# state @hash_mark := (); 274my %holy_priceless_collection_of_Etruscan_snoods : = (); 275my %wham_eth := (); 276our %THWUK := (); 277# state %octalthorpe := (); 278my $holy_sewer_pipe : = ''; 279my $thunk := undef; 280our $BLIT := time; 281state $crunch := 'Laa Laa'; 282my @glurpp := (); 283my @holy_harem : = (); 284our @FABADAP := (); 285# state @square := (); 286my %holy_pin_cushions : = (); 287my %swoosh := (); 288our %RRRRR := (); 289# state %scratchmark := (); 290EOT 291 292foreach my $test (@tests) { 293 use feature 'state'; 294 eval $test; 295 if ($test =~ /:=/) { 296 like $@, qr/Use of := for an empty attribute list is not allowed/, 297 "Parse error for q{$test}"; 298 } else { 299 is $@, '', "No error for q{$test}"; 300 } 301} 302 303# [perl #68560] Calling closure prototypes (only accessible via :attr) 304{ 305 package brength; 306 my $proto; 307 sub MODIFY_CODE_ATTRIBUTES { $proto = $_[1]; _: } 308 eval q{ 309 my $x; 310 () = sub :a0 { $x }; 311 }; 312 package main; 313 eval { $proto->() }; # used to crash in pp_entersub 314 like $@, qr/^Closure prototype called/, 315 "Calling closure proto with (no) args"; 316 eval { () = &$proto }; # used to crash in pp_leavesub 317 like $@, qr/^Closure prototype called/, 318 'Calling closure proto with no @_ that returns a lexical'; 319} 320 321# Referencing closure prototypes 322{ 323 package buckbuck; 324 my @proto; 325 sub MODIFY_CODE_ATTRIBUTES { push @proto, $_[1], \&{$_[1]}; _: } 326 my $id; 327 () = sub :buck {$id}; 328 &::is(@proto, 'referencing closure prototype'); 329} 330 331# [perl #68658] Attributes on stately variables 332{ 333 package thwext; 334 sub MODIFY_SCALAR_ATTRIBUTES { () } 335 my $i = 0; 336 my $x_values = ''; 337 eval 'sub foo { use 5.01; state $x :A0 = $i++; $x_values .= $x }'; 338 foo(); foo(); 339 package main; 340 is $x_values, '00', 'state with attributes'; 341} 342 343{ 344 package ningnangnong; 345 sub MODIFY_SCALAR_ATTRIBUTES{} 346 sub MODIFY_ARRAY_ATTRIBUTES{ } 347 sub MODIFY_HASH_ATTRIBUTES{ } 348 my ($cows, @go, %bong) : teapots = qw[ jibber jabber joo ]; 349 ::is $cows, 'jibber', 'list assignment to scalar with attrs'; 350 ::is "@go", 'jabber joo', 'list assignment to array with attrs'; 351} 352 353{ 354 my $w; 355 local $SIG{__WARN__} = sub { $w = shift }; 356 sub ent {} 357 sub lent :lvalue {} 358 my $posmsg = 359 'lvalue attribute applied to already-defined subroutine at ' 360 .'\(eval'; 361 my $negmsg = 362 'lvalue attribute removed from already-defined subroutine at ' 363 .'\(eval'; 364 eval 'use attributes __PACKAGE__, \&ent, "lvalue"'; 365 like $w, qr/^$posmsg/, 'lvalue attr warning on def sub'; 366 is join("",&attributes::get(\&ent)), "lvalue",':lvalue applied anyway'; 367 $w = ''; 368 eval 'use attributes __PACKAGE__, \&lent, "lvalue"; 1' or die; 369 is $w, "", 'no lvalue warning on def lvalue sub'; 370 eval 'use attributes __PACKAGE__, \&lent, "-lvalue"'; 371 like $w, qr/^$negmsg/, '-lvalue attr warning on def sub'; 372 is join("",&attributes::get(\&lent)), "", 373 'lvalue attribute removed anyway'; 374 $w = ''; 375 eval 'use attributes __PACKAGE__, \&lent, "-lvalue"; 1' or die; 376 is $w, "", 'no -lvalue warning on def non-lvalue sub'; 377 no warnings 'misc'; 378 eval 'use attributes __PACKAGE__, \&lent, "lvalue"'; 379 is $w, "", 'no lvalue warnings under no warnings misc'; 380 eval 'use attributes __PACKAGE__, \&ent, "-lvalue"'; 381 is $w, "", 'no -lvalue warnings under no warnings misc'; 382} 383 384unlike runperl( 385 prog => 'BEGIN {$^H{a}=b} sub foo:bar{1}', 386 stderr => 1, 387 ), 388 qr/Unbalanced/, 389 'attribute errors do not cause op trees to leak'; 390 391package ProtoTest { 392 sub MODIFY_CODE_ATTRIBUTES { $Proto = prototype $_[1]; () } 393 sub foo ($) : gelastic {} 394} 395is $ProtoTest::Proto, '$', 'prototypes are visible in attr handlers'; 396 397{ 398 my $w; 399 local $SIG{__WARN__} = sub { $w = shift }; 400 attributes ->import(__PACKAGE__, \&foo, "const"); 401 like $w, qr/^Useless use of attribute "const" at /, 402 'Warning for useless const via attributes.pm'; 403 $w = ''; 404 attributes ->import(__PACKAGE__, \&foo, "const"); 405 is $w, '', 'no warning for const if already applied'; 406 attributes ->import(__PACKAGE__, \&foo, "-const"); 407 is $w, '', 'no warning for -const with attr already applied'; 408 attributes ->import(__PACKAGE__, \&bar, "-const"); 409 is $w, '', 'no warning for -const with attr not already applied'; 410 package ConstTest; 411 sub MODIFY_CODE_ATTRIBUTES { 412 attributes->import(shift, shift, lc shift) if $_[2]; () 413 } 414 $_ = 32487; 415 my $sub = eval '+sub : Const { $_ }'; 416 ::is $w, '', 417 'no warning for :const applied to closure protosub via attributes.pm'; 418 undef $_; 419 ::is &$sub, 32487, 420 'applying const attr via attributes.pm'; 421} 422 423# [perl #123817] Attributes in list-type operators 424# These tests used to fail an assertion because the list op generated by 425# the lexical attribute declaration was converted to another op type with 426# the OPpLVAL_INTRO flag still set. These op types were not expecting that 427# flag to be set, though it was harmless for non-debugging builds. 428package _123817 { 429 sub MODIFY_SCALAR_ATTRIBUTES {()} 430 eval '{my $x : m}'; 431 eval '[(my $x : m)]'; 432 eval 'formline my $x : m'; 433 eval 'return my $x : m'; 434} 435 436# [perl #126257] 437# attributed lex var as function arg caused assertion failure 438 439package P126257 { 440 sub MODIFY_SCALAR_ATTRIBUTES {} 441 sub MODIFY_ARRAY_ATTRIBUTES {} 442 sub MODIFY_HASH_ATTRIBUTES {} 443 sub MODIFY_CODE_ATTRIBUTES {} 444 sub foo {} 445 eval { foo(my $x : bar); }; 446 ::is $@, "", "RT 126257 scalar"; 447 eval { foo(my @x : bar); }; 448 ::is $@, "", "RT 126257 array"; 449 eval { foo(my %x : bar); }; 450 ::is $@, "", "RT 126257 hash"; 451 eval { foo(sub : bar {}); }; 452 ::is $@, "", "RT 126257 sub"; 453} 454 455# RT #129099 456# Setting an attribute on a BEGIN prototype causes 457# BEGIN { require "attributes"; ... } 458# to be compiled, which caused problems with ops being prematurely 459# freed when CvSTART was transferred from the old BEGIN to the new BEGIN 460 461is runperl( 462 prog => 'package Foo; sub MODIFY_CODE_ATTRIBUTES {()} ' 463 . 'sub BEGIN :Foo; print qq{OK\n}', 464 stderr => 1, 465 ), 466 "OK\n", 467 'RT #129099 BEGIN'; 468is runperl( 469 prog => 'package Foo; sub MODIFY_CODE_ATTRIBUTES {()} ' 470 . 'no warnings q{prototype}; sub BEGIN() :Foo; print qq{OK\n}', 471 stderr => 1, 472 ), 473 "OK\n", 474 'RT #129099 BEGIN()'; 475 476 477#129086 478# When printing error message for an attribute arg without closing ')', 479# if the buffer got reallocated during the scan of the arg, the error 480# message would try to use the old buffer 481fresh_perl_like( 482 'my $abc: abcdefg(' . 'x' x 195 . "\n" . 'x' x 8200 ."\n", 483 qr/^Unterminated attribute parameter in attribute list at - line 1\.$/, 484 { stderr => 1 }, 485 'RT #129086 attr(00000' 486); 487 488TODO: { 489 local $TODO = 'RT #3605: Attribute syntax causes parsing errors near my $var :'; 490 my $out = runperl(prog => <<'EOP', stderr => 1); 491 $ref = \($1 ? my $var : my $othervar); 492EOP 493 unlike($out, qr/Invalid separator character/, 'RT #3605: Errors near attribute colon need a better error message'); 494 is($out, '', 'RT #3605: $a ? my $var : my $othervar is perfectly valid syntax'); 495} 496 497fresh_perl_is('sub dummy {} our $dummy : Dummy', <<EOS, {}, 498Invalid SCALAR attribute: Dummy at - line 1. 499BEGIN failed--compilation aborted at - line 1. 500EOS 501 "attribute on our scalar with sub of same name"); 502 503fresh_perl_is('sub dummy {} our @dummy : Dummy', <<EOS, {}, 504Invalid ARRAY attribute: Dummy at - line 1. 505BEGIN failed--compilation aborted at - line 1. 506EOS 507 "attribute on our array with sub of same name"); 508 509fresh_perl_is('sub dummy {} our %dummy : Dummy', <<EOS, {}, 510Invalid HASH attribute: Dummy at - line 1. 511BEGIN failed--compilation aborted at - line 1. 512EOS 513 "attribute on our hash with sub of same name"); 514 515fresh_perl_is('$_ = ""; s/^/ { my $x : shared = 1; } /e;', "", {}, 516 "attributes in sub-parse"); 517 518done_testing(); 519