File Coverage

blib/lib/Test/Fixme.pm
Criterion Covered Total %
statement 92 107 85.9
branch 31 44 70.4
condition 10 21 47.6
subroutine 14 15 93.3
pod 1 6 16.6
total 148 193 76.6


line stmt bran cond sub pod time code
1             package Test::Fixme;
2              
3             require 5.006002;
4 9     9   53597 use strict;
  9         16  
  9         319  
5 9     9   37 use warnings;
  9         13  
  9         285  
6              
7 9     9   37 use Carp;
  9         14  
  9         775  
8 9     9   43 use File::Find;
  9         15  
  9         526  
9 9     9   5640 use ExtUtils::Manifest qw( maniread );
  9         81430  
  9         838  
10              
11 9     9   2940 use Test::Builder;
  9         34737  
  9         3010  
12             require Exporter;
13             our @ISA = qw( Exporter );
14             our @EXPORT = qw( run_tests );
15              
16             # ABSTRACT: Check code for FIXMEs.
17             our $VERSION = '0.14_01'; # TRIAL VERSION
18              
19             my $Test = Test::Builder->new;
20              
21             sub run_tests {
22              
23             # Get the values and setup defaults if needed.
24 3     3 1 49 my %args = @_;
25 3 100 66     30 $args{match} = 'FIXME' unless defined $args{match} && length $args{match};
26 3 50 33     29 $args{where} = '.' unless defined $args{where} && length $args{where};
27 3 50 33     19 $args{warn} = 0 unless defined $args{warn} && length $args{warn};
28 3 50       15 $args{format} = $ENV{TEST_FIXME_FORMAT} if defined $ENV{TEST_FIXME_FORMAT};
29 3 50 33     20 $args{format} = 'original'
30             unless defined $args{format} && $args{format} =~ /^(original|perl)$/;
31 3 50 33     31 $args{filename_match} = qr/./
32             unless defined $args{filename_match} && length $args{filename_match};
33 3         12 my $first = 1;
34              
35             # Skip all tests if instructed to.
36 3 100       19 $Test->skip_all("All tests skipped.") if $args{skip_all};
37              
38             # Get files to work with and set the plan.
39 2         5 my @files;
40 2 100       10 if(defined $args{manifest}) {
41 1         2 @files = keys %{ maniread( $args{manifest} ) };
  1         6  
42             } else {
43 1         6 @files = list_files( $args{where}, $args{filename_match} );
44             }
45 2         153 $Test->plan( tests => scalar @files );
46              
47             # Check ech file in turn.
48 2         720 foreach my $file (@files) {
49 63         184 my $results = scan_file( file => $file, match => $args{match} );
50 63         106 my $ok = scalar @$results == 0;
51 63   33     410 $Test->ok($ok || $args{warn}, "'$file'");
52 63 50       29461 next if $ok;
53 0 0       0 $Test->diag('') if $first++;
54 0         0 $Test->diag(do {
55 9     9   61 no strict 'refs';
  9         16  
  9         6945  
56 0         0 &{"format_file_results_$args{format}"}($results)
  0         0  
57             });
58             }
59             }
60              
61             sub scan_file {
62 70     70 0 2538 my %args = @_;
63 70 100 100     358 return undef unless $args{file} && $args{match};
64              
65             # Get the contents of the files and split content into lines.
66 67         128 my $content = load_file( $args{file} );
67 67         1644 my @lines = split $/, $content;
68 67         194 my $line_number = 0;
69              
70             # Set up return array.
71 67         97 my @results = ();
72              
73 67         145 foreach my $line (@lines) {
74 3327         2582 $line_number++;
75 3327 100       8238 next unless $line =~ m/$args{match}/;
76              
77             # We have a match - add it to array.
78 5         18 push @results,
79             {
80             file => $args{file},
81             match => $args{match},
82             line => $line_number,
83             text => $line,
84             };
85             }
86              
87 67         1003 return \@results;
88             }
89              
90             sub format_file_results_original {
91 1     1 0 219 my $results = shift;
92 1 50       5 return undef unless defined $results;
93              
94 1         2 my $out = '';
95              
96             # format the file name.
97 1         2 $out .= "File: '" . ${$results}[0]->{file} . "'\n";
  1         4  
98              
99             # format the results.
100 1         2 foreach my $result (@$results) {
101 2         4 my $line = $$result{line};
102 2         3 my $txt = " $line";
103 2         6 $txt .= ' ' x ( 8 - length $line );
104 2         3 $txt .= $$result{text} . "\n";
105 2         6 $out .= $txt;
106             }
107              
108 1         25 return $out;
109             }
110              
111             sub format_file_results_perl {
112 0     0 0 0 my $results = shift;
113 0 0       0 return undef unless defined $results;
114              
115 0         0 my $out = '';
116              
117             # format the results.
118 0         0 foreach my $result (@$results) {
119 0         0 my $file = ${$results}[0]->{file};
  0         0  
120 0         0 my $line = $$result{line};
121 0         0 my $text = $$result{text};
122            
123 0         0 $out .= "Pattern found at file $file at $line:\n $text\n";
124             }
125              
126 0         0 return $out;
127             }
128              
129             sub list_files {
130 10     10 0 5652 my $path_arg = shift;
131 10 100       109 croak
132             'You must specify a single directory, or reference to a list of directories'
133             unless defined $path_arg;
134              
135 9         29 my $filename_match = shift;
136 9 100       22 if ( !defined $filename_match ) {
137              
138             # Filename match defaults to matching any single character, for
139             # backwards compatibility with one-arg list_files() invocation
140 7         28 $filename_match = qr/./;
141             }
142              
143 9         9 my @paths;
144 9 100       393 if ( ref $path_arg eq 'ARRAY' ) {
    50          
145              
146             # Ref to array
147 1         1 @paths = @{$path_arg};
  1         2  
148             }
149             elsif ( ref $path_arg eq '' ) {
150              
151             # one path
152 8         16 @paths = ($path_arg);
153             }
154             else {
155              
156             # something else
157 0         0 croak
158             'Argument to list_files must be a single path, or a reference to an array of paths';
159             }
160              
161 9         17 foreach my $path (@paths) {
162              
163             # Die if we got a bad dir.
164 10 100       310 croak "'$path' does not exist" unless -e $path;
165             }
166              
167 8         10 my @files;
168             find(
169             {
170             preprocess => sub {
171             # no GIT, Subversion or CVS directory contents
172 41     41   1469 grep !/^(.git|.svn|CVS)$/, @_,
173             },
174             wanted => sub {
175 126 100   126   3834 push @files, $File::Find::name
176             if -f $File::Find::name;
177             },
178 8         471 no_chdir => 1,
179             },
180             @paths
181             );
182              
183 84         296 @files =
184             sort # sort the files
185 85         722 grep { m/$filename_match/ }
186 8         47 grep { !-l $_ } # no symbolic links
187             @files;
188              
189 8         53 return @files;
190             }
191              
192             sub load_file {
193 70     70 0 980 my $filename = shift;
194              
195             # If the file is not regular then return undef.
196 70 100       1792 return undef unless -f $filename;
197              
198             # Slurp the file.
199 69 50       2568 open(my $fh, '<', $filename) || croak "error reading $filename $!";
200 69         94 my $content = do { local $/; <$fh> };
  69         697  
  69         1197  
201 69         474 close $fh;
202 69         353 return $content;
203             }
204              
205             1;
206              
207             =pod
208              
209             =encoding UTF-8
210              
211             =head1 NAME
212              
213             Test::Fixme - Check code for FIXMEs.
214              
215             =head1 VERSION
216              
217             version 0.14_01
218              
219             =head1 SYNOPSIS
220              
221             # In a test script like 't/test-fixme.t'
222             use Test::Fixme;
223             run_tests();
224            
225             # You can also tailor the behaviour.
226             use Test::Fixme;
227             run_tests( where => 'lib', # where to find files to check
228             match => 'TODO', # what to check for
229             skip_all => $ENV{SKIP} # should all tests be skipped
230             );
231              
232             =head1 DESCRIPTION
233              
234             When coding it is common to come up against problems that need to be
235             addressed but that are not a big deal at the moment. What generally
236             happens is that the coder adds comments like:
237              
238             # FIXME - what about windows that are bigger than the screen?
239              
240             # FIXME - add checking of user privileges here.
241              
242             L allows you to add a test file that ensures that none of
243             these get forgotten in the module.
244              
245             =head1 METHODS
246              
247             =head2 run_tests
248              
249             By default run_tests will search for 'FIXME' in all the files it can
250             find in the project. You can change these defaults by using 'where' or
251             'match' as follows:
252              
253             run_tests( where => 'lib', # just check the modules.
254             match => 'TODO' # look for things that are not done yet.
255             );
256              
257             =over 4
258              
259             =item where
260              
261             Specifies where to search for files. This can be a scalar containing a
262             single directory name, or it can be a list reference containing multiple
263             directory names.
264              
265             =item match
266              
267             Expression to search for within the files. This may be a simple
268             string, or a qr//-quoted regular expression. For example:
269              
270             match => qr/[T]ODO|[F]IXME|[B]UG/,
271              
272             =item filename_match
273              
274             Expression to filter file names. This should be a qr//-quoted regular
275             expression. For example:
276              
277             match => qr/\.(:pm|pl)$/,
278              
279             would only match .pm and .pl files under your specified directory.
280              
281             =item manifest
282              
283             Specifies the name of your MANIFEST file which will be used as the list
284             of files to test instead of I or I.
285              
286             manifest => 'MANIFEST',
287              
288             =item warn
289              
290             Do not fail when a FIXME or other pattern is matched. Tests that would
291             have been failures will still issue a diagnostic that will be viewed
292             when you run C without C<-v>, C or C<./Build test>.
293              
294             =item format
295              
296             Specifies how the found bad patterns will be displayed.
297              
298             =over 4
299              
300             =item original
301              
302             The original and currently default format looks something like this:
303              
304             # File: './lib/Test/Fixme.pm'
305             # 16 # ABSTRACT: Check code for FIXMEs.
306             # 25 $args{match} = 'FIXME' unless defined $args{match} && length $args{match};
307             # 28 $args{format} ||= $ENV{TEST_FIXME_FORMAT};
308             # 228 # FIXME - what about windows that are bigger than the screen?
309             # 230 # FIXME - add checking of user privileges here.
310             # 239 By default run_tests will search for 'FIXME' in all the files it can
311             # 280 Do not fail when a FIXME or other pattern is matched. Tests that would
312             # 288 If you want to match something other than 'FIXME' then you may find
313             # 296 run_tests( skip_all => $ENV{SKIP_TEST_FIXME} );
314             # 303 L
315              
316             With the line numbers on the left and the offending text on the right.
317              
318             =item perl
319              
320             The "perl" format is that used by Perl itself to report warnings and errors.
321              
322             # Pattern found at file ./lib/Test/Fixme.pm at 16:
323             # # ABSTRACT: Check code for FIXMEs.
324             # Pattern found at file ./lib/Test/Fixme.pm at 25:
325             # $args{match} = 'FIXME' unless defined $args{match} && length $args{match};
326             # Pattern found at file ./lib/Test/Fixme.pm at 28:
327             # $args{format} ||= $ENV{TEST_FIXME_FORMAT};
328             # Pattern found at file ./lib/Test/Fixme.pm at 228:
329             # # FIXME - what about windows that are bigger than the screen?
330             # Pattern found at file ./lib/Test/Fixme.pm at 230:
331             # # FIXME - add checking of user privileges here.
332             # Pattern found at file ./lib/Test/Fixme.pm at 239:
333             # By default run_tests will search for 'FIXME' in all the files it can
334             # Pattern found at file ./lib/Test/Fixme.pm at 280:
335             # Do not fail when a FIXME or other pattern is matched. Tests that would
336             # Pattern found at file ./lib/Test/Fixme.pm at 288:
337             # If you want to match something other than 'FIXME' then you may find
338             # Pattern found at file ./lib/Test/Fixme.pm at 296:
339             # run_tests( skip_all => $ENV{SKIP_TEST_FIXME} );
340             # Pattern found at file ./lib/Test/Fixme.pm at 303:
341             # L
342              
343             For files that contain many offending patterns it may be a bit harder to read for
344             humans, but easier to parse for IDEs.
345              
346             =back
347              
348             You may also use the C environment variable to override either
349             the default or the value specified in the test file.
350              
351             =back
352              
353             =head1 HINTS
354              
355             If you want to match something other than 'FIXME' then you may find
356             that the test file itself is being caught. Try doing this:
357              
358             run_tests( match => 'TO'.'DO' );
359              
360             You may also wish to suppress the tests - try this:
361              
362             use Test::Fixme;
363             run_tests( skip_all => $ENV{SKIP_TEST_FIXME} );
364              
365             You can only run run_tests once per file. Please use several test
366             files if you want to run several different tests.
367              
368             =head1 SEE ALSO
369              
370             L
371              
372             =head1 ACKNOWLEDGMENTS
373              
374             Dave O'Neill added support for 'filename_match' and also being able to pass a
375             list of several directories in the 'where' argument. Many thanks.
376              
377             =head1 AUTHOR
378              
379             Original author: Edmund von der Burg
380              
381             Current maintainer: Graham Ollis Eplicease@cpan.orgE
382              
383             Contributors:
384              
385             Dave O'Neill
386              
387             gregor herrmann Egregoa@debian.orgE
388              
389             =head1 COPYRIGHT AND LICENSE
390              
391             This software is copyright (c) 2015 by Edmund von der Burg , Graham Ollis .
392              
393             This is free software; you can redistribute it and/or modify it under
394             the same terms as the Perl 5 programming language system itself.
395              
396             =cut
397              
398             __END__