1package Test::Perl::Critic; 2 3use 5.006001; 4 5use strict; 6use warnings; 7 8use Carp qw(croak); 9use English qw(-no_match_vars); 10 11use Test::Builder qw(); 12use Perl::Critic qw(); 13use Perl::Critic::Violation qw(); 14use Perl::Critic::Utils; 15 16#--------------------------------------------------------------------------- 17 18our $VERSION = '1.04'; 19 20#--------------------------------------------------------------------------- 21 22my $TEST = Test::Builder->new; 23my $DIAG_INDENT = q{ }; 24my %CRITIC_ARGS = (); 25 26my $CRITIC_OBJ = undef; 27my $BUILD_CRITIC = sub { 28 return $CRITIC_OBJ if defined $CRITIC_OBJ; 29 $CRITIC_OBJ = Perl::Critic->new( @_ ); 30}; 31 32#--------------------------------------------------------------------------- 33 34sub import { 35 36 my ( $self, %args ) = @_; 37 my $caller = caller; 38 39 { 40 no strict 'refs'; ## no critic qw(ProhibitNoStrict) 41 *{ $caller . '::critic_ok' } = \&critic_ok; 42 *{ $caller . '::all_critic_ok' } = \&all_critic_ok; 43 } 44 45 # -format is supported for backward compatibility. 46 if ( exists $args{-format} ) { $args{-verbose} = $args{-format}; } 47 %CRITIC_ARGS = %args; 48 49 # Reset possibly lazy-initialized Perl::Critic. 50 $CRITIC_OBJ = undef; 51 52 $TEST->exported_to($caller); 53 54 return 1; 55} 56 57#--------------------------------------------------------------------------- 58 59sub critic_ok { 60 61 my ( $file, $test_name ) = @_; 62 croak q{no file specified} if not defined $file; 63 croak qq{"$file" does not exist} if not -f $file; 64 $test_name ||= qq{Test::Perl::Critic for "$file"}; 65 66 my $critic = undef; 67 my @violations = (); 68 my $ok = 0; 69 70 # Run Perl::Critic 71 my $status = eval { 72 $critic = $BUILD_CRITIC->( %CRITIC_ARGS ); 73 @violations = $critic->critique( $file ); 74 $ok = not scalar @violations; 75 1; 76 }; 77 78 # Evaluate results 79 $TEST->ok($ok, $test_name ); 80 81 if (!$status || $EVAL_ERROR) { # Trap exceptions from P::C 82 $TEST->diag( "\n" ); # Just to get on a new line. 83 $TEST->diag( qq{Perl::Critic had errors in "$file":} ); 84 $TEST->diag( qq{\t$EVAL_ERROR} ); 85 } 86 elsif ( not $ok ) { # Report Policy violations 87 $TEST->diag( "\n" ); # Just to get on a new line. 88 my $verbose = $critic->config->verbose(); 89 Perl::Critic::Violation::set_format( $verbose ); 90 for my $viol (@violations) { $TEST->diag($DIAG_INDENT . $viol) } 91 } 92 93 return $ok; 94} 95 96#--------------------------------------------------------------------------- 97 98sub all_critic_ok { 99 100 my @dirs_or_files = @_ ? @_ : (-e 'blib' ? 'blib' : 'lib'); 101 my @files = Perl::Critic::Utils::all_perl_files(@dirs_or_files); 102 croak 'Nothing to critique' if not @files; 103 104 my $have_mce = eval { require MCE::Grep; MCE::Grep->import; 1 }; 105 return $have_mce ? _test_parallel(@files) : _test_serial(@files); 106} 107 108#--------------------------------------------------------------------------- 109 110sub _test_parallel { 111 my @files = @_; 112 113 # Since tests are running in forked MCE workers, test results could arrive 114 # in any order. The test numbers will be meaningless, so turn them off. 115 $TEST->use_numbers(0); 116 117 # The parent won't know about any of the tests that were run by the forked 118 # workers. So we disable the T::B sanity checks at the end of its life. 119 $TEST->no_ending(1); 120 121 my $okays = MCE::Grep->run( sub { critic_ok($_) }, @files ); 122 my $pass = $okays == @files; 123 124 # To make Test::Harness happy, we must emit a test plan and a sensible exit 125 # status. Usually, T::B does this for us, but we disabled the ending above. 126 $pass || eval 'END { $? = 1 }'; ## no critic qw(Eval Interpolation) 127 $TEST->done_testing(scalar @files); 128 129 return $pass; 130} 131 132#--------------------------------------------------------------------------- 133 134sub _test_serial { 135 my @files = @_; 136 137 my $okays = grep {critic_ok($_)} @files; 138 my $pass = $okays == @files; 139 140 $TEST->done_testing(scalar @files); 141 142 return $pass; 143} 144 145#--------------------------------------------------------------------------- 146 1471; 148 149 150__END__ 151 152=pod 153 154=for stopwords API 155 156=head1 NAME 157 158Test::Perl::Critic - Use Perl::Critic in test programs 159 160=head1 SYNOPSIS 161 162Test one file: 163 164 use Test::Perl::Critic; 165 use Test::More tests => 1; 166 critic_ok($file); 167 168Or test all files in one or more directories: 169 170 use Test::Perl::Critic; 171 all_critic_ok($dir_1, $dir_2, $dir_N ); 172 173Or test all files in a distribution: 174 175 use Test::Perl::Critic; 176 all_critic_ok(); 177 178Recommended usage for CPAN distributions: 179 180 use strict; 181 use warnings; 182 use File::Spec; 183 use Test::More; 184 use English qw(-no_match_vars); 185 186 if ( not $ENV{TEST_AUTHOR} ) { 187 my $msg = 'Author test. Set $ENV{TEST_AUTHOR} to a true value to run.'; 188 plan( skip_all => $msg ); 189 } 190 191 eval { require Test::Perl::Critic; }; 192 193 if ( $EVAL_ERROR ) { 194 my $msg = 'Test::Perl::Critic required to criticise code'; 195 plan( skip_all => $msg ); 196 } 197 198 my $rcfile = File::Spec->catfile( 't', 'perlcriticrc' ); 199 Test::Perl::Critic->import( -profile => $rcfile ); 200 all_critic_ok(); 201 202 203=head1 DESCRIPTION 204 205Test::Perl::Critic wraps the L<Perl::Critic> engine in a convenient subroutine 206suitable for test programs written using the L<Test::More> framework. This 207makes it easy to integrate coding-standards enforcement into the build 208process. For ultimate convenience (at the expense of some flexibility), see 209the L<criticism> pragma. 210 211If you have an large existing code base, you might prefer to use 212L<Test::Perl::Critic::Progressive>, which allows you to clean your code 213incrementally instead of all at once.. 214 215If you'd like to try L<Perl::Critic> without installing anything, there is a 216web-service available at L<http://perlcritic.com>. The web-service does not 217support all the configuration features that are available in the native 218Perl::Critic API, but it should give you a good idea of what Perl::Critic can 219do. 220 221=head1 SUBROUTINES 222 223=over 224 225=item all_critic_ok( [ @FILES ] ) 226 227Runs C<critic_ok()> for all Perl files in the list of C<@FILES>. If a file is 228actually a directory, then all Perl files beneath that directory (recursively) 229will be run through C<critic_ok()>. If C<@FILES> is empty or not given, then the 230F<blib/> is used if it exists, and if not, then F<lib/> is used. Returns true 231if all files are okay, or false if any file fails. 232 233This subroutine emits its own test plan, so you do not need to specify the 234expected number of tests or call C<done_testing()>. Therefore, C<all_critic_ok> 235generally cannot be used in a test script that includes other sorts of tests. 236 237C<all_critic_ok()> is also optimized to run tests in parallel over multiple cores 238(if you have them) so it is usually better to call this function than calling 239C<critic_ok()> directly. 240 241=item critic_ok( $FILE [, $TEST_NAME ] ) 242 243Okays the test if Perl::Critic does not find any violations in C<$FILE>. If it 244does, the violations will be reported in the test diagnostics. The optional 245second argument is the name of test, which defaults to "Perl::Critic test for 246$FILE". 247 248If you use this form, you should load L<Test::More> and emit your own test plan 249first or call C<done_testing()> afterwards. 250 251=back 252 253=head1 CONFIGURATION 254 255L<Perl::Critic> is highly configurable. By default, Test::Perl::Critic 256invokes Perl::Critic with its default configuration. But if you have 257developed your code against a custom Perl::Critic configuration, you will want 258to configure Test::Perl::Critic to do the same. 259 260Any arguments passed through the C<use> pragma (or via 261C<< Test::Perl::Critic->import() >> )will be passed into the L<Perl::Critic> 262constructor. So if you have developed your code using a custom 263F<~/.perlcriticrc> file, you can direct L<Test::Perl::Critic> to use your 264custom file too. 265 266 use Test::Perl::Critic (-profile => 't/perlcriticrc'); 267 all_critic_ok(); 268 269Now place a copy of your own F<~/.perlcriticrc> file in the distribution as 270F<t/perlcriticrc>. Then, C<critic_ok()> will be run on all Perl files in this 271distribution using this same Perl::Critic configuration. See the 272L<Perl::Critic> documentation for details on the F<.perlcriticrc> file format. 273 274Any argument that is supported by the L<Perl::Critic> constructor can be 275passed through this interface. For example, you can also set the minimum 276severity level, or include & exclude specific policies like this: 277 278 use Test::Perl::Critic (-severity => 2, -exclude => ['RequireRcsKeywords']); 279 all_critic_ok(); 280 281See the L<Perl::Critic> documentation for complete details on its 282options and arguments. 283 284=head1 DIAGNOSTIC DETAILS 285 286By default, Test::Perl::Critic displays basic information about each Policy 287violation in the diagnostic output of the test. You can customize the format 288and content of this information by using the C<-verbose> option. This behaves 289exactly like the C<-verbose> switch on the F<perlcritic> program. For 290example: 291 292 use Test::Perl::Critic (-verbose => 6); 293 294 #or... 295 296 use Test::Perl::Critic (-verbose => '%f: %m at %l'); 297 298If given a number, L<Test::Perl::Critic> reports violations using one of the 299predefined formats described below. If given a string, it is interpreted to be 300an actual format specification. If the C<-verbose> option is not specified, it 301defaults to 3. 302 303 Verbosity Format Specification 304 ----------- ------------------------------------------------------- 305 1 "%f:%l:%c:%m\n", 306 2 "%f: (%l:%c) %m\n", 307 3 "%m at %f line %l\n", 308 4 "%m at line %l, column %c. %e. (Severity: %s)\n", 309 5 "%f: %m at line %l, column %c. %e. (Severity: %s)\n", 310 6 "%m at line %l, near '%r'. (Severity: %s)\n", 311 7 "%f: %m at line %l near '%r'. (Severity: %s)\n", 312 8 "[%p] %m at line %l, column %c. (Severity: %s)\n", 313 9 "[%p] %m at line %l, near '%r'. (Severity: %s)\n", 314 10 "%m at line %l, column %c.\n %p (Severity: %s)\n%d\n", 315 11 "%m at line %l, near '%r'.\n %p (Severity: %s)\n%d\n" 316 317Formats are a combination of literal and escape characters similar to the way 318C<sprintf> works. See L<String::Format> for a full explanation of the 319formatting capabilities. Valid escape characters are: 320 321 Escape Meaning 322 ------- ---------------------------------------------------------------- 323 %c Column number where the violation occurred 324 %d Full diagnostic discussion of the violation (DESCRIPTION in POD) 325 %e Explanation of violation or page numbers in PBP 326 %F Just the name of the logical file where the violation occurred. 327 %f Path to the logical file where the violation occurred. 328 %G Just the name of the physical file where the violation occurred. 329 %g Path to the physical file where the violation occurred. 330 %l Logical line number where the violation occurred 331 %L Physical line number where the violation occurred 332 %m Brief description of the violation 333 %P Full name of the Policy module that created the violation 334 %p Name of the Policy without the Perl::Critic::Policy:: prefix 335 %r The string of source code that caused the violation 336 %C The class of the PPI::Element that caused the violation 337 %s The severity level of the violation 338 339 340=head1 CAVEATS 341 342Despite the convenience of using a test script to enforce your coding 343standards, there are some inherent risks when distributing those tests to 344others. Since you don't know which version of L<Perl::Critic> the end-user 345has and whether they have installed any additional Policy modules, you can't 346really be sure that your code will pass the Test::Perl::Critic tests on 347another machine. 348 349B<For these reasons, we strongly advise you to make your perlcritic tests 350optional, or exclude them from the distribution entirely.> 351 352The recommended usage in the L<"SYNOPSIS"> section illustrates one way to make 353your F<perlcritic.t> test optional. Another option is to put F<perlcritic.t> 354and other author-only tests in a separate directory (F<xt/> seems to be 355common), and then use a custom build action when you want to run them. Also, 356you should B<not> list Test::Perl::Critic as a requirement in your build 357script. These tests are only relevant to the author and should not be a 358prerequisite for end-use. 359 360See L<http://chrisdolan.net/talk/2005/11/14/private-regression-tests/> 361for an interesting discussion about Test::Perl::Critic and other types 362of author-only regression tests. 363 364=head1 FOR Dist::Zilla USERS 365 366If you use Test::Perl::Critic with L<Dist::Zilla>, beware that some DZ plugins 367may mutate your code in ways that are not compliant with your Perl::Critic 368rules. In particular, the standard L<Dist::Zilla::Plugin::PkgVersion> will 369inject a C<$VERSION> declaration at the top of the file, which will violate 370L<Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict>. One solution 371is to use the L<Dist::Zilla::Plugin::OurPkgVersion> which allows you to control 372where the C<$VERSION> declaration appears. 373 374=head1 EXPORTS 375 376 critic_ok() 377 all_critic_ok() 378 379=head1 BUGS 380 381If you find any bugs, please submit them to 382L<https://github.com/Perl-Critic/Test-Perl-Critic/issues>. Thanks. 383 384 385=head1 SEE ALSO 386 387L<Module::Starter::PBP> 388 389L<Perl::Critic> 390 391L<Test::More> 392 393=head1 CREDITS 394 395Andy Lester, whose L<Test::Pod> module provided most of the code and 396documentation for Test::Perl::Critic. Thanks, Andy. 397 398=head1 AUTHOR 399 400Jeffrey Ryan Thalhammer <jeff@thaljef.org> 401 402=head1 COPYRIGHT 403 404Copyright (c) 2005-2018 Jeffrey Ryan Thalhammer. 405 406This program is free software; you can redistribute it and/or modify 407it under the same terms as Perl itself. The full text of this license 408can be found in the LICENSE file included with this module. 409 410=cut 411 412############################################################################## 413# Local Variables: 414# mode: cperl 415# cperl-indent-level: 4 416# fill-column: 78 417# indent-tabs-mode: nil 418# c-indentation-style: bsd 419# End: 420# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : 421