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