1 ##############################################################################
2 # $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/TestUtils.pm $
3 # $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
6 ##############################################################################
8 package Perl::Critic::TestUtils;
13 use English qw(-no_match_vars);
20 use File::Spec::Unix ();
22 use File::Find qw( find );
25 use Perl::Critic::Config;
26 use Perl::Critic::Exception::Fatal::Generic qw{ &throw_generic };
27 use Perl::Critic::Exception::Fatal::Internal qw{ &throw_internal };
28 use Perl::Critic::Utils qw{ :severities :data_conversion policy_long_name };
29 use Perl::Critic::PolicyFactory (-test => 1);
31 our $VERSION = '1.088';
33 Readonly::Array our @EXPORT_OK => qw(
34 pcritique pcritique_with_violations
35 critique critique_with_violations
36 fcritique fcritique_with_violations
38 should_skip_author_tests
39 get_author_test_skip_message
40 starting_points_including_examples
42 names_of_policies_willing_to_work
45 #-----------------------------------------------------------------------------
46 # If the user already has an existing perlcriticrc file, it will get
47 # in the way of these test. This little tweak to ensures that we
48 # don't find the perlcriticrc file.
50 sub block_perlcriticrc {
51 no warnings 'redefine'; ## no critic (ProhibitNoWarnings);
52 *Perl::Critic::UserProfile::_find_profile_path = sub { return }; ## no critic (ProtectPrivateVars)
56 #-----------------------------------------------------------------------------
57 # Criticize a code snippet using only one policy. Returns the violations.
59 sub pcritique_with_violations {
60 my($policy, $code_ref, $config_ref) = @_;
61 my $c = Perl::Critic->new( -profile => 'NONE' );
62 $c->add_policy(-policy => $policy, -config => $config_ref);
63 return $c->critique($code_ref);
66 #-----------------------------------------------------------------------------
67 # Criticize a code snippet using only one policy. Returns the number
70 sub pcritique { ##no critic(ArgUnpacking)
71 return scalar pcritique_with_violations(@_);
74 #-----------------------------------------------------------------------------
75 # Criticize a code snippet using a specified config. Returns the violations.
77 sub critique_with_violations {
78 my ($code_ref, $config_ref) = @_;
79 my $c = Perl::Critic->new( %{$config_ref} );
80 return $c->critique($code_ref);
83 #-----------------------------------------------------------------------------
84 # Criticize a code snippet using a specified config. Returns the
85 # number of violations
87 sub critique { ##no critic(ArgUnpacking)
88 return scalar critique_with_violations(@_);
91 #-----------------------------------------------------------------------------
92 # Like pcritique_with_violations, but forces a PPI::Document::File context.
93 # The $filename arg is a Unix-style relative path, like 'Foo/Bar.pm'
95 Readonly::Scalar my $TEMP_FILE_PERMISSIONS => oct 700;
97 sub fcritique_with_violations {
98 my($policy, $code_ref, $filename, $config_ref) = @_;
99 my $c = Perl::Critic->new( -profile => 'NONE' );
100 $c->add_policy(-policy => $policy, -config => $config_ref);
102 my $dir = File::Temp::tempdir( 'PerlCritic-tmpXXXXXX', TMPDIR => 1 );
103 $filename ||= 'Temp.pm';
104 my @fileparts = File::Spec::Unix->splitdir($filename);
105 if (@fileparts > 1) {
106 my $subdir = File::Spec->catdir($dir, @fileparts[0..$#fileparts-1]);
107 File::Path::mkpath($subdir, 0, $TEMP_FILE_PERMISSIONS);
109 my $file = File::Spec->catfile($dir, @fileparts);
110 if (open my $fh, '>', $file) {
111 print {$fh} ${$code_ref};
112 close $fh or throw_generic "unable to close $file: $!";
115 # Use eval so we can clean up before throwing an exception in case of
117 my @v = eval {$c->critique($file)};
118 my $err = $EVAL_ERROR;
119 File::Path::rmtree($dir, 0, 1);
126 #-----------------------------------------------------------------------------
127 # Like pcritique, but forces a PPI::Document::File context. The
128 # $filename arg is a Unix-style relative path, like 'Foo/Bar.pm'
130 sub fcritique { ##no critic(ArgUnpacking)
131 return scalar fcritique_with_violations(@_);
134 sub subtests_in_tree {
139 find( {wanted => sub {
141 my ($fileroot) = m{(.+)[.]run\z}mx;
142 return if !$fileroot;
143 my @pathparts = File::Spec->splitdir($fileroot);
144 if (@pathparts < 2) {
145 throw_internal 'confusing policy test filename ' . $_;
147 my $policy = join q{::}, @pathparts[-2, -1]; ## no critic (MagicNumbers)
149 my @subtests = _subtests_from_file( $_ );
150 $subtests{ $policy } = [ @subtests ];
151 }, no_chdir => 1}, $start );
155 # Answer whether author test should be run.
157 # Note: this code is duplicated in
158 # t/tlib/Perl/Critic/TestUtilitiesWithMinimalDependencies.pm.
159 # If you change this here, make sure to change it there.
161 sub should_skip_author_tests {
162 return not $ENV{TEST_AUTHOR_PERL_CRITIC}
165 sub get_author_test_skip_message {
166 ## no critic (RequireInterpolation);
167 return 'Author test. Set $ENV{TEST_AUTHOR_PERL_CRITIC} to a true value to run.';
171 sub starting_points_including_examples {
172 return (-e 'blib' ? 'blib' : 'lib', 'examples');
175 # The internal representation of a subtest is just a hash with some
176 # named keys. It could be an object with accessors for safety's sake,
177 # but at this point I don't see why.
179 sub _subtests_from_file {
180 my $test_file = shift;
182 my %valid_keys = hashify qw( name failures parms TODO error filename optional_modules );
184 return if -z $test_file; # Skip if the Policy has a regular .t file.
186 open my $fh, '<', $test_file ## no critic (RequireBriefOpen)
187 or throw_internal "Couldn't open $test_file: $OS_ERROR";
197 my $inheader = /^## name/ .. /^## cut/; ## no critic(RegularExpression)
202 $line =~ m/\A [#]/mx or throw_internal "Code before cut: $test_file";
203 my ($key,$value) = $line =~ m/\A [#][#] [ ] (\S+) (?:\s+(.+))? /mx;
205 next if $key eq 'cut';
206 if ( not $valid_keys{$key} ) {
207 throw_internal "Unknown key $key in $test_file";
210 if ( $key eq 'name' ) {
211 if ( $subtest ) { # Stash any current subtest
212 push @subtests, _finalize_subtest( $subtest );
215 $subtest->{lineno} = $lineno;
219 throw_internal "Header line found while still in code: $test_file";
221 $subtest->{$key} = $value;
225 # Don't start a subtest if we're not in one
226 push @{$subtest->{code}}, $line;
229 ## don't complain if we have not yet hit the first test
230 throw_internal "Got some code but I'm not in a subtest: $test_file";
233 close $fh or throw_generic "unable to close $test_file: $!";
236 push @subtests, _finalize_subtest( $subtest );
239 throw_internal "Incomplete subtest in $test_file";
246 sub _finalize_subtest {
249 if ( $subtest->{code} ) {
250 $subtest->{code} = join "\n", @{$subtest->{code}};
253 throw_internal "$subtest->{name} has no code lines";
255 if ( !defined $subtest->{failures} ) {
256 throw_internal "$subtest->{name} does not specify failures";
258 if ($subtest->{parms}) {
259 $subtest->{parms} = eval $subtest->{parms}; ## no critic(StringyEval)
262 "$subtest->{name} has an error in the 'parms' property:\n"
265 if ('HASH' ne ref $subtest->{parms}) {
267 "$subtest->{name} 'parms' did not evaluate to a hashref";
270 $subtest->{parms} = {};
273 if (defined $subtest->{error}) {
274 if ( $subtest->{error} =~ m{ \A / (.*) / \z }xms) {
275 $subtest->{error} = eval {qr/$1/}; ##no critic (RegularExpressions::)
278 "$subtest->{name} 'error' has a malformed regular expression";
286 sub bundled_policy_names {
287 require ExtUtils::Manifest;
288 my $manifest = ExtUtils::Manifest::maniread();
289 my @policy_paths = map {m{\A lib/(Perl/Critic/Policy/.*).pm \z}mx} keys %{$manifest};
290 my @policies = map { join q{::}, split m{/}mx, $_} @policy_paths;
291 return sort @policies;
294 sub names_of_policies_willing_to_work {
295 my %configuration = @_;
297 my @policies_willing_to_work =
299 ->new( %configuration )
302 return map { ref $_ } @policies_willing_to_work;
309 #-----------------------------------------------------------------------------
313 =for stopwords subtest subtests
317 Perl::Critic::TestUtils - Utility functions for testing new Policies.
321 use Perl::Critic::TestUtils qw(critique pcritique fcritique);
323 my $code = '<<END_CODE';
330 # Critique code against all loaded policies...
331 my $perl_critic_config = { -severity => 2 };
332 my $violation_count = critique( \$code, $perl_critic_config);
334 # Critique code against one policy...
335 my $custom_policy = 'Miscellanea::ProhibitFrobulation'
336 my $violation_count = pcritique( $custom_policy, \$code );
338 # Critique code against one filename-related policy...
339 my $custom_policy = 'Modules::RequireFilenameMatchesPackage'
340 my $violation_count = fcritique( $custom_policy, \$code, 'Foo/Bar.pm' );
344 This module is used by L<Perl::Critic> only for self-testing. It
345 provides a few handy subroutines for testing new Perl::Critic::Policy
346 modules. Look at the test scripts that ship with Perl::Critic for
347 more examples of how to use these subroutines.
353 =item block_perlcriticrc()
355 If a user has a F<~/.perlcriticrc> file, this can interfere with testing.
356 This handy method disables the search for that file -- simply call it at the
357 top of your F<.t> program. Note that this is not easily reversible, but that
360 =item critique_with_violations( $code_string_ref, $config_ref )
362 Test a block of code against the specified Perl::Critic::Config instance (or
363 C<undef> for the default). Returns the violations that occurred.
365 =item critique( $code_string_ref, $config_ref )
367 Test a block of code against the specified Perl::Critic::Config instance (or
368 C<undef> for the default). Returns the number of violations that occurred.
370 =item pcritique_with_violations( $policy_name, $code_string_ref, $config_ref )
372 Like C<critique_with_violations()>, but tests only a single policy instead of
375 =item pcritique( $policy_name, $code_string_ref, $config_ref )
377 Like C<critique()>, but tests only a single policy instead of the whole bunch.
379 =item fcritique_with_violations( $policy_name, $code_string_ref, $filename, $config_ref )
381 Like C<pcritique_with_violations()>, but pretends that the code was loaded
382 from the specified filename. This is handy for testing policies like
383 C<Modules::RequireFilenameMatchesPackage> which care about the filename that
384 the source derived from.
386 The C<$filename> parameter must be a relative path, not absolute. The file
387 and all necessary subdirectories will be created via L<File::Temp> and will be
388 automatically deleted.
390 =item fcritique( $policy_name, $code_string_ref, $filename, $config_ref )
392 Like C<pcritique()>, but pretends that the code was loaded from the specified
393 filename. This is handy for testing policies like
394 C<Modules::RequireFilenameMatchesPackage> which care about the filename that
395 the source derived from.
397 The C<$filename> parameter must be a relative path, not absolute. The file
398 and all necessary subdirectories will be created via L<File::Temp> and will be
399 automatically deleted.
401 =item subtests_in_tree( $dir )
403 Searches the specified directory recursively for F<.run> files. Each one
404 found is parsed and a hash-of-list-of-hashes is returned. The outer hash is
405 keyed on policy short name, like C<Modules::RequireEndWithOne>. The inner
406 hash specifies a single test to be handed to C<pcritique()> or C<fcritique()>,
407 including the code string, test name, etc. See below for the syntax of the
410 =item should_skip_author_tests()
412 Answers whether author tests should run.
414 =item get_author_test_skip_message()
416 Returns a string containing the message that should be emitted when a test
417 is skipped due to it being an author test when author tests are not enabled.
419 =item starting_points_including_examples()
421 Returns a list of the directories contain code that needs to be tested when it
422 is desired that the examples be included.
424 =item bundled_policy_names()
426 Returns a list of Policy packages that come bundled with this package. This
427 functions by searching F<MANIFEST> for F<lib/Perl/Critic/Policy/*.pm> and
428 converts the results to package names.
430 =item names_of_policies_willing_to_work( %configuration )
432 Returns a list of the packages of policies that are willing to function on
433 the current system using the specified configuration.
437 =head1 F<.run> file information
439 Testing a policy follows a very simple pattern:
443 * Optional parameters
444 * Number of failures expected
445 * Optional exception expected
446 * Optional filename for code
448 Each of the subtests for a policy is collected in a single F<.run> file, with
449 test properties as comments in front of each code block that describes how we expect
450 Perl::Critic to react to the code. For example, say you have a policy called
451 Variables::ProhibitVowels:
453 (In file t/Variables/ProhibitVowels.run)
459 my $vrbl_nm = 'foo'; # Good, vowel-free name
460 my $wango = 12; # Bad, pronouncable name
467 my $yllw = 0; # "y" not a vowel here
468 my $rhythm = 12; # But here it is
470 These are called "subtests", and two are shown above. The beauty of
471 incorporating multiple subtests in a file is that the F<.run> is itself a
472 (mostly) valid Perl file, and not hidden in a HEREDOC, so your editor's
473 color-coding still works, and it is much easier to work with the code and the
476 If you need to pass any configuration parameters for your subtest, do so like
479 ## parms { allow_y => '0' }
481 Note that all the values in this hash must be strings because that's what
482 Perl::Critic will hand you from a F<.perlcriticrc>.
484 If it's a TODO subtest (probably because of some weird corner of
485 PPI that we exercised that Adam is getting around to fixing, right?),
486 then make a C<##TODO> entry.
488 ## TODO Should pass when PPI 1.xxx comes out
490 If the code is expected to trigger an exception in the policy, indicate that
495 If you want to test the error message, mark it with C</.../> to indicate a
498 ## error /Can't load Foo::Bar/
500 If the policy you are testing cares about the filename of the code, you can
501 indicate that C<fcritique> should be used like so (see C<fcritique> for more
504 ## filename lib/Foo/Bar.pm
506 The value of C<parms> will get C<eval>ed and passed to C<pcritique()>,
509 Note that nowhere within the F<.run> file itself do you specify the
510 policy that you're testing. That's implicit within the filename.
512 =head1 BUGS AND CAVEATS AND TODO ITEMS
514 Test that we have a t/*/*.run for each lib/*/*.pm
516 Allow us to specify the nature of the failures, and which one. If
517 there are 15 lines of code, and six of them fail, how do we know
518 they're the right six?
522 Chris Dolan <cdolan@cpan.org>
523 and the rest of the L<Perl::Critic> team.
527 Copyright (c) 2005-2008 Chris Dolan. All rights reserved.
529 This program is free software; you can redistribute it and/or modify
530 it under the same terms as Perl itself. The full text of this license
531 can be found in the LICENSE file included with this module.
537 # cperl-indent-level: 4
539 # indent-tabs-mode: nil
540 # c-indentation-style: bsd
542 # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :