line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
12
|
|
|
12
|
|
277953
|
use 5.006; |
|
12
|
|
|
|
|
42
|
|
2
|
12
|
|
|
12
|
|
64
|
use strict; |
|
12
|
|
|
|
|
16
|
|
|
12
|
|
|
|
|
389
|
|
3
|
12
|
|
|
12
|
|
63
|
use warnings; |
|
12
|
|
|
|
|
16
|
|
|
12
|
|
|
|
|
986
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
package Test::CPAN::Changes::ReallyStrict::Object; |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our $VERSION = '1.000004'; |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
# ABSTRACT: Object Oriented Guts to ::ReallyStrict |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY |
12
|
|
|
|
|
|
|
|
13
|
12
|
|
|
12
|
|
630
|
use Test::Builder; |
|
12
|
|
|
|
|
8465
|
|
|
12
|
|
|
|
|
415
|
|
14
|
12
|
|
|
12
|
|
1197
|
use Encode qw( decode FB_CROAK LEAVE_SRC ); |
|
12
|
|
|
|
|
19881
|
|
|
12
|
|
|
|
|
1094
|
|
15
|
12
|
|
|
12
|
|
7401
|
use Try::Tiny qw( try catch ); |
|
12
|
|
|
|
|
28497
|
|
|
12
|
|
|
|
|
8321
|
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
my $TEST = Test::Builder->new(); |
18
|
|
|
|
|
|
|
my $version_re = '^[._\-[:alnum:]]+$'; # "Looks like" a version |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
use Class::Tiny { |
21
|
1
|
|
|
|
|
19
|
testbuilder => sub { $TEST }, |
22
|
0
|
|
|
|
|
0
|
filename => sub { 'Changes' }, |
23
|
|
|
|
|
|
|
next_token => sub { |
24
|
7
|
50
|
|
|
|
230
|
return unless defined $_[0]->next_style; |
25
|
0
|
0
|
|
|
|
0
|
return qr/[{][{]\$NEXT[}][}]/msx if 'dzil' eq $_[0]->next_style; |
26
|
0
|
|
|
|
|
0
|
return; |
27
|
|
|
|
|
|
|
}, |
28
|
7
|
|
|
|
|
105
|
next_style => sub { undef }, |
29
|
|
|
|
|
|
|
changes => sub { |
30
|
10
|
|
|
|
|
86
|
my ($self) = @_; |
31
|
10
|
|
|
|
|
800
|
require CPAN::Changes; |
32
|
10
|
|
|
|
|
11246
|
my @extra; |
33
|
10
|
100
|
|
|
|
250
|
push @extra, ( next_token => $self->next_token ) if defined $self->next_token; |
34
|
10
|
|
|
|
|
320
|
return CPAN::Changes->load( $self->filename, @extra ); |
35
|
|
|
|
|
|
|
}, |
36
|
|
|
|
|
|
|
normalised_lines => sub { |
37
|
10
|
|
|
|
|
90
|
my ($self) = @_; |
38
|
10
|
50
|
|
|
|
211
|
if ( $self->delete_empty_groups ) { |
39
|
0
|
|
|
|
|
0
|
$self->changes->delete_empty_groups; |
40
|
|
|
|
|
|
|
} |
41
|
10
|
|
|
|
|
238
|
my $string = $self->changes->serialize; |
42
|
10
|
|
|
|
|
243657
|
return [ split /\n/msx, $string ]; |
43
|
|
|
|
|
|
|
}, |
44
|
|
|
|
|
|
|
source_lines => sub { |
45
|
10
|
|
|
|
|
78
|
my ($self) = @_; |
46
|
10
|
|
|
|
|
19
|
my $fh; |
47
|
|
|
|
|
|
|
## no critic (ProhibitPunctuationVars) |
48
|
|
|
|
|
|
|
|
49
|
10
|
50
|
|
|
|
230
|
if ( not open $fh, '<:raw', $self->filename ) { |
50
|
0
|
|
|
|
|
0
|
$self->testbuilder->ok( 0, $self->filename . ' failed to open' ); |
51
|
0
|
|
|
|
|
0
|
$self->testbuilder->diag( 'Error ' . $! ); |
52
|
0
|
|
|
|
|
0
|
return; |
53
|
|
|
|
|
|
|
} |
54
|
10
|
|
|
|
|
646
|
my $str = do { |
55
|
10
|
|
|
|
|
54
|
local $/ = undef; |
56
|
10
|
|
|
|
|
354
|
scalar <$fh>; |
57
|
|
|
|
|
|
|
}; |
58
|
10
|
50
|
|
|
|
112
|
close $fh or $self->testbuilder->diag( 'Warning: Error Closing ' . $self->filename ); |
59
|
|
|
|
|
|
|
## no critic (RequireCheckingReturnValueOfEval, ProhibitBitwiseOperators) |
60
|
10
|
|
|
|
|
27
|
eval { $str = decode( 'UTF-8', $str, FB_CROAK | LEAVE_SRC ); }; |
|
10
|
|
|
|
|
136
|
|
61
|
10
|
|
|
|
|
4772
|
return [ split /\n/msx, $str ]; |
62
|
|
|
|
|
|
|
}, |
63
|
|
|
|
|
|
|
delete_empty_groups => sub { }, |
64
|
|
|
|
|
|
|
keep_comparing => sub { }, |
65
|
12
|
|
|
12
|
|
2152
|
}; |
|
12
|
|
|
|
|
11832
|
|
|
12
|
|
|
|
|
356
|
|
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
sub changes_ok { |
72
|
10
|
|
|
10
|
1
|
1077
|
my ( $self, ) = @_; |
73
|
10
|
|
|
|
|
19
|
my $exi; |
74
|
|
|
|
|
|
|
$self->testbuilder->subtest( |
75
|
|
|
|
|
|
|
'changes_ok' => sub { |
76
|
10
|
50
|
|
10
|
|
2767
|
return unless $self->loads_ok; |
77
|
10
|
50
|
|
|
|
46
|
return unless $self->has_releases; |
78
|
10
|
50
|
|
|
|
59
|
return unless $self->valid_releases; |
79
|
10
|
100
|
|
|
|
47
|
return unless $self->compare_lines; |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
#$self->testbuilder->ok(1, 'All Subtests for ' . $self->filename . ' done' ); |
82
|
6
|
|
|
|
|
35
|
$exi = 1; |
83
|
|
|
|
|
|
|
}, |
84
|
10
|
|
|
|
|
397
|
); |
85
|
10
|
100
|
|
|
|
2294
|
return unless $exi; |
86
|
6
|
|
|
|
|
82
|
return 1; |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
sub loads_ok { |
98
|
10
|
|
|
10
|
1
|
22
|
my ($self) = @_; |
99
|
10
|
|
|
|
|
16
|
my ( $error, $success ); |
100
|
|
|
|
|
|
|
try { |
101
|
10
|
|
|
10
|
|
885
|
$self->changes(); |
102
|
10
|
|
|
|
|
101736
|
$success = 1; |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
catch { |
105
|
0
|
|
|
0
|
|
0
|
undef $success; |
106
|
0
|
|
|
|
|
0
|
$error = $_; |
107
|
10
|
|
|
|
|
104
|
}; |
108
|
10
|
50
|
33
|
|
|
417
|
if ( not $error and $success ) { |
109
|
10
|
|
|
|
|
385
|
$self->testbuilder->ok( 1, $self->filename . ' is loadable' ); |
110
|
10
|
|
|
|
|
1600
|
return 1; |
111
|
|
|
|
|
|
|
} |
112
|
0
|
|
|
|
|
0
|
$self->testbuilder->ok( 0, $self->filename . ' is loadable' ); |
113
|
0
|
|
|
|
|
0
|
$self->testbuilder->diag($error); |
114
|
0
|
|
|
|
|
0
|
return; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
sub has_releases { |
126
|
10
|
|
|
10
|
1
|
25
|
my ($self) = @_; |
127
|
10
|
|
|
|
|
241
|
my (@releases) = $self->changes->releases; |
128
|
10
|
50
|
|
|
|
22146
|
if (@releases) { |
129
|
10
|
|
|
|
|
319
|
$self->testbuilder->ok( 1, $self->filename . ' contains at least one release' ); |
130
|
10
|
|
|
|
|
1171
|
return 1; |
131
|
|
|
|
|
|
|
} |
132
|
0
|
|
|
|
|
0
|
$self->testbuilder->ok( 0, $self->filename . ' does not contain any release' ); |
133
|
0
|
|
|
|
|
0
|
return; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
sub valid_release_date { |
145
|
244
|
|
|
244
|
1
|
317
|
my ( $self, $release, $release_id ) = @_; |
146
|
244
|
100
|
66
|
|
|
532
|
if ( not defined $release->date and defined $self->next_token ) { |
147
|
2
|
|
|
|
|
69
|
$self->testbuilder->ok( 1, "release $release_id has valid date (none|next_token)" ); |
148
|
2
|
|
|
|
|
45
|
return 1; |
149
|
|
|
|
|
|
|
} |
150
|
242
|
50
|
|
|
|
1513
|
if ( $release->date =~ m/\A${CPAN::Changes::W3CDTF_REGEX}\s*\z/msx ) { |
151
|
242
|
|
|
|
|
7602
|
$self->testbuilder->ok( 1, "release $release_id has valid date (regexp match)" ); |
152
|
242
|
|
|
|
|
13586
|
return 1; |
153
|
|
|
|
|
|
|
} |
154
|
0
|
|
|
|
|
0
|
$self->testbuilder->ok( 0, "release $release_id has an invalid release date" ); |
155
|
0
|
|
|
|
|
0
|
$self->testbuilder->diag( ' ERR:' . $release->date ); |
156
|
0
|
|
|
|
|
0
|
return; |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub valid_release_version { |
168
|
244
|
|
|
244
|
1
|
304
|
my ( $self, $release, $release_id ) = @_; |
169
|
244
|
50
|
33
|
|
|
492
|
if ( not defined $release->version and defined $self->next_token ) { |
170
|
0
|
|
|
|
|
0
|
$self->testbuilder->ok( 1, "release $release_id has valid version (none|next_token)" ); |
171
|
0
|
|
|
|
|
0
|
return 1; |
172
|
|
|
|
|
|
|
} |
173
|
244
|
100
|
100
|
|
|
5670
|
if ( defined $self->next_token and $release->version =~ $self->next_token ) { |
174
|
2
|
|
|
|
|
76
|
$self->testbuilder->ok( 1, "release $release_id has valid version (regexp match on next_token)" ); |
175
|
2
|
|
|
|
|
43
|
return 1; |
176
|
|
|
|
|
|
|
} |
177
|
242
|
50
|
|
|
|
3401
|
if ( $release->version =~ m/$version_re/msx ) { |
178
|
242
|
|
|
|
|
6471
|
$self->testbuilder->ok( 1, "release $release_id has valid version (regexp match version re)" ); |
179
|
242
|
|
|
|
|
13423
|
return 1; |
180
|
|
|
|
|
|
|
} |
181
|
0
|
|
|
|
|
0
|
$self->testbuilder->ok( 0, "release $release_id has valid version." ); |
182
|
0
|
|
|
|
|
0
|
$self->testbuilder->diag( ' ERR:' . $release->version ); |
183
|
0
|
|
|
|
|
0
|
return; |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
sub valid_releases { |
195
|
10
|
|
|
10
|
1
|
22
|
my ($self) = @_; |
196
|
10
|
|
|
|
|
22
|
my $top_exit = 1; |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
$self->testbuilder->subtest( |
199
|
|
|
|
|
|
|
'valid releases' => sub { |
200
|
10
|
|
|
10
|
|
2308
|
my (@releases) = $self->changes->releases; |
201
|
10
|
|
|
|
|
27433
|
for my $id ( 0 .. $#releases ) { |
202
|
244
|
|
|
|
|
339
|
my ($release) = $releases[$id]; |
203
|
244
|
|
|
|
|
282
|
my $sub_exit; |
204
|
|
|
|
|
|
|
$self->testbuilder->subtest( |
205
|
|
|
|
|
|
|
'valid release: ' . $id => sub { |
206
|
244
|
50
|
|
|
|
21591
|
return unless $self->valid_release_date( $release, $id ); |
207
|
244
|
50
|
|
|
|
440
|
return unless $self->valid_release_version( $release, $id ); |
208
|
244
|
|
|
|
|
485
|
$sub_exit = 1; |
209
|
|
|
|
|
|
|
}, |
210
|
244
|
|
|
|
|
4643
|
); |
211
|
244
|
50
|
|
|
|
22834
|
undef $top_exit unless $sub_exit; |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
}, |
214
|
10
|
|
|
|
|
233
|
); |
215
|
10
|
50
|
|
|
|
1446
|
return 1 if $top_exit; |
216
|
0
|
|
|
|
|
0
|
return; |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
sub compare_line { |
228
|
2214
|
|
|
2214
|
1
|
3880
|
my ( $self, $source, $normalised, $line_number, $failed_before ) = @_; |
229
|
2214
|
0
|
33
|
|
|
3712
|
if ( not defined $source and not defined $normalised ) { |
230
|
0
|
|
|
|
|
0
|
$self->testbuilder->ok( 1, "source($line_number) == normalised($line_number) : undef vs undef" ); |
231
|
0
|
|
|
|
|
0
|
return 1; |
232
|
|
|
|
|
|
|
} |
233
|
2214
|
50
|
33
|
|
|
8457
|
if ( defined $source and not defined $normalised ) { |
234
|
0
|
|
|
|
|
0
|
$self->testbuilder->ok( 0, "source($line_number) != normalised($line_number) : defined vs undef" ); |
235
|
0
|
|
|
|
|
0
|
return; |
236
|
|
|
|
|
|
|
} |
237
|
2214
|
50
|
33
|
|
|
3991
|
if ( not defined $source and defined $normalised ) { |
238
|
0
|
|
|
|
|
0
|
$self->testbuilder->ok( 0, "source($line_number) != normalised($line_number) : undef vs defined" ); |
239
|
0
|
|
|
|
|
0
|
return; |
240
|
|
|
|
|
|
|
} |
241
|
2214
|
50
|
|
|
|
3816
|
if ( $] > 5.008 ) { |
242
|
|
|
|
|
|
|
## no critic (ProhibitCallsToUnexportedSubs) |
243
|
2214
|
50
|
|
|
|
4023
|
if ( $ENV{AUTHOR_TESTING} ) { |
244
|
0
|
|
|
|
|
0
|
my (@utf8ness) = map { utf8::is_utf8($_) } $source, $normalised; |
|
0
|
|
|
|
|
0
|
|
245
|
0
|
0
|
|
|
|
0
|
if ( $utf8ness[0] != $utf8ness[1] ) { |
246
|
0
|
|
|
|
|
0
|
$self->testbuilder->diag( sprintf 'utf8ness differs: source=%s normalised=%s', @utf8ness ); |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
} |
249
|
2214
|
50
|
|
|
|
6147
|
utf8::encode($source) if utf8::is_utf8($source); |
250
|
2214
|
50
|
|
|
|
4933
|
utf8::encode($normalised) if utf8::is_utf8($normalised); |
251
|
|
|
|
|
|
|
} |
252
|
2214
|
100
|
|
|
|
3814
|
if ( $source eq $normalised ) { |
253
|
1638
|
|
|
|
|
46031
|
$self->testbuilder->ok( 1, "source($line_number) == normalised($line_number) : val eq val" ); |
254
|
1638
|
|
|
|
|
183276
|
return 1; |
255
|
|
|
|
|
|
|
} |
256
|
576
|
100
|
|
|
|
885
|
if ( not $failed_before ) { |
257
|
4
|
|
|
|
|
94
|
$self->testbuilder->ok( 0, "Lines differ at $line_number" ); |
258
|
|
|
|
|
|
|
} |
259
|
576
|
|
|
|
|
13018
|
$self->testbuilder->diag( sprintf q{[%s] Expected: >%s<}, $line_number, $normalised ); |
260
|
576
|
|
|
|
|
31978
|
$self->testbuilder->diag( sprintf q{[%s] Got : >%s<}, $line_number, $source ); |
261
|
576
|
|
|
|
|
19835
|
return; |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
sub compare_lines { |
274
|
10
|
|
|
10
|
1
|
22
|
my ($self) = @_; |
275
|
|
|
|
|
|
|
|
276
|
10
|
|
|
|
|
17
|
my (@source) = @{ $self->source_lines }; |
|
10
|
|
|
|
|
212
|
|
277
|
10
|
|
|
|
|
23
|
my (@normalised) = @{ $self->normalised_lines }; |
|
10
|
|
|
|
|
295
|
|
278
|
|
|
|
|
|
|
|
279
|
10
|
|
|
|
|
41
|
my $all_lines_passed = 1; |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
$self->testbuilder->subtest( |
282
|
|
|
|
|
|
|
'compare lines source vs normalised' => sub { |
283
|
10
|
|
|
10
|
|
2591
|
$self->testbuilder->note( sprintf q[Source: %s, Normalised: %s], $#source, $#normalised ); |
284
|
10
|
|
|
|
|
708
|
my $failed_already; |
285
|
10
|
|
|
|
|
52
|
for ( 0 .. $#source ) { |
286
|
2214
|
|
|
|
|
7110
|
my $line_passed = $self->compare_line( $source[$_], $normalised[$_], $_, $failed_already ); |
287
|
2214
|
100
|
|
|
|
4923
|
if ( not $line_passed ) { |
288
|
576
|
|
|
|
|
507
|
$failed_already = 1; |
289
|
576
|
|
|
|
|
519
|
undef $all_lines_passed; |
290
|
576
|
100
|
|
|
|
12249
|
if ( not $self->keep_comparing ) { |
291
|
2
|
|
|
|
|
22
|
last; |
292
|
|
|
|
|
|
|
} |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
}, |
296
|
10
|
|
|
|
|
472
|
); |
297
|
10
|
100
|
|
|
|
3828
|
return 1 if $all_lines_passed; |
298
|
4
|
|
|
|
|
218
|
return; |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
1; |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
__END__ |