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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
#!/usr/bin/perl
# Load ALL of the PPI files, and look for a collection
# of known problems, implemented using PPI itself.
# Using PPI to analyse its own code at install-time? Fuck yeah! :)
use lib 't/lib';
use PPI::Test::pragmas;
use Class::Inspector 1.22 ();
use File::Spec::Functions qw( catdir );
use Params::Util qw( _CLASS _ARRAY _INSTANCE _IDENTIFIER );
use PPI ();
use PPI::Test qw( find_files );
use PPI::Test::Object (); ## no perlimports
use Test::More; # Plan comes later
use Test::Object qw( object_ok );
use constant CI => Class::Inspector::;
use Helper 'safe_new';
#####################################################################
# Prepare
# Find all of the files to be checked
my %tests = map { $_ => $INC{$_} } grep { ! /\bXS\.pm/ } grep { /^PPI\b/ } keys %INC;
unless ( %tests ) {
Test::More::plan( tests => 1 + ($ENV{AUTHOR_TESTING} ? 1 : 0) );
ok( undef, "Failed to find any files to test" );
exit();
}
my @files = sort values %tests;
# Find all the testable perl files in t/data
foreach my $dir ( '05_lexer', '08_regression', '11_util', '13_data', '15_transform' ) {
my @perl = find_files( catdir('t', 'data', $dir) );
push @files, @perl;
}
# Declare our plan
Test::More::plan( tests => scalar(@files) * 16 + 4 + ($ENV{AUTHOR_TESTING} ? 1 : 0) );
#####################################################################
# Self-test the search functions before we use them
# Check this actually finds something bad
my $sample = safe_new \<<'END_PERL';
isa($foo, 'Bad::Class1');
isa($foo, 'PPI::Document');
$foo->isa('Bad::Class2');
$foo->isa("Bad::Class3");
isa($foo, 'ARRAY'); # Not bad
isa($foo->thing, qq <Bad::Class4> # ok?
);
END_PERL
my $bad = $sample->find( \&bug_bad_isa_class_name );
ok( _ARRAY($bad), 'Found bad things' );
@$bad = map { $_->string } @$bad;
is_deeply( $bad, [ 'Bad::Class1', 'Bad::Class2', 'Bad::Class3', 'Bad::Class4' ],
'Found all found known bad things' );
#####################################################################
# Run the Tests
foreach my $file ( @files ) {
# MD5 the raw file
my $md5a = PPI::Util::md5hex_file($file);
like( $md5a, qr/^[[:xdigit:]]{32}\z/, 'md5hex_file ok' );
# Load the file
my $Document = safe_new $file;
ok( _INSTANCE($Document, 'PPI::Document'), "$file: Parsed ok" );
# Compare the preload signature to the post-load value
my $md5b = $Document->hex_id;
is( $md5b, $md5a, '->hex_id matches md5hex' );
# By this point, everything should have parsed properly at least
# once, so no need to skip.
SCOPE: {
my $rv = $Document->find( \&bug_bad_isa_class_name );
if ( $rv ) {
$Document->index_locations;
foreach ( @$rv ) {
print "# $file: Found bad class "
. $_->content
. "\n";
}
}
is_deeply( $rv, '', "$file: All class names in ->isa calls exist" );
}
SCOPE: {
my $rv = $Document->find( \&bad_static_method );
if ( $rv ) {
$Document->index_locations;
foreach ( @$rv ) {
my $c = $_->sprevious_sibling->content;
my $m = $_->snext_sibling->content;
my $l = $_->location;
print "# $file: Found bad call ${c}->${m} at line $l->[0], col $l->[1]\n";
}
}
is_deeply( $rv, '', "$file: All class names in static method calls" );
}
# Test with Test::Object stuff
object_ok( $Document );
}
#####################################################################
# Test Functions
# Check for accidental use of illegal or non-existant classes in
# ->isa calls. This has happened at least once, presumably because
# PPI has a LOT of classes and it can get confusing.
sub bug_bad_isa_class_name {
my ($Document, $Element) = @_;
# Find a quote containing a class name
$Element->isa('PPI::Token::Quote') or return '';
_CLASS($Element->string) or return '';
if ( $Element->string =~ /^(?:ARRAY|HASH|CODE|SCALAR|REF|GLOB)$/ ) {
return '';
}
# It should be the last thing in an expression in a list
my $Expression = $Element->parent or return '';
$Expression->isa('PPI::Statement::Expression') or return '';
$Element == $Expression->schild(-1) or return '';
my $List = $Expression->parent or return '';
$List->isa('PPI::Structure::List') or return '';
$List->schildren == 1 or return '';
# The list should be the params list for an isa call
my $Word = $List->sprevious_sibling or return '';
$Word->isa('PPI::Token::Word') or return '';
$Word->content =~ /^(?:UNIVERSAL::)?isa\z/s or return '';
# Is the class real and loaded?
CI->loaded($Element->string) and return '';
# Looks like we found a class that doesn't exist in
# an isa call.
return 1;
}
# Check for the use of a method that doesn't exist
sub bad_static_method {
my ($document, $element) = @_;
# Find a quote containing a class name
$element->isa('PPI::Token::Operator') or return '';
$element->content eq '->' or return '';
# Check the method
my $method = $element->snext_sibling or return '';
$method->isa('PPI::Token::Word') or return '';
_IDENTIFIER($method->content) or return '';
# Check the class
my $class = $element->sprevious_sibling or return '';
$class->isa('PPI::Token::Word') or return '';
_CLASS($class->content) or return '';
# It's usually a deep class
$class = $class->content;
$method = $method->content;
$class =~ /::/ or return '';
# Check the method exists
$class->can($method) and return '';
# special case IO::String as it will normally not be loaded, and the call
# to it is also conditional.
$class eq 'IO::String' && $method eq 'new' and return '';
return 1;
}
1;
|
