This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: Réf. : Re: PATCH proposal for ext/Safe/safe2.t
[perl5.git] / ext / attrs.t
CommitLineData
09bef843
SB
1#!./perl
2
3# Regression tests for attrs.pm and the C<sub x : attrs> syntax.
4
5BEGIN {
6 chdir 't' if -d 't';
20822f61 7 @INC = '../lib';
09bef843
SB
8 eval 'require attrs; 1' or do {
9 print "1..0\n";
10 exit 0;
11 }
12}
13
b75c8c73
MS
14use warnings;
15no warnings qw(deprecated); # else attrs cries.
16
09bef843
SB
17sub NTESTS () ;
18
b75c8c73 19my ($test, $ntests);
09bef843
SB
20BEGIN {$ntests=0}
21$test=0;
22my $failed = 0;
23
24print "1..".NTESTS."\n";
25
26eval 'sub t1 ($) { use attrs "locked"; $_[0]++ }';
27(print "not "), $failed=1 if $@;
28print "ok ",++$test,"\n";
29BEGIN {++$ntests}
30
31eval 'sub t2 { use attrs "locked"; $_[0]++ }';
32(print "not "), $failed=1 if $@;
33print "ok ",++$test,"\n";
34BEGIN {++$ntests}
35
36eval 'sub t3 ($) : locked ;';
37(print "not "), $failed=1 if $@;
38print "ok ",++$test,"\n";
39BEGIN {++$ntests}
40
41eval 'sub t4 : locked ;';
42(print "not "), $failed=1 if $@;
43print "ok ",++$test,"\n";
44BEGIN {++$ntests}
45
46my $anon1;
47eval '$anon1 = sub ($) { use attrs qw(locked method); $_[0]++ }';
48(print "not "), $failed=1 if $@;
49print "ok ",++$test,"\n";
50BEGIN {++$ntests}
51
52my $anon2;
53eval '$anon2 = sub { use attrs qw(locked method); $_[0]++ }';
54(print "not "), $failed=1 if $@;
55print "ok ",++$test,"\n";
56BEGIN {++$ntests}
57
58my $anon3;
59eval '$anon3 = sub { use attrs "method"; $_[0]->[1] }';
60(print "not "), $failed=1 if $@;
61print "ok ",++$test,"\n";
62BEGIN {++$ntests}
63
64my @attrs = attrs::get($anon3 ? $anon3 : \&ns);
65(print "not "), $failed=1 unless "@attrs" eq "method";
66print "ok ",++$test,"\n";
67BEGIN {++$ntests}
68
69@attrs = sort +attrs::get($anon2 ? $anon2 : \&ns);
70(print "not "), $failed=1 unless "@attrs" eq "locked method";
71print "ok ",++$test,"\n";
72BEGIN {++$ntests}
73
74@attrs = sort +attrs::get($anon1 ? $anon1 : \&ns);
75(print "not "), $failed=1 unless "@attrs" eq "locked method";
76print "ok ",++$test,"\n";
77BEGIN {++$ntests}
78
79eval 'sub e1 ($) : plugh ;';
80unless ($@ && $@ =~ m/^Invalid CODE attribute: ["']?plugh["']? at/) {
81 my $x = $@;
82 $x =~ s/\n.*\z//s;
83 print "# $x\n";
84 print "not ";
85 $failed = 1;
86}
87print "ok ",++$test,"\n";
88BEGIN {++$ntests}
89
90eval 'sub e2 ($) : plugh(0,0) xyzzy ;';
91unless ($@ && $@ =~ m/^Invalid CODE attributes: ["']?plugh\(0,0\)["']? /) {
92 my $x = $@;
93 $x =~ s/\n.*\z//s;
94 print "# $x\n";
95 print "not ";
96 $failed = 1;
97}
98print "ok ",++$test,"\n";
99BEGIN {++$ntests}
100
101eval 'sub e3 ($) : plugh(0,0 xyzzy ;';
102unless ($@ && $@ =~ m/Unterminated attribute parameter in attribute list at/) {
103 my $x = $@;
104 $x =~ s/\n.*\z//s;
105 print "# $x\n";
106 print "not ";
107 $failed = 1;
108}
109print "ok ",++$test,"\n";
110BEGIN {++$ntests}
111
112eval 'sub e4 ($) : plugh + xyzzy ;';
113unless ($@ && $@ =~ m/Invalid separator character '[+]' in attribute list at/) {
114 my $x = $@;
115 $x =~ s/\n.*\z//s;
116 print "# $x\n";
117 print "not ";
118 $failed = 1;
119}
120print "ok ",++$test,"\n";
121BEGIN {++$ntests}
122
8cd79558
GS
123{
124 my $w = "" ;
b75c8c73 125 local $SIG{__WARN__} = sub {$w = shift} ;
8cd79558
GS
126 eval 'sub w1 ($) { use warnings "deprecated"; use attrs "locked"; $_[0]++ }';
127 (print "not "), $failed=1 if $@;
128 print "ok ",++$test,"\n";
129 BEGIN {++$ntests}
130 (print "not "), $failed=1
131 if $w !~ /^pragma "attrs" is deprecated, use "sub NAME : ATTRS" instead at/;
132 print "ok ",++$test,"\n";
133 BEGIN {++$ntests}
134}
135
09bef843
SB
136
137# Other tests should be added above this line
138
139sub NTESTS () { $ntests }
140
141exit $failed;