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