1#!./perl -w 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} 10 11plan tests => 47; 12 13$SIG{__WARN__} = sub { die @_ }; 14 15sub eval_ok ($) { 16 eval $_[0]; 17 is( $@, '' ); 18} 19 20eval_ok 'sub t1 ($) : locked { $_[0]++ }'; 21eval_ok 'sub t2 : locked { $_[0]++ }'; 22eval_ok 'sub t3 ($) : locked ;'; 23eval_ok 'sub t4 : locked ;'; 24our $anon1; eval_ok '$anon1 = sub ($) : locked:method { $_[0]++ }'; 25our $anon2; eval_ok '$anon2 = sub : locked : method { $_[0]++ }'; 26our $anon3; eval_ok '$anon3 = sub : method { $_[0]->[1] }'; 27 28eval 'sub e1 ($) : plugh ;'; 29like $@, qr/^Invalid CODE attributes?: ["']?plugh["']? at/; 30 31eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; 32like $@, qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; 33 34eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; 35like $@, qr/Unterminated attribute parameter in attribute list at/; 36 37eval 'sub e4 ($) : plugh + xyzzy ;'; 38like $@, qr/Invalid separator character '[+]' in attribute list at/; 39 40eval_ok 'my main $x : = 0;'; 41eval_ok 'my $x : = 0;'; 42eval_ok 'my $x ;'; 43eval_ok 'my ($x) : = 0;'; 44eval_ok 'my ($x) ;'; 45eval_ok 'my ($x) : ;'; 46eval_ok 'my ($x,$y) : = 0;'; 47eval_ok 'my ($x,$y) ;'; 48eval_ok 'my ($x,$y) : ;'; 49 50eval 'my ($x,$y) : plugh;'; 51like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; 52 53# bug #16080 54eval '{my $x : plugh}'; 55like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; 56eval '{my ($x,$y) : plugh(})}'; 57like $@, qr/^Invalid SCALAR attribute: ["']?plugh\(}\)["']? at/; 58 59# More syntax tests from the attributes manpage 60eval 'my $x : switch(10,foo(7,3)) : expensive;'; 61like $@, qr/^Invalid SCALAR attributes: ["']?switch\(10,foo\(7,3\)\) : expensive["']? at/; 62eval q/my $x : Ugly('\(") :Bad;/; 63like $@, qr/^Invalid SCALAR attributes: ["']?Ugly\('\\\("\) : Bad["']? at/; 64eval 'my $x : _5x5;'; 65like $@, qr/^Invalid SCALAR attribute: ["']?_5x5["']? at/; 66eval 'my $x : locked method;'; 67like $@, qr/^Invalid SCALAR attributes: ["']?locked : method["']? at/; 68eval 'my $x : switch(10,foo();'; 69like $@, qr/^Unterminated attribute parameter in attribute list at/; 70eval q/my $x : Ugly('(');/; 71like $@, qr/^Unterminated attribute parameter in attribute list at/; 72eval 'my $x : 5x5;'; 73like $@, qr/error/; 74eval 'my $x : Y2::north;'; 75like $@, qr/Invalid separator character ':' in attribute list at/; 76 77sub A::MODIFY_SCALAR_ATTRIBUTES { return } 78eval 'my A $x : plugh;'; 79like $@, qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; 80 81eval 'my A $x : plugh plover;'; 82like $@, qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; 83 84eval 'package Cat; my Cat @socks;'; 85like $@, qr/^Can't declare class for non-scalar \@socks in "my"/; 86 87sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } 88sub X::foo { 1 } 89*Y::bar = \&X::foo; 90*Y::bar = \&X::foo; # second time for -w 91eval 'package Z; sub Y::bar : foo'; 92like $@, qr/^X at /; 93 94eval 'package Z; sub Y::baz : locked {}'; 95my @attrs = eval 'attributes::get \&Y::baz'; 96is "@attrs", "locked"; 97 98@attrs = eval 'attributes::get $anon1'; 99is "@attrs", "locked method"; 100 101sub Z::DESTROY { } 102sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } 103my $thunk = eval 'bless +sub : method locked { 1 }, "Z"'; 104is ref($thunk), "Z"; 105 106@attrs = eval 'attributes::get $thunk'; 107is "@attrs", "locked method Z"; 108 109# Test ability to modify existing sub's (or XSUB's) attributes. 110eval 'package A; sub X { $_[0] } sub X : lvalue'; 111@attrs = eval 'attributes::get \&A::X'; 112is "@attrs", "lvalue"; 113 114# Above not with just 'pure' built-in attributes. 115sub Z::MODIFY_CODE_ATTRIBUTES { (); } 116eval 'package Z; sub L { $_[0] } sub L : Z lvalue'; 117@attrs = eval 'attributes::get \&Z::L'; 118is "@attrs", "lvalue Z"; 119 120# Begin testing attributes that tie 121 122{ 123 package Ttie; 124 sub DESTROY {} 125 sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; } 126 sub FETCH { ${$_[0]} } 127 sub STORE { 128 ::pass; 129 ${$_[0]} = $_[1]*2; 130 } 131 package Tloop; 132 sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); } 133} 134 135eval_ok ' 136 package Tloop; 137 for my $i (0..2) { 138 my $x : TieLoop = $i; 139 $x != $i*2 and ::is $x, $i*2; 140 } 141'; 142 143# bug #15898 144eval 'our ${""} : foo = 1'; 145like $@, qr/Can't declare scalar dereference in our/; 146eval 'my $$foo : bar = 1'; 147like $@, qr/Can't declare scalar dereference in my/; 148