File Coverage

blib/lib/Test/CPAN/Changes/ReallyStrict/Object.pm
Criterion Covered Total %
statement 127 160 79.3
branch 42 70 60.0
condition 10 21 47.6
subroutine 19 20 95.0
pod 8 8 100.0
total 206 279 73.8


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__