File Coverage

blib/lib/Test/Strict.pm
Criterion Covered Total %
statement 169 211 80.0
branch 65 102 63.7
condition 42 70 60.0
subroutine 29 30 96.6
pod 7 7 100.0
total 312 420 74.2


line stmt bran cond sub pod time code
1             package Test::Strict;
2              
3             =head1 NAME
4              
5             Test::Strict - Check syntax, presence of use strict; and test coverage
6              
7             =head1 VERSION
8              
9             Version 0.51
10              
11             =head1 SYNOPSIS
12              
13             C lets you check the syntax, presence of C
14             and presence C in your perl code.
15             It report its results in standard L fashion:
16              
17             use Test::Strict tests => 3;
18             syntax_ok( 'bin/myscript.pl' );
19             strict_ok( 'My::Module', "use strict; in My::Module" );
20             warnings_ok( 'lib/My/Module.pm' );
21              
22             Module authors can include the following in a t/strict.t
23             and have C automatically find and check
24             all perl files in a module distribution:
25              
26             use Test::Strict;
27             all_perl_files_ok(); # Syntax ok and use strict;
28              
29             or
30              
31             use Test::Strict;
32             all_perl_files_ok( @mydirs );
33              
34             C can also enforce a minimum test coverage
35             the test suite should reach.
36             Module authors can include the following in a t/cover.t
37             and have C automatically check the test coverage:
38              
39             use Test::Strict;
40             all_cover_ok( 80 ); # at least 80% coverage
41              
42             or
43              
44             use Test::Strict;
45             all_cover_ok( 80, 't/' );
46              
47             =head1 DESCRIPTION
48              
49             The most basic test one can write is "does it compile ?".
50             This module tests if the code compiles and play nice with L modules.
51              
52             Another good practice this module can test is to "use strict;" in all perl files.
53              
54             By setting a minimum test coverage through C, a code author
55             can ensure his code is tested above a preset level of I throughout the development cycle.
56              
57             Along with L, this module can provide the first tests to setup for a module author.
58              
59             This module should be able to run under the -T flag for perl >= 5.6.
60             All paths are untainted with the following pattern: C
61             controlled by C<$Test::Strict::UNTAINT_PATTERN>.
62              
63             =cut
64              
65 5     5   221747 use strict; use warnings;
  5     5   29  
  5         118  
  5         23  
  5         6  
  5         129  
66 5     5   108 use 5.006;
  5         14  
67 5     5   23 use Test::Builder;
  5         7  
  5         116  
68 5     5   31 use File::Spec;
  5         11  
  5         131  
69 5     5   2106 use FindBin qw($Bin);
  5         4420  
  5         540  
70 5     5   30 use File::Find;
  5         8  
  5         210  
71 5     5   24 use Config;
  5         10  
  5         1198  
72              
73             our $COVER;
74             our $VERSION = '0.51';
75             our $PERL = $^X || 'perl';
76             our $COVERAGE_THRESHOLD = 50; # 50%
77             our $UNTAINT_PATTERN = qr|^(.*)$|;
78             our $PERL_PATTERN = qr/^#!.*perl/;
79             our $CAN_USE_WARNINGS = ($] >= 5.006);
80             our $TEST_SYNTAX = 1; # Check compile
81             our $TEST_STRICT = 1; # Check use strict;
82             our $TEST_WARNINGS = 0; # Check use warnings;
83             our $TEST_SKIP = []; # List of files to skip check
84             our $DEVEL_COVER_OPTIONS = '+ignore,".Test.Strict\b"';
85             our $DEVEL_COVER_DB = 'cover_db';
86             my $IS_WINDOWS = $^O =~ /MSwin/i;
87              
88             my $Test = Test::Builder->new;
89             my $updir = File::Spec->updir();
90             my %file_find_arg = ($] <= 5.006) ? ()
91             : (
92             untaint => 1,
93             untaint_pattern => $UNTAINT_PATTERN,
94             untaint_skip => 1,
95             );
96              
97             sub import {
98 4     4   28 my $self = shift;
99 4         10 my $caller = caller;
100              
101             {
102 5     5   34 no strict 'refs';
  5         8  
  5         12792  
  4         5  
103 4         8 *{$caller.'::strict_ok'} = \&strict_ok;
  4         18  
104 4         9 *{$caller.'::warnings_ok'} = \&warnings_ok;
  4         11  
105 4         7 *{$caller.'::syntax_ok'} = \&syntax_ok;
  4         10  
106 4         8 *{$caller.'::all_perl_files_ok'} = \&all_perl_files_ok;
  4         12  
107 4         6 *{$caller.'::all_cover_ok'} = \&all_cover_ok;
  4         10  
108             }
109              
110 4         16 $Test->exported_to($caller);
111 4         39 $Test->plan(@_);
112             }
113              
114             ##
115             ## _all_perl_files( @dirs )
116             ## Returns a list of perl files in @dir
117             ## if @dir is not provided, it searches from one dir level above
118             ##
119             sub _all_perl_files {
120 2     2   5 my @all_files = _all_files(@_);
121 2 100       4 return grep { _is_perl_module($_) || _is_perl_script($_) } @all_files;
  42         73  
122             }
123              
124             sub _all_files {
125 2 100   2   18 my @base_dirs = @_ ? @_
126             : File::Spec->catdir($Bin, $updir);
127 2         4 my @found;
128             my $want_sub = sub {
129             #return if ($File::Find::dir =~ m![\\/]?CVS[\\/]|[\\/]?.svn[\\/]!); # Filter out cvs or subversion dirs/
130             #return if ($File::Find::dir =~ m![\\/]?blib[\\/]libdoc$!); # Filter out pod doc in dist
131             #return if ($File::Find::dir =~ m![\\/]?blib[\\/]man\d$!); # Filter out pod doc in dist
132 66 100 66 66   871 if (-d $File::Find::name &&
      100        
133             ($_ eq 'CVS' || $_ eq '.svn' || $_ eq '.git' || # Filter out cvs or git or subversion dirs
134             $File::Find::name =~ m!(?:^|[\\/])blib[\\/]libdoc$! || # Filter out pod doc in dist
135             $File::Find::name =~ m!(?:^|[\\/])blib[\\/]man\d$!) # Filter out pod doc in dist
136             ) {
137 2         5 $File::Find::prune = 1;
138 2         12 return;
139             }
140              
141 64 100 66     1935 return unless (-f $File::Find::name && -r _);
142 43 50       96 return if ($File::Find::name =~ m!\.#.+?[\d\.]+$!); # Filter out CVS backup files (.#file.revision)
143 43         617 push @found, File::Spec->canonpath( File::Spec->no_upwards( $File::Find::name ) );
144 2         15 };
145              
146 2         19 my $find_arg = {
147             %file_find_arg,
148             wanted => $want_sub,
149             no_chdir => 1,
150             };
151 2         253 find( $find_arg, @base_dirs); # Find all potential file candidates
152              
153 2   50     9 my $files_to_skip = $TEST_SKIP || [];
154 2         5 my %skip = map { $_ => undef } @$files_to_skip;
  1         5  
155 2         3 return grep { ! exists $skip{$_} } @found; # Exclude files to skip
  43         68  
156             }
157              
158             =head1 FUNCTIONS
159              
160             =head2 syntax_ok( $file [, $text] )
161              
162             Run a syntax check on C<$file> by running C with an external perl interpreter.
163             The external perl interpreter path is stored in C<$Test::Strict::PERL> which can be modified.
164             You may prefer C from L to syntax test a module.
165             For a module, the path (lib/My/Module.pm) or the name (My::Module) can be both used.
166              
167             =cut
168              
169             sub syntax_ok {
170 20     20 1 59 my $file = shift;
171 20   66     109 my $test_txt = shift || "Syntax check $file";
172              
173 20         54 $file = _module_to_path($file);
174 20 50 33     410 unless (-f $file && -r _) {
175 0         0 $Test->ok( 0, $test_txt );
176 0         0 $Test->diag( "File $file not found or not readable" );
177 0         0 return;
178             }
179              
180 20         129 my $is_script = _is_perl_script($file);
181              
182             # Set the environment to compile the script or module
183 20         281 require Config;
184 20   50     809 my $inc = join($Config::Config{path_sep}, @INC) || '';
185 20         86 $file = _untaint($file);
186 20         38 my $perl_bin = _untaint($PERL);
187 20 50       88 local $ENV{PATH} = _untaint($ENV{PATH}) if $ENV{PATH};
188              
189             # Add the -t -T switches if they are set in the #! line
190 20         40 my $switch = '';
191 20 100 100     70 $switch = _taint_switch($file) || '' if $is_script;
192              
193             # Compile and check for errors
194 20         38 my $eval = do {
195 20         112 local $ENV{PERL5LIB} = $inc;
196 20         1273361 `$perl_bin -c$switch \"$file\" 2>&1`;
197             };
198 20         477 $file = quotemeta($file);
199 20         1668 my $ok = $eval =~ qr!$file syntax OK!ms;
200 20         639 $Test->ok($ok, $test_txt);
201 20 50       16101 unless ($ok) {
202 0         0 $Test->diag( $eval );
203             }
204 20         471 return $ok;
205             }
206              
207             =head2 strict_ok( $file [, $text] )
208              
209             Check if C<$file> contains a C statement.
210             C and C are also considered valid.
211             use Modern::Perl is also accepted.
212              
213             This is a pretty naive test which may be fooled in some edge cases.
214             For a module, the path (lib/My/Module.pm) or the name (My::Module) can be both used.
215              
216             =cut
217              
218             sub strict_ok {
219 26     26 1 7392 my $file = shift;
220 26   66     268 my $test_txt = shift || "use strict $file";
221 26         228 $file = _module_to_path($file);
222 26 50       1278 open my $fh, '<', $file or do { $Test->ok(0, $test_txt); $Test->diag("Could not open $file: $!"); return; };
  0         0  
  0         0  
  0         0  
223 26         172 my $ok = _strict_ok($fh);
224 26         120 $Test->ok($ok, $test_txt);
225 26         7299 return $ok;
226             }
227              
228             sub _module_rx {
229 39     39   237 my (@module_names) = @_;
230 39         1114 my $names = join '|', map quotemeta, reverse sort @module_names;
231             # TODO: improve this matching (e.g. see TODO test)
232 39         2851 return qr/\buse\s+(?:$names)(?:[;\s]|$)/;
233             }
234              
235             sub _strict_ok {
236 28     28   459191 my ($in) = @_;
237 28         79 my $strict_module_rx = _module_rx( modules_enabling_strict() );
238 28         104 local $_;
239 28         463 while (<$in>) {
240 257 100       1291 next if (/^\s*#/); # Skip comments
241 239 100       553 next if (/^\s*=.+/ .. /^\s*=(cut|back|end)/); # Skip pod
242 47 50       99 last if (/^\s*(__END__|__DATA__)/); # End of code
243 47 100       510 return 1 if $_ =~ $strict_module_rx;
244 23 100 100     108 if (/\buse\s+(5\.\d+)/ and $1 >= 5.012) {
245 2         19 return 1;
246             }
247 21 100 66     91 if (/\buse\s+v5\.(\d+)/ and $1 >= 12) {
248 1         11 return 1;
249             }
250             }
251 1         17 return;
252             }
253              
254             =head2 modules_enabling_strict
255              
256             Experimental. Returning a list of modules and pragmata that enable strict.
257             To modify this list, change C<@Test::Strict::MODULES_ENABLING_STRICT>.
258              
259             List taken from L v95
260              
261             =cut
262              
263             our @MODULES_ENABLING_STRICT = qw(
264             strict
265             Any::Moose
266             Catmandu::Sane
267             Class::Spiffy
268             Coat
269             common::sense
270             Dancer
271             HTML::FormHandler::Moose
272             HTML::FormHandler::Moose::Role
273             Mo
274             Modern::Perl
275             Mojo::Base
276             Moo
277             Moo::Role
278             MooX
279             Moose
280             Moose::Exporter
281             Moose::Role
282             MooseX::Declare
283             MooseX::Role::Parameterized
284             MooseX::Types
285             Mouse
286             Mouse::Role
287             perl5
288             perl5i::1
289             perl5i::2
290             perl5i::latest
291             Role::Tiny
292             Spiffy
293             strictures
294             Test::Most
295             Test::Roo
296             Test::Roo::Role
297             );
298              
299 28     28 1 624 sub modules_enabling_strict { return @MODULES_ENABLING_STRICT }
300              
301             =head2 modules_enabling_warnings
302              
303             Experimental. Returning a list of modules and pragmata that enable warnings
304             To modify this list, change C<@Test::Strict::MODULES_ENABLING_WARNINGS>.
305              
306             List taken from L v95
307              
308             =cut
309              
310             our @MODULES_ENABLING_WARNINGS = qw(
311             warnings
312             Any::Moose
313             Catmandu::Sane
314             Class::Spiffy
315             Coat
316             common::sense
317             Dancer
318             HTML::FormHandler::Moose
319             HTML::FormHandler::Moose::Role
320             Mo
321             Modern::Perl
322             Mojo::Base
323             Moo
324             Moo::Role
325             MooX
326             Moose
327             Moose::Exporter
328             Moose::Role
329             MooseX::Declare
330             MooseX::Role::Parameterized
331             MooseX::Types
332             Mouse
333             Mouse::Role
334             perl5
335             perl5i::1
336             perl5i::2
337             perl5i::latest
338             Role::Tiny
339             Spiffy
340             strictures
341             Test::Most
342             Test::Roo
343             Test::Roo::Role
344             );
345              
346 11     11 1 133 sub modules_enabling_warnings { return @MODULES_ENABLING_WARNINGS }
347              
348             =head2 warnings_ok( $file [, $text] )
349              
350             Check if warnings have been turned on.
351              
352             If C<$file> is a module, check if it contains a C or C
353             or C or C statement. use Modern::Perl is also accepted.
354             If the perl version is <= 5.6, this test is skipped (C appeared in perl 5.6).
355              
356             If C<$file> is a script, check if it starts with C<#!...perl -w>.
357             If the -w is not found and perl is >= 5.6, check for a C or C
358             or C or C statement. use Modern::Perl is also accepted.
359              
360             This is a pretty naive test which may be fooled in some edge cases.
361             For a module, the path (lib/My/Module.pm) or the name (My::Module) can be both used.
362              
363             =cut
364              
365             sub warnings_ok {
366 11     11 1 3741 my $file = shift;
367 11   66     86 my $test_txt = shift || "use warnings $file";
368              
369 11         68 $file = _module_to_path($file);
370 11         49 my $is_module = _is_perl_module( $file );
371 11         24 my $is_script = _is_perl_script( $file );
372 11 50 100     60 if (!$is_script and $is_module and ! $CAN_USE_WARNINGS) {
      66        
373 0         0 $Test->skip();
374 0         0 $Test->diag("This version of perl ($]) does not have use warnings - perl 5.6 or higher is required");
375 0         0 return;
376             }
377              
378 11 50       309 open my $fh, '<', $file or do { $Test->ok(0, $test_txt); $Test->diag("Could not open $file: $!"); return; };
  0         0  
  0         0  
  0         0  
379 11         47 my $ok = _warnings_ok($is_script, $fh);
380 11         42 $Test->ok($ok, $test_txt);
381 11         2996 return $ok
382             }
383              
384             # TODO unite with _strict_ok
385             sub _warnings_ok {
386 11     11   32 my ($is_script, $in) = @_;
387 11         23 my $warnings_module_rx = _module_rx( modules_enabling_warnings() );
388 11         63 local $_;
389 11         150 while (<$in>) {
390 13 100 100     207 if ($. == 1 and $is_script and $_ =~ $PERL_PATTERN) {
      100        
391 6 100       28 if (/\s+-\w*[wW]/) {
392 5         20 return 1;
393             }
394             }
395 8 50       18 last unless $CAN_USE_WARNINGS;
396 8 100       23 next if (/^\s*#/); # Skip comments
397 7 50       38 next if (/^\s*=.+/ .. /^\s*=(cut|back|end)/); # Skip pod
398 7 50       14 last if (/^\s*(__END__|__DATA__)/); # End of code
399 7 100       65 return 1 if $_ =~ $warnings_module_rx;
400             }
401 0         0 return;
402             }
403              
404             =head2 all_perl_files_ok( [ @directories ] )
405              
406             Applies C and C to all perl files found in C<@directories> (and sub directories).
407             If no <@directories> is given, the starting point is one level above the current running script,
408             that should cover all the files of a typical CPAN distribution.
409             A perl file is *.pl or *.pm or *.t or a file starting with C<#!...perl>
410              
411             If the test plan is defined:
412              
413             use Test::Strict tests => 18;
414             all_perl_files_ok();
415              
416             the total number of files tested must be specified.
417              
418             You can control which tests are run on each perl site through:
419              
420             $Test::Strict::TEST_SYNTAX (default = 1)
421             $Test::Strict::TEST_STRICT (default = 1)
422             $Test::Strict::TEST_WARNINGS (default = 0)
423             $Test::Strict::TEST_SKIP (default = []) "Trusted" files to skip
424              
425             =cut
426              
427             sub all_perl_files_ok {
428 2     2 1 10060 my @files = _all_perl_files( @_ );
429              
430 2         7 _make_plan();
431 2         192 foreach my $file ( @files ) {
432 17 50       129 syntax_ok( $file ) if $TEST_SYNTAX;
433 17 50       211 strict_ok( $file ) if $TEST_STRICT;
434 17 100       157 warnings_ok( $file ) if $TEST_WARNINGS;
435             }
436             }
437              
438             =head2 all_cover_ok( [coverage_threshold [, @t_dirs]] )
439              
440             This will run all the tests in @t_dirs
441             (or current script's directory if @t_dirs is undef)
442             under L
443             and calculate the global test coverage of the code loaded by the tests.
444             If the test coverage is greater or equal than C, it is a pass,
445             otherwise it's a fail. The default coverage threshold is 50
446             (meaning 50% of the code loaded has been covered by test).
447              
448             The threshold can be modified through C<$Test::Strict::COVERAGE_THRESHOLD>.
449              
450             You may want to select which files are selected for code
451             coverage through C<$Test::Strict::DEVEL_COVER_OPTIONS>,
452             see L for the list of available options.
453             The default is '+ignore,"/Test/Strict\b"'.
454              
455             The path to C utility can be modified through C<$Test::Strict::COVER>.
456              
457             The 50% threshold is a completely arbitrary value, which should not be considered
458             as a good enough coverage.
459              
460             The total coverage is the return value of C.
461              
462             =cut
463              
464             sub all_cover_ok {
465 0     0 1 0 my $cover_bin = _cover_path();
466 0 0       0 die "ERROR: Cover binary not found, please install Devel::Cover.\n"
467             unless (defined $cover_bin);
468              
469 0   0     0 my $threshold = shift || $COVERAGE_THRESHOLD;
470 0 0 0     0 my @dirs = @_ ? @_
471             : (File::Spec->splitpath( $0 ))[1] || '.';
472 0   0     0 my @all_files = grep { ! /$0$/o && $0 !~ /$_$/ }
473 0         0 grep { _is_perl_script($_) }
  0         0  
474             _all_files(@dirs);
475 0         0 _make_plan();
476              
477 0         0 my $perl_bin = _untaint($PERL);
478 0 0       0 local $ENV{PATH} = _untaint($ENV{PATH}) if $ENV{PATH};
479 0 0 0     0 if ($IS_WINDOWS and ! -d $DEVEL_COVER_DB) {
480 0 0       0 mkdir $DEVEL_COVER_DB or warn "$DEVEL_COVER_DB: $!";
481             }
482              
483 0         0 my $res = `$cover_bin -delete 2>&1`;
484 0 0       0 if ($?) {
485 0         0 $Test->skip();
486 0         0 $Test->diag("Cover at $cover_bin got error $?: $res");
487 0         0 return;
488             }
489 0         0 foreach my $file ( @all_files ) {
490 0         0 $file = _untaint($file);
491 0         0 `$perl_bin -MDevel::Cover=$DEVEL_COVER_OPTIONS $file`;
492 0         0 $Test->ok(! $?, "Coverage captured from $file" );
493             }
494 0         0 $Test->ok(my $cover = `$cover_bin 2>&1`, "Got cover");
495              
496 0         0 my ($total) = ($cover =~ /^\s*Total.+?([\d\.]+)\s*$/m);
497 0         0 $Test->ok( $total >= $threshold, "coverage = ${total}% > ${threshold}%");
498 0         0 return $total;
499             }
500              
501             sub _is_perl_module {
502 56 100   56   231 return 0 if $_[0] =~ /\~$/;
503 55 100       319 $_[0] =~ /\.pm$/i || $_[0] =~ /::/;
504             }
505              
506              
507             sub _is_perl_script {
508 74     74   206 my $file = shift;
509              
510 74 100       274 return 0 if $file =~ /\~$/;
511 73 100       288 return 1 if $file =~ /\.pl$/i;
512 58 100       156 return 1 if $file =~ /\.t$/;
513 34 50       826 open my $fh, '<', $file or return;
514 34         347 my $first = <$fh>;
515 34 50 66     293 return 1 if defined $first && ($first =~ $PERL_PATTERN);
516 34         392 return;
517             }
518              
519             ##
520             ## Returns the taint switches -tT in the #! line of a perl script
521             ##
522             sub _taint_switch {
523 16     16   27 my $file = shift;
524              
525 16 50       539 open my $fh, '<', $file or return;
526 16         214 my $first = <$fh>;
527 16 100       330 $first =~ /^#!.*\bperl.*\s-\w*([Tt]+)/ or return;
528 2         46 return $1;
529             }
530              
531             ##
532             ## Return the path of a module
533             ##
534             sub _module_to_path {
535 57     57   114 my $file = shift;
536              
537 57         264 my @parts = split /::/, $file;
538 57         798 my $module = File::Spec->catfile(@parts) . '.pm';
539 57         275 foreach my $dir (@INC) {
540 609         3933 my $candidate = File::Spec->catfile($dir, $module);
541 609 50 66     6036 next unless (-e $candidate && -f _ && -r _);
      66        
542 2         16 return $candidate;
543             }
544 55         201 return $file; # non existing file - error is catched elsewhere
545             }
546              
547              
548             sub _cover_path {
549 1 50   1   67 return $COVER if defined $COVER;
550              
551 1 50       4 my $os_separator = $IS_WINDOWS ? ';' : ':';
552 1         16 foreach ((split /$os_separator/, $ENV{PATH}), @Config{qw(bin sitedir scriptdir)} ) {
553 12   100     160 my $path = $_ || '.';
554 12         78 my $path_cover = File::Spec->catfile($path, 'cover');
555 12 50       25 if ($IS_WINDOWS) {
556 0 0 0     0 next unless (-f $path_cover && -r _);
557             }
558             else {
559 12 50       158 next unless -x $path_cover;
560             }
561 0         0 return $COVER = _untaint($path_cover);
562             }
563 1         6 return;
564             }
565              
566              
567             sub _make_plan {
568 2 50   2   16 unless ($Test->has_plan) {
569 0         0 $Test->plan( 'no_plan' );
570             }
571 2         240 $Test->expected_tests;
572             }
573              
574             sub _untaint {
575 60     60   99 my @untainted = map {($_ =~ $UNTAINT_PATTERN)} @_;
  60         459  
576             wantarray ? @untainted
577 60 50       230 : $untainted[0];
578             }
579              
580             =head1 CAVEATS
581              
582             For C to work properly, it is strongly advised to install the most recent version of L
583             and use perl 5.8.1 or above.
584             In the case of a C scenario, C re-run all the tests in a separate perl interpreter,
585             this may lead to some side effects.
586              
587             =head1 SEE ALSO
588              
589             L, L. L, L
590              
591             =head1 REPOSITORY
592              
593             L
594              
595             =head1 AUTHOR
596              
597             Pierre Denis, C<< >>.
598              
599             =head1 MAINTAINER
600              
601             L
602              
603             Currently maintained by Mohammad S Anwar (MANWAR), C<< >>
604              
605             =head1 COPYRIGHT
606              
607             Copyright 2005, 2010 Pierre Denis, All Rights Reserved.
608              
609             You may use, modify, and distribute this package under the
610             same terms as Perl itself.
611              
612             =cut
613              
614             1;