1#!./perl 2 3# Regression tests for attributes.pm and the C< : attrs> syntax. 4 5BEGIN { 6 if ($ENV{PERL_CORE_MINITEST}) { 7 print "1..0 # skip: miniperl can't load attributes\n"; 8 exit 0; 9 } 10 chdir 't' if -d 't'; 11 @INC = '../lib'; 12 require './test.pl'; 13} 14 15use warnings; 16 17plan 90; 18 19$SIG{__WARN__} = sub { die @_ }; 20 21sub eval_ok ($;$) { 22 eval shift; 23 is( $@, '', @_); 24} 25 26eval_ok 'sub t1 ($) : locked { $_[0]++ }'; 27eval_ok 'sub t2 : locked { $_[0]++ }'; 28eval_ok 'sub t3 ($) : locked ;'; 29eval_ok 'sub t4 : locked ;'; 30our $anon1; eval_ok '$anon1 = sub ($) : locked:method { $_[0]++ }'; 31our $anon2; eval_ok '$anon2 = sub : locked : method { $_[0]++ }'; 32our $anon3; eval_ok '$anon3 = sub : method { $_[0]->[1] }'; 33 34eval 'sub e1 ($) : plugh ;'; 35like $@, qr/^Invalid CODE attributes?: ["']?plugh["']? at/; 36 37eval 'sub e2 ($) : plugh(0,0) xyzzy ;'; 38like $@, qr/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /; 39 40eval 'sub e3 ($) : plugh(0,0 xyzzy ;'; 41like $@, qr/Unterminated attribute parameter in attribute list at/; 42 43eval 'sub e4 ($) : plugh + xyzzy ;'; 44like $@, qr/Invalid separator character '[+]' in attribute list at/; 45 46eval_ok 'my main $x : = 0;'; 47eval_ok 'my $x : = 0;'; 48eval_ok 'my $x ;'; 49eval_ok 'my ($x) : = 0;'; 50eval_ok 'my ($x) ;'; 51eval_ok 'my ($x) : ;'; 52eval_ok 'my ($x,$y) : = 0;'; 53eval_ok 'my ($x,$y) ;'; 54eval_ok 'my ($x,$y) : ;'; 55 56eval 'my ($x,$y) : plugh;'; 57like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; 58 59# bug #16080 60eval '{my $x : plugh}'; 61like $@, qr/^Invalid SCALAR attribute: ["']?plugh["']? at/; 62eval '{my ($x,$y) : plugh(})}'; 63like $@, qr/^Invalid SCALAR attribute: ["']?plugh\(}\)["']? at/; 64 65# More syntax tests from the attributes manpage 66eval 'my $x : switch(10,foo(7,3)) : expensive;'; 67like $@, qr/^Invalid SCALAR attributes: ["']?switch\(10,foo\(7,3\)\) : expensive["']? at/; 68eval q/my $x : Ugly('\(") :Bad;/; 69like $@, qr/^Invalid SCALAR attributes: ["']?Ugly\('\\\("\) : Bad["']? at/; 70eval 'my $x : _5x5;'; 71like $@, qr/^Invalid SCALAR attribute: ["']?_5x5["']? at/; 72eval 'my $x : locked method;'; 73like $@, qr/^Invalid SCALAR attributes: ["']?locked : method["']? at/; 74eval 'my $x : switch(10,foo();'; 75like $@, qr/^Unterminated attribute parameter in attribute list at/; 76eval q/my $x : Ugly('(');/; 77like $@, qr/^Unterminated attribute parameter in attribute list at/; 78eval 'my $x : 5x5;'; 79like $@, qr/error/; 80eval 'my $x : Y2::north;'; 81like $@, qr/Invalid separator character ':' in attribute list at/; 82 83sub A::MODIFY_SCALAR_ATTRIBUTES { return } 84eval 'my A $x : plugh;'; 85like $@, qr/^SCALAR package attribute may clash with future reserved word: ["']?plugh["']? at/; 86 87eval 'my A $x : plugh plover;'; 88like $@, qr/^SCALAR package attributes may clash with future reserved words: ["']?plugh["']? /; 89 90no warnings 'reserved'; 91eval 'my A $x : plugh;'; 92is $@, ''; 93 94eval 'package Cat; my Cat @socks;'; 95like $@, qr/^Can't declare class for non-scalar \@socks in "my"/; 96 97sub X::MODIFY_CODE_ATTRIBUTES { die "$_[0]" } 98sub X::foo { 1 } 99*Y::bar = \&X::foo; 100*Y::bar = \&X::foo; # second time for -w 101eval 'package Z; sub Y::bar : foo'; 102like $@, qr/^X at /; 103 104eval 'package Z; sub Y::baz : locked {}'; 105my @attrs = eval 'attributes::get \&Y::baz'; 106is "@attrs", "locked"; 107 108@attrs = eval 'attributes::get $anon1'; 109is "@attrs", "locked method"; 110 111sub Z::DESTROY { } 112sub Z::FETCH_CODE_ATTRIBUTES { return 'Z' } 113my $thunk = eval 'bless +sub : method locked { 1 }, "Z"'; 114is ref($thunk), "Z"; 115 116@attrs = eval 'attributes::get $thunk'; 117is "@attrs", "locked method Z"; 118 119# Test attributes on predeclared subroutines: 120eval 'package A; sub PS : lvalue'; 121@attrs = eval 'attributes::get \&A::PS'; 122is "@attrs", "lvalue"; 123 124# Test ability to modify existing sub's (or XSUB's) attributes. 125eval 'package A; sub X { $_[0] } sub X : lvalue'; 126@attrs = eval 'attributes::get \&A::X'; 127is "@attrs", "lvalue"; 128 129# Above not with just 'pure' built-in attributes. 130sub Z::MODIFY_CODE_ATTRIBUTES { (); } 131eval 'package Z; sub L { $_[0] } sub L : Z lvalue'; 132@attrs = eval 'attributes::get \&Z::L'; 133is "@attrs", "lvalue Z"; 134 135# Begin testing attributes that tie 136 137{ 138 package Ttie; 139 sub DESTROY {} 140 sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; } 141 sub FETCH { ${$_[0]} } 142 sub STORE { 143 ::pass; 144 ${$_[0]} = $_[1]*2; 145 } 146 package Tloop; 147 sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); } 148} 149 150eval_ok ' 151 package Tloop; 152 for my $i (0..2) { 153 my $x : TieLoop = $i; 154 $x != $i*2 and ::is $x, $i*2; 155 } 156'; 157 158# bug #15898 159eval 'our ${""} : foo = 1'; 160like $@, qr/Can't declare scalar dereference in "our"/; 161eval 'my $$foo : bar = 1'; 162like $@, qr/Can't declare scalar dereference in "my"/; 163 164 165my @code = qw(lvalue locked method); 166my @other = qw(shared unique); 167my %valid; 168$valid{CODE} = {map {$_ => 1} @code}; 169$valid{SCALAR} = {map {$_ => 1} @other}; 170$valid{ARRAY} = $valid{HASH} = $valid{SCALAR}; 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) { 177 my $attribute = $negate . $attr; 178 eval "use attributes __PACKAGE__, \$value, '$attribute'"; 179 if ($valid{$type}{$attr}) { 180 if ($attribute eq '-shared') { 181 like $@, qr/^A variable may not be unshared/; 182 } else { 183 is( $@, '', "$type attribute $attribute"); 184 } 185 } else { 186 like $@, qr/^Invalid $type attribute: $attribute/, 187 "Bogus $type attribute $attribute should fail"; 188 } 189 } 190 } 191} 192 193# this will segfault if it fails 194sub PVBM () { 'foo' } 195{ my $dummy = index 'foo', PVBM } 196 197ok !defined(attributes::get(\PVBM)), 198 'PVBMs don\'t segfault attributes::get'; 199