(intentionally empty)
[perl.git] / ext / attrs.t
1 #!./perl
2
3 # Regression tests for attrs.pm and the C<sub x : attrs> syntax.
4
5 BEGIN {
6     chdir 't' if -d 't';
7     @INC = '../lib';
8     eval 'require attrs; 1' or do {
9         print "1..0\n";
10         exit 0;
11     }
12 }
13
14 use warnings;
15 no warnings qw(deprecated);     # else attrs cries.
16
17 sub NTESTS () ;
18
19 my ($test, $ntests);
20 BEGIN {$ntests=0}
21 $test=0;
22 my $failed = 0;
23
24 print "1..".NTESTS."\n";
25
26 eval 'sub t1 ($) { use attrs "locked"; $_[0]++ }';
27 (print "not "), $failed=1 if $@;
28 print "ok ",++$test,"\n";
29 BEGIN {++$ntests}
30
31 eval 'sub t2 { use attrs "locked"; $_[0]++ }';
32 (print "not "), $failed=1 if $@;
33 print "ok ",++$test,"\n";
34 BEGIN {++$ntests}
35
36 eval 'sub t3 ($) : locked ;';
37 (print "not "), $failed=1 if $@;
38 print "ok ",++$test,"\n";
39 BEGIN {++$ntests}
40
41 eval 'sub t4 : locked ;';
42 (print "not "), $failed=1 if $@;
43 print "ok ",++$test,"\n";
44 BEGIN {++$ntests}
45
46 my $anon1;
47 eval '$anon1 = sub ($) { use attrs qw(locked method); $_[0]++ }';
48 (print "not "), $failed=1 if $@;
49 print "ok ",++$test,"\n";
50 BEGIN {++$ntests}
51
52 my $anon2;
53 eval '$anon2 = sub { use attrs qw(locked method); $_[0]++ }';
54 (print "not "), $failed=1 if $@;
55 print "ok ",++$test,"\n";
56 BEGIN {++$ntests}
57
58 my $anon3;
59 eval '$anon3 = sub { use attrs "method"; $_[0]->[1] }';
60 (print "not "), $failed=1 if $@;
61 print "ok ",++$test,"\n";
62 BEGIN {++$ntests}
63
64 my @attrs = attrs::get($anon3 ? $anon3 : \&ns);
65 (print "not "), $failed=1 unless "@attrs" eq "method";
66 print "ok ",++$test,"\n";
67 BEGIN {++$ntests}
68
69 @attrs = sort +attrs::get($anon2 ? $anon2 : \&ns);
70 (print "not "), $failed=1 unless "@attrs" eq "locked method";
71 print "ok ",++$test,"\n";
72 BEGIN {++$ntests}
73
74 @attrs = sort +attrs::get($anon1 ? $anon1 : \&ns);
75 (print "not "), $failed=1 unless "@attrs" eq "locked method";
76 print "ok ",++$test,"\n";
77 BEGIN {++$ntests}
78
79 eval 'sub e1 ($) : plugh ;';
80 unless ($@ && $@ =~ 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 }
87 print "ok ",++$test,"\n";
88 BEGIN {++$ntests}
89
90 eval 'sub e2 ($) : plugh(0,0) xyzzy ;';
91 unless ($@ && $@ =~ 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 }
98 print "ok ",++$test,"\n";
99 BEGIN {++$ntests}
100
101 eval 'sub e3 ($) : plugh(0,0 xyzzy ;';
102 unless ($@ && $@ =~ 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 }
109 print "ok ",++$test,"\n";
110 BEGIN {++$ntests}
111
112 eval 'sub e4 ($) : plugh + xyzzy ;';
113 unless ($@ && $@ =~ 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 }
120 print "ok ",++$test,"\n";
121 BEGIN {++$ntests}
122
123 {
124     my $w = "" ;
125     local $SIG{__WARN__} = sub {$w = shift} ;
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
136
137 # Other tests should be added above this line
138
139 sub NTESTS () { $ntests }
140
141 exit $failed;