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