File Coverage

blib/lib/App/Prove/Plugin/TraceUse.pm
Criterion Covered Total %
statement 151 212 71.2
branch 28 58 48.2
condition 6 22 27.2
subroutine 30 35 85.7
pod 1 1 100.0
total 216 328 65.8


line stmt bran cond sub pod time code
1             package App::Prove::Plugin::TraceUse;
2              
3 13     13   1153686 use warnings;
  13         35  
  13         425  
4 13     13   69 use strict;
  13         30  
  13         468  
5              
6 13     13   11198 use version qw/is_lax qv/; our $VERSION = qv('1.0.3');
  13         34726  
  13         86  
7              
8 13     13   1414 use Carp;
  13         27  
  13         970  
9 13     13   13516 use Tree::Simple;
  13         43588  
  13         94  
10 13     13   14345 use Set::Object qw/set/;
  13         139880  
  13         674  
11 13     13   14782 use Pod::Perldoc;
  13         336929  
  13         592  
12 13     13   12605 use File::Slurp;
  13         218374  
  13         1173  
13 13     13   15199 use Safe;
  13         576585  
  13         17825  
14              
15             my $pd;
16              
17             sub _parse_module_and_version {
18              
19 209     209   426 my @parsed = ();
20              
21 209 100       1598 if ( $_[0] =~ /^\s+\d+\.\s+(\S+)(?: ([\d\._]+))?,/ ) {
22 203         3631 @parsed = grep defined , ($1,$2);
23             }
24 209         2245 return @parsed;
25              
26             }
27              
28             sub _parse_traceuse {
29              
30             # General idea:
31             # * create a tree from the indentation levels
32             # * root nodes should be modules with [main]
33             # * output that has less indent modules than any [main]
34             # should give a parse error
35              
36             # When tree done:
37             # * check @INC of local system
38             # * root nodes are candidates for being a dependency
39             # * root nodes not in @INC shoule be skipped and next level considered instead
40              
41 1     1   79 my @lines = split /\n/, $_[0];
42              
43 1         25 my %indent_parents =
44             ( 0 => Tree::Simple->new( 1, Tree::Simple->ROOT ) );
45              
46 1         70 for ( @lines ) {
47              
48 108         43008 my($mod,$ver) = _parse_module_and_version($_);
49              
50 108 100       324 next unless $mod;
51              
52 102         628 my $node = Tree::Simple->new([$mod,$ver]);
53              
54 102         5103 my ($indent) = /^\s+\d+\.(\s+)\S+/;
55              
56 102         189 my $indent_level = length $indent;
57              
58 102         175 $indent_parents{$indent_level} = $node;
59 102         175 my $parent = $indent_parents{$indent_level - 2};
60              
61 102 50       230 unless ( $parent ) {
62 0         0 confess "Odd, should have had a parent for:\n$_\nIndent: $indent_level, indent: [$indent]\n";
63             }
64              
65 102         10110 $parent->addChild( $node );
66              
67             }
68              
69 1         24 return $indent_parents{0};
70              
71             }
72              
73             sub _system_inc {
74              
75 36     36   24682 my $negate = shift;
76              
77 36         182 my $s1 = set( @INC );
78              
79 36 50       1287 my $s2 = set( ".",
80             (exists($ENV{PERL5LIB}) ? split( ":", $ENV{PERL5LIB}) : ())
81             );
82              
83 36 100       620 my @i = $negate ? (@$s2) : @{$s1 - $s2};
  18         359  
84              
85 36         4751 return @i;
86              
87             }
88              
89             sub _module_dir {
90              
91 16     16   12855 my ($mod,$check_noninc) = @_;
92              
93 16         60 my @inc = _system_inc;
94 16         57 my @noninc = _system_inc(1);
95              
96 16   66     89 $pd ||= Pod::Perldoc->new;
97              
98 16 100       1158 my $d = $check_noninc ? $pd->searchfor( 1, $mod, @noninc ) : $pd->searchfor( 1, $mod, @inc );
99              
100 16 100       889186 return unless $d;
101              
102 9         48 (my $m2 = $mod) =~ s|::|/|g;
103 9         25 $m2 .= ".pm";
104              
105 9         208 $d =~ s|/$m2||;
106              
107 9 50       403 return unless -d $d;
108              
109 9         66 return $d;
110              
111             }
112              
113             sub __recursively_check_loaded_modules {
114 3     3   26 my($node,$dep_ref) = @_;
115              
116 3         7 for ( @{ $node->getAllChildren } ) {
  3         15  
117              
118 6         60 my $mdir = _module_dir( $_->getNodeValue->[0] );
119 6         41 my $mdir_n = _module_dir( $_->getNodeValue->[0], 1 );
120              
121 6 100 66     58 if (
122             defined($mdir) and not defined($mdir_n)
123             ) {
124 5         35 push @$dep_ref, $_->getNodeValue;
125             } else {
126 1         8 __recursively_check_loaded_modules($_, $dep_ref);
127             }
128              
129             }
130              
131             }
132              
133             sub _find_dependent_modules {
134              
135 2     2   20255 my ($t) = @_;
136              
137 2         5 my @dependencies;
138              
139 2         11 __recursively_check_loaded_modules($t,\@dependencies);
140              
141 2         40 return \@dependencies;
142              
143             }
144              
145             sub _find_module_in_code {
146              
147 34     34   120 my($mod,$code) = @_;
148              
149             ## super simple test if the module is present in the code without being comented
150 34         3705 return $code =~ /^[^#]*\b$mod\b.*\d.*$/m;
151              
152             }
153              
154             sub _check_makefile_pl_for_module {
155              
156 11     11   4479 my($mod) = @_;
157              
158 11         33 my $mf = read_file( "./Makefile.PL" );
159              
160 11         767 return _find_module_in_code($mod,$mf);
161              
162             }
163              
164             sub _check_build_pl_for_module {
165              
166 11     11   12666 my($mod) = @_;
167              
168 11         38 my $bf = read_file( "./Build.PL" );
169              
170 11         1109 return _find_module_in_code($mod,$bf);
171              
172             }
173              
174             sub _parse_makefile_pl {
175              
176 3     3   26808 my ($makefile_input) = @_;
177              
178 3         8 my $makefile_content;
179              
180 3 100       35 if ( $makefile_input ) {
    50          
181              
182 2 50       57 if ( -e $makefile_input ) {
183 2         17 $makefile_content = read_file($makefile_input);
184             }
185             else {
186 0         0 croak "Dont know what to do with input";
187             }
188              
189             }
190             elsif ( -e "Makefile.PL" ) {
191 1         35 $makefile_content = read_file("Makefile.PL");
192             }
193              
194 3 50       284 return unless $makefile_content;
195              
196 3         63 my($prereq_content) = $makefile_content =~ /^\s*PREREQ_PM\s*=>\s*({\s*[^}]+})/m;
197              
198 3         38 my $compartment = Safe->new;
199              
200 3         3712 my $prereq_hash_ref = $compartment->reval($prereq_content);
201              
202             ## make sure it is sane
203 3         2004 while ( my($mod,$ver) = each %$prereq_hash_ref) {
204              
205 0 0       0 if ( not is_lax($ver) ) {
206 0         0 delete $prereq_hash_ref->{$mod};
207             }
208              
209             }
210              
211 3         19 return $prereq_hash_ref;
212              
213             }
214              
215             sub _parse_build_pl {
216              
217 3     3   16093 my ($build_input) = @_;
218              
219 3         8 my $build_content;
220              
221 3 100       30 if ( $build_input ) {
    50          
222              
223 2 50       49 if ( -e $build_input ) {
224 2         11 $build_content = read_file($build_input);
225             }
226             else {
227 0         0 croak "Dont know what to do with input";
228             }
229              
230             }
231             elsif ( -e "Build.PL" ) {
232 1         58 $build_content = read_file("Build.PL");
233             }
234              
235 3 50       284 return unless $build_content;
236              
237 3         59 my($prereq_content) = $build_content =~ /^\s*requires\s*=>\s*({\s*[^}]+})/m;
238              
239 3 50       11 return unless $prereq_content;
240              
241 3         31 my $compartment = Safe->new;
242 3         3924 my $prereq_hash_ref = $compartment->reval($prereq_content);
243              
244             ## make sure it is sane
245 3         1873 while ( my($mod,$ver) = each %$prereq_hash_ref) {
246              
247 0 0       0 if ( not is_lax($ver) ) {
248 0         0 delete $prereq_hash_ref->{$mod};
249             }
250              
251             }
252              
253 3         18 return $prereq_hash_ref;
254              
255             }
256              
257             {
258             package TAP::Harness::FOO;
259              
260 13     13   296 use strict;
  13         26  
  13         530  
261 13     13   70 use warnings;
  13         23  
  13         478  
262 13     13   67 use version;
  13         26  
  13         114  
263              
264 13     13   1197 use base 'TAP::Harness';
  13         20  
  13         15898  
265              
266 13     13   215804 use File::Temp;
  13         148191  
  13         1310  
267 13     13   156 use File::Slurp;
  13         26  
  13         1034  
268              
269 13     13   79 use List::Util qw/max/;
  13         30  
  13         1328  
270              
271 13     13   15922 use Term::ANSIColor;
  13         113017  
  13         13570  
272              
273             sub _uniquify_dependencies {
274              
275 4     4   24837 my $self = shift;
276              
277 4         8 my %d;
278              
279 4         6 for ( @{ $self->{collected_dependencies} } ) {
  4         13  
280              
281 9 100 100     156 if ( version->new($_->[1]) > version->new($d{ $_->[0] } || 0) ) {
282 6         29 $d{ $_->[0] } = $_->[1];
283             }
284              
285             }
286              
287 4         8 my @d;
288 4         21 while ( my ($k,$v) = each %d ) {
289 5         20 push @d, [$k,$v];
290             }
291              
292 4         16 $self->{collected_dependencies} = \@d;
293              
294             }
295              
296             sub present_dependencies {
297              
298 0     0   0 my $self = shift;
299              
300 0         0 my @d = sort {
301 0         0 $a->[0] cmp $b->[0]
302 0         0 } @{ $self->{collected_dependencies} };
303              
304 0         0 my $n = max( map {length $_->[0]} @d ) + 2;
  0         0  
305              
306 0         0 print "# TraceUse report:\n";
307              
308 0 0       0 if ( not @d ) {
309 0         0 print "# no noncore dependencies found\n";
310 0         0 return;
311             }
312              
313 0         0 my $makefile_requirements = App::Prove::Plugin::TraceUse::_parse_makefile_pl();
314 0         0 my $build_requirements = App::Prove::Plugin::TraceUse::_parse_build_pl();
315              
316             my $present_file_dep = sub {
317 0     0   0 my ($dep_hash) = @_;
318              
319 0         0 my $hash_fails = 0;
320              
321 0         0 for (@d) {
322              
323 0         0 my($mod,$ver) = @$_;
324              
325 0         0 my $v = $dep_hash->{$mod};
326              
327 0 0 0     0 if ( not $v ) {
    0          
328 0         0 print "# ";
329 0         0 print colored ['bold red'], sprintf "%-${n}s => '%s',\n", "'".$_->[0]."'", $_->[1];
330 0         0 $hash_fails = 1;
331             }
332             elsif ( $v and qv($v) < qv($ver) ) {
333 0         0 print "# ";
334 0         0 print colored ['bold yellow'], sprintf "%-${n}s => '%s',\n", "'".$_->[0]."'", $_->[1];
335 0         0 $hash_fails = 1;
336             }
337              
338             }
339              
340 0 0       0 if ( not $hash_fails ) {
341 0         0 print "# - dependencies are ok\n";
342             }
343              
344 0         0 return not $hash_fails;
345              
346 0         0 };
347              
348 0         0 my $dependencies_are_good = 1;
349              
350 0 0       0 if ( $makefile_requirements ) {
351              
352 0         0 print "# Makefile.PL:\n";
353 0         0 my $ok = $present_file_dep->($makefile_requirements);
354 0   0     0 $dependencies_are_good &&= $ok;
355              
356             }
357              
358 0 0       0 if ( $build_requirements ) {
359              
360 0         0 print "# Build.PL:\n";
361 0         0 my $ok = $present_file_dep->($build_requirements);
362 0   0     0 $dependencies_are_good &&= $ok;
363              
364             }
365              
366 0 0 0     0 if ( not $dependencies_are_good and 0 ) {
367 0         0 print "# List of dependencies found during testing:\n";
368 0         0 for ( @d ) {
369 0         0 printf "# %-${n}s => '%s',\n", "'".$_->[0]."'", $_->[1];
370             }
371             }
372              
373             }
374              
375             sub new {
376              
377 1     1   15 my $self = shift;
378              
379 1         13 my $tf = File::Temp->new;
380 1         756 my $fn = "$tf";
381              
382             ## add the traceuse option
383 1         35 $_[0]->{switches} = ["-d:TraceUse=hidecore,output:$fn"];
384              
385 1         16 my $obj = $self->SUPER::new(@_);
386              
387 1         9125 $obj->{collected_dependencies} = [];
388              
389             my $trace_use_sub = sub {
390              
391 0     0   0 my $dt = read_file( $fn );
392 0         0 my $p = App::Prove::Plugin::TraceUse::_parse_traceuse($dt);
393 0         0 my $deps = App::Prove::Plugin::TraceUse::_find_dependent_modules($p);
394 0         0 push @{ $obj->{collected_dependencies} }, @$deps;
  0         0  
395              
396 1         8 };
397              
398 1         11 $obj->callback( "after_test", $trace_use_sub );
399              
400             my $collected_dependencies = sub {
401 0     0   0 $obj->_uniquify_dependencies;
402 0         0 $obj->present_dependencies;
403 1         26 };
404              
405 1         5 $obj->callback( "after_runtests", $collected_dependencies );
406              
407 1         20 return $obj;
408              
409             }
410              
411             }
412              
413              
414             sub load {
415              
416 0     0 1   my( $class, $p ) = @_;
417              
418 0           my $app = $p->{app_prove};
419              
420 0 0 0       if ( defined($app->harness) and $app->harness ne "TAP::Harness" ) {
421 0           croak "TraceUse plugin is only compatible wtih TAP::Harness";
422             }
423              
424 0           $app->{harness_class} = "TAP::Harness::FOO";
425              
426 0           1;
427              
428             }
429              
430             1; # Magic true value required at end of module
431             __END__
432              
433             =encoding utf8
434              
435             =head1 NAME
436              
437             App::Prove::Plugin::TraceUse - Report all modules used during testing
438             and check if they are listed as dependencies in Makefile.PL and
439             Build.PL
440              
441              
442             =head1 VERSION
443              
444             This document describes App::Prove::Plugin::TraceUse version 1.0.3
445              
446              
447             =head1 SYNOPSIS
448              
449             # Run this module as a plugin to the prove script, ie:
450             # cd /your/module/folder
451             # prove -l -PTraceUse
452              
453             # Will output the following in the end
454             # if dependencies are missing in MakeFile/Build:
455             # (missing deps in red, bad version in yellow)
456             #
457             # [...]
458             # TraceUse report:
459             # Makefile.PL:
460             # 'File::Slurp' => '9999.19',
461             # 'Tree::Simple' => '1.18',
462             # Build.PL:
463             # 'File::Slurp' => '9999.19',
464             # 'Tree::Simple' => '1.18',
465              
466              
467             =head1 DESCRIPTION
468              
469             This module keeps track of all modules and versions loaded during
470             testing. if Makefile.PL and Build.PL are formatted as they come from a
471             plain module-starter, it will recognize the requirement list and check
472             this list with what was found during testing. It reports any non-core
473             modules not listed as requirements
474              
475             Currently it does not care about core modules changing between perl
476             versions.
477              
478             =head1 INTERFACE
479              
480             =head2 load
481              
482             Don't call this. It gets called by App::Prove. Does the following:
483              
484             =over
485              
486             =item Makes sure user didnt specify any other harness class than TAP::Harness
487              
488             =item Creates a subclass of TAP::Harness and makes App::Prove use that.
489              
490             =item Adds -d:TraceUse=hidecore,output:$fn to perl switches for perl
491             tests. $fn is a temp file name for this test.
492              
493             =item Adds a callback to "after_test" to catch TraceUse output
494              
495             =back
496              
497             =head1 DIAGNOSTICS
498              
499             =over
500              
501             =item C<< TraceUse plugin is only compatible wtih TAP::Harness >>
502              
503             Apparently you use something else than TAP::Harness. Unfortunately
504             that does not compute with this plugin.
505              
506             =item C<< Odd, should have had a parent for... >>
507              
508             Parsing the Devel::TraceUse output failed. Send me data to investigate.
509              
510             =back
511              
512              
513             =head1 CONFIGURATION AND ENVIRONMENT
514              
515             App::Prove::Plugin::TraceUse requires no configuration files or environment variables.
516              
517              
518             =head1 DEPENDENCIES
519              
520             App::Prove
521             Test::Perl::Critic
522             Test::Pod::Coverage
523             Test::Most
524             Set::Object
525             Test::Pod
526             File::Slurp
527             Tree::Simple
528              
529             =head1 INCOMPATIBILITIES
530              
531             None reported.
532              
533             =head1 BUGS AND LIMITATIONS
534              
535             No bugs have been reported.
536              
537             Please report any bugs or feature requests to
538             C<bug-app-prove-plugin-traceuse@rt.cpan.org>, or through the web interface at
539             L<http://rt.cpan.org>.
540              
541              
542             =head1 AUTHOR
543              
544             Torbjørn Lindahl C<< <torbjorn.lindahl@gmail.com> >>
545              
546              
547             =head1 LICENCE AND COPYRIGHT
548              
549             Copyright (c) 2013, Torbjørn Lindahl C<< <torbjorn.lindahl@gmail.com> >>. All rights reserved.
550              
551             This module is free software; you can redistribute it and/or
552             modify it under the same terms as Perl itself. See L<perlartistic>.
553              
554              
555             =head1 DISCLAIMER OF WARRANTY
556              
557             BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
558             FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
559             OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
560             PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
561             EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
562             WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
563             ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
564             YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
565             NECESSARY SERVICING, REPAIR, OR CORRECTION.
566              
567             IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
568             WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
569             REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
570             LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
571             OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
572             THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
573             RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
574             FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
575             SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
576             SUCH DAMAGES.