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
|
#!./perl
# Regression tests for attrs.pm and the C<sub x : attrs> syntax.
BEGIN {
chdir 't' if -d 't';
unshift @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}
# Other tests should be added above this line
sub NTESTS () { $ntests }
exit $failed;
|
