commit e3ffca65c1b77b0ecf02cce26c4ec9add4e394af Author: denghao Date: Tue Sep 27 11:33:17 2022 +0300 Import Upstream version 1.140 diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..58709e4 --- /dev/null +++ b/Build.PL @@ -0,0 +1,99 @@ +use 5.006001; + +use strict; +use warnings; + +use Module::Build; +# meta_merge->resources->license now takes an arrayref of URLs in 0.4200 (or +# thereabouts, but I can't tell for sure from the Changes file). + +use lib 'inc'; + +use Perl::Critic::BuildUtilities qw< + required_module_versions + build_required_module_versions + emit_tar_warning_if_necessary + get_PL_files +>; +use Perl::Critic::Module::Build; + + +emit_tar_warning_if_necessary(); + + +my $builder = Perl::Critic::Module::Build->new( + module_name => 'Perl::Critic', + dist_author => 'Jeffrey Thalhammer ', + dist_abstract => 'Critique Perl source code for best-practices.', + license => 'perl', + dynamic_config => 1, + create_readme => 1, + create_packlist => 1, + sign => 0, + + requires => { required_module_versions() }, + build_requires => { build_required_module_versions() }, + + # Don't require a developer version of Module::Build, even if the + # distribution tarball was created with one. (Oops.) + configure_requires => { + 'Module::Build' => '0.4204', + }, + + PL_files => get_PL_files(), + + script_files => ['bin/perlcritic'], + + meta_merge => { + resources => { + bugtracker => 'https://github.com/Perl-Critic/Perl-Critic/issues', + homepage => 'http://perlcritic.com', + license => [ 'http://dev.perl.org/licenses' ], + MailingList => 'https://groups.google.com/d/forum/perl-critic', + repository => 'git://github.com/Perl-Critic/Perl-Critic.git', + }, + no_index => { + file => [ + qw< + TODO.pod + > + ], + directory => [ + qw< + doc + inc + tools + xt + > + ], + }, + x_authority => 'cpan:CRITICRE', + }, + + add_to_cleanup => [ + qw< + Debian_CPANTS.txt + Makefile + Makefile.old + MANIFEST.bak + META.json + META.yml + pm_to_blib + README + >, + values %{ get_PL_files() }, + ], +); + +$builder->create_build_script(); + + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 0000000..e9d1b88 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,26 @@ +# Contributing to Perl::Critic + +These are the guidelines for contributing to the Perl::Critic repository. + +## Issues + +File an issue if you think you've found a bug. Please describe + +1. How can it be reproduced +2. What was expected +3. What actually occurred +4. What version of the involved component + +## Patches + +Patches for fixes, features, and improvements are accepted via pull requests. + +Pull requests should be based on the **dev branch**, unless you want to contribute to an active branch for a specific topic. + +All contributions are welcome and most will be accepted. + +Please see the [developer guidelines](https://github.com/Perl-Critic/Perl-Critic/blob/dev/README.developer) and the complete [developer documentation](https://metacpan.org/pod/Perl::Critic::DEVELOPER). + +## Licensing and copyright + +Please note that accepted contributions are included in the repository and hence under the same license as the repository contributed to. diff --git a/Changes b/Changes new file mode 100644 index 0000000..8af7b07 --- /dev/null +++ b/Changes @@ -0,0 +1,2377 @@ +Revision history for Perl module Perl::Critic + + +1.140 Tue Mar 23 21:42:19 CDT 2021 + + [New Features] + Subroutines::RequireFinalReturn now lets you specify a + terminal_methods parameter to specify methods that should been as + terminal. This is like the terminal_funcs parameter, but for methods. + Thanks, Robin Smidsrød and Mike Bruins. (GH #920) + + +1.139_01 Tue Sep 1 23:52:18 CDT 2020 + + [Fixes] + Removed an extra /x in RequireInterpolationOfMetachars.pm that caused + deprecation warnings in Perl 5.22 and higher. (GH #822) + + Documentation::RequirePackageMatchesPodName now recognizes the package + name if it's in C<< I<> >> or C<< B<> >> markup. Thanks, Renée Bäcker. + (GH #913) + + +1.138 Fri Jan 24 15:50:34 CST 2020 + + Stable release. No changes since 1.137_01. + + +1.137_01 Thu Jan 23 16:44:57 CST 2020 + + [Fixes] + RequireCheckingReturnValueOfEval didn't count returning the result of an + eval as checking it. Now it does. However, it's only if you "return eval + { ... }". It still doesn't handle the case of "return ( eval {} )". + Thanks, Tom Wyant. (GH #324) + + ProhibitPunctuationVars would get confused and think that the expression + qr/SOME$/ was using the $/ special variable. Thanks, Tom Wyan. (GH #843) + + +1.136 Wed Nov 27 09:51:09 CST 2019 + + Stable release. No changes since 1.135_01. + + +1.135_01 Tue Nov 26 14:50:11 CST 2019 + [New Features] + The ProhibitNoWarnings pollicy now handles warnings in the experimental:: + group. Thanks, Renée Bäcker. (GH #892) + + [Documentation] + Prevented some example code from showing up in `perldoc`. Thanks, Tom + Hukins. (GH #799) + + +1.134 Wed May 22 21:17:21 CDT 2019 + + Stable release. No changes since 1.133_02. + + +1.133_02 Mon May 20 10:48:16 CDT 2019 + [New Features] + * Support indented heredocs. Thanks, Gregory Oschwald. (GH#861) + + * In Subroutines::ProhibitManyArgs, you can now omit the object + variable (C<$self> or C<$class>) from the argument count. Thanks, + Szymon Nieznański. (GH#815) + + [Dependencies] + * Removed use of File::HomeDir. Thanks, Karen Etheridge. + + * Upgrade to PPI 1.265. By Will Braswell. (GH#860) + + * Fix failed tests caused by new PPI. Thanks, Szymon Nieznański. + (GH #858) + + [Internals] + * Updated the Appveyor config. Thanks, Roy Ivy III. (GH#851) + + +1.133_01 Thu Oct 25 23:21:31 CDT 2018 + [New Features] + * Added new policy BuiltinFunctions::ProhibitShiftRef. It disallows + this construct that causes a memory leak in Perl 5.21.4 and above: + + my $ref = \shift; + + The documentation for the policy contains details on when this can + happen. Thanks, Todd Rinaldo. (GH#837) + + [Policy Changes] + * The policy Documentation::RequirePodLinksIncludeText is obsolete and + has been removed. Thanks, Salvatore Bonaccorso. (GH#494) + + +1.132 Thu May 31 21:48:48 CDT 2018 + [New Features] + * Added the ability to specify a regex to tell what unused private + subroutines are OK in Subroutines::ProhibitUnusedPrivateSubroutines. + This is handy for Moose classes where there could be many false + positives on _build_xxxx() subroutines. + Thanks, Dave Cross. (GH #811, #812) + + [Dependencies] + * Perl::Critic now no longer relies on the deprecated Email::Address. + Thanks, Giovanni Mariani. (GH #816) + +1.131_02 Tue Feb 20 17:18:03 CST 2018 + [New Features] + * Perl::Critic now assumes that .psgi files are Perl, too. Thanks, Tom + Hukins. (GH#805) + + * Variables::ProhibitUnusedVariables no longer gives a false positive for + variables used in interpolation. Thanks, Omer Gazit. (GH#801) + + [Bug Fixes] + * Added missing requirement for Fatal.pm. + + +1.131_01 Tue Nov 21 17:28:06 CST 2017 + [New Features] + * In the ProhibitLeadingZeros policy, added an exception for mkfifo. + Thanks, Evan Zacks. (GH#786) + + * Add color support for Windows platforms. Thanks, Roy Ivy III. (GH#700) + + [Bug Fixes] + * Recode Perl::Critic::Utils::all_perl_files() to use File::Find instead + of opendir/readdir. This solves endless directory traversals if + the directories contain circular symbolic references. Thanks, Tom Wyant. + + [Documentation] + * Added CONTRIBUTING.md. Thanks, Jonas B. Nielsen. + +1.130 Thu Jul 20 23:16:34 CDT 2017 + [New Features] + * Policies which ensure that system calls are checked such as + RequireCheckedSystemCalls now have an "autodie_modules" setting which + allows you to tell the policy about other modules which export + autodie. Fixes #699. PR #747. Thanks to Dave Rolsky. + +1.128 Sat Jun 10 22:31:28 CDT 2017 + +Stable release. No changes since 1.127_02. + +1.127_02 Tue May 23 18:31:59 CDT 2017 + +Developer release leading up to 1.128. + + [Bug Fixes] + * PPI misparsing a module caused an incorrect "Must end with a + recognizable true value." This is fixed by upgrading to PPI + 1.224. (GH #696, GH #607) + * A test would fail under the upcoming Perl 5.26 that omits the current + directory from @INC. Thanks, Kent Fredric. + * Fixed an invalid test in the RequireBarewordsIncludes test. Thanks, + Christian Walde. (GH #751) + * If an element contained blank lines then the source "%r" displayed + for a violation was wrong. Thanks, Sawyer X. (GH #702, #734) + + [Dependencies] + Perl::Critic now requires PPI 1.224. PPI is the underlying Perl parser + on which Perl::Critic is built, and 1.224 introduces many parsing fixes + such as: + * Fixes for dot-in-@INC. + * Parse left side of => as bareword even if it looks like a keyword or op. + * $::x now works. + * Higher accuracy when deciding whether certain characters are operators or + variable type casts (*&% etc.). + * Subroutine attributes parsed correctly. + + [Performance Enhancements] + * Sped up BuiltinFunctions::ProhibitUselessTopic ~7%. Thanks, James + Raspass. (GH #656) + + [Documentation] + * Fixed incorrect explanation of capture variables in + ProhibitCaptureWithoutTest. Thanks, Felipe Gasper. + * Fixed incorrect links. Thanks, Glenn Fowler. + * Fixed incorrect example for returning a sorted list. Thanks, @daviding58. + * Fixed invalid POD. Thanks, Jakub Wilk. (GH #735) + * Updated docs on ProhibitYadaOperator. Thanks, Stuart A Johnston. (GH #662) + * Removed all the references to the old mailing list and code repository + at tigris.org. (GH #757) + + +1.127_01 Sun May 21 21:57:16 CDT 2017 + + Removed from CPAN because it did not get indexed correctly. + +1.126 2015-08-10 + + [New Policies] + * Added a policy: ControlStructures::ProhibitYadaOperator - Never use ... + in production code. + + [Bug Fixes] + * Fixed problems arising from having -b in your .perltidyrc file. Thanks + @hjkatz. + * Removed extra newline from policy names returned by P::C::Config->policies. + Thanks @ratsbane. + * `fc` and `say` are now covered by ProhibitUselessTopic. Thanks @JRaspass. + + [Miscellanea] + * Add more strict/warnings importer modules. Thanks @oalders. + * Path::Tiny is now recommended over File::Slurp + * Micro-optimize by calling ->content() directly instead of going + through the overloads. Thanks @JRaspass. + * Square brackets are now allowed around your `## no critic` policy + list. Thanks @zdm. + + +1.125 2015-03-02 + + [Bug Fixes] + * Corrected dependency on List::Util::any() to List::MoreUtils::any() + + [Miscellanea] + * Revised and updated documentation. + +1.124 2015-02-27 + + [Policy Changes] + * The ProhibitUnusedPrivateSubroutines policy can now ignore files that + use particular modules with 'skip_when_using' option allows of, for + example, skipping the policy for roles. Thanks to Mark Fowler. + + * The RequireUseStrict and RequireUseWarnings policies now regard Moose, + Moo, Mouse, Dancer, Mojolicious, and several other modules as equivalent + to the strict and warnings pragma. + + [Bug Fixes] + * The RequireChecked* family of policies has been fixed to accommodate + version numbers when use-ing the autodie pragma. GH #612. Thanks citrin. + +1.123 2014-11-11 + + [Dependencies] + * Now requires PPI-1.220 which has numerous bug fixes. This may + eliminate the need for some "## no critic" markers you inserted to + work around those bugs. The "ProhibitUselessNoCritic" policy should + help you find them. + + [Miscellanea] + * Fixed a typo in the Variables::ProhibitPerl4PackageNames message. + +1.122 2014-08-25 + + [Dependencies] + * Now requires PPI-1.218 which has numerous enahncements and bug fixes. + Also now requires Readonly-2.00, which obviates the need for Readonly::XS + to get fast constants. + + * File::HomeDir, File::Which, and Term::ANSIColor are all required now + instead of being optional or recommended. This simplifies our test code + and ensures consistent optimal behavior for all users. + + [New Policies] + * Added two new policies: BuiltinFunctions::ProhibitUselessTopic and + RegularExpressions::ProhibitUselessTopic. + + [Miscellanea] + * Updated the perlcritic.el script to use modern Emacs hooks. + Thanks to @intrigeri and the Debian team for the patch. Fixes GH #556. + + * Removed all the internal RCS keyword boilerplate blocks that were never + getting expanded. + +1.121_01 2013-11-17 + + * Changes summarized above under 1.122 + +1.121 2013-11-02 + + [New Features] + * Added new themes based on CERT guidelines. Thanks Kirk Kimmel. + + [Administrative Changes] + * The source code repository for Perl-Critic has been moved to GitHub + at http://github.com/Perl-Critic/Perl-Critic. All tickets from the + RT queue have also been moved there. Please use GitHub for submitting + any new bugs or corresponding about existing ones. Huge thanks to + Tim Bunce, Andreas Marienborg, fREW Schmidt, and Graham Knop for + making this happen. + + [Miscellanea] + * This change log was reformatted to comply with CPAN::Changes::Spec, + courtesy of Neil Bowers as part of a quest on http://questhub.io. + Does your change log comply? + + +1.120_01 2013-10-29 *DEVELOPER RELEASE* + + * Changes summarized above + + +1.120 2013-10-25 + + [Bug Fixes] + * Corrected "Possible precedence issue with control flow operator" + warning. This fixes RT #88866 + + +1.119 2013-09-25 + + [Bug Fixes] + * Tests were failing with Config::Tiny 2.17 or later, due to a + change in the error messages produced by that module. + This fixes #16 on Github, #88679 & #88889 on RT. + + [Policy Changes] + * BuiltinFunctions::ProhibitVoidGrep and ::ProhibitVoidMap: grep + and map called as functions are now allowed in slice operations. + RT #79289. Thanks to Wade at Anomaly dot org for the patch. + * Subroutines::RequireArgUnpacking: Most tests of the size of @_ + are now allowed. RT #79138 + + [Other Changes] + * Modernized our usage of Exporter. See RT #75300. Thanks + to Olivier Mengué for the patch. + + +1.118 2012-07-10 + + [Policy Changes] + * CodeLayout::RequireTidyCode: Revise to work with incompatible + changes in Perl::Tidy 20120619. RT #77977. + * TestingAndDebugging::ProhibitNoWarnings: Correct the parse of the + 'no warnings' statement, so that 'no warnings "qw"' is recognized + as supressing just 'qw' warnings. RT #74647. + * Miscellanea::RequireRcsKeywords has been moved to the Perl-Critic-More + distribution, RT #69546 + + [Other Changes] + * Make all unescaped literal "{" characters in regexps into + character classes. These are deprecated, and became noisy with + Perl 5.17.0. RT #77510. + + +1.117 2011-12-21 HAPPY HOLIDAYS! + + [New Policies] + * Variables::ProhibitAugmentedAssignmentInDeclaration reports + constructs like 'my $x += 1'. Contributed by Mike O'Regan. + + [Policy Changes] + * BuiltinFunctions::ProhibitLvalueSubstr: Add explicit 'use version'. + RT #68498. + * CodeLayout::ProhibitHardTabs: Add 'pbp' to the default_themes list. + RT #71093. + * ControlStructures::ProhibitMutatingListFunctions now understands that + tr///r (introduced in 5.13.7) does not change its operand. + * ControlStructures::ProhibitMutatingListFunctions now understands that + '//=', '<<=', and '>>=' are assignment operators. RT #70901. + * ErrorHandling::RequireCheckingReturnValueOfEval now allows things + like grep { eval $_ }. RT #69489. + * Modules::RequireExplicitPackage now has configuration option + allow_import_of, to allow the import of specified modules before + the package statement. RT #72660. + * RegularExpressions::ProhibitEnumeratedClasses no longer thinks + that [A-Za-z_] matches \w. RT #69322. + * RegularExpressions::ProhibitUnusedCaptures now skips the first + block of an 'if' or 'elsif' if the regular expression is bound to + its operand with the '!~' operator. RT #69867. + * RegularExpressions::ProhibitUnusedCaptures now looks into lists + and blocks in the replacement portion of the regular expression if + /e is asserted. RT #72086. + * RegularExpressions::RequireDotMatchAnything, + RegularExpressions::RequireExtendedFormatting and + RegularExpressions::RequireLineBoundaryMatching now honor defaults + set with 'use re "/modifiers"'. RT #72151. + * Subroutines::ProhibitManyArgs now recognizes '+' as a prototype + character. + * Variables::ProhibitPunctuationVars now recognizes bracketed + variables embedded in interpolated strings (e.g. "${$}"). For the + purpose of the 'allow' configuration, these are considered + equivalent to the unbracketed form. RT #72910. + + [Other Changes] + * Corrected POD in Perl::Critic::PPI::Utils. RT #68898. + * Perl::Critic::Violation source() method now returns the line + containing the violation (not the first line) when the statement + containing the violation spans multiple lines. + + +1.116 2011-05-15 + + [Policy Changes] + * BuiltInFunctions::ProhibitLvalueSubstr does not report violations + if the document contains an explicit 'use n.nnn;' where the + version is before 5.005. RT #59112 + * Documentation::RequirePodSections no longer blows up on code + having POD but no =head1. This problem was introduced with RT + #59268. RT #67231 + * RegularExpressions::ProhibitUnusedCapture should more reliably + find things like s/(a)/${1}2/. RT #67273. + * ValuesAndExpressions::ProhibitMagicNumbers and + Module::RequireVersionVar now treat versions passed as the second + argument of a 'package' statement the same as versions declared as + 'our $VERSION ...'. RT #67159 + * Variables::RequireLexicalLoopIterators does not report violations + if the document contains an explicit 'use n.nnn;' where the + version is before 5.004. RT #67760 + + +1.115 2011-03-31 + + [Minor Changes] + * Fatal error in RegularExpressions::ProhibitUnusedCapture here + document check. RT #67116. + * Internal POD error in Documentation::RequirePodLinksIncludeText. Patch + by Salvatore Bonaccorso. RT #67012 + + +1.114 2011-03-26 + + [Policy Changes] + * Documentation::RequirePodLinksIncludeText now handles nested POD + formatting. RT #65569 + * Clarified relation of severity numbers to names in Perl::Critic + POD. RT #66017 + * Removed caveats from Variables::RequireLocalizedPunctuationVars, + no longer necessary with PPI 1.208. RT #65514 + * Have InputOutput::RequireBriefOpen attempt to expand scope as + necessary to deal with the case where the open() and the + corresponding close() are not in the same scope. RT #64437 + * RegularExpressions::ProhibitUnusedCapture now looks inside + double-quotish things. RT #38942. + * RegularExpressions::ProhibitUnusedCapture now takes logical + alternation into account, so that (e.g.) + if ( /(a)/ || /(b)/ ) { + say $1; + } + is not a violation. RT #38942. + * ValuesAndExpressions::ProhibitCommaSeparatedStatements now + recognizes 'return { foo => 1, bar => 2 }' as containing a hash + constructor, not a block. This was fixed by PPI 1.215. RT #61301. + * ValuesAndExpressions::ProhibitCommaSeparatedStatements now + recognizes 'bless { foo => 1, bar => 2 }' as containing a hash + constructor, not a block. This was fixed by PPI 1.215. RT #64132. + + +1.113 2011-02-14 + + [New Policies] + * InputOutput::RequireEncodingWithUTF8Layer recommends + ':encoding(utf8)' over ':utf8' in open() and binmode(). It is severity 5 + because of the bad things that can happen if invalid UTF8 gets loose in + your code. + * Modules::ProhibitConditionalUseStatements prohibits + 'use module' inside a conditional, since the statement is executed + unconditionally at compile time. Thanks to Peter Guzis for submitting + the policy and tests in RT #59065. + + [Policy Changes] + * CodeLayout::RequireConsistentNewlines produces multiple undefined + value errors when a violation is found. RT #65663 + * ControlStructures::ProhibitMutatingListFunctions allows s///r, + which was introduced in 5.13.2. + * ControlStructures::ProhibitPostfixControls now looks for "when". It is + treated in the same way as "if". + * Documentation::RequirePodSections now honors '## no critic' + annotation anywhere before the '__END__', '__DATA__', or first + '=head1', whichever comes first. The line number of the offending + '=head1 NAME' was added to the violation description. RT #59268. + * RegularExpressions::ProhibitUnusedCapture now takes account of the + use of $- and $+ (and their English equivalents under 'use + English') provided the subscripts are literal integers. + * RegularExpressions::ProhibitUnusedCapture now takes account of the + use of capture variables in the replacement portion of + s/.../.../e. + * Subroutines::ProhibitUnusedPrivateSubroutines now looks inside + regular expressions. + * ValuesAndExpressions::ProhibitMagicNumbers now supports Const::Fast. + * ValuesAndExpressions::ProhibitMagicNumbers now has a + constant_creator_subroutines parameter to allow the user to + configure the names of subroutines that create constants. RT #62562. + * ValuesAndExpressions::ProhibitMismatchedOperators didn't handle file + test operators properly. Patch by H.Merijn Brand. RT #58751 + * Variables::ProhibitUnusedVariables now looks inside regular + expressions. + * ValuesAndExpressions::RequireInterpolationOfMetachars now detects + and complains about "\b" and "\l" as documented in perlop, and + "\1" through "\7", which are not documented there, but were found + in toke.c. + + [New Developer Features] + * uses_module(), namespaces(), and subdocuments_for_namespace() methods on + Perl::Critic::Document. + * Perl::Critic::Document->new() now accepts a -filename-override argument + for setting the filename when the source code comes from something + other than an actual file. + + [Other Changes] + * Test::Perl::Critic::Policy no longer exports by default. + * Build phase now requires Test::Deep. + * Added example using Try::Tiny to documentation of + ErrorHandling::RequireCheckingReturnValueOfEval. Suggested by Andy + Lester on the developers mailing list. + * In order to get more consistent behavior across all installations of + Perl::Critic, IPC::Open2 (which actually is part of core), PPIx::Regexp, + Perl::Tidy, Pod::Spell, and Text::ParseWords are no longer optional + prerequisites. + * Now depends upon PPIx::Utilities v1.1.0. + + [Bug Fixes] + * Build.PL/Makefile.PL didn't specify a minimum version of version.pm, but + TestingAndDebugging::RequireUseStrict did. RT #58952 + * Perl::Critic::Annotation needs to look inside the __END__ statement to + find the true end of the document, otherwise POD policies may give false + positives. RT #59176 + * BuiltinFunctions::ProhibitStringyEval no longer dies on eval + "#...". RT #60179 + * RegularExpressions::ProhibitUnusedCapture now takes account of the + %LAST_PAREN_MATCH as well as %+ if English has been loaded. RT #60002 + * Subroutines::ProhibitManyArgs now interprets prototype groups (e.g. + \[$@%]) as representing a single argument. + * Require Exporter version 5.63 (versus version 0) to get sane handling of + export tags. RT# 61071 + * Prevent Subroutines::ProhibitUnusedPrivateSubroutines from failing + on &_subroutine(). RT #61311 + * Subroutines::ProhibitAmpersandSigils now allows references of the + form \( &sub1, &sub2 ). RT #49609 + +1.112_002 2011-02-09 +1.112_001 2010-12-14 + + * Changes summarized into 1.113 above. + For exact details, see Changes on BackPAN. + + +1.111 2010-12-14 + + [Bug Fixes] + * TestingAndDebugging::ProhibitNoStrict and ProhibitNoWarnings no longer + rely on the behavior of all() when the list is empty due to change in + List::MoreUtils 0.28. RT #63816 + + +1.110_001 2010-11-30 + + * Changes summarized into 1.113 above. + For exact details, see Changes on BackPAN. + (Yes, all of this stuff was not in 1.111.) + + +1.109 2010-08-29 + + [Bug Fixes] + * ValuesAndExpressions::RequireInterpolationOfMetachars fix due to changes + in Email::Address 1.890. Note that this may find problems in code that + it didn't before, e.g. q<'@foo'>. + + +1.108 2010-06-22 + + [Dedication] + * This is the "Give Shawn Moore what we promised him a year ago and hurry + up and get this out before Brad Oaks gives his YAPC::NA talk" release. + + [New Policies] + * Documentation::RequirePodLinksIncludeText + * Subroutines::ProhibitUnusedPrivateSubroutines + + [New Features] + * There is a new global configuration item, 'program-extensions', which + configures Perl::Critic's idea of which file name extensions represent + programs. The desired extensions are specified as a space-separated list, + with leading '.' on each if that is desired. Files whose names end in + '.PL' will always be considered programs. This can be overridden by + command option --programs-extensions, which can be specified multiple + times. + * There is now a perlcritic --allow-unsafe switch. Without this switch, + Perl::Critic will silently refuse to load any Policy that is marked + unsafe. Unsafe Policies are usually ones that may compile or execute + untrusted code (see Perl::Critic::DynamicPolicy for an example); Policy + authors can mark their policies as unsafe by overriding the is_safe() + method. + * The framework that we use to test Perl::Critic Policies has been + packaged into a convenient module that you can use to test your own + Policies. See Test::Perl::Critic::Policy and Perl::Critic::TestUtils + for details. + + [Policy Changes] + * BuiltInFunctions::ProhibitLvalueSubstr no longer complains when there + is a low-precedence operator between the substr() and the assignment + operator. + * CodeLayout::ProhibitParensWithBuiltins now allows 'state ($foo)'. RT + #52029 + * ErrorHandling::RequireCarping now has an + allow_in_main_if_not_in_subroutine option to allow "die" directly in + the default namespace. + * InputOutput::RequireBriefOpen now recognizes CORE::open(), + CORE::close(), CORE::GLOBAL::open(), and CORE::GLOBAL::close(). RT + #52391 + * Modules::ProhibitEvilModules now complains by default about the modules + deprecated by the Perl 5 Porters in 5.12. + * Modules::RequireVersionVar documentation updated to make clear that "my + $VERSION" does not work as a module version declaration. RT #56667 + * The RegularExpressions::* policies have been converted from using + Regexp::Parser to using PPIx::Regexp for their heavy lifting. + * RegularExpressions::ProhibitCaptureWithoutTest now allows capture + variables inside when() {}. RT #36081. + * RegularExpressions::ProhibitUnusedCapture now checks for unused named + captures. + * Subroutines::ProhibitManyArgs revised to count only characters in the + prototype that represent arguments. RT #56627 + * Subroutines::ProhibitNestedSubs no longer complains about scheduled + blocks (BEGIN, etc.) inside subroutines and vice versa. + * Subroutines::RequireFinalReturn should now understand a final given/when + statement, and declare an error if there is no 'default' block or if any + branch does not return. + * TestingAndDebugging::RequireUseStrict now accepts 'use 5.011' or greater + as equivalent to 'use strict'. + * ValuesAndExpressions::ProhibitMismatchedOperators false positive with + "'foo' x 15 . 'bar'". RT #54524 + * Variables::ProhibitPunctuationVars gave false positives on qr// regexp's + ending in '$'. RT #55604 + + [Bug Fixes] + * The "## no critic" annotations now respect #line directives. + * Annotations on statements spanning more than one line (e.g. + my $foo = + '$bar'; ## no critic (RequireInterpolationOfMetachars) + ) are now handled as single-line annotations, not block annotations. + * All instances of L in the POD have been changed to L. + L and L were allowed to stand. RT #37485 + * Spaces are now allowed immediately inside the enclosing parentheses in + "## no critic ( Foo )". RT #52038 + * With the introduction of PPIx::Regexp, Perl::Critic no longer dies + when it encounters a Perl 5.010 regexp. RT #49442. + * DEVELOPER.pod typo in link to + ValuesAndExpressions::ProhibitConstantPragma policy. RT #57818 + * Spelling errors in documentation. RT #57375 + * "die" used instead of "croak". RT #56619 + * Fixed regex test that caused test failures on every Perl 5.11 + (credit Tom Wyant). + * t/20_policy_pod_spelling.t now works (or at least no longer fails) + in non-English locales (again). RT #43291 and RT #48986. + * Perldoc has broken link for McCabe score definition. RT #53219 + * RT #33935 and #49679 were fixed by upgrading to PPI 1.208 + + [Other Changes] + * Perl::Critic::Utils::is_unchecked_call() updated to include chmod in the + set of things covered by autodie (this happened in autodie v2.08). The + primary effect of this is on InputOutput::RequireCheckedSyscalls. + * Now depends upon Task::Weaken to ensure that we only install with perls + where Scalar::Util::weaken() works. + * Email::Address was optional, but is now required. So everyone + gets the optimal behavior from RequireInterpolationOfMetachars. + * Some infrastructure has been extracted to the new PPIx-Utilities + distro. It is also a required dependency here. Over time a good + portion of Perl::Critic::Utils* will be migrated to this distribution. + * Perl::Critic::Utils::PPI::get_constant_name_element_from_declaring_statement() + is deprecated because it doesn't handle multiple constants being + declared within a single "use constant" statement. Use + PPIx::Utilities::Statement::get_constant_name_elements_from_declaring_statement() + instead. + * Removed all uses of Perl::Critic::Utils::PPIRegep. Since the + PPIx::Regexp update, Perl::Critic only used get_match_string() and + friends, which were superseded by the corresponding PPI methods. + Perl::Critic now depends on PPI-1.208 or newer. + * Moved Perl::Critic::Utils::PPIRegexp to the Perl-Critic-Deprecated. + * The PolicySummary.pod file is now generated when the distribution + is created, rather than when you install it. This ensures the file + will be available on http://search.cpan.org. Thanks to Bear Longyear + for bringing this to our attention. + + +1.107_001 2010-06-20 + + * Changes summarized into 1.108 above. + For exact details, see Changes on BackPAN. + + +1.106 2010-05-10 + + [Bug Fixes] + * NamingConventions::Capitalization fix for PPI 1.212. RT #57348 + + +1.105_03 2010-03-21 +1.105_02 2010-01-23 +1.105_01 2010-01-16 + + * Changes summarized into 1.108 above. + For exact details, see Changes on BackPAN. + + +1.105 2009-09-07 + + [Bug Fixes] + * Variables::ProhibitPunctuationVars would complain about "%-" appearing + anywhere in a string. RT #49016 + + [Policy Changes] + * InputOutput::RequireCheckedSyscalls now complains about unchecked "say" + by default. RT #37487 + + +1.104 2009-08-23 + + [Dedication] + * This release is dedicated to Tom Wyant in appreciation of the amount of + effort he put into the enhancements and bug fixes in this release, for + having the patience to wait for the amount of time that it took to get + them out, and for overall awesomeness. Thank you, Tom. + + [New Policies] + * Objects::ProhibitIndirectSyntax + * ValuesAndExpressions::ProhibitComplexVersion + * ValuesAndExpressions::RequireConstantVersion + + [New Optional Requirement] + * Email::Address, if you want + ValuesAndExpressions::ProhibitInterpolationOfLiterals to properly ignore + email addresses. + + [New Features] + * Perlcritic will list the names of files with violations if given the + --files-with-violations option, or the names of files without + violations if given the --files-without-violations options. These + have synonyms -l and -L respectively. + * Perlcritic has a new --list-enabled option, which lists the Policies + that will be enforced, given the current configuration. This is + useful if you've written a complex command-line or modified your + .perlcriticrc file and you want to see which Policies *would* + be used with the current configuration, if you were actually going + to critique a file with it. + * Perl::Critic::Violation now takes #line directives into account in the + %F, %f, and %l formats. You can get the old values via the new %G, %g, + and %L formats. + + [Policy Changes] + * CodeLayout::ProhibitParensWithBuiltins was complaining in certain cases + where parentheses are required due to operator precedence. RT #46862. + * ControlStructures::ProhibitMutatingListFunctions no longer complains + about uses of tr/// that don't modify the operand. Reported by EDAVIS, + RT #44515. + * Miscellanea::RequireRcsKeywords now accepts "qw$Keyword: ...$". RT + #45196. + * Modules::RequireFilenameMatchesPackage now respects logical filenames + defined by the "#line" directives. This allows the Policy to work + properly with IDEs and code generators. + * NamingConventions::Capitalization now allows fully qualified subroutine + declarations ( e.g. "sub Foo::Bar::baz {...}" ). However, the + non-package part of the subroutine name must still conform to whatever + capitalization rule you have chosen. + * RegularExpressions::ProhibitCaptureWithoutTest no longer complains if + the regex is followed by an "or die" or similar. Reported by EDAVIS, + RT #36081. + * RegularExpressions::ProhibitComplexRegexes no longer counts variable + substitutions in the length. Reported by EDAVIS, RT #36098. + * RegularExpressions::ProhibitUnusedCapture now considers the body of + while loops and not just their condition. Reported by EDAVIS, RT + #38942. + * ValuesAndExpressions::ProhibitVersionStrings was getting confused by + comments. Reported by Kevin Ryde, RT #44986. + * ValuesAndExpressions::RequireInterpolationOfMetachars now allows sigils + in the arguments to "use vars". Contributed by Kevin Ryde, RT #47318. + * ValuesAndExpressions::RequireInterpolationOfMetachars now properly + ignores email addresses, if you have Email::Address installed. Inspired + by the Kevin Ryde contribution in RT #47318. + * Variables::ProhibitPunctuationVars gained the ability to look inside + interpolated strings. Doing this correctly is challenging and things + may not work out right; how the policy does this can be controlled via + the new "string_mode" option. Contributed by Edgar Whipple + . + * Variables::ProhibitPunctuationVars now ignores $] by default since there + is no English.pm equivalent. + + [Other Bug Fixes] + * Perl::Critic::Utils::parse_arg_list() was slurping up the "or die ..." + portion of "open my $foo, 'somefile' or die ...", causing + InputOutput::ProhibitTwoArgOpen to not complain about this example. + Reported by Alexandr Ciornii, RT #44554. + + [Minor Changes] + * The line count emitted by the --statistics option is further broken down + by line content. + + [Minor Documentation Fixes] + * ValuesAndExpressions::ProhibitInterpolationOfLiterals. Reported by + Debian in http://bugs.debian.org/542814, RT #48936 + + [Build Fixes] + * There wasn't a specific version given for the List::MoreUtils dependency + and we're using features that weren't available until 0.19. So, we now + require version 0.19. Noticed by John J. Trammell, RT #48917. + * Some tests were tied to the specific "true" and "false" values that some + functions were returning. Reported by Michael Schwern, RT #43910. + + [Other News] + * Komodo version 5.1.1 now has built-in support for Perl-Critic, + if you have the Perl::Critic and criticism modules installed. + Both should be available through the ActiveState Perl Package + Manager ppm(1). + + +1.103 2009-08-03 + + * Fix configure_requires prerequisite on Module::Build 0.34_02. + + +1.102 2009-08-03 + + [Bug Fixes] + * Works with PPI 1.205. Yay for 5.10 support! + * Variables::RequireLexicalLoopIterators didn't work correctly on foreach + loops with labels. + + +1.101_003 2009-07-22 +1.101_002 2009-07-21 +1.101_001 2009-07-21 + + * Changes summarized into 1.102 above. + For exact details, see Changes on BackPAN. + + +1.100 2009-07-17 + + * This is a POD fix release to deal with issues identified by Test::POD + 1.40. There is no functional difference between this release and 1.098. + This is the last release of Perl::Critic that will be compatible with PPI + 1.203. PPI's parsing of for(each)? loops is changing in its next release + in an incompatible manner and there will be a release in the near future + to make Perl::Critic compatible with that change. + + +1.099_002 2009-06-27 +1.099_001 2009-06-25 + + * Experimental releases. For exact details, see Changes on BackPAN. + + +1.098 2009-03-07 + + [Some Exciting News] + * The Perl Development Kit (PDK 8.0) from ActiveState now includes a + very slick graphical interface to Perl-Critic. I highly recommend + that you check it out. Here's a link to screenshots and docs: + http://docs.activestate.com/pdk/8.0/PerlCritic_gui.html + + [New Features] + * Violation coloring is now configurable via command line or profile. The + profile entries are color-severity-highest, -high, -medium, -low, or + -lowest. Numbers are accepted in lieu of named severities (e.g. + 'color-severity-5' for 'color-severity-highest'), and 'colour' is + accepted in lieu of 'color'. + * Handling of unrecognized policy configuration items is now controlled by + the profile_strictness. The default is to warn about them. The previous + default was that they were fatal. + * -p is now a synonym for --profile. + * The --verbose option for perlcritic now supports a %C format that will + displays the class of PPI::Element that caused the violation. + + [Policy Changes] + * ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions + didn't include "pbp" in its default themes even though it is derived + from the book. Now it does. :] + * ErrorHandling::RequireCarping now allows a here document as the last + element if the "allow_messages_ending_with_newlines" option is true. + * Fix Subroutines::ProhibitAmpersandSigils so it allows "defined(&x)" as + well as "defined &x". Patch from Kevin Ryde, RT #38855. + * Subroutines::ProtectPrivateSubs now has an "allow" option to specify + subroutines which are exempt from this policy. RT #38678. + Additionally, a "private_name_regex" option has been added that allows + you to specify what a private subrouting name looks like. + * Subroutines::RequireArgUnpacking now has an "allow_subscripts" option + to allow array slices and elements. RT #34009. + * Subroutines::RequireArgUnpacking now has an "allow_delegation_to" option + to allow the usual delegation idiom. Delegation to 'SUPER::' and + 'NEXT::' are allowed by default. RT #33839. + * Subroutines::RequireArgUnpacking no longer generates a false positive + for '$$_[]', which is an obfuscated way of saying '$_->[]'. RT #37713. + * ValuesAndExpressions::ProhibitMagicNumbers now has an + allow_to_the_right_of_a_fat_comma option, which defaults to true. Note + that it currently only works /directly/ to the right of a fat comma. + * Variables::ProhibitMatchVars had its default themes changed to "core + performance pbp", instead of "core bugs pbp" because, while the match + variables make regular expressions slow, it doesn't cause them to not + work correctly. + * Variables::ProhibitPackageVars has had FindBin and Log::Log4perl added + to the default exemptions. + * Variables::ProhibitReusedNames now has an "allow" option to specify + names that can be reused. It defaults to enabling $self and $class. RT + #42767. + * Variables::RequireLocalizedPunctuationVars has a customizable set of + exemptions via the "allow" option. + + [New Developer Features] + * The guts of perlcritic have been moved to Perl::Critic::Command. You + can invoke Perl::Critic::Command::run() to get the equivalent of running + the command. (Note, however, this interface WILL change, so don't count + on the current one.) + * Modules have had a "INTERFACE SUPPORT" section added which states + whether the Perl::Critic developers consider the particular module is + public or not. Any removal of functionality from a public module will + go through a deprecation cycle. Non-public modules may have their + interfaces changed without notice. + * P::C::Policy now has an is_enabled() method. + * P::C::Violation now has an element_class() method. + + [Bug Fixes] + * CodeLayout::ProhibitTrailingWhitespace didn't notice cases where PPI + would produce instances of PPI::Token::Whitespace that contained + multiple lines. + * Subroutines::ProtectPrivateSubs no longer regards the exportable POSIX + subroutines whose names begin with underscore as private. RT #38678. + * Subroutines::RequireArgUnpacking mishandled a complicated situation with + $_ being an array reference. RT #39601. + * Variables::RequireLocalizedPunctuationVars now applies to subscripted + names. RT #29384. + + [Internals] + * The guts of Build.PL and Makefile.PL have been rearranged. + + +1.097_002 2009-03-01 +1.097_001 2009-03-01 + + * Changes summarized into 1.098 above. + For exact details, see Changes on BackPAN. + + +1.096 2009-02-01 + + [New Policies] + * ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator + + [Policy Changes] + * Documentation::PodSpelling now has a stop_words_file option. + * Modules::ProhibitEvilModules now has a modules_file option. + + [Bug Fixes] + * ErrorHandling::RequireCarping will now allow a literal newline + as well as "\n". Fixed by Kyle Hasselbacher, RT #25046 + * Fix InputOutput::ProhibitTwoArgOpen so it allows '-|' or '|-' as the + second of two arguments. Patches from Kyle Hasselbacher and Leland + Johnson, RT #42384. + * InputOutput::RequireBracedFileHandleWithPrint applies to printf as well + as print. Fixed by Kyle Hasselbacher, RT #42537. + * TestingAndDebugging::RequireUseStrict and + TestingAndDebugging::RequireUseWarnings are no longer fooled by a + block-scoped pragma. RT #42310. + * ValuesAndExpressions::RequireInterpolationOfMetachars allows for escaped + backslashes. Fixed by Tom Wyant, RT #38530. + * Fix for problem in P::C::Document in dealing with underscores in + expressions like "use 5.009_001". Patch by Kevin Ryde, RT #36570 and + #42089. + * Fix in extras/perlcritic.el for a radio button. Patch by Kevin Ryde, RT + #42190. + * Fix distclean target in Makefile.PL. Patch by Richard Soderberg, + RT #42088. + * Fix temporary files not being cleaned up after tests. Patch by Kyle + Hasselbacher, RT #41443. + * Deal with changes in Pod::Parser v1.36 in test in t/05_utils_pod.t. + + [Minor Changes] + * Documentation improvements contributed by Mark Grimes in response to RT + #41942. + + +1.095_001 2009-01-18 + + * Changes summarized into 1.096 above. + For exact details, see Changes on BackPAN. + + +1.094001 2009-01-01 + + [Bug Fixes] + * Tests would fail on systems without Regexp::Parser installed. + + +1.094 2009-01-01 + + [Incompatible Changes] + * The way that "## no critic" markers was refactored. As + a result, we discovered that the syntax for the markers was pretty + vague. If you didn't do it just right, it would disable all policies, + and not just the specific ones that you wanted. So we've tightened this + up a bit. If you followed the examples that have been in the docs for + the last couple years, then you should be fine. But if you've been + using certain other variations in your "## no critic" markers, then you + might suddenly find yourself violating the new + ProhibtUnrestrictedNoCritic policy. To fix this, just make sure your + Policy names appear in parentheses: + + ## no critic Foo, Bar, Baz # wrong! + ## no critic Foo Bar Baz # wrong! + + + ## no critic (Foo, Bar, Baz) # ok! + ## no critic qw(Foo Bar Baz) # also ok! + + * The deprecated $FORMAT variables for Perl::Critic::Policy and + Perl::Critic::Violation no longer exist. Use the corresponding + get_format() and set_format() functions instead. + + [New Policies] + * Miscellanea::ProhibitUnrestrictedNoCritic + * Miscellanea::ProhibitUselessNoCritic + * NamingConventions::Capitalization + * Subroutines::ProhibitReturnSort + * Variables::ProhibitReusedNames + + [Removed Policies] + * NamingConventions::ProhibitMixedCaseSubs and + NamingConventions::ProhibitMixedCaseVars have been moved to a separate + Perl-Critic-Deprecated distribution. The + NamingConventions::Capitalization policy does everything they do, plus + more. + + [Policy Changes] + * BuiltinFunctions::ProhibitStringyEval now has an allow_includes option + that makes it behave (mostly) like Ricardo SIGNES' + Perl::Critic::Policy::Lax::ProhibitStringyEval::ExceptForRequire. + * InputOutput::RequireCheckedClose, InputOutput::RequireCheckedOpen, and + InputOutput::RequireCheckedSyscalls now all support autodie. + Unfortunately, autodie is currently treated like a module and not a + pragma, which means that the lexical scoping is not taken into account. + * InputOutput::RequireCheckedSyscalls now has an exclude_functions + parameter. + * Modules::ProhibitEvilModules now allows you to specify what the + description of a use of a bad module should be, to, say, suggest that + people use autodie instead of Fatal. + * Subroutine::ProhibitExcessComplexity violation descriptions now include + the name of the subroutine, thanks to Andreas Koenig, RT #40070. + * TestingAndDebugging::RequireUseStrict and + TestingAndDebugging::RequireUseWarnings now have equivalent_modules + parameters that allow you to designate other modules as being equivalent + to the strict and warnings pragmata. This one is for all you Moose fans + out there. :] + + [Bug Fixes] + * ControlStructures::ProhibitUnreachableCode would treat package + statements as unreachable. Fixed by Kevin Ryde. RT #41734 + * Fix warning from InputOutput::ProhibitOneArgSelect when select was + called with no arguments. RT #41926 + * Miscellanea::RequireRcsKeywords couldn't find keywords after __END__ + that didn't look like part of POD. + * Modules::RequireFilenameMatchesPackage would incorrectly complain about + programs. Yet more greatness contributed by Schwern. RT #39024. + * If a perlcriticrc file referred to a policy that wasn't installed and + the profile-strictness option was set to "fatal", + Perl::Critic::PolicyFactory fell over instead of reporting the + problematic policy name. + + [Miscellanea] + * Perl::Critic::Violation will automatically strip trailing periods + from your Policy description and explanation strings. This ensures that + the punctuation is consistent with the format specified by the user via + the -verbose formatting options. + + [New Developer Features] + * Perl::Critic::Policy::prepare_to_scan_document() is now checked and a + Policy can disable itself for just a single document, which can speed + things up. + + +1.093_03 2008-12-11 +1.093_02 2008-10-30 +1.093_01 2008-09-07 + + * Changes summarized into 1.094 above. + For exact details, see Changes in 1.093_003 on BackPAN. + + +1.092 2008-09-02 + + [Bug Fixes] + * Fixed POD errors that were causing build failures. Sorry + about that. + + +1.091 2008-09-01 + + [New Policies] + * RegularExpressions::RequireDotMatchAnything + + [New Features] + * perlcritic now supports a -pager option, so you can more easily + send the output to your favorite pager. You can set this option + on the command-line or in your .perlcriticrc file. See the + perlcritic perldoc for more details. Credit to Michael Schwern. + * The output from "perlcritic -doc PATTERN" will be automatically + sent to your pager if you have set the -pager option. + + [Policy Changes] + * CodeLayout::ProhibitQuotedWordLists no longer applies if the list + contains any non-words, by default. A non-word is anything that does + not match /[\w-]+/. You can restore the former behavior by setting the + "strict" option. RT #37886. + * CodeLayout::ProhibitQuotedWordLists also now applies to the import + arguments of a C statement. RT #24467. + * ErrorHandling::RequireCheckingReturnValueOfEval now recognizes ternary + left-sides as valid checks. + * RegularExpressions::RequireExtendedFormatting gains a + minimum_regex_length_to_complain_about option. Also, regexes that + contain only word and whitespace characters are now exempt from this + policy, by default; you can make it complain about them by turning on + the new strict option. Contributed by Michael Schwern. RT #38531. + * TestingAndDebugging::ProhibitNoWarnings now supports a + allow_with_category_restriction option, thanks to Michael Schwern. + RT #38514. + * CodeLayout::ProhibitHardTabs now allows leading tabs in qw() word lists + and regexes with the /x modifier. You can still configure this + policy to forbid all hard tabs, if you like. RT #32440 + + [Bug Fixes] + * perlcritic should now work under PAR. RT #38380. + * URL for our repository in META.yml now works for anonymous + checkout. The password is "" (empty). RT #38628. + * color for high-severity violations is now magenta because + it is more redable than yellow on white backgrounds. RT #38511. + + +1.090 2008-07-22 + + [Bug Fixes] + * Test was incorrectly failing when Regexp::Parser wasn't installed. + + +1.089 2008-07-21 + + [Minor Enhancements] + * -s is now a synonym for --single-policy. + + [Policy Changes] + * Subroutines::ProhibitBuiltinHomonyms now also prohibits subroutines + with the same name as a Perl keyword (e.g. if, foreach, while). + Inspired by RT #37632. + * Subroutines::ProtectPrivateSubs now allows expressions like + "shift->_some_private_method();". Note that this *only* applies + to the "shift" function -- a private method call on the right of any + other bareword still causes a violation. RT #34713. + * Subroutines::RequireFinalReturn now includes exec in the set of things + that mark a successful return. RT #37672 + * ValuesAndExpressions::ProhibitInterpolationOfLiterals now takes a + allow_if_string_contains_single_quote option. Contributed by Ed + Avis . RT #36125. + * ValuesAndExpressions::RequireInterpolationOfMetachars now supports a + rcs_keywords option to allow for the common case where those require + dollar signs. + + [Bug Fixes] + * BuiltinFunctions::ProhibitSleepViaSelect would complain if there were + three undefs as arguments to select(), but one of them was the timeout. + RT #37416. + * Reduced false positives in + RegularExpressions::ProhibitSingleCharAlternation. Thanks to + Andy Lester and Elliot Shank test cases. + * RegularExpressions::ProhibitUnusedCapture would complain if there were + multiple captures used in a substitution, e.g. s/(.)(.)/$2$1/. + * Subroutines::ProhibitAmpersandSigils no longer complains about + "sort &foo(...)". + * Makefile.PL, Build.PL and other ".PL" scripts which typically do not + have a shebang are no longer mistaken as modules. This prevents + spurious warnings from Modules::RequireEndWithOne. RT #20481. + + [Internals] + * Tests are now self compliant. + + +1.088 2008-07-04 + + [New Policies] + * ErrorHandling::RequireCheckingReturnValueOfEval + + [Policy Changes] + * ValuesAndExpressions::ProhibitLeadingZeros now accepts octal numbers + for the Unix permissions argument to chmod, dbmopen, mkdir, sysopen, or + umask, by default. Use the "strict" option to get the old behavior. + RT #31977. + * Due to the consensus at YAPC::NA 2008, + Variables::ProhibitUnusedVariables default severity has been raised to + medium/3. + + [Minor Changes] + * The perlcritic "--Version" option is now "--version" in order to act + like the rest of the world. + + +1.087 2008-06-21 + + [Policy Changes] + * CodeLayout::ProhibitParensWithBuiltins no longer complains about + sort(foo(@x)). + * TestingAndDebugging::RequireUseWarnings will not complain about files + that contain a "use 5.005" statement or similar for perls prior to 5.6. + Lesson of the day: computer conferences where you can meet in the real + world can clarify conversations greatly. Good to finally meet you Adam. + * InputOutput::ProhibitTwoArgOpen similarly will not complain if there's + a "use/require 5.005" statement in the file. RT #34385. + + [Bug Fixes] + * Perl::Critic can now critique a file named "0". However, PPI will give + a parse error until the next version comes out. Fixes RT #36127. + * Moved detection of the lack of any enabled Policies from P::C::Config + to Perl::Critic. This was causing the perlcritic.t in Parrot to fail. + Note, however, there are plans afoot to change how Perl::Critic is + configured and things that depend upon that may break. Please contact + users@perlcritic.tigris.org and tell us how you're using P::C::Config + directly so that we can take your needs into account. + + +1.086 2008-06-12 + + [Policy Changes] + * NamingConventions::ProhibitAmbiguousNames now specifies the name that + it had problems with in its violation descriptions. + + [Bug Fixes] + * The color option wasn't being correctly set from a .perlcriticrc. + RT #36569. + + [Minor Changes] + * --colour is now a synonym for --color. + + +1.085 2008-06-07 + + [New Policies] + * Documentation::RequirePackageMatchesPodName + + [Policy Changes] + * Variables::ProhibitUnusedVariables detects a few more cases. It's + still very limited, though. + + [Bug Fixes] + * ControlStructures::ProhibitUnreachableCode didn't notice "until" was an + conditional expression. + + [Minor Changes] + * Documentation updates. + + +1.084 2008-05-24 + + [New Features] + * perlcritic now supports a --list-themes option. + * You can specify the maximum number of violations you want per Policy + per document. Developers can give a default value for this for a + Policy by overriding default_maximum_violations_per_document(). + See RequireUseStrict and ProhibitMagicNumbers for examples. + + [Policy Moved] + * The ValuesAndExpressions::ProhibitMagicNumbers policy has been moved + from Perl::Critic::More into the primary Perl::Critic distribution. + + [New Policies] + * Variables::ProhibitUnusedVariables (very dumb, limited initial + implementation.) + * ControlStructures::ProhibitLabelsWithSpecialBlockNames + Contributed by Mike O'Regan. Kickin' ass, Mike. + + [Policy Changes] + * ControlStructures::ProhibitUnreachableCode now handles the perl 5.10 + "//" and "err" operators. RT #36080 + * InputOutput::RequireBriefOpen now ignores opens of STDIN, STDOUT, + and STDERR. You're generally trying to make long-lasting global + effects when manipulating these. (RT #35774) + * RegularExpressions::ProhibitUnusualDelimiters now supports an + "allow_all_brackets" option. + * RegularExpressions::RequireBracesForMultiline now supports an + "allow_all_brackets" option. + * TestingAndDebugging::RequireUseStrict now accepts "use Moose::Role" + as equivalent to "use strict". (RT #34838) + * TestingAndDebugging::RequireUseWarnings now accepts "use Moose::Role" + as equivalent to "use warnings". (RT #34838) + * ValuesAndExpressions::ProhibitMagicNumbers now accepts constant + subroutines. + * Variables::ProhibitMatchVars no longer detects "use English;". + This problem is detected in a more clear way by + Modules::RequireNoMatchVarsWithUseEnglish. + * Variables::ProhibitPerl4PackageNames no longer complains about + $'/$POSTMATCH. RT #36059 + * Variables::RequireLocalizedPunctuationVars now allows the use of "my". + RT #33937 + + [Bug Fixes] + * No longer falls over if a single file has a parse error. + + [New Developer Features] + * If a document specifies a minimum perl version, e.g. "use 5.008003", + P::C::Document::highest_explicit_perl_version() will tell you what it + is. + * The parameter to P::C::Policy::initialize_if_enabled is now a + P::C::PolicyConfig object instead of a hash reference. + + [Minor Changes] + * LOTS of documentation updates. + * A few more statistics are emitted by perlcritic with the --statistics + option. + * perlcritic --profile-proto now includes policy abstracts in its + output. + + [Prerequisites] + * Now depends upon PPI 1.203. + * New dependency upon version. + + +1.083_006 2008-05-20 +1.083_005 2008-05-19 +1.083_004 2008-05-18 +1.083_003 2008-05-17 +1.083_002 2008-05-17 +1.083_001 2008-04-13 + + * Changes summarized into 1.084 above. + For exact details, see Changes in 1.083_006 on BackPAN. + + +1.082 2008-03-08 + + [New Features] + * A new metadata system for defining policy parameters/options has been + added. This makes the life of policy authors easier because + configuration validation and parsing can be taken care of + automatically, in most cases. This allows greater integration with + IDEs and allows the perlcritic "--profile-proto" option to produce + better output. + + Note: This change does NOT REQUIRE ANY CHANGES to policies outside of + this distribution; they should continue to work as is. However, use + of this facility can reduce the size of your code and provide the + means for tools to discover more about your policy. If this change + does break any of your policies, please let us know. + + To learn how to take advantage of this facility, read + Perl::Critic::DEVELOPER and look at the source of any of the + configurable policies included in this distribution. + + There is a discussion of the design considerations for this facility in + the source repository under doc/PolicyParameter_Notes.pod. + * Added support for "criticism-fatal" option in your perlcriticrc + file. This will be used by the criticism pragma to cause execution + to abort if the file contains any violations. + + [New Policy] + * Module::RequireNoMatchVarsWithUseEnglish + + [Policy Changes] + * Added an allow_last_statement_to_be_comma_separated_in_map_and_grep + option to ValuesAndExpressions::ProhibitCommaSeparatedStatements. + Partial response to http://rt.cpan.org/Public/Bug/Display.html?id=27654. + * ControlStructures::ProhibitPostfixControls gains the ability to have + the flow control statements allowed to be modified. This in response + to RT #29540. + * TestingAndDebugging::RequireUseStrict now accepts "use Moose" as + equivalent to "use strict". + * TestingAndDebugging::RequireUseWarnings now accepts "use Moose" as + equivalent to "use warnings". + + [Bug Fixes] + * RT #31281 perlcritic doesn't recognize "#!/bin/env perl" shebang + * Replace usage of Unicode property escapes with POSIX character classes + order to restore 5.6 compatability. + * RT #30388 ValuesAndExpressions::ProhibitVersionStrings complained + about numbered directories in "use lib". + * Fixed handling of badly behaved spelling programs in PodSpelling. + + +1.081_006 2008-03-02 +1.081_005 2007-12-29 +1.081_004 2007-12-20 +1.081_003 2007-12-16 +1.081_002 2007-12-16 +1.081_001 2007-12-15 + + * Changes summarized into 1.082 above. + For exact details, see Changes in 1.081_006 on BackPAN. + + +1.080 2007-11-11 + + [New Features] + * Allow a "## no critic" statement after a shebang on line 1 of a + file. This allows users to block violations that apply to + whole files and still allow shebangs. + + [New Policies - funded by a Perl Foundation grant] + * InputOutput::ProhibitExplicitStdin + * RegularExpressions::ProhibitFixedStringMatches + * RegularExpressions::RequireBracesForMultiline + * RegularExpressions::ProhibitUnusualDelimiters + * RegularExpressions::ProhibitUnusedCapture + * RegularExpressions::ProhibitComplexRegexes + * RegularExpressions::ProhibitSingleCharAlternation + * RegularExpressions::ProhibitEscapedMetacharacters + * RegularExpressions::ProhibitEnumeratedClasses + * InputOutput::RequireBriefOpen + * InputOutput::RequireCheckedSyscalls + + [Other New Policies] + * ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions + + [Policy Changes] + * Variables::ProhibitConditionalDeclarations now permits you to local-ize + variables in conditional declarations. This makes sense, since + C is actually a variable modifier, rather than a declaration. + Thanks to David Golden for reporting this. + + [New Developer Features] + * Perl::Critic::Utils::PPIRegexp encapsulates interaction with + the PPI Regexp token classes. Those classes have very sparse + APIs, so this package hides away the ugly fiddling with PPI + internals. + * Added a new optional_modules parameter for the .run syntax. + + [Bug Fixes] + * PPI::Structure::List can now contain multiple children, + so P::C::Utils::parse_arg_list() needs to handle it. + This was done in the process of fixing + http://rt.cpan.org/Ticket/Display.html?id=24924, which was a problem + with TestingAndDebugging::RequireTestLabels. + * ValuesAndExpressions::ProhibitLongChainsOfMethodCalls wasn't resetting + chain length when it ran into the end of a sub-expression. + http://rt.cpan.org/Public/Bug/Display.html?id=30040 + * ValuesAndExpressions::ProhibitCommaSeparatedStatements was reporting + false positives when builtins which accept both no and multiple + arguments were involved. + http://rt.cpan.org/Public/Bug/Display.html?id=27654 + + [Internals] + * Removed all use of Carp in favor of exceptions. + + [Prerequisites] + * Now requires PPI 1.201. A number of workarounds for PPI bugs have been + removed. + * New dependency upon Exception::Class. + + [Installation] + * Use Devel::CheckOS to see whether Perl::Critic is being installed on + a Solaris system and warn about tar(1) chopping file names off if it + is. + + +1.079_003 2007-10-22 +1.079_002 2007-10-21 +1.079_001 2007-10-09 + + * Changes summarized into 1.080 above. For exact details, see Changes in + 1.079_003 on BackPAN. + + +1.078 2007-09-19 + + * Restore Perl::Critic::TestUtils::should_skip_author_tests() and + get_author_test_skip_message(). Some Perl::Critic add-on distributions + are using them. + + +1.077 2007-09-15 + + * Note: if you don't have any problems installing Perl::Critic 1.076, there + is no need to upgrade to this version. There are no functionality + changes. This release only contains changes related to installation that + a few people were experiencing. + + [Minor Changes] + * Removed build-time use of Readonly, again, due to problems some people + were having when trying to compile the code by hand, rather than using + CPAN(PLUS)?. + * Don't run author tests if there's a .svn directory present because + users who grabbed the code from the source repository were executing + them and getting failures. + * Don't generate optional, module-hiding test wrappers if author tests + are not enabled. + + +1.076 2007-09-07 + + * It appears from reports on the 1.075_001 release that the subroutine + sigils were indeed the problem. Release to the general populace. + + +1.075_001 2007-09-06 + + [Bug Fixes] + * Undo the changes in 1.073 and 1.074. Instead, stop using the subroutine + sigil in import and export lists. It is suspected that the problem lies + with Exporter stripping off ampersands. + + +1.074 2007-09-04 + + [Bug Fixes] + * Repeat the Makefile.PL change on + t/generate_without_optional_dependencies_wrappers.PL. + I love CPAN Testers. + + +1.073 2007-09-04 + + [Bug Fixes] + * Work around problems with the combination of Exporter & Readonly in + Makefile.PL on some machines. + + +1.072 2007-09-03 + + [Bug Fixes] + * The Makefile generated by Makefile.PL was not syntactically correct + according to some versions of Solaris. Thanks to Diab Jerius + (DJERIUS) for discovery and testing. + * Fixed mis-definition of "quiet" value for the "--profile-strictness" + option. + * Enhanced testing with the absence of optional modules. + + +1.071 2007-08-24 + + * The "Brown Paper Bag" Release + + [Bug Fixes] + * Tests would not pass in environments that did not have all optional + dependencies installed. + + +1.07 2007-08-21 + + [New Policies - funded by a Perl Foundation grant] + * BuiltinFunctions::ProhibitBooleanGrep + * BuiltinFunctions::ProhibitComplexMappings + * Documentation::PodSpelling + * InputOutput::ProhibitJoinedReadline + * Subroutines::ProhibitManyArgs + * Subroutines::RequireArgUnpacking + * ValuesAndExpressions::ProhibitImplicitNewlines + * Variables::RequireLocalizedPunctuationVars + + [Other New Policies] + * Subroutines::ProhibitNestedSubs + + [New Features] + * The "perlcritic --profile-proto" output now includes the "add_themes" + parameter for each policy. + * The perlcritic "--strict-profile" option has been replaced with a + "--profile-strictness" option. This new option takes values of "warn" + (the default), "fatal", and "quiet", which controls what happens with + ignorable problems in a .perlcriticrc file. + + [New Developer Features] + * Perl::Critic::Policy now has an overridable initialize_if_enabled() + method which allows a Policy to perform expensive initialization after + it has been determined whether the user has it enabled or not. Also, + this method allows a Policy to say that it should be disabled + regardless of what the user says. + + Actually, use of this method is now encouraged over using a + constructor. + + [Other Stuff] + * Now requires the Readonly module in order to be more self-compliant. + + +1.061 2007-07-24 + + [Bug Fixes] + * Fix P::C::Theme-- Exporter in Perl 5.6 does not export import(), so you + must subclass it. *sigh* + * Fix P::C::Config::_validate_and_save_theme()-- eval of an empty string + does not reset $@/$EVAL_ERROR in Perl 5.6. + * Big thanks to Anirvan Chatterjee for identifying and helping debug these + issues. + + +1.06 2007-06-27 + + [New Features] + * perlcritic now emits errors for all the problems it can find for the + global options in the command-line parameters and .perlcriticrc file, + rather than bailing on the first one it encounters. + * perlcritic now has a "--strict-profile" option which will make warnings + about problems in a profile fatal. + * perlcritic now has a "--statistics-only" option which suppresses the + display of individual violations and only shows the additional output + produced by the "--statistics" option. + + [Feature requests] + * A value for "color" can now be specified in a .perlcriticrc. + http://rt.cpan.org/Ticket/Display.html?id=24877 + + [New Policies] + * ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters + As suggested in http://rt.cpan.org/Ticket/Display.html?id=23290. + * ValuesAndExpressions::ProhibitLongChainsOfMethodCalls + * Modules::ProhibitExcessMainComplexity + As suggested in http://rt.cpan.org/Ticket/Display.html?id=24699 + + [Minor Changes] + * The perlcritic "--profile-proto" option now emits the short names for + policies, rather than the full ones. + * The "-profileproto" and "-singlepolicy" options have been renamed to + "-profile-proto" and "-single-policy" in order to make the growing + number of command-line options comprehensible. The change of + "singlepolicy" also affects your F<.perlcriticrc> file. + + +1.053 2007-06-02 *DEVELOPMENT RELEASE* + + [Bug Fixes] + * Fixed bug in 15_statistics.t test script, which caused the build + to fail on machines that don't have Perl::Tidy installed. + + +1.052 2007-06-01 *DEVELOPMENT RELEASE* + + [New Features] + * perlcritic now emits a summary about the scanned code when enabled by + the "-statistics" option. + + [Policy Enhancements] + * InputOutput::ProhibitBacktickOperators can now be configured to only + check in void contexts. + + [Bug Fixes] + * 27073: False positive in RequireUpperCaseHeredocTerminator + * 27065: CodeLayout::ProhibitTrailingWhitespace breaks under Perl 5.6.1 + * 26462: ControlStructures::ProhibitCascadingIfElse pod typo + * ValuesAndExpressions::ProhibitCommaSeparatedStatements was complaining + about multiple values in the list to be iterated over by a foreach loop. + * Corrected PBP page numbers for some policies (Quinn Weaver). + + +1.051 2007-04-12 *DEVELOPMENT RELEASE* + + * No new policies. + * No particular bug fixes. + + [Internals] + * Added several new utility functions to support the StricterSubs distro. + Also, some of the existing functions in Perl-Critic-Utils have + changed in ways that might break your custom policies. + + [Miscellanea] + * Updated Emacs plugin (Courtesy Josh ben Jore). + See extras/perlcritic.el for details. + * Added copy of BBEdit plugin (Courtesy of Josh Clark). + See extras/perl_critic_for_bbedit-1_0.zip for details + + +1.05 2007-03-19 + + [Bug Fixes] + * 25557: t/20_policy_prohibittrailingwhitespace.t fails on Perl 5.8.0 + + +1.04 2007-03-18 + + [Bug Fixes] + * 25008: Subroutines::RequireFinalReturn should allow "throw" + * 25085: False Positive - Heredoc terminator must be quoted + * 18423: VERSION check does not notice Readonly::Scalar version + * 25449: Proposal of $VERSION declaration (DUPLICATE) + + [New Policies] + * CodeLayout::ProhibitTrailingWhitespace + * ValuesAndExpressions::ProhibitCommaSeparatedStatements + * Variables::ProhibitPerl4PackageNames + + [Policy Enhancements] + * Subroutines::RequireFinalReturn can now be configured to recognize + your custom functions that behave like "die" or "exit". + * Documentation::RequirePodSections can be configured to match + Module::Starter:PBP or to really match the PBP book. + + +1.03 2007-02-13 + + [Bug Fixes] + * Fixed a few more problems with the %f, %F, and %r format escapes. + * I forgot to put Conway's perlcriticrc file in the MANIFEST. Sorry. + + [Interface Changes] + * Perl::Critic::Utils automatically exports everything. However, + this is deprecated. In the future, you must request your exports. + + [Policy Changes] + * Duplicate violations of RequireExcplicitPackage are now squelched, + in the same way as RequireUseStrict and RequireUseWarnings. + + +1.02 2007-02-11 + + [Bug Fixes] + * "undef" incorrectly triggered ProhibitMutatingListFunctions. + * 24876: %f and %F escapes not working in custom "verbose" format strings. + * 24875: Documentation bug in TestingAndDebugging::ProhibitNoStrict + + [New Policies] + * InputOutput::RequireCheckedOpen + * InputOutput::RequireCheckedClose + + [Other Cool Stuff] + * Added Conway's own suggested Perl::Critic configuration as + examples/perlcriticrc-conway. + * See the examples/ directory for some neat demonstrations of using + the Perl::Critic API. Contributed by Elliot Shank. + + [Interface Changes] + * Perl::Critic::Utils no longer exports anything by default. Policies + outside the distribution will need to specify what exactly they need + from this module. There are a number of tags that can be used in + addition to individual imports. + + +1.01 2007-01-24 + + * PRODUCTION RELEASE: You may now consider the public Perl::Critic + API as "stable." Future minor releases will focus on bug fixes, + new policies, and internal refactoring. + + [Bug Fixes] + * Fixed memory leak. This was reported by the Parrot team at + http://rt.perl.org/rt3/Ticket/Display.html?id=41230 + + +0.23 2007-01-19 + + [Bug Fixes] + * 23994: Test 56 in t/05_utils.t of Perl::Critic v0.22 fails + * 24005: test 95 in t/13_bundled_policies fails in 0.22 + + [Groovy New Features] + * Added '%F' to the Violation format specifications. This will + give you just the name of file where the violation occurred + (i.e. without the path). + * Improved validation of .perlcriticrc file. An invalid + default setting will now cause a fatal exception. A + strange-looking policy name will cause a warning. + + [Interface Changes] + * The syntax for theme expressions has changed. Instead of using + mathematical operators qw(+ * -) you must now use the logical + operators qw(|| && !). See the Perl::Critic docs for more info. + * The @GLOBALS and @BUILTINS variables are no longer exported by + Perl::Critic::Utils. Use the is_perl_global() and is_perl_builtin() + functions instead. + * Perl::Critic::Policy::policy_parameters() has bee renamed to + Perl::Critic::Policy::supported_paramters(). This was an + undocumented feature anyway, so it shouldn't affect anyone. + + [Other Internal Changes] + * Perl::Critic now requires B::Keywords v1.05 or newer. + * A few internal classes have been refactored. As a result, + Set::Scalar is no longer a required dependency. + + +0.22 2006-12-15 + + [New Features] + * Introduced named severity levels: gentle, stern, harsh, cruel, brutal + You can use these named levels instead of the numeric ones. + For example: "perlcritic --severity=cruel MyModule.pm" + Or just: "perlcritic --cruel MyModule.pm" + * For perlcritic, the "-List" option has been renamed to + "-profileproto". The output now includes the names of the + parameters that each Policy supports, if any. + * Improved validation of Policy parameters in your F<.perlcriticrc> + Any invalid parameter now causes a fatal exception. + + [Major Changes] + * Reassigned themes for most policies. Now there are fewer + themes and they are organized around programming concepts + instead of severity levels. If you have assigned your own + themes to any Policies, they should still work as expected. + + [Policy Changes] + * ErrorHandling::RequireCarping will not complain if it can figure + out that the die or warn message will always end in a newline + ("\n"). The idea is that, if you put the newline there, you + don't indend for there to be any file/line/stack information + emitted, in which case you really don't want carp/croak. + + You can restore the old strict behavior by giving the policy + a false value for "allow_messages_ending_with_newlines" in your + configuration. + + [Misc Changes] + * Added single-letter uppercase alternatives for some perlcritic options. + + +0.21_01 2006-12-03 + + [New Policies] + * TestingAndDebugging::ProhibitProlongedStrictureOverride + * ControlStructures::ProhibitMutatingListFunctions + + [New Features] + * Say "perlcritic -List" to get an expanded listing of all Policies. + The format is suitable for use as your .perlcriticrc file. + * Say "perlcritic -doc PATTERN" to get the documentation for all + Policies that match m/PATTERN/imx. This is a little easier than + typing in the full name of the Policy module with "perldoc". + * Say "perlcritic --singlepolicy PATTERN" to use one and only one + policy. + * Can now specify exceptions to Variables::ProhibitPackageVars, + for packages like File::Find that only interface through + package variables. + + [Bug Fixes] + * 21713 false positive for parens used with substr and unpack. + * 22890 allow Rcs keywords in POD. + + [Internals] + * Testing system overhauled. Details on the Policy/subtest + framework is in t/run.t. + * Added Perl::Critic::Utils::words_from_string. This is safer + than plain old C. + + +0.21 2006-11-05 + + [New Policies] + * BuiltinFunctions::ProhibitReverseSortBlock + * BuiltinFunctions::ProhibitVoidGrep + * BuiltinFunctions::ProhibitVoidMap + * CodeLayout::RequireConsistentNewlines + * Modules::RequireFilenameMatchesPackage + * TestingAndDebugging::RequireTestLabels + * ValuesAndExpressions::ProhibitMismatchedOperators + + [New Features] + * Introduced policy "themes." Themes are arbitrary names that can + be used to identify a group of related Policies. You can select + your favorite policies by combining themes in a mathematic expression + such as "pbp * (danger + risky)". See POD for details. + * perlcritic output is colorized if you have Term::ANSIColor. This + only works on non-Win32 platforms. Use -nocolor switch to disable. + * Say "perlcritic -count" to get just the the total number of + violations per file. Use this feature to quickly identify hot-spots. + * Use the -only switch to choose only from policies mentioned in your + .perlcriticrc file. This is useful if you usually only want to + work with a small subset of the policies. + * Default values for most of the perlcritic and Perl::Critic options + can now be defined in your .perlcriticrc file. See POD for details. + + [Bug Fixes] + * 21236: wrong page number for "printing to filehandles" + * 21916: File handle ... wrong page reference in PBP [DUPE] + * 21714: false positive for capture var used in ternary condition + * 21718: No skip for File::Slurp in includes.t + * ProhibitBarewordFilehandles doesn't complain if you open + STDIN, STDOUT or STDERR. + * Parrot 40564: Subroutines::RequireFinalReturn should allow die, + exit, etc. + * Each "for" and "foreach" loop now adds one point to the McCabe + complexity score. + + [Other Stuff] + * The internals of Perl::Critic have been significantly refactored, + but should still be compatible with existing third-party Policies. + * Added author-only tests to the release, but disabled by default + * New Perl::Critic::Utils::shebang_line() method + * Support for filename-based policies + * Additional prerequisite: Set::Scalar + * Now requires PPI version 1.118 + + +0.20 2006-09-10 + + * Perl::Critic now requires PPI version 1.117, which fixes + several bugs that were introduced in version 1.116. + + [Bug Fixes] + * 21079: grep clears @SITE_POLICIES + * 21352: Test failures with PPI 1.117 + * 11365: sub DESTROY detected as a builtin homonym + + +0.19 2006-08-20 + + [New Policies] + * BuiltinFunctions::ProhibitStringySplit + * ControlStructures::ProhibitDeepNests + * RegularExpressions::ProhibitCaptureWithoutTest + * Variables::RequireLexicalLoopIterator + + [New Features] + * "perlcritic -quiet" suppresses the "source OK" message. + * Variables::ProhibitPunctuationVars is now configurable. + + [Bug Fixes] + * 20965: "Hard tabs used at" shouldn't check __DATA__ + * 21070: ProhibitNoisyQuotes hates overload + * Punctuation variables are now exempt from ProhibitLocalVars + + [Other Stuff] + * Test coverage is now over 95% + + +0.18_01 2006-08-06 + + [New Policies] + * Variables::RequireNegativeIndices + * InputOutput::ProhibitInteractiveTest + * ErrorHandling::RequireCarping + + [Bug Fixes] + * RequireTidyCode tests fail if user has custom .perltidyrc file + * 20612: RequirePerlTidy was ignoring HEREDOCs + * 20659: __END__ statement considered "unreachable" + * Fix for PPI::XS (no C support) + * Support for 'goto' in ProhibitAmpersandSigils and + Subroutines::RequireFinalReturn + + [Performance Enhancements] + * Introduced Perl::Critic::Document class. This is a facade for + PPI::Document which internally caches search results. This + reduces the running time by about 35%. The facade should be + invisible, unless you are doing something really sneaky. + * Extraction of the 'diagnostics' information is postponed + until it is really needed. Speedup has not been measured. + * Calls to helper-subs have been reordered for maximum efficiency. + + [Other Cool Stuff] + * Includes updated version of perlcritic mode for emacs. See + "extras/perlcritic.el" for details. + + +0.18 2006-07-16 + + [Bug Fixes] + * 14855: Home discovery is dangerously naive. + * 20060: Incorrect page numbers in ProhibitLeadingZeros + and RequireNumberSeparator policies. + * 20068: .perlrc file - inconsistent documentation + * 20254: "use vars qw(@EXPORT_OK)" not recognized + * 20463: No-case heredoc terminator incorrectly detected as lower case. + * ProhibitOneArgBless doesn't understand "bless {} => $class;" + * ProhibitExcessComplexity doesn't count 'while' and 'until' stmnts + * ProhibitLeadingZeros was falsely hits '.0456' + + [Enhancements] + * If File::HomeDir is available, we use it to locate the + .perlcriticrc file. This should help make Perl::Critic + more portable to Win32 platforms. If File::HomeDir is + not installed, we resort to looking at the usual + environment variables. + + [Other Stuff] + * Added "perlcritic.el", which is a super-cool emacs minor-mode + that runs perl-critic on the current buffer and returns the + results in a sexy hot-linked "compiler" window. You can run + it on demand, or have it run automatically every time you + save the buffer. You can find this in the extras/ directory. + Thanks to Josh ben Jore for contributing this. + * Moved "Perl::Critic::TestUtils" into the installed build. This + module is only used for unit-testing Perl::Critic, but we + are putting it in the installation so folks who want to + extend Perl::Critic can make use of it. + + +0.17 2006-06-13 + + [Bug Fixes] + * 19836: Perl-Critic0.16 fails tests during install. This was + caused by a bug in version 3.01 of Module::Pluggable. See + http://rt.cpan.org/Ticket/Display.html?id=19857 for details. + * Fixed bug in no-critic pragma parser. + + [New Policies] + * ValuesAndExpressions::ProhibitEscapedCharacters + * BuiltinFunctions::RequireSimpleSortBlock + + [Enhancements] + * Perl::Critic can export critique() as a static function. This + may appeal to folks who dislike the object-oriented interface. + + +0.16 2006-05-14 + + [Enhancements] + * Perl::Critic->critique() now accepts a PPI::Document as the + argument. This feature creates an additional dependency on + Scalar::Util, but that shouldn't be a problem because it is + included with List::Util, which we already use. + + [Miscellanea] + * Increased PPI dependency from v1.110 to v1.112 + + +0.15_03 2006-05-07 + + [Bug Fixes] + * The "## no critic" feature is now implemented without eval-ing + the code. This keeps Perl::Critic pure and safe :) + * 19082: Page number for AUTOLOAD is incorrect + + [New Policies] + * ControlStructures::ProhibitUnreachableCode (by Peter Guzis) + * Modules::ProhibitAutomaticExportation + * ValuesAndExpressions::ProhibitVersionStrings + + +0.15_02 2006-04-26 + + [Bug Fixes] + * Reimplemented the '##no critic' pragmas to have effect on the + line where the violation is reported, not on the line where + the candidate element lives. This is because some policies + may report violations that are nowhere near the element that + is being evaluated. + * RequireUseStrict, RequireUseWarnings, and RequireExplcitPackage + all emit violations for _every_ statement that violates the + Policy. This closes a loophole that allowed you to circumvent + the Policy by using '## no critic' on just the first statement + that violated the policy. + * Fixed the workaround for the magic shebang that is inserted + by EU::MM and M::B. This had stopped working around version 13. + * Fixed -noprofile option on 'perlcritic'. This also had stopped + working at some point. + + +0.15_01 2006-04-16 + + [Enhancements] + * Added diagnostic messages if the .perlcriticrc contains entries + for Policy modules that don't seem to exist. + * Now you can specify which policies to disable with the + "## no critic" pseudo-pragmas. This feature is still + experimental. See docs for details. + * perlcritic's directory searching now skips backup files, such + as *.swp, *.bak and *~. It also ignores version control system + directories, and the blib directory in module build directories. + + [Bug Fixes] + * 18386: Bad example in POD for Documentation::RequirePodSections + * 18670: Test failure if Perl::Tidy is not installed + * 18698: Policy idea ProhibitUniversalFunctions (see New Policies) + * RequireInterpolationOfMetachars falsely hit strings like 'foo=s@' + which are commonly used with Getopt::Long. + + [New Policies] + * BuiltinFunctions::ProhibitUniversalCan (by Chris Dolan) + * BuiltinFunctions::ProhibitUniversalIsa (by Chris Dolan) + + [Miscellanea] + * All spurrious options for `perlcritic` are now fatal. + * Changed several of the -verbose formats to be more readable. + * Explicit -severity option now overrides -[12345] shortcuts instead + of being the other way around. + + +0.15 2006-03-26 + + [Bug Fixes] + * 17964: Insists my code is not tidy (may not be fixed for all cases) + + +0.14_02 2006-03-19 + + [Bug Fixes] + * 15653: False positive in OneArgSelect (fixed for real this time) + + [New Policies] + * ClassHierarchies::ProhibitAutoloading + * Documentation::RequirePodSections + * InputOutput::RequireBracedFileHandleWithPrint + * ValuesAndExpressions::ProhibitMixedBooleanOperators + * Variables::RequireInitializationForLocalVars + + +0.14_01 2006-03-05 + + [Bug Fixes] + * 14731: False positive: Builtin function called with parens + * 17554: False positive in CodeLayout::RequireTrailingCommas + + [New Policies] + * ClassHierarchies::ProhibitExplicitISA + * InputOutput::ProhibitReadlineInForLoop + * Miscellanea::ProhibitFormats + * Miscellanea::ProhibitTies + * Variables::ProhibitConditionalDeclarations + + +0.14 2006-01-29 + + * More documentation edits. + + [New Policies] + * Documentation::RequirePodAtEnd + * Subroutines::ProtectPrivateSubs + * Variables::ProhibitMatchVars + * Variables::ProtectPrivateVars + + [Bug Fixes] + * 15295: "## no critic" pragmas too aggresive on compound statements. + * t/01_config.t failed in the presence of third-party policies + * Implemented workaround for failing pod_coverage tests. + * 16906: tr/// created false-postives with RegularExpression polices. + + +0.13_04 2005-12-31 + + * Moved DEVELOPER.pod file into the Perl/Critic dir. + * More documentation edits. + + +0.13_03 2005-12-30 + + * perlcritic now prints 'source OK' if it doesn't find any + violations. This gives folks a warm fuzzy feeling. + * Tweaked some test cases that were failing on my Solaris + environment at work. + + +0.13_02 2005-12-29 + + * Fixed Config to recognize fully-qualified module names in the + .perlcriticrc file. + * Various documentation edits. + + +0.13_01 2005-12-28 + + * Replaced 'priority' concept with 'severity'. Now each Policy module + has a predefined severity level ranging from 1 to 5. By default, + perlcritic only reports the most severe violations. You can adjust + the severity threshold at the command line, and you can change + the severity for any Policy using the config file. + * Chris implemented the applies_to() mechanism, which allows each Policy + class to declare the types of PPI elements that it wants to examine. + When traversing the document, Perl::Critic invokes the Policy only + for elements that are of the correct type. This improves performance + by about 33%. + * Perl::Critic now uses a Plugin architecture to automatically + discover Policy modules. So if you have custom Policies, all you + have to do is install them in the Perl::Critic::Policy namespace -- + no need to add anything to your .perlcriticrc file. If you write + policies in a different namespace, you can configure that too. See + the Perl::Critic::Config docs for details. + + [New Policies] + * Modules::RequireEndWithOne + * NamingConventions::ProhibitAmbiguousNames + * References::ProhibitDoubleSigils + * Subroutines::RequireFinalReturn + * Subroutines::ProhibitAmpersandSigils + * Subroutines::ProhibitExcessComplexity + * TestingAndDebugging::ProhibitNoStrict + * TestingAndDebugging::ProhibitNoWarnings + + [Bug Fixes] + * 15101: Plugin architecture improves support for 3rd-party code + * 16319: Fixed incorrect PBP page number in ProhibitBarwordFilehandle + * 16321: Lists of empty quotes are now allowed by ProhibitQuotedWordLists + * 16288: Empty lists caused a fatal error RequireTrailingCommas + * 15653: Fixed false positive in OneArgSelect. + + +0.13 2005-10-31 + + * Renamed -Policy option to -include. Added -exclude to give the + opposite effect. + * Refactored constructor of Perl::Critic. Now, most of the work + is delegated to Perl::Critic::Config. I'm not sure I like how + this turned out, but we'll see how it goes. + * Renamed some Policy modules to be a bit more comprehensible. Note + that you may need to change your .perlcriticrc file accordingly. + I also suggest removing your current Perl::Critic installation + before installing this one. + * Improved error message when Perl::Critic dies because PPI can't + parse the input code. + * Changed output of -help to be more terse. + * Added -Policy option to perlcritic. The idea is to provide a + compact interface for selecting Policy modules at the command-line. + This feature is experimental and subject to change. + * Added a warning message if -verbose value looks strange. In most + applications, the -verbose option does not require a value, so people + might be puzzled when they write 'perlcritic -verbose my_file.pm' and + nothing seems to happen. + * Command-line options to perlcritic are now case-sensitive. This + makes it easier to abbreviate options that start with the same letters + (e.g. 'Version' and 'verbose') + * Fixed the new Policy modules that were misnamed and misplaced in the + previous distribution. + * Rewrote some of the ControlStructures and BuiltinFunction + policies to be simpler (and probably a little faster). + * Edited POD. Fixed some typos. Added PREREQUISITES section + to Perl::Critic documentation. + * Fixed the -verbose FORMAT option so that you can put metachars + in the FORMAT specification. If using perlcritic, be careful to + protect them from getting munged by the shell first. + * Replaced ProhibitRequireStatements with RequireBarewordIncludes + module. Courtesy of Chris Dolan + * Added configuration to ProhibitInterpolationOfLiterals so that + certain flavors of quotes can be exempt. This is for folks who + have configured their editor to use special syntax highlighting + for certain kinds of strings (SQL, for example). + * perlcritic now accepts multiple file arguments, so now you can + critique your entire distribution in one shot. As a result, the + output-formats have changed slightly. + + [New Policies] + * BuiltinFunctions::ProhibitLvalueSubstr + * BuiltinFunctions::ProhibitSleepViaSelect + * ClassHierarchies::ProhibitOneArgBless + * CodeLayout::RequireTrailingCommas + * CodeLayout::RequireQuotedWordLists + * InputOutput::ProhibitTwoArgOpen + * InputOutput::ProhibitOneArgSelect + * InputOutput::ProhibitBarewordFileHandles + * Miscellanea::RequireRcsKeywords + * Modules::RequireVersionVar + * RegularExpressions::RequireExtendedFormatting + * RegularExpressions::RequireLineBoundaryMatching + + [Name Changes] + * ProhibitUnpackagedCode => RequireExplicitPackage + * RequireQuotedWords => ProhibitQuotedWordLists + + [Bug Fixes] + 14923: 'require' is now permitted. See RequireBarewordIncludes. + 15022: Fixed false-positives when keywords are used as hash keys. + 15023: Fixed spurious Violations by removing magic shebang. + 15031: Fixed spelling mistakes (and probably added some new ones). + 15233: Postfix 'if' is now allowed with 'die', 'croak', etc. + + +0.12 2005-10-10 + + * The internal dynamics and API of Perl::Critic have changed + considerably. The result is a 300% increase in performance. + See the POD in Perl::Critic::Policy for details. + * Redesigned the 'verbose' feature. Now the output format + can be user-defined using a sprintf-like specification. + perlciritc also has a predefined output format that is + compatible with grep mode in editors like vim and emacs. + * 'return' is now exempt from ProhibitParensWithBuiltins. I may + extend this exemption to all unary functions. + * Edited POD. Added a super brief description of each policy + in the main Perl::Critic documentation. Added details about + editor integration. + + [New Features] + * Added -verbose option to put more stuff in the output. In the + extreme, you can get the POD from Policy attached to each + and every violation. + + [Additional Prerequisites] + * String::Format + * IO::String + * Pod::PlainText + + +0.10 2005-10-05 + + * Fixed stupid bug in newest Policy modules. They were returning + PPI objects instead of Perl::Critic::Violation objects. Doh! + * Fixed test scripts to prevent failures if the user already has a + .perlcriticrc file. + * 'ProhibitHardTabs' now allows leading tabs by default. + * Put the Changes file in reverse-chronological order, so the most + recent stuff is easy to find at the top of the file + + +0.09 2005-10-04 + + * Changed the syntax for the magic comments. Adam had the + idea of using a pragma-like notation. I liked it. + + [Bug Fixes] + * 14810: Now you are allowed to create your own 'import' function, + since this is frequently done with fancy modules. + * 14817: Parens, brackets, and braces are now excluded from + 'ProhibitNoisyQuotes' since they look better in quotes anyway. + * 14787: $1..$9 and '_' are exempt from ProhibitPunctuationVars + * 14899: Object methods with the same name as a built-in can + be called with parens (ProhibitParensWithBuiltins). + * 14901: Normalized the exit status of perlcritic to 0, 1, or 2. + See documentation for explanation. + * 14855: Partially fixed home directory discovery. Still not + completely portable, but at least doesn't create warnings. + + [New features] + * 14734: Limit for number separators is now configurable + + [New Policy modules] + * CodeLayout::ProhibitHardTabs + * ControlStructures::ProhibitUnlessBlocks + * ControlStructures::ProhibitUntilBlocks + * ControlStructures::ProhibitCStyleForLoops + + +0.08_2 2005-09-27 + + * Fixed problems with Perl::Critic::Config that caused File::Spec + to emit 'uninitialized value' warnings during the build. + * Added 1 Policy module contributed by Graham TerMarsch + * Switched from File::Spec::Functions to plain File::Spec because + I think its usage is more common. + * Removed 'FindBin' from the test files so I can be sure that the + right libraries are getting loaded. This means I'll have to + use the -l option with C. + * Fixed "ProhibitParensWithBuiltins" to allow parens to be used with + object method calls that have the same name as a builtin functions. + * Introduced magical comments that allow developers to configure + Perl::Critic on-the-fly from within their code. + * Added META.yml files and POD tests to the build. I did this + mostly just to boost the Kwalitee score on CPANTS. + * Switched from "Config::Std" to "Config::Tiny" because it doesn't + require those fancy Damian modules that don't seem to work on + some older versions of Perl. + * Edited more POD. + + +0.07 2005-09-21 + + * Fixed bugs in the ProhibitCascadingIfElse policy. + * Added ProhibitExplicitReturnUndef policy + * Made ProhibitUnpackagedCode configurable so you can exempt scripts, + which typically don't have an explicit 'package' statement. + * ProhibitPackageVars policy now exempts vars in ALL_CAPS. This + is to permit common package variables like @EXPORT and $VERSION. + * Renamed "ProhibitStringyGrep and "ProhibitStringyMap" because + the so-called string form doesn't really exist. Now called + "RequireBlockGrep" and "RequireBlockMap" + * Corrected documentation on defining Policy names within the + configuration file. This still isn't very clear and needs + to be rewritten. + * Perl::Critic now requires PPI version 1.003, which has a few bug + fixes of its own. + * Rewrite some code just to make Perl::Critic more self-compliant. + * Added test cases to verify the configuration functionality. These + are not completely thorough and need more work. + + +0.06 2005-09-17 + + * Now called 'Perl::Critic'. + * Added 4 new policy modules. + * Fixed bugs in build process. + * Added support for Module::Build. + + +0.05 2005-09-17 + + * End of 'Perl::Review' releases. I have changed the name to + 'Perl::Critic' to avoid possible confusion with "The Perl Review" + magazine. + + +0.04 2005-09-14 + + * Version 0.03 was a bust because I uploaded the wrong tarball to PAUSE. + + +0.03 2005-09-13 + + * Fixed some POD links. + * Removed test cases for missing policy module. + + +0.02 2005-09-13 + + * Major overhaul based on feedback from Perl community. + * Factored coding standards into separate modules (known as + Policies). The idea here is to allow other developers to easily + contribute additional coding standards. + * Reworked Perl::Review into a simple engine for loading and running + Policy modules. + * Gave perlreview a command-line interface and configuration file + for selecting which Policy modules to use. + + +0.01 2005-08-16 + + * Initial version. + + +# ex: set ts=8 sts=4 sw=4 tw=78 ft= expandtab shiftround : diff --git a/INSTALL b/INSTALL new file mode 100644 index 0000000..e2a0d28 --- /dev/null +++ b/INSTALL @@ -0,0 +1,11 @@ +INSTALLATION + + To install Perl::Critic give the following commands + to your favorite shell: + + tar -zxf Perl-Critic-1.126.tar.gz + cd Perl-Critic-1.126 + perl Build.pl + ./Build + ./Build test + ./Build install diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..358c5ff --- /dev/null +++ b/LICENSE @@ -0,0 +1,307 @@ +Terms of Perl itself + +a) the GNU General Public License as published by the Free + Software Foundation; either version 1, or (at your option) any + later version, or +b) the "Artistic License" + +---------------------------------------------------------------------------- + + GNU GENERAL PUBLIC LICENSE + Version 1, February 1989 + + Copyright (C) 1989 Free Software Foundation, Inc. + 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The license agreements of most software companies try to keep users +at the mercy of those companies. By contrast, our General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. The +General Public License applies to the Free Software Foundation's +software and to any other program whose authors commit to using it. +You can use it for your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Specifically, the General Public License is designed to make +sure that you have the freedom to give away or sell copies of free +software, that you receive source code or can get it if you want it, +that you can change the software or use pieces of it in new free +programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of a such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must tell them their rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any program or other work which +contains a notice placed by the copyright holder saying it may be +distributed under the terms of this General Public License. The +"Program", below, refers to any such program or work, and a "work based +on the Program" means either the Program or any work containing the +Program or a portion of it, either verbatim or with modifications. Each +licensee is addressed as "you". + + 1. You may copy and distribute verbatim copies of the Program's source +code as you receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice and +disclaimer of warranty; keep intact all the notices that refer to this +General Public License and to the absence of any warranty; and give any +other recipients of the Program a copy of this General Public License +along with the Program. You may charge a fee for the physical act of +transferring a copy. + + 2. You may modify your copy or copies of the Program or any portion of +it, and copy and distribute such modifications under the terms of Paragraph +1 above, provided that you also do the following: + + a) cause the modified files to carry prominent notices stating that + you changed the files and the date of any change; and + + b) cause the whole of any work that you distribute or publish, that + in whole or in part contains the Program or any part thereof, either + with or without modifications, to be licensed at no charge to all + third parties under the terms of this General Public License (except + that you may choose to grant warranty protection to some or all + third parties, at your option). + + c) If the modified program normally reads commands interactively when + run, you must cause it, when started running for such interactive use + in the simplest and most usual way, to print or display an + announcement including an appropriate copyright notice and a notice + that there is no warranty (or else, saying that you provide a + warranty) and that users may redistribute the program under these + conditions, and telling the user how to view a copy of this General + Public License. + + d) You may charge a fee for the physical act of transferring a + copy, and you may at your option offer warranty protection in + exchange for a fee. + +Mere aggregation of another independent work with the Program (or its +derivative) on a volume of a storage or distribution medium does not bring +the other work under the scope of these terms. + + 3. You may copy and distribute the Program (or a portion or derivative of +it, under Paragraph 2) in object code or executable form under the terms of +Paragraphs 1 and 2 above provided that you also do one of the following: + + a) accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of + Paragraphs 1 and 2 above; or, + + b) accompany it with a written offer, valid for at least three + years, to give any third party free (except for a nominal charge + for the cost of distribution) a complete machine-readable copy of the + corresponding source code, to be distributed under the terms of + Paragraphs 1 and 2 above; or, + + c) accompany it with the information you received as to where the + corresponding source code may be obtained. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form alone.) + +Source code for a work means the preferred form of the work for making +modifications to it. For an executable file, complete source code means +all the source code for all modules it contains; but, as a special +exception, it need not include source code for modules which are standard +libraries that accompany the operating system on which the executable +file runs, or for standard header files or definitions files that +accompany that operating system. + + 4. You may not copy, modify, sublicense, distribute or transfer the +Program except as expressly provided under this General Public License. +Any attempt otherwise to copy, modify, sublicense, distribute or transfer +the Program is void, and will automatically terminate your rights to use +the Program under this License. However, parties who have received +copies, or rights to use copies, from you under this General Public +License will not have their licenses terminated so long as such parties +remain in full compliance. + + 5. By copying, distributing or modifying the Program (or any work based +on the Program) you indicate your acceptance of this license to do so, +and all its terms and conditions. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the original +licensor to copy, distribute or modify the Program subject to these +terms and conditions. You may not impose any further restrictions on the +recipients' exercise of the rights granted herein. + + 7. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of the license which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +the license, you may choose any version ever published by the Free Software +Foundation. + + 8. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + +---------------------------------------------------------------------------- + +The Artistic License + +Preamble + +The intent of this document is to state the conditions under which a Package +may be copied, such that the Copyright Holder maintains some semblance of +artistic control over the development of the package, while giving the users of the +package the right to use and distribute the Package in a more-or-less customary +fashion, plus the right to make reasonable modifications. + +Definitions: + +- "Package" refers to the collection of files distributed by the Copyright + Holder, and derivatives of that collection of files created through textual + modification. +- "Standard Version" refers to such a Package if it has not been modified, + or has been modified in accordance with the wishes of the Copyright + Holder. +- "Copyright Holder" is whoever is named in the copyright or copyrights for + the package. +- "You" is you, if you're thinking about copying or distributing this Package. +- "Reasonable copying fee" is whatever you can justify on the basis of + media cost, duplication charges, time of people involved, and so on. (You + will not be required to justify it to the Copyright Holder, but only to the + computing community at large as a market that must bear the fee.) +- "Freely Available" means that no fee is charged for the item itself, though + there may be fees involved in handling the item. It also means that + recipients of the item may redistribute it under the same conditions they + received it. + +1. You may make and give away verbatim copies of the source form of the +Standard Version of this Package without restriction, provided that you duplicate +all of the original copyright notices and associated disclaimers. + +2. You may apply bug fixes, portability fixes and other modifications derived from +the Public Domain or from the Copyright Holder. A Package modified in such a +way shall still be considered the Standard Version. + +3. You may otherwise modify your copy of this Package in any way, provided +that you insert a prominent notice in each changed file stating how and when +you changed that file, and provided that you do at least ONE of the following: + + a) place your modifications in the Public Domain or otherwise + make them Freely Available, such as by posting said modifications + to Usenet or an equivalent medium, or placing the modifications on + a major archive site such as ftp.uu.net, or by allowing the + Copyright Holder to include your modifications in the Standard + Version of the Package. + + b) use the modified Package only within your corporation or + organization. + + c) rename any non-standard executables so the names do not + conflict with standard executables, which must also be provided, + and provide a separate manual page for each non-standard + executable that clearly documents how it differs from the Standard + Version. + + d) make other distribution arrangements with the Copyright Holder. + +4. You may distribute the programs of this Package in object code or executable +form, provided that you do at least ONE of the following: + + a) distribute a Standard Version of the executables and library + files, together with instructions (in the manual page or equivalent) + on where to get the Standard Version. + + b) accompany the distribution with the machine-readable source of + the Package with your modifications. + + c) accompany any non-standard executables with their + corresponding Standard Version executables, giving the + non-standard executables non-standard names, and clearly + documenting the differences in manual pages (or equivalent), + together with instructions on where to get the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +5. You may charge a reasonable copying fee for any distribution of this Package. +You may charge any fee you choose for support of this Package. You may not +charge a fee for this Package itself. However, you may distribute this Package in +aggregate with other (possibly commercial) programs as part of a larger +(possibly commercial) software distribution provided that you do not advertise +this Package as a product of your own. + +6. The scripts and library files supplied as input to or produced as output from +the programs of this Package do not automatically fall under the copyright of this +Package, but belong to whomever generated them, and may be sold +commercially, and may be aggregated with this Package. + +7. C or perl subroutines supplied by you and linked into this Package shall not +be considered part of this Package. + +8. The name of the Copyright Holder may not be used to endorse or promote +products derived from this software without specific prior written permission. + +9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED +WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR +PURPOSE. + +The End + + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..be6b5c1 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,427 @@ +bin/perlcritic +Build.PL +Changes +CONTRIBUTING.md +cpanfile +examples/generatestats +examples/loadanalysisdb +examples/perlcriticrc +examples/perlcriticrc-conway +extras/perlcritic.el +inc/Devel/AssertOS.pm +inc/Devel/AssertOS/Solaris.pm +inc/Devel/CheckOS.pm +inc/Perl/Critic/BuildUtilities.pm +inc/Perl/Critic/Module/Build.pm +inc/Perl/Critic/Module/Build/Standard.pm +inc/Perl/Critic/PolicySummaryGenerator.pm +INSTALL +lib/Perl/Critic.pm +lib/Perl/Critic/Annotation.pm +lib/Perl/Critic/Command.pm +lib/Perl/Critic/Config.pm +lib/Perl/Critic/CORE_DEVELOPER.pod +lib/Perl/Critic/DEVELOPER.pod +lib/Perl/Critic/Document.pm +lib/Perl/Critic/Exception.pm +lib/Perl/Critic/Exception/AggregateConfiguration.pm +lib/Perl/Critic/Exception/Configuration.pm +lib/Perl/Critic/Exception/Configuration/Generic.pm +lib/Perl/Critic/Exception/Configuration/NonExistentPolicy.pm +lib/Perl/Critic/Exception/Configuration/Option.pm +lib/Perl/Critic/Exception/Configuration/Option/Global.pm +lib/Perl/Critic/Exception/Configuration/Option/Global/ExtraParameter.pm +lib/Perl/Critic/Exception/Configuration/Option/Global/ParameterValue.pm +lib/Perl/Critic/Exception/Configuration/Option/Policy.pm +lib/Perl/Critic/Exception/Configuration/Option/Policy/ExtraParameter.pm +lib/Perl/Critic/Exception/Configuration/Option/Policy/ParameterValue.pm +lib/Perl/Critic/Exception/Fatal.pm +lib/Perl/Critic/Exception/Fatal/Generic.pm +lib/Perl/Critic/Exception/Fatal/Internal.pm +lib/Perl/Critic/Exception/Fatal/PolicyDefinition.pm +lib/Perl/Critic/Exception/IO.pm +lib/Perl/Critic/Exception/Parse.pm +lib/Perl/Critic/OptionsProcessor.pm +lib/Perl/Critic/Policy.pm +lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitBooleanGrep.pm +lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitComplexMappings.pm +lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitLvalueSubstr.pm +lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitReverseSortBlock.pm +lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitShiftRef.pm +lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitSleepViaSelect.pm +lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringyEval.pm +lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringySplit.pm +lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalCan.pm +lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalIsa.pm +lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUselessTopic.pm +lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidGrep.pm +lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidMap.pm +lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockGrep.pm +lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockMap.pm +lib/Perl/Critic/Policy/BuiltinFunctions/RequireGlobFunction.pm +lib/Perl/Critic/Policy/BuiltinFunctions/RequireSimpleSortBlock.pm +lib/Perl/Critic/Policy/ClassHierarchies/ProhibitAutoloading.pm +lib/Perl/Critic/Policy/ClassHierarchies/ProhibitExplicitISA.pm +lib/Perl/Critic/Policy/ClassHierarchies/ProhibitOneArgBless.pm +lib/Perl/Critic/Policy/CodeLayout/ProhibitHardTabs.pm +lib/Perl/Critic/Policy/CodeLayout/ProhibitParensWithBuiltins.pm +lib/Perl/Critic/Policy/CodeLayout/ProhibitQuotedWordLists.pm +lib/Perl/Critic/Policy/CodeLayout/ProhibitTrailingWhitespace.pm +lib/Perl/Critic/Policy/CodeLayout/RequireConsistentNewlines.pm +lib/Perl/Critic/Policy/CodeLayout/RequireTidyCode.pm +lib/Perl/Critic/Policy/CodeLayout/RequireTrailingCommas.pm +lib/Perl/Critic/Policy/ControlStructures/ProhibitCascadingIfElse.pm +lib/Perl/Critic/Policy/ControlStructures/ProhibitCStyleForLoops.pm +lib/Perl/Critic/Policy/ControlStructures/ProhibitDeepNests.pm +lib/Perl/Critic/Policy/ControlStructures/ProhibitLabelsWithSpecialBlockNames.pm +lib/Perl/Critic/Policy/ControlStructures/ProhibitMutatingListFunctions.pm +lib/Perl/Critic/Policy/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.pm +lib/Perl/Critic/Policy/ControlStructures/ProhibitPostfixControls.pm +lib/Perl/Critic/Policy/ControlStructures/ProhibitUnlessBlocks.pm +lib/Perl/Critic/Policy/ControlStructures/ProhibitUnreachableCode.pm +lib/Perl/Critic/Policy/ControlStructures/ProhibitUntilBlocks.pm +lib/Perl/Critic/Policy/ControlStructures/ProhibitYadaOperator.pm +lib/Perl/Critic/Policy/Documentation/PodSpelling.pm +lib/Perl/Critic/Policy/Documentation/RequirePackageMatchesPodName.pm +lib/Perl/Critic/Policy/Documentation/RequirePodAtEnd.pm +lib/Perl/Critic/Policy/Documentation/RequirePodSections.pm +lib/Perl/Critic/Policy/ErrorHandling/RequireCarping.pm +lib/Perl/Critic/Policy/ErrorHandling/RequireCheckingReturnValueOfEval.pm +lib/Perl/Critic/Policy/InputOutput/ProhibitBacktickOperators.pm +lib/Perl/Critic/Policy/InputOutput/ProhibitBarewordFileHandles.pm +lib/Perl/Critic/Policy/InputOutput/ProhibitExplicitStdin.pm +lib/Perl/Critic/Policy/InputOutput/ProhibitInteractiveTest.pm +lib/Perl/Critic/Policy/InputOutput/ProhibitJoinedReadline.pm +lib/Perl/Critic/Policy/InputOutput/ProhibitOneArgSelect.pm +lib/Perl/Critic/Policy/InputOutput/ProhibitReadlineInForLoop.pm +lib/Perl/Critic/Policy/InputOutput/ProhibitTwoArgOpen.pm +lib/Perl/Critic/Policy/InputOutput/RequireBracedFileHandleWithPrint.pm +lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm +lib/Perl/Critic/Policy/InputOutput/RequireCheckedClose.pm +lib/Perl/Critic/Policy/InputOutput/RequireCheckedOpen.pm +lib/Perl/Critic/Policy/InputOutput/RequireCheckedSyscalls.pm +lib/Perl/Critic/Policy/InputOutput/RequireEncodingWithUTF8Layer.pm +lib/Perl/Critic/Policy/Miscellanea/ProhibitFormats.pm +lib/Perl/Critic/Policy/Miscellanea/ProhibitTies.pm +lib/Perl/Critic/Policy/Miscellanea/ProhibitUnrestrictedNoCritic.pm +lib/Perl/Critic/Policy/Miscellanea/ProhibitUselessNoCritic.pm +lib/Perl/Critic/Policy/Modules/ProhibitAutomaticExportation.pm +lib/Perl/Critic/Policy/Modules/ProhibitConditionalUseStatements.pm +lib/Perl/Critic/Policy/Modules/ProhibitEvilModules.pm +lib/Perl/Critic/Policy/Modules/ProhibitExcessMainComplexity.pm +lib/Perl/Critic/Policy/Modules/ProhibitMultiplePackages.pm +lib/Perl/Critic/Policy/Modules/RequireBarewordIncludes.pm +lib/Perl/Critic/Policy/Modules/RequireEndWithOne.pm +lib/Perl/Critic/Policy/Modules/RequireExplicitPackage.pm +lib/Perl/Critic/Policy/Modules/RequireFilenameMatchesPackage.pm +lib/Perl/Critic/Policy/Modules/RequireNoMatchVarsWithUseEnglish.pm +lib/Perl/Critic/Policy/Modules/RequireVersionVar.pm +lib/Perl/Critic/Policy/NamingConventions/Capitalization.pm +lib/Perl/Critic/Policy/NamingConventions/ProhibitAmbiguousNames.pm +lib/Perl/Critic/Policy/Objects/ProhibitIndirectSyntax.pm +lib/Perl/Critic/Policy/References/ProhibitDoubleSigils.pm +lib/Perl/Critic/Policy/RegularExpressions/ProhibitCaptureWithoutTest.pm +lib/Perl/Critic/Policy/RegularExpressions/ProhibitComplexRegexes.pm +lib/Perl/Critic/Policy/RegularExpressions/ProhibitEnumeratedClasses.pm +lib/Perl/Critic/Policy/RegularExpressions/ProhibitEscapedMetacharacters.pm +lib/Perl/Critic/Policy/RegularExpressions/ProhibitFixedStringMatches.pm +lib/Perl/Critic/Policy/RegularExpressions/ProhibitSingleCharAlternation.pm +lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusedCapture.pm +lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusualDelimiters.pm +lib/Perl/Critic/Policy/RegularExpressions/ProhibitUselessTopic.pm +lib/Perl/Critic/Policy/RegularExpressions/RequireBracesForMultiline.pm +lib/Perl/Critic/Policy/RegularExpressions/RequireDotMatchAnything.pm +lib/Perl/Critic/Policy/RegularExpressions/RequireExtendedFormatting.pm +lib/Perl/Critic/Policy/RegularExpressions/RequireLineBoundaryMatching.pm +lib/Perl/Critic/Policy/Subroutines/ProhibitAmpersandSigils.pm +lib/Perl/Critic/Policy/Subroutines/ProhibitBuiltinHomonyms.pm +lib/Perl/Critic/Policy/Subroutines/ProhibitExcessComplexity.pm +lib/Perl/Critic/Policy/Subroutines/ProhibitExplicitReturnUndef.pm +lib/Perl/Critic/Policy/Subroutines/ProhibitManyArgs.pm +lib/Perl/Critic/Policy/Subroutines/ProhibitNestedSubs.pm +lib/Perl/Critic/Policy/Subroutines/ProhibitReturnSort.pm +lib/Perl/Critic/Policy/Subroutines/ProhibitSubroutinePrototypes.pm +lib/Perl/Critic/Policy/Subroutines/ProhibitUnusedPrivateSubroutines.pm +lib/Perl/Critic/Policy/Subroutines/ProtectPrivateSubs.pm +lib/Perl/Critic/Policy/Subroutines/RequireArgUnpacking.pm +lib/Perl/Critic/Policy/Subroutines/RequireFinalReturn.pm +lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoStrict.pm +lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoWarnings.pm +lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitProlongedStrictureOverride.pm +lib/Perl/Critic/Policy/TestingAndDebugging/RequireTestLabels.pm +lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseStrict.pm +lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseWarnings.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitCommaSeparatedStatements.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitComplexVersion.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitConstantPragma.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEmptyQuotes.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEscapedCharacters.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitImplicitNewlines.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitInterpolationOfLiterals.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLeadingZeros.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLongChainsOfMethodCalls.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMagicNumbers.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMismatchedOperators.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMixedBooleanOperators.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitNoisyQuotes.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitQuotesAsQuotelikeOperatorDelimiters.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitSpecialLiteralHeredocTerminator.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitVersionStrings.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/RequireConstantVersion.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/RequireInterpolationOfMetachars.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/RequireNumberSeparators.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/RequireQuotedHeredocTerminator.pm +lib/Perl/Critic/Policy/ValuesAndExpressions/RequireUpperCaseHeredocTerminator.pm +lib/Perl/Critic/Policy/Variables/ProhibitAugmentedAssignmentInDeclaration.pm +lib/Perl/Critic/Policy/Variables/ProhibitConditionalDeclarations.pm +lib/Perl/Critic/Policy/Variables/ProhibitEvilVariables.pm +lib/Perl/Critic/Policy/Variables/ProhibitLocalVars.pm +lib/Perl/Critic/Policy/Variables/ProhibitMatchVars.pm +lib/Perl/Critic/Policy/Variables/ProhibitPackageVars.pm +lib/Perl/Critic/Policy/Variables/ProhibitPerl4PackageNames.pm +lib/Perl/Critic/Policy/Variables/ProhibitPunctuationVars.pm +lib/Perl/Critic/Policy/Variables/ProhibitReusedNames.pm +lib/Perl/Critic/Policy/Variables/ProhibitUnusedVariables.pm +lib/Perl/Critic/Policy/Variables/ProtectPrivateVars.pm +lib/Perl/Critic/Policy/Variables/RequireInitializationForLocalVars.pm +lib/Perl/Critic/Policy/Variables/RequireLexicalLoopIterators.pm +lib/Perl/Critic/Policy/Variables/RequireLocalizedPunctuationVars.pm +lib/Perl/Critic/Policy/Variables/RequireNegativeIndices.pm +lib/Perl/Critic/PolicyConfig.pm +lib/Perl/Critic/PolicyFactory.pm +lib/Perl/Critic/PolicyListing.pm +lib/Perl/Critic/PolicyParameter.pm +lib/Perl/Critic/PolicyParameter/Behavior.pm +lib/Perl/Critic/PolicyParameter/Behavior/Boolean.pm +lib/Perl/Critic/PolicyParameter/Behavior/Enumeration.pm +lib/Perl/Critic/PolicyParameter/Behavior/Integer.pm +lib/Perl/Critic/PolicyParameter/Behavior/String.pm +lib/Perl/Critic/PolicyParameter/Behavior/StringList.pm +lib/Perl/Critic/PolicySummary.pod +lib/Perl/Critic/ProfilePrototype.pm +lib/Perl/Critic/Statistics.pm +lib/Perl/Critic/TestUtils.pm +lib/Perl/Critic/Theme.pm +lib/Perl/Critic/ThemeListing.pm +lib/Perl/Critic/UserProfile.pm +lib/Perl/Critic/Utils.pm +lib/Perl/Critic/Utils/Constants.pm +lib/Perl/Critic/Utils/DataConversion.pm +lib/Perl/Critic/Utils/McCabe.pm +lib/Perl/Critic/Utils/Perl.pm +lib/Perl/Critic/Utils/POD.pm +lib/Perl/Critic/Utils/POD/ParseInteriorSequence.pm +lib/Perl/Critic/Utils/PPI.pm +lib/Perl/Critic/Violation.pm +lib/Test/Perl/Critic/Policy.pm +LICENSE +MANIFEST This list of files +META.json +META.yml +README +README.md +t/00_modules.t +t/00_versions.t +t/01_bad_perlcriticrc +t/01_config.t +t/01_config_bad_perlcriticrc.t +t/01_policy_config.t +t/02_policy.t +t/03_annotations.t +t/03_pragmas.t +t/04_options_processor.t +t/05_utils.t +t/05_utils_perl.t +t/05_utils_pod.t +t/05_utils_ppi.t +t/06_violation.d/lib/Perl/Critic/Policy/Test.pm +t/06_violation.d/lib/ViolationTest.pm +t/06_violation.d/lib/ViolationTest2.pm +t/06_violation.d/source/Line.pm +t/06_violation.t +t/07_command.t +t/07_perlcritic.t +t/08_document.t +t/09_theme.t +t/10_user_profile.t +t/11_policy_factory.t +t/12_policy_listing.t +t/12_theme_listing.t +t/13_bundled_policies.t +t/14_policy_parameter_behavior_boolean.t +t/14_policy_parameter_behavior_enumeration.t +t/14_policy_parameter_behavior_integer.t +t/14_policy_parameter_behavior_list_string.t +t/14_policy_parameter_behavior_string.t +t/14_policy_parameters.t +t/15_statistics.t +t/16_roundtrip_defaults.t +t/20_policies.t +t/20_policy_pod_spelling.d/stop-words.txt +t/20_policy_pod_spelling.t +t/20_policy_prohibit_evil_modules.t +t/20_policy_prohibit_hard_tabs.t +t/20_policy_prohibit_trailing_whitespace.t +t/20_policy_require_consistent_newlines.t +t/20_policy_require_tidy_code.t +t/92_memory_leaks.t +t/BuiltinFunctions/ProhibitBooleanGrep.run +t/BuiltinFunctions/ProhibitComplexMappings.run +t/BuiltinFunctions/ProhibitLvalueSubstr.run +t/BuiltinFunctions/ProhibitReverseSortBlock.run +t/BuiltinFunctions/ProhibitShiftRef.run +t/BuiltinFunctions/ProhibitSleepViaSelect.run +t/BuiltinFunctions/ProhibitStringyEval.run +t/BuiltinFunctions/ProhibitStringySplit.run +t/BuiltinFunctions/ProhibitUniversalCan.run +t/BuiltinFunctions/ProhibitUniversalIsa.run +t/BuiltinFunctions/ProhibitUselessTopic.run +t/BuiltinFunctions/ProhibitVoidGrep.run +t/BuiltinFunctions/ProhibitVoidMap.run +t/BuiltinFunctions/RequireBlockGrep.run +t/BuiltinFunctions/RequireBlockMap.run +t/BuiltinFunctions/RequireGlobFunction.run +t/BuiltinFunctions/RequireSimpleSortBlock.run +t/ClassHierarchies/ProhibitAutoloading.run +t/ClassHierarchies/ProhibitExplicitISA.run +t/ClassHierarchies/ProhibitOneArgBless.run +t/CodeLayout/ProhibitParensWithBuiltins.run +t/CodeLayout/ProhibitQuotedWordLists.run +t/CodeLayout/RequireTrailingCommas.run +t/ControlStructures/ProhibitCascadingIfElse.run +t/ControlStructures/ProhibitCStyleForLoops.run +t/ControlStructures/ProhibitDeepNests.run +t/ControlStructures/ProhibitLabelsWithSpecialBlockNames.run +t/ControlStructures/ProhibitMutatingListFunctions.run +t/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.run.PL +t/ControlStructures/ProhibitPostfixControls.run +t/ControlStructures/ProhibitUnlessBlocks.run +t/ControlStructures/ProhibitUnreachableCode.run +t/ControlStructures/ProhibitUntilBlocks.run +t/ControlStructures/ProhibitYadaOperator.run +t/Documentation/RequirePackageMatchesPodName.run +t/Documentation/RequirePodAtEnd.run +t/Documentation/RequirePodSections.run +t/ErrorHandling/RequireCarping.run +t/ErrorHandling/RequireCheckingReturnValueOfEval.run +t/gh-734.t +t/InputOutput/ProhibitBacktickOperators.run +t/InputOutput/ProhibitBarewordFileHandles.run +t/InputOutput/ProhibitExplicitStdin.run +t/InputOutput/ProhibitInteractiveTest.run +t/InputOutput/ProhibitJoinedReadline.run +t/InputOutput/ProhibitOneArgSelect.run +t/InputOutput/ProhibitReadlineInForLoop.run +t/InputOutput/ProhibitTwoArgOpen.run +t/InputOutput/RequireBracedFileHandleWithPrint.run +t/InputOutput/RequireBriefOpen.run +t/InputOutput/RequireCheckedClose.run +t/InputOutput/RequireCheckedOpen.run +t/InputOutput/RequireCheckedSyscalls.run +t/InputOutput/RequireEncodingWithUTF8Layer.run +t/Miscellanea/ProhibitFormats.run +t/Miscellanea/ProhibitTies.run +t/Miscellanea/ProhibitUnrestrictedNoCritic.run +t/Modules/ProhibitAutomaticExportation.run +t/Modules/ProhibitConditionalUseStatements.run +t/Modules/ProhibitEvilModules.d/modules-no-regular-expressions.txt +t/Modules/ProhibitEvilModules.d/modules-regular-expressions.txt +t/Modules/ProhibitEvilModules.run +t/Modules/ProhibitExcessMainComplexity.run +t/Modules/ProhibitMultiplePackages.run +t/Modules/RequireBarewordIncludes.run +t/Modules/RequireEndWithOne.run +t/Modules/RequireExplicitPackage.run +t/Modules/RequireFilenameMatchesPackage.run +t/Modules/RequireNoMatchVarsWithUseEnglish.run +t/Modules/RequireVersionVar.run +t/NamingConventions/Capitalization.run.PL +t/NamingConventions/ProhibitAmbiguousNames.run +t/Objects/ProhibitIndirectSyntax.run +t/References/ProhibitDoubleSigils.run +t/RegularExpressions/ProhibitCaptureWithoutTest.run +t/RegularExpressions/ProhibitComplexRegexes.run +t/RegularExpressions/ProhibitEnumeratedClasses.run +t/RegularExpressions/ProhibitEscapedMetacharacters.run +t/RegularExpressions/ProhibitFixedStringMatches.run +t/RegularExpressions/ProhibitSingleCharAlternation.run +t/RegularExpressions/ProhibitUnusedCapture.run +t/RegularExpressions/ProhibitUnusualDelimiters.run +t/RegularExpressions/ProhibitUselessTopic.run +t/RegularExpressions/RequireBracesForMultiline.run +t/RegularExpressions/RequireDotMatchAnything.run +t/RegularExpressions/RequireExtendedFormatting.run +t/RegularExpressions/RequireLineBoundaryMatching.run +t/Subroutines/ProhibitAmpersandSigils.run +t/Subroutines/ProhibitBuiltinHomonyms.run +t/Subroutines/ProhibitExcessComplexity.run +t/Subroutines/ProhibitExplicitReturnUndef.run +t/Subroutines/ProhibitManyArgs.run +t/Subroutines/ProhibitNestedSubs.run +t/Subroutines/ProhibitReturnSort.run +t/Subroutines/ProhibitSubroutinePrototypes.run +t/Subroutines/ProhibitUnusedPrivateSubroutines.run +t/Subroutines/ProtectPrivateSubs.run +t/Subroutines/RequireArgUnpacking.run +t/Subroutines/RequireFinalReturn.run +t/TestingAndDebugging/ProhibitNoStrict.run +t/TestingAndDebugging/ProhibitNoWarnings.run +t/TestingAndDebugging/ProhibitProlongedStrictureOverride.run +t/TestingAndDebugging/RequireTestLabels.run +t/TestingAndDebugging/RequireUseStrict.run +t/TestingAndDebugging/RequireUseWarnings.run +t/ValuesAndExpressions/ProhibitCommaSeparatedStatements.run +t/ValuesAndExpressions/ProhibitComplexVersion.run +t/ValuesAndExpressions/ProhibitConstantPragma.run +t/ValuesAndExpressions/ProhibitEmptyQuotes.run +t/ValuesAndExpressions/ProhibitEscapedCharacters.run +t/ValuesAndExpressions/ProhibitImplicitNewlines.run +t/ValuesAndExpressions/ProhibitInterpolationOfLiterals.run +t/ValuesAndExpressions/ProhibitLeadingZeros.run +t/ValuesAndExpressions/ProhibitLongChainsOfMethodCalls.run +t/ValuesAndExpressions/ProhibitMagicNumbers.run +t/ValuesAndExpressions/ProhibitMismatchedOperators.run +t/ValuesAndExpressions/ProhibitMixedBooleanOperators.run +t/ValuesAndExpressions/ProhibitNoisyQuotes.run +t/ValuesAndExpressions/ProhibitQuotesAsQuotelikeOperatorDelimiters.run +t/ValuesAndExpressions/ProhibitSpecialLiteralHeredocTerminator.run +t/ValuesAndExpressions/ProhibitVersionStrings.run +t/ValuesAndExpressions/RequireConstantVersion.run +t/ValuesAndExpressions/RequireInterpolationOfMetachars.run +t/ValuesAndExpressions/RequireNumberSeparators.run +t/ValuesAndExpressions/RequireQuotedHeredocTerminator.run +t/ValuesAndExpressions/RequireUpperCaseHeredocTerminator.run +t/Variables/ProhibitAugmentedAssignmentInDeclaration.run +t/Variables/ProhibitConditionalDeclarations.run +t/Variables/ProhibitEvilVariables.d/variables-no-regular-expressions.txt +t/Variables/ProhibitEvilVariables.d/variables-regular-expressions.txt +t/Variables/ProhibitEvilVariables.run +t/Variables/ProhibitLocalVars.run +t/Variables/ProhibitMatchVars.run +t/Variables/ProhibitPackageVars.run +t/Variables/ProhibitPerl4PackageNames.run +t/Variables/ProhibitPunctuationVars.run +t/Variables/ProhibitReusedNames.run +t/Variables/ProhibitUnusedVariables.run +t/Variables/ProtectPrivateVars.run +t/Variables/RequireInitializationForLocalVars.run +t/Variables/RequireLexicalLoopIterators.run +t/Variables/RequireLocalizedPunctuationVars.run.PL +t/Variables/RequireNegativeIndices.run +TODO.pod +tools/ppidump +xt/40_criticize-code.t +xt/40_perlcriticrc-code +xt/40_stop_words +xt/41_criticize-policies.t +xt/41_perlcriticrc-policies +xt/42_criticize-tests.t +xt/42_perlcriticrc-tests +xt/43_criticize-run-files.t +xt/43_perlcriticrc-run-files +xt/80_policysummary.t +xt/81_ppi_problems.t +xt/94_includes.t +xt/95_kwalitee.t +xt/98_pod_syntax.t +xt/99_pod_coverage.t diff --git a/META.json b/META.json new file mode 100644 index 0000000..0d1e55c --- /dev/null +++ b/META.json @@ -0,0 +1,896 @@ +{ + "abstract" : "Critique Perl source code for best-practices.", + "author" : [ + "Jeffrey Thalhammer " + ], + "dynamic_config" : 1, + "generated_by" : "Module::Build version 0.4231", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "Perl-Critic", + "no_index" : { + "directory" : [ + "doc", + "inc", + "tools", + "xt" + ], + "file" : [ + "TODO.pod" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "Test::Deep" : "0", + "Test::More" : "0", + "lib" : "0" + } + }, + "configure" : { + "requires" : { + "Module::Build" : "0.4204" + } + }, + "runtime" : { + "requires" : { + "B::Keywords" : "1.05", + "Carp" : "0", + "Config::Tiny" : "2", + "English" : "0", + "Exception::Class" : "1.23", + "Exporter" : "5.63", + "Fatal" : "0", + "File::Basename" : "0", + "File::Find" : "0", + "File::Path" : "0", + "File::Spec" : "0", + "File::Spec::Unix" : "0", + "File::Temp" : "0", + "File::Which" : "0", + "Getopt::Long" : "0", + "IO::String" : "0", + "IPC::Open2" : "1", + "List::MoreUtils" : "0.19", + "List::Util" : "0", + "Module::Build" : "0.4204", + "Module::Pluggable" : "3.1", + "PPI" : "1.265", + "PPI::Document" : "1.265", + "PPI::Document::File" : "1.265", + "PPI::Node" : "1.265", + "PPI::Token::Quote::Single" : "1.265", + "PPI::Token::Whitespace" : "1.265", + "PPIx::QuoteLike" : "0", + "PPIx::Regexp" : "0.027", + "PPIx::Regexp::Util" : "0.068", + "PPIx::Utilities::Node" : "1.001", + "PPIx::Utilities::Statement" : "1.001", + "Perl::Tidy" : "0", + "Pod::Parser" : "0", + "Pod::PlainText" : "0", + "Pod::Select" : "0", + "Pod::Spell" : "1", + "Pod::Usage" : "0", + "Readonly" : "2", + "Scalar::Util" : "0", + "String::Format" : "1.18", + "Task::Weaken" : "0", + "Term::ANSIColor" : "2.02", + "Test::Builder" : "0.92", + "Text::ParseWords" : "3", + "base" : "0", + "charnames" : "0", + "overload" : "0", + "perl" : "5.006001", + "strict" : "0", + "version" : "0.77", + "warnings" : "0" + } + } + }, + "provides" : { + "Perl::Critic" : { + "file" : "lib/Perl/Critic.pm", + "version" : "1.140" + }, + "Perl::Critic::Annotation" : { + "file" : "lib/Perl/Critic/Annotation.pm", + "version" : "1.140" + }, + "Perl::Critic::Command" : { + "file" : "lib/Perl/Critic/Command.pm", + "version" : "1.140" + }, + "Perl::Critic::Config" : { + "file" : "lib/Perl/Critic/Config.pm", + "version" : "1.140" + }, + "Perl::Critic::Document" : { + "file" : "lib/Perl/Critic/Document.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception" : { + "file" : "lib/Perl/Critic/Exception.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::AggregateConfiguration" : { + "file" : "lib/Perl/Critic/Exception/AggregateConfiguration.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::Configuration" : { + "file" : "lib/Perl/Critic/Exception/Configuration.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::Configuration::Generic" : { + "file" : "lib/Perl/Critic/Exception/Configuration/Generic.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::Configuration::NonExistentPolicy" : { + "file" : "lib/Perl/Critic/Exception/Configuration/NonExistentPolicy.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::Configuration::Option" : { + "file" : "lib/Perl/Critic/Exception/Configuration/Option.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::Configuration::Option::Global" : { + "file" : "lib/Perl/Critic/Exception/Configuration/Option/Global.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::Configuration::Option::Global::ExtraParameter" : { + "file" : "lib/Perl/Critic/Exception/Configuration/Option/Global/ExtraParameter.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::Configuration::Option::Global::ParameterValue" : { + "file" : "lib/Perl/Critic/Exception/Configuration/Option/Global/ParameterValue.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::Configuration::Option::Policy" : { + "file" : "lib/Perl/Critic/Exception/Configuration/Option/Policy.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter" : { + "file" : "lib/Perl/Critic/Exception/Configuration/Option/Policy/ExtraParameter.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue" : { + "file" : "lib/Perl/Critic/Exception/Configuration/Option/Policy/ParameterValue.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::Fatal" : { + "file" : "lib/Perl/Critic/Exception/Fatal.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::Fatal::Generic" : { + "file" : "lib/Perl/Critic/Exception/Fatal/Generic.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::Fatal::Internal" : { + "file" : "lib/Perl/Critic/Exception/Fatal/Internal.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::Fatal::PolicyDefinition" : { + "file" : "lib/Perl/Critic/Exception/Fatal/PolicyDefinition.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::IO" : { + "file" : "lib/Perl/Critic/Exception/IO.pm", + "version" : "1.140" + }, + "Perl::Critic::Exception::Parse" : { + "file" : "lib/Perl/Critic/Exception/Parse.pm", + "version" : "1.140" + }, + "Perl::Critic::OptionsProcessor" : { + "file" : "lib/Perl/Critic/OptionsProcessor.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy" : { + "file" : "lib/Perl/Critic/Policy.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::ProhibitBooleanGrep" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitBooleanGrep.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::ProhibitComplexMappings" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitComplexMappings.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::ProhibitLvalueSubstr" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitLvalueSubstr.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::ProhibitReverseSortBlock" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitReverseSortBlock.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::ProhibitShiftRef" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitShiftRef.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::ProhibitSleepViaSelect" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitSleepViaSelect.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringyEval.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringySplit.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalCan" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalCan.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalIsa.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::ProhibitUselessTopic" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUselessTopic.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidGrep.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidMap.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockGrep.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::RequireBlockMap" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockMap.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::RequireGlobFunction" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/RequireGlobFunction.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::BuiltinFunctions::RequireSimpleSortBlock" : { + "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/RequireSimpleSortBlock.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ClassHierarchies::ProhibitAutoloading" : { + "file" : "lib/Perl/Critic/Policy/ClassHierarchies/ProhibitAutoloading.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA" : { + "file" : "lib/Perl/Critic/Policy/ClassHierarchies/ProhibitExplicitISA.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless" : { + "file" : "lib/Perl/Critic/Policy/ClassHierarchies/ProhibitOneArgBless.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::CodeLayout::ProhibitHardTabs" : { + "file" : "lib/Perl/Critic/Policy/CodeLayout/ProhibitHardTabs.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins" : { + "file" : "lib/Perl/Critic/Policy/CodeLayout/ProhibitParensWithBuiltins.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists" : { + "file" : "lib/Perl/Critic/Policy/CodeLayout/ProhibitQuotedWordLists.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::CodeLayout::ProhibitTrailingWhitespace" : { + "file" : "lib/Perl/Critic/Policy/CodeLayout/ProhibitTrailingWhitespace.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines" : { + "file" : "lib/Perl/Critic/Policy/CodeLayout/RequireConsistentNewlines.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::CodeLayout::RequireTidyCode" : { + "file" : "lib/Perl/Critic/Policy/CodeLayout/RequireTidyCode.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::CodeLayout::RequireTrailingCommas" : { + "file" : "lib/Perl/Critic/Policy/CodeLayout/RequireTrailingCommas.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ControlStructures::ProhibitCStyleForLoops" : { + "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitCStyleForLoops.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ControlStructures::ProhibitCascadingIfElse" : { + "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitCascadingIfElse.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ControlStructures::ProhibitDeepNests" : { + "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitDeepNests.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ControlStructures::ProhibitLabelsWithSpecialBlockNames" : { + "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitLabelsWithSpecialBlockNames.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions" : { + "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitMutatingListFunctions.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions" : { + "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ControlStructures::ProhibitPostfixControls" : { + "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitPostfixControls.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ControlStructures::ProhibitUnlessBlocks" : { + "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitUnlessBlocks.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode" : { + "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitUnreachableCode.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ControlStructures::ProhibitUntilBlocks" : { + "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitUntilBlocks.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ControlStructures::ProhibitYadaOperator" : { + "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitYadaOperator.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Documentation::PodSpelling" : { + "file" : "lib/Perl/Critic/Policy/Documentation/PodSpelling.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Documentation::RequirePackageMatchesPodName" : { + "file" : "lib/Perl/Critic/Policy/Documentation/RequirePackageMatchesPodName.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Documentation::RequirePodAtEnd" : { + "file" : "lib/Perl/Critic/Policy/Documentation/RequirePodAtEnd.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Documentation::RequirePodSections" : { + "file" : "lib/Perl/Critic/Policy/Documentation/RequirePodSections.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ErrorHandling::RequireCarping" : { + "file" : "lib/Perl/Critic/Policy/ErrorHandling/RequireCarping.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval" : { + "file" : "lib/Perl/Critic/Policy/ErrorHandling/RequireCheckingReturnValueOfEval.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::InputOutput::ProhibitBacktickOperators" : { + "file" : "lib/Perl/Critic/Policy/InputOutput/ProhibitBacktickOperators.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles" : { + "file" : "lib/Perl/Critic/Policy/InputOutput/ProhibitBarewordFileHandles.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::InputOutput::ProhibitExplicitStdin" : { + "file" : "lib/Perl/Critic/Policy/InputOutput/ProhibitExplicitStdin.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::InputOutput::ProhibitInteractiveTest" : { + "file" : "lib/Perl/Critic/Policy/InputOutput/ProhibitInteractiveTest.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::InputOutput::ProhibitJoinedReadline" : { + "file" : "lib/Perl/Critic/Policy/InputOutput/ProhibitJoinedReadline.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::InputOutput::ProhibitOneArgSelect" : { + "file" : "lib/Perl/Critic/Policy/InputOutput/ProhibitOneArgSelect.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::InputOutput::ProhibitReadlineInForLoop" : { + "file" : "lib/Perl/Critic/Policy/InputOutput/ProhibitReadlineInForLoop.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen" : { + "file" : "lib/Perl/Critic/Policy/InputOutput/ProhibitTwoArgOpen.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::InputOutput::RequireBracedFileHandleWithPrint" : { + "file" : "lib/Perl/Critic/Policy/InputOutput/RequireBracedFileHandleWithPrint.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::InputOutput::RequireBriefOpen" : { + "file" : "lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::InputOutput::RequireCheckedClose" : { + "file" : "lib/Perl/Critic/Policy/InputOutput/RequireCheckedClose.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::InputOutput::RequireCheckedOpen" : { + "file" : "lib/Perl/Critic/Policy/InputOutput/RequireCheckedOpen.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::InputOutput::RequireCheckedSyscalls" : { + "file" : "lib/Perl/Critic/Policy/InputOutput/RequireCheckedSyscalls.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::InputOutput::RequireEncodingWithUTF8Layer" : { + "file" : "lib/Perl/Critic/Policy/InputOutput/RequireEncodingWithUTF8Layer.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Miscellanea::ProhibitFormats" : { + "file" : "lib/Perl/Critic/Policy/Miscellanea/ProhibitFormats.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Miscellanea::ProhibitTies" : { + "file" : "lib/Perl/Critic/Policy/Miscellanea/ProhibitTies.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic" : { + "file" : "lib/Perl/Critic/Policy/Miscellanea/ProhibitUnrestrictedNoCritic.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Miscellanea::ProhibitUselessNoCritic" : { + "file" : "lib/Perl/Critic/Policy/Miscellanea/ProhibitUselessNoCritic.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Modules::ProhibitAutomaticExportation" : { + "file" : "lib/Perl/Critic/Policy/Modules/ProhibitAutomaticExportation.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Modules::ProhibitConditionalUseStatements" : { + "file" : "lib/Perl/Critic/Policy/Modules/ProhibitConditionalUseStatements.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Modules::ProhibitEvilModules" : { + "file" : "lib/Perl/Critic/Policy/Modules/ProhibitEvilModules.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Modules::ProhibitExcessMainComplexity" : { + "file" : "lib/Perl/Critic/Policy/Modules/ProhibitExcessMainComplexity.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Modules::ProhibitMultiplePackages" : { + "file" : "lib/Perl/Critic/Policy/Modules/ProhibitMultiplePackages.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Modules::RequireBarewordIncludes" : { + "file" : "lib/Perl/Critic/Policy/Modules/RequireBarewordIncludes.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Modules::RequireEndWithOne" : { + "file" : "lib/Perl/Critic/Policy/Modules/RequireEndWithOne.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Modules::RequireExplicitPackage" : { + "file" : "lib/Perl/Critic/Policy/Modules/RequireExplicitPackage.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage" : { + "file" : "lib/Perl/Critic/Policy/Modules/RequireFilenameMatchesPackage.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish" : { + "file" : "lib/Perl/Critic/Policy/Modules/RequireNoMatchVarsWithUseEnglish.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Modules::RequireVersionVar" : { + "file" : "lib/Perl/Critic/Policy/Modules/RequireVersionVar.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::NamingConventions::Capitalization" : { + "file" : "lib/Perl/Critic/Policy/NamingConventions/Capitalization.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::NamingConventions::ProhibitAmbiguousNames" : { + "file" : "lib/Perl/Critic/Policy/NamingConventions/ProhibitAmbiguousNames.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Objects::ProhibitIndirectSyntax" : { + "file" : "lib/Perl/Critic/Policy/Objects/ProhibitIndirectSyntax.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::References::ProhibitDoubleSigils" : { + "file" : "lib/Perl/Critic/Policy/References/ProhibitDoubleSigils.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest" : { + "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitCaptureWithoutTest.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::RegularExpressions::ProhibitComplexRegexes" : { + "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitComplexRegexes.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::RegularExpressions::ProhibitEnumeratedClasses" : { + "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitEnumeratedClasses.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::RegularExpressions::ProhibitEscapedMetacharacters" : { + "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitEscapedMetacharacters.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::RegularExpressions::ProhibitFixedStringMatches" : { + "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitFixedStringMatches.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::RegularExpressions::ProhibitSingleCharAlternation" : { + "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitSingleCharAlternation.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture" : { + "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusedCapture.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::RegularExpressions::ProhibitUnusualDelimiters" : { + "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusualDelimiters.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::RegularExpressions::ProhibitUselessTopic" : { + "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitUselessTopic.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::RegularExpressions::RequireBracesForMultiline" : { + "file" : "lib/Perl/Critic/Policy/RegularExpressions/RequireBracesForMultiline.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::RegularExpressions::RequireDotMatchAnything" : { + "file" : "lib/Perl/Critic/Policy/RegularExpressions/RequireDotMatchAnything.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::RegularExpressions::RequireExtendedFormatting" : { + "file" : "lib/Perl/Critic/Policy/RegularExpressions/RequireExtendedFormatting.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::RegularExpressions::RequireLineBoundaryMatching" : { + "file" : "lib/Perl/Critic/Policy/RegularExpressions/RequireLineBoundaryMatching.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Subroutines::ProhibitAmpersandSigils" : { + "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitAmpersandSigils.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms" : { + "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitBuiltinHomonyms.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Subroutines::ProhibitExcessComplexity" : { + "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitExcessComplexity.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Subroutines::ProhibitExplicitReturnUndef" : { + "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitExplicitReturnUndef.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Subroutines::ProhibitManyArgs" : { + "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitManyArgs.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Subroutines::ProhibitNestedSubs" : { + "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitNestedSubs.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Subroutines::ProhibitReturnSort" : { + "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitReturnSort.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Subroutines::ProhibitSubroutinePrototypes" : { + "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitSubroutinePrototypes.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Subroutines::ProhibitUnusedPrivateSubroutines" : { + "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitUnusedPrivateSubroutines.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Subroutines::ProtectPrivateSubs" : { + "file" : "lib/Perl/Critic/Policy/Subroutines/ProtectPrivateSubs.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Subroutines::RequireArgUnpacking" : { + "file" : "lib/Perl/Critic/Policy/Subroutines/RequireArgUnpacking.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Subroutines::RequireFinalReturn" : { + "file" : "lib/Perl/Critic/Policy/Subroutines/RequireFinalReturn.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict" : { + "file" : "lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoStrict.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings" : { + "file" : "lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoWarnings.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::TestingAndDebugging::ProhibitProlongedStrictureOverride" : { + "file" : "lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitProlongedStrictureOverride.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::TestingAndDebugging::RequireTestLabels" : { + "file" : "lib/Perl/Critic/Policy/TestingAndDebugging/RequireTestLabels.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict" : { + "file" : "lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseStrict.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings" : { + "file" : "lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseWarnings.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::ProhibitCommaSeparatedStatements" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitCommaSeparatedStatements.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::ProhibitComplexVersion" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitComplexVersion.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::ProhibitConstantPragma" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitConstantPragma.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::ProhibitEmptyQuotes" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEmptyQuotes.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::ProhibitEscapedCharacters" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEscapedCharacters.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::ProhibitImplicitNewlines" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitImplicitNewlines.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::ProhibitInterpolationOfLiterals" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitInterpolationOfLiterals.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLeadingZeros.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::ProhibitLongChainsOfMethodCalls" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLongChainsOfMethodCalls.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::ProhibitMagicNumbers" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMagicNumbers.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::ProhibitMismatchedOperators" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMismatchedOperators.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMixedBooleanOperators.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::ProhibitNoisyQuotes" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitNoisyQuotes.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitQuotesAsQuotelikeOperatorDelimiters.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitSpecialLiteralHeredocTerminator.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::ProhibitVersionStrings" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitVersionStrings.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::RequireConstantVersion" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/RequireConstantVersion.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/RequireInterpolationOfMetachars.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::RequireNumberSeparators" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/RequireNumberSeparators.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::RequireQuotedHeredocTerminator" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/RequireQuotedHeredocTerminator.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator" : { + "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/RequireUpperCaseHeredocTerminator.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Variables::ProhibitAugmentedAssignmentInDeclaration" : { + "file" : "lib/Perl/Critic/Policy/Variables/ProhibitAugmentedAssignmentInDeclaration.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Variables::ProhibitConditionalDeclarations" : { + "file" : "lib/Perl/Critic/Policy/Variables/ProhibitConditionalDeclarations.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Variables::ProhibitEvilVariables" : { + "file" : "lib/Perl/Critic/Policy/Variables/ProhibitEvilVariables.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Variables::ProhibitLocalVars" : { + "file" : "lib/Perl/Critic/Policy/Variables/ProhibitLocalVars.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Variables::ProhibitMatchVars" : { + "file" : "lib/Perl/Critic/Policy/Variables/ProhibitMatchVars.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Variables::ProhibitPackageVars" : { + "file" : "lib/Perl/Critic/Policy/Variables/ProhibitPackageVars.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Variables::ProhibitPerl4PackageNames" : { + "file" : "lib/Perl/Critic/Policy/Variables/ProhibitPerl4PackageNames.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Variables::ProhibitPunctuationVars" : { + "file" : "lib/Perl/Critic/Policy/Variables/ProhibitPunctuationVars.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Variables::ProhibitReusedNames" : { + "file" : "lib/Perl/Critic/Policy/Variables/ProhibitReusedNames.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Variables::ProhibitUnusedVariables" : { + "file" : "lib/Perl/Critic/Policy/Variables/ProhibitUnusedVariables.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Variables::ProtectPrivateVars" : { + "file" : "lib/Perl/Critic/Policy/Variables/ProtectPrivateVars.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Variables::RequireInitializationForLocalVars" : { + "file" : "lib/Perl/Critic/Policy/Variables/RequireInitializationForLocalVars.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Variables::RequireLexicalLoopIterators" : { + "file" : "lib/Perl/Critic/Policy/Variables/RequireLexicalLoopIterators.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Variables::RequireLocalizedPunctuationVars" : { + "file" : "lib/Perl/Critic/Policy/Variables/RequireLocalizedPunctuationVars.pm", + "version" : "1.140" + }, + "Perl::Critic::Policy::Variables::RequireNegativeIndices" : { + "file" : "lib/Perl/Critic/Policy/Variables/RequireNegativeIndices.pm", + "version" : "1.140" + }, + "Perl::Critic::PolicyConfig" : { + "file" : "lib/Perl/Critic/PolicyConfig.pm", + "version" : "1.140" + }, + "Perl::Critic::PolicyFactory" : { + "file" : "lib/Perl/Critic/PolicyFactory.pm", + "version" : "1.140" + }, + "Perl::Critic::PolicyListing" : { + "file" : "lib/Perl/Critic/PolicyListing.pm", + "version" : "1.140" + }, + "Perl::Critic::PolicyParameter" : { + "file" : "lib/Perl/Critic/PolicyParameter.pm", + "version" : "1.140" + }, + "Perl::Critic::PolicyParameter::Behavior" : { + "file" : "lib/Perl/Critic/PolicyParameter/Behavior.pm", + "version" : "1.140" + }, + "Perl::Critic::PolicyParameter::Behavior::Boolean" : { + "file" : "lib/Perl/Critic/PolicyParameter/Behavior/Boolean.pm", + "version" : "1.140" + }, + "Perl::Critic::PolicyParameter::Behavior::Enumeration" : { + "file" : "lib/Perl/Critic/PolicyParameter/Behavior/Enumeration.pm", + "version" : "1.140" + }, + "Perl::Critic::PolicyParameter::Behavior::Integer" : { + "file" : "lib/Perl/Critic/PolicyParameter/Behavior/Integer.pm", + "version" : "1.140" + }, + "Perl::Critic::PolicyParameter::Behavior::String" : { + "file" : "lib/Perl/Critic/PolicyParameter/Behavior/String.pm", + "version" : "1.140" + }, + "Perl::Critic::PolicyParameter::Behavior::StringList" : { + "file" : "lib/Perl/Critic/PolicyParameter/Behavior/StringList.pm", + "version" : "1.140" + }, + "Perl::Critic::ProfilePrototype" : { + "file" : "lib/Perl/Critic/ProfilePrototype.pm", + "version" : "1.140" + }, + "Perl::Critic::Statistics" : { + "file" : "lib/Perl/Critic/Statistics.pm", + "version" : "1.140" + }, + "Perl::Critic::TestUtils" : { + "file" : "lib/Perl/Critic/TestUtils.pm", + "version" : "1.140" + }, + "Perl::Critic::Theme" : { + "file" : "lib/Perl/Critic/Theme.pm", + "version" : "1.140" + }, + "Perl::Critic::ThemeListing" : { + "file" : "lib/Perl/Critic/ThemeListing.pm", + "version" : "1.140" + }, + "Perl::Critic::UserProfile" : { + "file" : "lib/Perl/Critic/UserProfile.pm", + "version" : "1.140" + }, + "Perl::Critic::Utils" : { + "file" : "lib/Perl/Critic/Utils.pm", + "version" : "1.140" + }, + "Perl::Critic::Utils::Constants" : { + "file" : "lib/Perl/Critic/Utils/Constants.pm", + "version" : "1.140" + }, + "Perl::Critic::Utils::DataConversion" : { + "file" : "lib/Perl/Critic/Utils/DataConversion.pm", + "version" : "1.140" + }, + "Perl::Critic::Utils::McCabe" : { + "file" : "lib/Perl/Critic/Utils/McCabe.pm", + "version" : "1.140" + }, + "Perl::Critic::Utils::POD" : { + "file" : "lib/Perl/Critic/Utils/POD.pm", + "version" : "1.140" + }, + "Perl::Critic::Utils::POD::ParseInteriorSequence" : { + "file" : "lib/Perl/Critic/Utils/POD/ParseInteriorSequence.pm", + "version" : "1.140" + }, + "Perl::Critic::Utils::PPI" : { + "file" : "lib/Perl/Critic/Utils/PPI.pm", + "version" : "1.140" + }, + "Perl::Critic::Utils::Perl" : { + "file" : "lib/Perl/Critic/Utils/Perl.pm", + "version" : "1.140" + }, + "Perl::Critic::Violation" : { + "file" : "lib/Perl/Critic/Violation.pm", + "version" : "1.140" + }, + "Test::Perl::Critic::Policy" : { + "file" : "lib/Test/Perl/Critic/Policy.pm", + "version" : "1.140" + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "web" : "https://github.com/Perl-Critic/Perl-Critic/issues" + }, + "homepage" : "http://perlcritic.com", + "license" : [ + "http://dev.perl.org/licenses/" + ], + "repository" : { + "url" : "git://github.com/Perl-Critic/Perl-Critic.git" + }, + "x_MailingList" : "https://groups.google.com/d/forum/perl-critic" + }, + "version" : "1.140", + "x_authority" : "cpan:CRITICRE", + "x_serialization_backend" : "JSON::PP version 4.04" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..1fd3d39 --- /dev/null +++ b/META.yml @@ -0,0 +1,673 @@ +--- +abstract: 'Critique Perl source code for best-practices.' +author: + - 'Jeffrey Thalhammer ' +build_requires: + Test::Deep: '0' + Test::More: '0' + lib: '0' +configure_requires: + Module::Build: '0.4204' +dynamic_config: 1 +generated_by: 'Module::Build version 0.4231, CPAN::Meta::Converter version 2.150010' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Perl-Critic +no_index: + directory: + - doc + - inc + - tools + - xt + file: + - TODO.pod +provides: + Perl::Critic: + file: lib/Perl/Critic.pm + version: '1.140' + Perl::Critic::Annotation: + file: lib/Perl/Critic/Annotation.pm + version: '1.140' + Perl::Critic::Command: + file: lib/Perl/Critic/Command.pm + version: '1.140' + Perl::Critic::Config: + file: lib/Perl/Critic/Config.pm + version: '1.140' + Perl::Critic::Document: + file: lib/Perl/Critic/Document.pm + version: '1.140' + Perl::Critic::Exception: + file: lib/Perl/Critic/Exception.pm + version: '1.140' + Perl::Critic::Exception::AggregateConfiguration: + file: lib/Perl/Critic/Exception/AggregateConfiguration.pm + version: '1.140' + Perl::Critic::Exception::Configuration: + file: lib/Perl/Critic/Exception/Configuration.pm + version: '1.140' + Perl::Critic::Exception::Configuration::Generic: + file: lib/Perl/Critic/Exception/Configuration/Generic.pm + version: '1.140' + Perl::Critic::Exception::Configuration::NonExistentPolicy: + file: lib/Perl/Critic/Exception/Configuration/NonExistentPolicy.pm + version: '1.140' + Perl::Critic::Exception::Configuration::Option: + file: lib/Perl/Critic/Exception/Configuration/Option.pm + version: '1.140' + Perl::Critic::Exception::Configuration::Option::Global: + file: lib/Perl/Critic/Exception/Configuration/Option/Global.pm + version: '1.140' + Perl::Critic::Exception::Configuration::Option::Global::ExtraParameter: + file: lib/Perl/Critic/Exception/Configuration/Option/Global/ExtraParameter.pm + version: '1.140' + Perl::Critic::Exception::Configuration::Option::Global::ParameterValue: + file: lib/Perl/Critic/Exception/Configuration/Option/Global/ParameterValue.pm + version: '1.140' + Perl::Critic::Exception::Configuration::Option::Policy: + file: lib/Perl/Critic/Exception/Configuration/Option/Policy.pm + version: '1.140' + Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter: + file: lib/Perl/Critic/Exception/Configuration/Option/Policy/ExtraParameter.pm + version: '1.140' + Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue: + file: lib/Perl/Critic/Exception/Configuration/Option/Policy/ParameterValue.pm + version: '1.140' + Perl::Critic::Exception::Fatal: + file: lib/Perl/Critic/Exception/Fatal.pm + version: '1.140' + Perl::Critic::Exception::Fatal::Generic: + file: lib/Perl/Critic/Exception/Fatal/Generic.pm + version: '1.140' + Perl::Critic::Exception::Fatal::Internal: + file: lib/Perl/Critic/Exception/Fatal/Internal.pm + version: '1.140' + Perl::Critic::Exception::Fatal::PolicyDefinition: + file: lib/Perl/Critic/Exception/Fatal/PolicyDefinition.pm + version: '1.140' + Perl::Critic::Exception::IO: + file: lib/Perl/Critic/Exception/IO.pm + version: '1.140' + Perl::Critic::Exception::Parse: + file: lib/Perl/Critic/Exception/Parse.pm + version: '1.140' + Perl::Critic::OptionsProcessor: + file: lib/Perl/Critic/OptionsProcessor.pm + version: '1.140' + Perl::Critic::Policy: + file: lib/Perl/Critic/Policy.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::ProhibitBooleanGrep: + file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitBooleanGrep.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::ProhibitComplexMappings: + file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitComplexMappings.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::ProhibitLvalueSubstr: + file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitLvalueSubstr.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::ProhibitReverseSortBlock: + file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitReverseSortBlock.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::ProhibitShiftRef: + file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitShiftRef.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::ProhibitSleepViaSelect: + file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitSleepViaSelect.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval: + file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringyEval.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit: + file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringySplit.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalCan: + file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalCan.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa: + file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalIsa.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::ProhibitUselessTopic: + file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUselessTopic.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep: + file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidGrep.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap: + file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidMap.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep: + file: lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockGrep.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::RequireBlockMap: + file: lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockMap.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::RequireGlobFunction: + file: lib/Perl/Critic/Policy/BuiltinFunctions/RequireGlobFunction.pm + version: '1.140' + Perl::Critic::Policy::BuiltinFunctions::RequireSimpleSortBlock: + file: lib/Perl/Critic/Policy/BuiltinFunctions/RequireSimpleSortBlock.pm + version: '1.140' + Perl::Critic::Policy::ClassHierarchies::ProhibitAutoloading: + file: lib/Perl/Critic/Policy/ClassHierarchies/ProhibitAutoloading.pm + version: '1.140' + Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA: + file: lib/Perl/Critic/Policy/ClassHierarchies/ProhibitExplicitISA.pm + version: '1.140' + Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless: + file: lib/Perl/Critic/Policy/ClassHierarchies/ProhibitOneArgBless.pm + version: '1.140' + Perl::Critic::Policy::CodeLayout::ProhibitHardTabs: + file: lib/Perl/Critic/Policy/CodeLayout/ProhibitHardTabs.pm + version: '1.140' + Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins: + file: lib/Perl/Critic/Policy/CodeLayout/ProhibitParensWithBuiltins.pm + version: '1.140' + Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists: + file: lib/Perl/Critic/Policy/CodeLayout/ProhibitQuotedWordLists.pm + version: '1.140' + Perl::Critic::Policy::CodeLayout::ProhibitTrailingWhitespace: + file: lib/Perl/Critic/Policy/CodeLayout/ProhibitTrailingWhitespace.pm + version: '1.140' + Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines: + file: lib/Perl/Critic/Policy/CodeLayout/RequireConsistentNewlines.pm + version: '1.140' + Perl::Critic::Policy::CodeLayout::RequireTidyCode: + file: lib/Perl/Critic/Policy/CodeLayout/RequireTidyCode.pm + version: '1.140' + Perl::Critic::Policy::CodeLayout::RequireTrailingCommas: + file: lib/Perl/Critic/Policy/CodeLayout/RequireTrailingCommas.pm + version: '1.140' + Perl::Critic::Policy::ControlStructures::ProhibitCStyleForLoops: + file: lib/Perl/Critic/Policy/ControlStructures/ProhibitCStyleForLoops.pm + version: '1.140' + Perl::Critic::Policy::ControlStructures::ProhibitCascadingIfElse: + file: lib/Perl/Critic/Policy/ControlStructures/ProhibitCascadingIfElse.pm + version: '1.140' + Perl::Critic::Policy::ControlStructures::ProhibitDeepNests: + file: lib/Perl/Critic/Policy/ControlStructures/ProhibitDeepNests.pm + version: '1.140' + Perl::Critic::Policy::ControlStructures::ProhibitLabelsWithSpecialBlockNames: + file: lib/Perl/Critic/Policy/ControlStructures/ProhibitLabelsWithSpecialBlockNames.pm + version: '1.140' + Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions: + file: lib/Perl/Critic/Policy/ControlStructures/ProhibitMutatingListFunctions.pm + version: '1.140' + Perl::Critic::Policy::ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions: + file: lib/Perl/Critic/Policy/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.pm + version: '1.140' + Perl::Critic::Policy::ControlStructures::ProhibitPostfixControls: + file: lib/Perl/Critic/Policy/ControlStructures/ProhibitPostfixControls.pm + version: '1.140' + Perl::Critic::Policy::ControlStructures::ProhibitUnlessBlocks: + file: lib/Perl/Critic/Policy/ControlStructures/ProhibitUnlessBlocks.pm + version: '1.140' + Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode: + file: lib/Perl/Critic/Policy/ControlStructures/ProhibitUnreachableCode.pm + version: '1.140' + Perl::Critic::Policy::ControlStructures::ProhibitUntilBlocks: + file: lib/Perl/Critic/Policy/ControlStructures/ProhibitUntilBlocks.pm + version: '1.140' + Perl::Critic::Policy::ControlStructures::ProhibitYadaOperator: + file: lib/Perl/Critic/Policy/ControlStructures/ProhibitYadaOperator.pm + version: '1.140' + Perl::Critic::Policy::Documentation::PodSpelling: + file: lib/Perl/Critic/Policy/Documentation/PodSpelling.pm + version: '1.140' + Perl::Critic::Policy::Documentation::RequirePackageMatchesPodName: + file: lib/Perl/Critic/Policy/Documentation/RequirePackageMatchesPodName.pm + version: '1.140' + Perl::Critic::Policy::Documentation::RequirePodAtEnd: + file: lib/Perl/Critic/Policy/Documentation/RequirePodAtEnd.pm + version: '1.140' + Perl::Critic::Policy::Documentation::RequirePodSections: + file: lib/Perl/Critic/Policy/Documentation/RequirePodSections.pm + version: '1.140' + Perl::Critic::Policy::ErrorHandling::RequireCarping: + file: lib/Perl/Critic/Policy/ErrorHandling/RequireCarping.pm + version: '1.140' + Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval: + file: lib/Perl/Critic/Policy/ErrorHandling/RequireCheckingReturnValueOfEval.pm + version: '1.140' + Perl::Critic::Policy::InputOutput::ProhibitBacktickOperators: + file: lib/Perl/Critic/Policy/InputOutput/ProhibitBacktickOperators.pm + version: '1.140' + Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles: + file: lib/Perl/Critic/Policy/InputOutput/ProhibitBarewordFileHandles.pm + version: '1.140' + Perl::Critic::Policy::InputOutput::ProhibitExplicitStdin: + file: lib/Perl/Critic/Policy/InputOutput/ProhibitExplicitStdin.pm + version: '1.140' + Perl::Critic::Policy::InputOutput::ProhibitInteractiveTest: + file: lib/Perl/Critic/Policy/InputOutput/ProhibitInteractiveTest.pm + version: '1.140' + Perl::Critic::Policy::InputOutput::ProhibitJoinedReadline: + file: lib/Perl/Critic/Policy/InputOutput/ProhibitJoinedReadline.pm + version: '1.140' + Perl::Critic::Policy::InputOutput::ProhibitOneArgSelect: + file: lib/Perl/Critic/Policy/InputOutput/ProhibitOneArgSelect.pm + version: '1.140' + Perl::Critic::Policy::InputOutput::ProhibitReadlineInForLoop: + file: lib/Perl/Critic/Policy/InputOutput/ProhibitReadlineInForLoop.pm + version: '1.140' + Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen: + file: lib/Perl/Critic/Policy/InputOutput/ProhibitTwoArgOpen.pm + version: '1.140' + Perl::Critic::Policy::InputOutput::RequireBracedFileHandleWithPrint: + file: lib/Perl/Critic/Policy/InputOutput/RequireBracedFileHandleWithPrint.pm + version: '1.140' + Perl::Critic::Policy::InputOutput::RequireBriefOpen: + file: lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm + version: '1.140' + Perl::Critic::Policy::InputOutput::RequireCheckedClose: + file: lib/Perl/Critic/Policy/InputOutput/RequireCheckedClose.pm + version: '1.140' + Perl::Critic::Policy::InputOutput::RequireCheckedOpen: + file: lib/Perl/Critic/Policy/InputOutput/RequireCheckedOpen.pm + version: '1.140' + Perl::Critic::Policy::InputOutput::RequireCheckedSyscalls: + file: lib/Perl/Critic/Policy/InputOutput/RequireCheckedSyscalls.pm + version: '1.140' + Perl::Critic::Policy::InputOutput::RequireEncodingWithUTF8Layer: + file: lib/Perl/Critic/Policy/InputOutput/RequireEncodingWithUTF8Layer.pm + version: '1.140' + Perl::Critic::Policy::Miscellanea::ProhibitFormats: + file: lib/Perl/Critic/Policy/Miscellanea/ProhibitFormats.pm + version: '1.140' + Perl::Critic::Policy::Miscellanea::ProhibitTies: + file: lib/Perl/Critic/Policy/Miscellanea/ProhibitTies.pm + version: '1.140' + Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic: + file: lib/Perl/Critic/Policy/Miscellanea/ProhibitUnrestrictedNoCritic.pm + version: '1.140' + Perl::Critic::Policy::Miscellanea::ProhibitUselessNoCritic: + file: lib/Perl/Critic/Policy/Miscellanea/ProhibitUselessNoCritic.pm + version: '1.140' + Perl::Critic::Policy::Modules::ProhibitAutomaticExportation: + file: lib/Perl/Critic/Policy/Modules/ProhibitAutomaticExportation.pm + version: '1.140' + Perl::Critic::Policy::Modules::ProhibitConditionalUseStatements: + file: lib/Perl/Critic/Policy/Modules/ProhibitConditionalUseStatements.pm + version: '1.140' + Perl::Critic::Policy::Modules::ProhibitEvilModules: + file: lib/Perl/Critic/Policy/Modules/ProhibitEvilModules.pm + version: '1.140' + Perl::Critic::Policy::Modules::ProhibitExcessMainComplexity: + file: lib/Perl/Critic/Policy/Modules/ProhibitExcessMainComplexity.pm + version: '1.140' + Perl::Critic::Policy::Modules::ProhibitMultiplePackages: + file: lib/Perl/Critic/Policy/Modules/ProhibitMultiplePackages.pm + version: '1.140' + Perl::Critic::Policy::Modules::RequireBarewordIncludes: + file: lib/Perl/Critic/Policy/Modules/RequireBarewordIncludes.pm + version: '1.140' + Perl::Critic::Policy::Modules::RequireEndWithOne: + file: lib/Perl/Critic/Policy/Modules/RequireEndWithOne.pm + version: '1.140' + Perl::Critic::Policy::Modules::RequireExplicitPackage: + file: lib/Perl/Critic/Policy/Modules/RequireExplicitPackage.pm + version: '1.140' + Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage: + file: lib/Perl/Critic/Policy/Modules/RequireFilenameMatchesPackage.pm + version: '1.140' + Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish: + file: lib/Perl/Critic/Policy/Modules/RequireNoMatchVarsWithUseEnglish.pm + version: '1.140' + Perl::Critic::Policy::Modules::RequireVersionVar: + file: lib/Perl/Critic/Policy/Modules/RequireVersionVar.pm + version: '1.140' + Perl::Critic::Policy::NamingConventions::Capitalization: + file: lib/Perl/Critic/Policy/NamingConventions/Capitalization.pm + version: '1.140' + Perl::Critic::Policy::NamingConventions::ProhibitAmbiguousNames: + file: lib/Perl/Critic/Policy/NamingConventions/ProhibitAmbiguousNames.pm + version: '1.140' + Perl::Critic::Policy::Objects::ProhibitIndirectSyntax: + file: lib/Perl/Critic/Policy/Objects/ProhibitIndirectSyntax.pm + version: '1.140' + Perl::Critic::Policy::References::ProhibitDoubleSigils: + file: lib/Perl/Critic/Policy/References/ProhibitDoubleSigils.pm + version: '1.140' + Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest: + file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitCaptureWithoutTest.pm + version: '1.140' + Perl::Critic::Policy::RegularExpressions::ProhibitComplexRegexes: + file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitComplexRegexes.pm + version: '1.140' + Perl::Critic::Policy::RegularExpressions::ProhibitEnumeratedClasses: + file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitEnumeratedClasses.pm + version: '1.140' + Perl::Critic::Policy::RegularExpressions::ProhibitEscapedMetacharacters: + file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitEscapedMetacharacters.pm + version: '1.140' + Perl::Critic::Policy::RegularExpressions::ProhibitFixedStringMatches: + file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitFixedStringMatches.pm + version: '1.140' + Perl::Critic::Policy::RegularExpressions::ProhibitSingleCharAlternation: + file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitSingleCharAlternation.pm + version: '1.140' + Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture: + file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusedCapture.pm + version: '1.140' + Perl::Critic::Policy::RegularExpressions::ProhibitUnusualDelimiters: + file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusualDelimiters.pm + version: '1.140' + Perl::Critic::Policy::RegularExpressions::ProhibitUselessTopic: + file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitUselessTopic.pm + version: '1.140' + Perl::Critic::Policy::RegularExpressions::RequireBracesForMultiline: + file: lib/Perl/Critic/Policy/RegularExpressions/RequireBracesForMultiline.pm + version: '1.140' + Perl::Critic::Policy::RegularExpressions::RequireDotMatchAnything: + file: lib/Perl/Critic/Policy/RegularExpressions/RequireDotMatchAnything.pm + version: '1.140' + Perl::Critic::Policy::RegularExpressions::RequireExtendedFormatting: + file: lib/Perl/Critic/Policy/RegularExpressions/RequireExtendedFormatting.pm + version: '1.140' + Perl::Critic::Policy::RegularExpressions::RequireLineBoundaryMatching: + file: lib/Perl/Critic/Policy/RegularExpressions/RequireLineBoundaryMatching.pm + version: '1.140' + Perl::Critic::Policy::Subroutines::ProhibitAmpersandSigils: + file: lib/Perl/Critic/Policy/Subroutines/ProhibitAmpersandSigils.pm + version: '1.140' + Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms: + file: lib/Perl/Critic/Policy/Subroutines/ProhibitBuiltinHomonyms.pm + version: '1.140' + Perl::Critic::Policy::Subroutines::ProhibitExcessComplexity: + file: lib/Perl/Critic/Policy/Subroutines/ProhibitExcessComplexity.pm + version: '1.140' + Perl::Critic::Policy::Subroutines::ProhibitExplicitReturnUndef: + file: lib/Perl/Critic/Policy/Subroutines/ProhibitExplicitReturnUndef.pm + version: '1.140' + Perl::Critic::Policy::Subroutines::ProhibitManyArgs: + file: lib/Perl/Critic/Policy/Subroutines/ProhibitManyArgs.pm + version: '1.140' + Perl::Critic::Policy::Subroutines::ProhibitNestedSubs: + file: lib/Perl/Critic/Policy/Subroutines/ProhibitNestedSubs.pm + version: '1.140' + Perl::Critic::Policy::Subroutines::ProhibitReturnSort: + file: lib/Perl/Critic/Policy/Subroutines/ProhibitReturnSort.pm + version: '1.140' + Perl::Critic::Policy::Subroutines::ProhibitSubroutinePrototypes: + file: lib/Perl/Critic/Policy/Subroutines/ProhibitSubroutinePrototypes.pm + version: '1.140' + Perl::Critic::Policy::Subroutines::ProhibitUnusedPrivateSubroutines: + file: lib/Perl/Critic/Policy/Subroutines/ProhibitUnusedPrivateSubroutines.pm + version: '1.140' + Perl::Critic::Policy::Subroutines::ProtectPrivateSubs: + file: lib/Perl/Critic/Policy/Subroutines/ProtectPrivateSubs.pm + version: '1.140' + Perl::Critic::Policy::Subroutines::RequireArgUnpacking: + file: lib/Perl/Critic/Policy/Subroutines/RequireArgUnpacking.pm + version: '1.140' + Perl::Critic::Policy::Subroutines::RequireFinalReturn: + file: lib/Perl/Critic/Policy/Subroutines/RequireFinalReturn.pm + version: '1.140' + Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict: + file: lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoStrict.pm + version: '1.140' + Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings: + file: lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoWarnings.pm + version: '1.140' + Perl::Critic::Policy::TestingAndDebugging::ProhibitProlongedStrictureOverride: + file: lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitProlongedStrictureOverride.pm + version: '1.140' + Perl::Critic::Policy::TestingAndDebugging::RequireTestLabels: + file: lib/Perl/Critic/Policy/TestingAndDebugging/RequireTestLabels.pm + version: '1.140' + Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict: + file: lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseStrict.pm + version: '1.140' + Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings: + file: lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseWarnings.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::ProhibitCommaSeparatedStatements: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitCommaSeparatedStatements.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::ProhibitComplexVersion: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitComplexVersion.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::ProhibitConstantPragma: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitConstantPragma.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::ProhibitEmptyQuotes: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEmptyQuotes.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::ProhibitEscapedCharacters: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEscapedCharacters.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::ProhibitImplicitNewlines: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitImplicitNewlines.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::ProhibitInterpolationOfLiterals: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitInterpolationOfLiterals.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLeadingZeros.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::ProhibitLongChainsOfMethodCalls: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLongChainsOfMethodCalls.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::ProhibitMagicNumbers: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMagicNumbers.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::ProhibitMismatchedOperators: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMismatchedOperators.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMixedBooleanOperators.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::ProhibitNoisyQuotes: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitNoisyQuotes.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitQuotesAsQuotelikeOperatorDelimiters.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitSpecialLiteralHeredocTerminator.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::ProhibitVersionStrings: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitVersionStrings.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::RequireConstantVersion: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/RequireConstantVersion.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/RequireInterpolationOfMetachars.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::RequireNumberSeparators: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/RequireNumberSeparators.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::RequireQuotedHeredocTerminator: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/RequireQuotedHeredocTerminator.pm + version: '1.140' + Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator: + file: lib/Perl/Critic/Policy/ValuesAndExpressions/RequireUpperCaseHeredocTerminator.pm + version: '1.140' + Perl::Critic::Policy::Variables::ProhibitAugmentedAssignmentInDeclaration: + file: lib/Perl/Critic/Policy/Variables/ProhibitAugmentedAssignmentInDeclaration.pm + version: '1.140' + Perl::Critic::Policy::Variables::ProhibitConditionalDeclarations: + file: lib/Perl/Critic/Policy/Variables/ProhibitConditionalDeclarations.pm + version: '1.140' + Perl::Critic::Policy::Variables::ProhibitEvilVariables: + file: lib/Perl/Critic/Policy/Variables/ProhibitEvilVariables.pm + version: '1.140' + Perl::Critic::Policy::Variables::ProhibitLocalVars: + file: lib/Perl/Critic/Policy/Variables/ProhibitLocalVars.pm + version: '1.140' + Perl::Critic::Policy::Variables::ProhibitMatchVars: + file: lib/Perl/Critic/Policy/Variables/ProhibitMatchVars.pm + version: '1.140' + Perl::Critic::Policy::Variables::ProhibitPackageVars: + file: lib/Perl/Critic/Policy/Variables/ProhibitPackageVars.pm + version: '1.140' + Perl::Critic::Policy::Variables::ProhibitPerl4PackageNames: + file: lib/Perl/Critic/Policy/Variables/ProhibitPerl4PackageNames.pm + version: '1.140' + Perl::Critic::Policy::Variables::ProhibitPunctuationVars: + file: lib/Perl/Critic/Policy/Variables/ProhibitPunctuationVars.pm + version: '1.140' + Perl::Critic::Policy::Variables::ProhibitReusedNames: + file: lib/Perl/Critic/Policy/Variables/ProhibitReusedNames.pm + version: '1.140' + Perl::Critic::Policy::Variables::ProhibitUnusedVariables: + file: lib/Perl/Critic/Policy/Variables/ProhibitUnusedVariables.pm + version: '1.140' + Perl::Critic::Policy::Variables::ProtectPrivateVars: + file: lib/Perl/Critic/Policy/Variables/ProtectPrivateVars.pm + version: '1.140' + Perl::Critic::Policy::Variables::RequireInitializationForLocalVars: + file: lib/Perl/Critic/Policy/Variables/RequireInitializationForLocalVars.pm + version: '1.140' + Perl::Critic::Policy::Variables::RequireLexicalLoopIterators: + file: lib/Perl/Critic/Policy/Variables/RequireLexicalLoopIterators.pm + version: '1.140' + Perl::Critic::Policy::Variables::RequireLocalizedPunctuationVars: + file: lib/Perl/Critic/Policy/Variables/RequireLocalizedPunctuationVars.pm + version: '1.140' + Perl::Critic::Policy::Variables::RequireNegativeIndices: + file: lib/Perl/Critic/Policy/Variables/RequireNegativeIndices.pm + version: '1.140' + Perl::Critic::PolicyConfig: + file: lib/Perl/Critic/PolicyConfig.pm + version: '1.140' + Perl::Critic::PolicyFactory: + file: lib/Perl/Critic/PolicyFactory.pm + version: '1.140' + Perl::Critic::PolicyListing: + file: lib/Perl/Critic/PolicyListing.pm + version: '1.140' + Perl::Critic::PolicyParameter: + file: lib/Perl/Critic/PolicyParameter.pm + version: '1.140' + Perl::Critic::PolicyParameter::Behavior: + file: lib/Perl/Critic/PolicyParameter/Behavior.pm + version: '1.140' + Perl::Critic::PolicyParameter::Behavior::Boolean: + file: lib/Perl/Critic/PolicyParameter/Behavior/Boolean.pm + version: '1.140' + Perl::Critic::PolicyParameter::Behavior::Enumeration: + file: lib/Perl/Critic/PolicyParameter/Behavior/Enumeration.pm + version: '1.140' + Perl::Critic::PolicyParameter::Behavior::Integer: + file: lib/Perl/Critic/PolicyParameter/Behavior/Integer.pm + version: '1.140' + Perl::Critic::PolicyParameter::Behavior::String: + file: lib/Perl/Critic/PolicyParameter/Behavior/String.pm + version: '1.140' + Perl::Critic::PolicyParameter::Behavior::StringList: + file: lib/Perl/Critic/PolicyParameter/Behavior/StringList.pm + version: '1.140' + Perl::Critic::ProfilePrototype: + file: lib/Perl/Critic/ProfilePrototype.pm + version: '1.140' + Perl::Critic::Statistics: + file: lib/Perl/Critic/Statistics.pm + version: '1.140' + Perl::Critic::TestUtils: + file: lib/Perl/Critic/TestUtils.pm + version: '1.140' + Perl::Critic::Theme: + file: lib/Perl/Critic/Theme.pm + version: '1.140' + Perl::Critic::ThemeListing: + file: lib/Perl/Critic/ThemeListing.pm + version: '1.140' + Perl::Critic::UserProfile: + file: lib/Perl/Critic/UserProfile.pm + version: '1.140' + Perl::Critic::Utils: + file: lib/Perl/Critic/Utils.pm + version: '1.140' + Perl::Critic::Utils::Constants: + file: lib/Perl/Critic/Utils/Constants.pm + version: '1.140' + Perl::Critic::Utils::DataConversion: + file: lib/Perl/Critic/Utils/DataConversion.pm + version: '1.140' + Perl::Critic::Utils::McCabe: + file: lib/Perl/Critic/Utils/McCabe.pm + version: '1.140' + Perl::Critic::Utils::POD: + file: lib/Perl/Critic/Utils/POD.pm + version: '1.140' + Perl::Critic::Utils::POD::ParseInteriorSequence: + file: lib/Perl/Critic/Utils/POD/ParseInteriorSequence.pm + version: '1.140' + Perl::Critic::Utils::PPI: + file: lib/Perl/Critic/Utils/PPI.pm + version: '1.140' + Perl::Critic::Utils::Perl: + file: lib/Perl/Critic/Utils/Perl.pm + version: '1.140' + Perl::Critic::Violation: + file: lib/Perl/Critic/Violation.pm + version: '1.140' + Test::Perl::Critic::Policy: + file: lib/Test/Perl/Critic/Policy.pm + version: '1.140' +requires: + B::Keywords: '1.05' + Carp: '0' + Config::Tiny: '2' + English: '0' + Exception::Class: '1.23' + Exporter: '5.63' + Fatal: '0' + File::Basename: '0' + File::Find: '0' + File::Path: '0' + File::Spec: '0' + File::Spec::Unix: '0' + File::Temp: '0' + File::Which: '0' + Getopt::Long: '0' + IO::String: '0' + IPC::Open2: '1' + List::MoreUtils: '0.19' + List::Util: '0' + Module::Build: '0.4204' + Module::Pluggable: '3.1' + PPI: '1.265' + PPI::Document: '1.265' + PPI::Document::File: '1.265' + PPI::Node: '1.265' + PPI::Token::Quote::Single: '1.265' + PPI::Token::Whitespace: '1.265' + PPIx::QuoteLike: '0' + PPIx::Regexp: '0.027' + PPIx::Regexp::Util: '0.068' + PPIx::Utilities::Node: '1.001' + PPIx::Utilities::Statement: '1.001' + Perl::Tidy: '0' + Pod::Parser: '0' + Pod::PlainText: '0' + Pod::Select: '0' + Pod::Spell: '1' + Pod::Usage: '0' + Readonly: '2' + Scalar::Util: '0' + String::Format: '1.18' + Task::Weaken: '0' + Term::ANSIColor: '2.02' + Test::Builder: '0.92' + Text::ParseWords: '3' + base: '0' + charnames: '0' + overload: '0' + perl: '5.006001' + strict: '0' + version: '0.77' + warnings: '0' +resources: + MailingList: https://groups.google.com/d/forum/perl-critic + bugtracker: https://github.com/Perl-Critic/Perl-Critic/issues + homepage: http://perlcritic.com + license: http://dev.perl.org/licenses/ + repository: git://github.com/Perl-Critic/Perl-Critic.git +version: '1.140' +x_authority: cpan:CRITICRE +x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/README b/README new file mode 100644 index 0000000..3d0bad9 --- /dev/null +++ b/README @@ -0,0 +1,712 @@ +NAME + Perl::Critic - Critique Perl source code for best-practices. + +SYNOPSIS + use Perl::Critic; + my $file = shift; + my $critic = Perl::Critic->new(); + my @violations = $critic->critique($file); + print @violations; + +DESCRIPTION + Perl::Critic is an extensible framework for creating and applying coding + standards to Perl source code. Essentially, it is a static source code + analysis engine. Perl::Critic is distributed with a number of + Perl::Critic::Policy modules that attempt to enforce various coding + guidelines. Most Policy modules are based on Damian Conway's book Perl + Best Practices. However, Perl::Critic is not limited to PBP and will + even support Policies that contradict Conway. You can enable, disable, + and customize those Polices through the Perl::Critic interface. You can + also create new Policy modules that suit your own tastes. + + For a command-line interface to Perl::Critic, see the documentation for + perlcritic. If you want to integrate Perl::Critic with your build + process, Test::Perl::Critic provides an interface that is suitable for + test programs. Also, Test::Perl::Critic::Progressive is useful for + gradually applying coding standards to legacy code. For the ultimate + convenience (at the expense of some flexibility) see the criticism + pragma. + + If you'd like to try Perl::Critic without installing anything, there is + a web-service available at . The web-service does + not yet support all the configuration features that are available in the + native Perl::Critic API, but it should give you a good idea of what it + does. + + Also, ActivePerl includes a very slick graphical interface to + Perl-Critic called "perlcritic-gui". You can get a free community + edition of ActivePerl from . + +PREREQUISITES + Perl::Critic runs on Perl back to Perl 5.6.1. It relies on the PPI + module to do the heavy work of parsing Perl. + +INTERFACE SUPPORT + The "Perl::Critic" module is considered to be a public class. Any + changes to its interface will go through a deprecation cycle. + +CONSTRUCTOR + "new( [ -profile => $FILE, -severity => $N, -theme => $string, -include + => \@PATTERNS, -exclude => \@PATTERNS, -top => $N, -only => $B, + -profile-strictness => $PROFILE_STRICTNESS_{WARN|FATAL|QUIET}, -force => + $B, -verbose => $N ], -color => $B, -pager => $string, -allow-unsafe => + $B, -criticism-fatal => $B)" + "new()" + Returns a reference to a new Perl::Critic object. Most arguments are + just passed directly into Perl::Critic::Config, but I have described + them here as well. The default value for all arguments can be + defined in your .perlcriticrc file. See the "CONFIGURATION" section + for more information about that. All arguments are optional + key-value pairs as follows: + + -profile is a path to a configuration file. If $FILE is not defined, + Perl::Critic::Config attempts to find a .perlcriticrc configuration + file in the current directory, and then in your home directory. + Alternatively, you can set the "PERLCRITIC" environment variable to + point to a file in another location. If a configuration file can't + be found, or if $FILE is an empty string, then all Policies will be + loaded with their default configuration. See "CONFIGURATION" for + more information. + + -severity is the minimum severity level. Only Policy modules that + have a severity greater than $N will be applied. Severity values are + integers ranging from 1 (least severe violations) to 5 (most severe + violations). The default is 5. For a given "-profile", decreasing + the "-severity" will usually reveal more Policy violations. You can + set the default value for this option in your .perlcriticrc file. + Users can redefine the severity level for any Policy in their + .perlcriticrc file. See "CONFIGURATION" for more information. + + If it is difficult for you to remember whether severity "5" is the + most or least restrictive level, then you can use one of these named + values: + + SEVERITY NAME ...is equivalent to... SEVERITY NUMBER + -------------------------------------------------------- + -severity => 'gentle' -severity => 5 + -severity => 'stern' -severity => 4 + -severity => 'harsh' -severity => 3 + -severity => 'cruel' -severity => 2 + -severity => 'brutal' -severity => 1 + + The names reflect how severely the code is criticized: a "gentle" + criticism reports only the most severe violations, and so on down to + a "brutal" criticism which reports even the most minor violations. + + -theme is special expression that determines which Policies to apply + based on their respective themes. For example, the following would + load only Policies that have a 'bugs' AND 'pbp' theme: + + my $critic = Perl::Critic->new( -theme => 'bugs && pbp' ); + + Unless the "-severity" option is explicitly given, setting "-theme" + silently causes the "-severity" to be set to 1. You can set the + default value for this option in your .perlcriticrc file. See the + "POLICY THEMES" section for more information about themes. + + -include is a reference to a list of string @PATTERNS. Policy + modules that match at least one "m/$PATTERN/ixms" will always be + loaded, irrespective of all other settings. For example: + + my $critic = Perl::Critic->new(-include => ['layout'], -severity => 4); + + This would cause Perl::Critic to apply all the "CodeLayout::*" + Policy modules even though they have a severity level that is less + than 4. You can set the default value for this option in your + .perlcriticrc file. You can also use "-include" in conjunction with + the "-exclude" option. Note that "-exclude" takes precedence over + "-include" when a Policy matches both patterns. + + -exclude is a reference to a list of string @PATTERNS. Policy + modules that match at least one "m/$PATTERN/ixms" will not be + loaded, irrespective of all other settings. For example: + + my $critic = Perl::Critic->new(-exclude => ['strict'], -severity => 1); + + This would cause Perl::Critic to not apply the "RequireUseStrict" + and "ProhibitNoStrict" Policy modules even though they have a + severity level that is greater than 1. You can set the default value + for this option in your .perlcriticrc file. You can also use + "-exclude" in conjunction with the "-include" option. Note that + "-exclude" takes precedence over "-include" when a Policy matches + both patterns. + + -single-policy is a string "PATTERN". Only one policy that matches + "m/$PATTERN/ixms" will be used. Policies that do not match will be + excluded. This option has precedence over the "-severity", "-theme", + "-include", "-exclude", and "-only" options. You can set the default + value for this option in your .perlcriticrc file. + + -top is the maximum number of Violations to return when ranked by + their severity levels. This must be a positive integer. Violations + are still returned in the order that they occur within the file. + Unless the "-severity" option is explicitly given, setting "-top" + silently causes the "-severity" to be set to 1. You can set the + default value for this option in your .perlcriticrc file. + + -only is a boolean value. If set to a true value, Perl::Critic will + only choose from Policies that are mentioned in the user's profile. + If set to a false value (which is the default), then Perl::Critic + chooses from all the Policies that it finds at your site. You can + set the default value for this option in your .perlcriticrc file. + + -profile-strictness is an enumerated value, one of + "$PROFILE_STRICTNESS_WARN" in Perl::Critic::Utils::Constants (the + default), "$PROFILE_STRICTNESS_FATAL" in + Perl::Critic::Utils::Constants, and "$PROFILE_STRICTNESS_QUIET" in + Perl::Critic::Utils::Constants. If set to + "$PROFILE_STRICTNESS_FATAL" in Perl::Critic::Utils::Constants, + Perl::Critic will make certain warnings about problems found in a + .perlcriticrc or file specified via the -profile option fatal. For + example, Perl::Critic normally only "warn"s about profiles referring + to non-existent Policies, but this value makes this situation fatal. + Correspondingly, "$PROFILE_STRICTNESS_QUIET" in + Perl::Critic::Utils::Constants makes Perl::Critic shut up about + these things. + + -force is a boolean value that controls whether Perl::Critic + observes the magical "## no critic" annotations in your code. If set + to a true value, Perl::Critic will analyze all code. If set to a + false value (which is the default) Perl::Critic will ignore code + that is tagged with these annotations. See "BENDING THE RULES" for + more information. You can set the default value for this option in + your .perlcriticrc file. + + -verbose can be a positive integer (from 1 to 11), or a literal + format specification. See Perl::Critic::Violation for an explanation + of format specifications. You can set the default value for this + option in your .perlcriticrc file. + + -unsafe directs Perl::Critic to allow the use of Policies that are + marked as "unsafe" by the author. Such policies may compile + untrusted code or do other nefarious things. + + -color and -pager are not used by Perl::Critic but is provided for + the benefit of perlcritic. + + -criticism-fatal is not used by Perl::Critic but is provided for the + benefit of criticism. + + -color-severity-highest, -color-severity-high, -color-severity- + medium, -color-severity-low, and -color-severity-lowest are not used + by Perl::Critic, but are provided for the benefit of perlcritic. + Each is set to the Term::ANSIColor color specification to be used to + display violations of the corresponding severity. + + -files-with-violations and -files-without-violations are not used by + Perl::Critic, but are provided for the benefit of perlcritic, to + cause only the relevant filenames to be displayed. + +METHODS + "critique( $source_code )" + Runs the $source_code through the Perl::Critic engine using all the + Policies that have been loaded into this engine. If $source_code is + a scalar reference, then it is treated as a string of actual Perl + code. If $source_code is a reference to an instance of + PPI::Document, then that instance is used directly. Otherwise, it is + treated as a path to a local file containing Perl code. This method + returns a list of Perl::Critic::Violation objects for each violation + of the loaded Policies. The list is sorted in the order that the + Violations appear in the code. If there are no violations, this + method returns an empty list. + + "add_policy( -policy => $policy_name, -params => \%param_hash )" + Creates a Policy object and loads it into this Critic. If the object + cannot be instantiated, it will throw a fatal exception. Otherwise, + it returns a reference to this Critic. + + -policy is the name of a Perl::Critic::Policy subclass module. The + 'Perl::Critic::Policy' portion of the name can be omitted for + brevity. This argument is required. + + -params is an optional reference to a hash of Policy parameters. The + contents of this hash reference will be passed into to the + constructor of the Policy module. See the documentation in the + relevant Policy module for a description of the arguments it + supports. + + " policies() " + Returns a list containing references to all the Policy objects that + have been loaded into this engine. Objects will be in the order that + they were loaded. + + " config() " + Returns the Perl::Critic::Config object that was created for or + given to this Critic. + + " statistics() " + Returns the Perl::Critic::Statistics object that was created for + this Critic. The Statistics object accumulates data for all files + that are analyzed by this Critic. + +FUNCTIONAL INTERFACE + For those folks who prefer to have a functional interface, The + "critique" method can be exported on request and called as a static + function. If the first argument is a hashref, its contents are used to + construct a new Perl::Critic object internally. The keys of that hash + should be the same as those supported by the "Perl::Critic::new()" + method. Here are some examples: + + use Perl::Critic qw(critique); + + # Use default parameters... + @violations = critique( $some_file ); + + # Use custom parameters... + @violations = critique( {-severity => 2}, $some_file ); + + # As a one-liner + %> perl -MPerl::Critic=critique -e 'print critique(shift)' some_file.pm + + None of the other object-methods are currently supported as static + functions. Sorry. + +CONFIGURATION + Most of the settings for Perl::Critic and each of the Policy modules can + be controlled by a configuration file. The default configuration file is + called .perlcriticrc. Perl::Critic will look for this file in the + current directory first, and then in your home directory. Alternatively, + you can set the "PERLCRITIC" environment variable to explicitly point to + a different file in another location. If none of these files exist, and + the "-profile" option is not given to the constructor, then all the + modules that are found in the Perl::Critic::Policy namespace will be + loaded with their default configuration. + + The format of the configuration file is a series of INI-style blocks + that contain key-value pairs separated by '='. Comments should start + with '#' and can be placed on a separate line or after the name-value + pairs if you desire. + + Default settings for Perl::Critic itself can be set before the first + named block. For example, putting any or all of these at the top of your + configuration file will set the default value for the corresponding + constructor argument. + + severity = 3 #Integer or named level + only = 1 #Zero or One + force = 0 #Zero or One + verbose = 4 #Integer or format spec + top = 50 #A positive integer + theme = (pbp || security) && bugs #A theme expression + include = NamingConventions ClassHierarchies #Space-delimited list + exclude = Variables Modules::RequirePackage #Space-delimited list + criticism-fatal = 1 #Zero or One + color = 1 #Zero or One + allow-unsafe = 1 #Zero or One + pager = less #pager to pipe output to + + The remainder of the configuration file is a series of blocks like this: + + [Perl::Critic::Policy::Category::PolicyName] + severity = 1 + set_themes = foo bar + add_themes = baz + maximum_violations_per_document = 57 + arg1 = value1 + arg2 = value2 + + "Perl::Critic::Policy::Category::PolicyName" is the full name of a + module that implements the policy. The Policy modules distributed with + Perl::Critic have been grouped into categories according to the table of + contents in Damian Conway's book Perl Best Practices. For brevity, you + can omit the 'Perl::Critic::Policy' part of the module name. + + "severity" is the level of importance you wish to assign to the Policy. + All Policy modules are defined with a default severity value ranging + from 1 (least severe) to 5 (most severe). However, you may disagree with + the default severity and choose to give it a higher or lower severity, + based on your own coding philosophy. You can set the "severity" to an + integer from 1 to 5, or use one of the equivalent names: + + SEVERITY NAME ...is equivalent to... SEVERITY NUMBER + ---------------------------------------------------- + gentle 5 + stern 4 + harsh 3 + cruel 2 + brutal 1 + + The names reflect how severely the code is criticized: a "gentle" + criticism reports only the most severe violations, and so on down to a + "brutal" criticism which reports even the most minor violations. + + "set_themes" sets the theme for the Policy and overrides its default + theme. The argument is a string of one or more whitespace-delimited + alphanumeric words. Themes are case-insensitive. See "POLICY THEMES" for + more information. + + "add_themes" appends to the default themes for this Policy. The argument + is a string of one or more whitespace-delimited words. Themes are case- + insensitive. See "POLICY THEMES" for more information. + + "maximum_violations_per_document" limits the number of Violations the + Policy will return for a given document. Some Policies have a default + limit; see the documentation for the individual Policies to see whether + there is one. To force a Policy to not have a limit, specify "no_limit" + or the empty string for the value of this parameter. + + The remaining key-value pairs are configuration parameters that will be + passed into the constructor for that Policy. The constructors for most + Policy objects do not support arguments, and those that do should have + reasonable defaults. See the documentation on the appropriate Policy + module for more details. + + Instead of redefining the severity for a given Policy, you can + completely disable a Policy by prepending a '-' to the name of the + module in your configuration file. In this manner, the Policy will never + be loaded, regardless of the "-severity" given to the Perl::Critic + constructor. + + A simple configuration might look like this: + + #-------------------------------------------------------------- + # I think these are really important, so always load them + + [TestingAndDebugging::RequireUseStrict] + severity = 5 + + [TestingAndDebugging::RequireUseWarnings] + severity = 5 + + #-------------------------------------------------------------- + # I think these are less important, so only load when asked + + [Variables::ProhibitPackageVars] + severity = 2 + + [ControlStructures::ProhibitPostfixControls] + allow = if unless # My custom configuration + severity = cruel # Same as "severity = 2" + + #-------------------------------------------------------------- + # Give these policies a custom theme. I can activate just + # these policies by saying `perlcritic -theme larry` + + [Modules::RequireFilenameMatchesPackage] + add_themes = larry + + [TestingAndDebugging::RequireTestLables] + add_themes = larry curly moe + + #-------------------------------------------------------------- + # I do not agree with these at all, so never load them + + [-NamingConventions::Capitalization] + [-ValuesAndExpressions::ProhibitMagicNumbers] + + #-------------------------------------------------------------- + # For all other Policies, I accept the default severity, + # so no additional configuration is required for them. + + For additional configuration examples, see the perlcriticrc file that is + included in this examples directory of this distribution. + + Damian Conway's own Perl::Critic configuration is also included in this + distribution as examples/perlcriticrc-conway. + +THE POLICIES + A large number of Policy modules are distributed with Perl::Critic. They + are described briefly in the companion document + Perl::Critic::PolicySummary and in more detail in the individual modules + themselves. Say ""perlcritic -doc PATTERN"" to see the perldoc for all + Policy modules that match the regex "m/PATTERN/ixms" + + There are a number of distributions of additional policies on CPAN. If + Perl::Critic doesn't contain a policy that you want, some one may have + already written it. See the "SEE ALSO" section below for a list of some + of these distributions. + +POLICY THEMES + Each Policy is defined with one or more "themes". Themes can be used to + create arbitrary groups of Policies. They are intended to provide an + alternative mechanism for selecting your preferred set of Policies. For + example, you may wish disable a certain subset of Policies when + analyzing test programs. Conversely, you may wish to enable only a + specific subset of Policies when analyzing modules. + + The Policies that ship with Perl::Critic have been broken into the + following themes. This is just our attempt to provide some basic logical + groupings. You are free to invent new themes that suit your needs. + + THEME DESCRIPTION + -------------------------------------------------------------------------- + core All policies that ship with Perl::Critic + pbp Policies that come directly from "Perl Best Practices" + bugs Policies that that prevent or reveal bugs + certrec Policies that CERT recommends + certrule Policies that CERT considers rules + maintenance Policies that affect the long-term health of the code + cosmetic Policies that only have a superficial effect + complexity Policies that specifically relate to code complexity + security Policies that relate to security issues + tests Policies that are specific to test programs + + Any Policy may fit into multiple themes. Say "perlcritic -list" to get a + listing of all available Policies and the themes that are associated + with each one. You can also change the theme for any Policy in your + .perlcriticrc file. See the "CONFIGURATION" section for more information + about that. + + Using the "-theme" option, you can create an arbitrarily complex rule + that determines which Policies will be loaded. Precedence is the same as + regular Perl code, and you can use parentheses to enforce precedence as + well. Supported operators are: + + Operator Alternative Example + ----------------------------------------------------------------- + && and 'pbp && core' + || or 'pbp || (bugs && security)' + ! not 'pbp && ! (portability || complexity)' + + Theme names are case-insensitive. If the "-theme" is set to an empty + string, then it evaluates as true all Policies. + +BENDING THE RULES + Perl::Critic takes a hard-line approach to your code: either you comply + or you don't. In the real world, it is not always practical (nor even + possible) to fully comply with coding standards. In such cases, it is + wise to show that you are knowingly violating the standards and that you + have a Damn Good Reason (DGR) for doing so. + + To help with those situations, you can direct Perl::Critic to ignore + certain lines or blocks of code by using annotations: + + require 'LegacyLibaray1.pl'; ## no critic + require 'LegacyLibrary2.pl'; ## no critic + + for my $element (@list) { + + ## no critic + + $foo = ""; #Violates 'ProhibitEmptyQuotes' + $barf = bar() if $foo; #Violates 'ProhibitPostfixControls' + #Some more evil code... + + ## use critic + + #Some good code... + do_something($_); + } + + The "## no critic" annotations direct Perl::Critic to ignore the + remaining lines of code until a "## use critic" annotation is found. If + the ""## no critic"" annotation is on the same line as a code statement, + then only that line of code is overlooked. To direct perlcritic to + ignore the ""## no critic"" annotations, use the "--force" option. + + A bare "## no critic" annotation disables all the active Policies. If + you wish to disable only specific Policies, add a list of Policy names + as arguments, just as you would for the "no strict" or "no warnings" + pragmas. For example, this would disable the "ProhibitEmptyQuotes" and + "ProhibitPostfixControls" policies until the end of the block or until + the next "## use critic" annotation (whichever comes first): + + ## no critic (EmptyQuotes, PostfixControls) + + # Now exempt from ValuesAndExpressions::ProhibitEmptyQuotes + $foo = ""; + + # Now exempt ControlStructures::ProhibitPostfixControls + $barf = bar() if $foo; + + # Still subjected to ValuesAndExpression::RequireNumberSeparators + $long_int = 10000000000; + + Since the Policy names are matched against the "## no critic" arguments + as regular expressions, you can abbreviate the Policy names or disable + an entire family of Policies in one shot like this: + + ## no critic (NamingConventions) + + # Now exempt from NamingConventions::Capitalization + my $camelHumpVar = 'foo'; + + # Now exempt from NamingConventions::Capitalization + sub camelHumpSub {} + + The argument list must be enclosed in parentheses or brackets and must + contain one or more comma-separated barewords (e.g. don't use quotes). + The "## no critic" annotations can be nested, and Policies named by an + inner annotation will be disabled along with those already disabled an + outer annotation. + + Some Policies like "Subroutines::ProhibitExcessComplexity" apply to an + entire block of code. In those cases, the "## no critic" annotation must + appear on the line where the violation is reported. For example: + + sub complicated_function { ## no critic (ProhibitExcessComplexity) + # Your code here... + } + + Policies such as "Documentation::RequirePodSections" apply to the entire + document, in which case violations are reported at line 1. + + Use this feature wisely. "## no critic" annotations should be used in + the smallest possible scope, or only on individual lines of code. And + you should always be as specific as possible about which Policies you + want to disable (i.e. never use a bare "## no critic"). If Perl::Critic + complains about your code, try and find a compliant solution before + resorting to this feature. + +THE Perl::Critic PHILOSOPHY + Coding standards are deeply personal and highly subjective. The goal of + Perl::Critic is to help you write code that conforms with a set of best + practices. Our primary goal is not to dictate what those practices are, + but rather, to implement the practices discovered by others. Ultimately, + you make the rules -- Perl::Critic is merely a tool for encouraging + consistency. If there is a policy that you think is important or that we + have overlooked, we would be very grateful for contributions, or you can + simply load your own private set of policies into Perl::Critic. + +EXTENDING THE CRITIC + The modular design of Perl::Critic is intended to facilitate the + addition of new Policies. You'll need to have some understanding of PPI, + but most Policy modules are pretty straightforward and only require + about 20 lines of code. Please see the Perl::Critic::DEVELOPER file + included in this distribution for a step-by-step demonstration of how to + create new Policy modules. + + If you develop any new Policy modules, feel free to send them to + "" and I'll be happy to consider putting them into + the Perl::Critic distribution. Or if you would like to work on the + Perl::Critic project directly, you can fork our repository at + . + + The Perl::Critic team is also available for hire. If your organization + has its own coding standards, we can create custom Policies to enforce + your local guidelines. Or if your code base is prone to a particular + defect pattern, we can design Policies that will help you catch those + costly defects before they go into production. To discuss your needs + with the Perl::Critic team, just contact "". + +PREREQUISITES + Perl::Critic requires the following modules: + + B::Keywords + + Config::Tiny + + Exception::Class + + File::Spec + + File::Spec::Unix + + File::Which + + IO::String + + List::MoreUtils + + List::Util + + Module::Pluggable + + Perl::Tidy + + Pod::Spell + + PPI + + Pod::PlainText + + Pod::Select + + Pod::Usage + + Readonly + + Scalar::Util + + String::Format + + Task::Weaken + + Term::ANSIColor + + Text::ParseWords + + version + +CONTACTING THE DEVELOPMENT TEAM + You are encouraged to subscribe to the public mailing list at + . At least one member of + the development team is usually hanging around in + and you can follow Perl::Critic on + Twitter, at . + +SEE ALSO + There are a number of distributions of additional Policies available. A + few are listed here: + + Perl::Critic::More + + Perl::Critic::Bangs + + Perl::Critic::Lax + + Perl::Critic::StricterSubs + + Perl::Critic::Swift + + Perl::Critic::Tics + + These distributions enable you to use Perl::Critic in your unit tests: + + Test::Perl::Critic + + Test::Perl::Critic::Progressive + + There is also a distribution that will install all the Perl::Critic + related modules known to the development team: + + Task::Perl::Critic + +BUGS + Scrutinizing Perl code is hard for humans, let alone machines. If you + find any bugs, particularly false-positives or false-negatives from a + Perl::Critic::Policy, please submit them at + . Thanks. + +CREDITS + Adam Kennedy - For creating PPI, the heart and soul of Perl::Critic. + + Damian Conway - For writing Perl Best Practices, finally :) + + Chris Dolan - For contributing the best features and Policy modules. + + Andy Lester - Wise sage and master of all-things-testing. + + Elliot Shank - The self-proclaimed quality freak. + + Giuseppe Maxia - For all the great ideas and positive encouragement. + + and Sharon, my wife - For putting up with my all-night code sessions. + + Thanks also to the Perl Foundation for providing a grant to support + Chris Dolan's project to implement twenty PBP policies. + + + Thanks also to this incomplete laundry list of folks who have + contributed to Perl::Critic in some way: Daniel Mita, Gregory Oschwald, + Mike O'Regan, Tom Hukins, Omer Gazit, Evan Zacks, Paul Howarth, Sawyer + X, Christian Walde, Dave Rolsky, Jakub Wilk, Roy Ivy III, Oliver + Trosien, Glenn Fowler, Matt Creenan, Alex Balhatchet, Sebastian Paaske + Tørholm, Stuart A Johnston, Dan Book, Steven Humphrey, James Raspass, + Nick Tonkin, Harrison Katz, Douglas Sims, Mark Fowler, Alan Berndt, Neil + Bowers, Sergey Romanov, Gabor Szabo, Graham Knop, Mike Eldridge, David + Steinbrunner, Kirk Kimmel, Guillaume Aubert, Dave Cross, Anirvan + Chatterjee, Todd Rinaldo, Graham Ollis, Karen Etheridge, Jonas Brømsø, + Olaf Alders, Jim Keenan, Slaven Rezić, Szymon Nieznański. + +AUTHOR + Jeffrey Ryan Thalhammer + +COPYRIGHT + Copyright (c) 2005-2019 Imaginative Software Systems. All rights + reserved. + + This program is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. The full text of this license can + be found in the LICENSE file included with this module. + diff --git a/README.md b/README.md new file mode 100644 index 0000000..9f213d1 --- /dev/null +++ b/README.md @@ -0,0 +1,754 @@ +# BUILD STATUS + +* [![Build Status](https://github.com/Perl-Critic/Perl-Critic/workflows/testsuite/badge.svg?branch=dev)](https://github.com/Perl-Critic/Perl-Critic/actions?query=workflow%3Atestsuite+branch%3Adev) +* [CPAN Testers](http://cpantesters.org/distro/P/Perl-Critic.html) + +# NAME + +Perl::Critic - Critique Perl source code for best-practices. + +# SYNOPSIS + + use Perl::Critic; + my $file = shift; + my $critic = Perl::Critic->new(); + my @violations = $critic->critique($file); + print @violations; + +# DESCRIPTION + +Perl::Critic is an extensible framework for creating and applying coding +standards to Perl source code. Essentially, it is a static source code +analysis engine. Perl::Critic is distributed with a number of +[Perl::Critic::Policy](https://metacpan.org/pod/Perl::Critic::Policy) modules that attempt to enforce various coding +guidelines. Most Policy modules are based on Damian Conway's book **Perl Best +Practices**. However, Perl::Critic is **not** limited to PBP and will even +support Policies that contradict Conway. You can enable, disable, and +customize those Polices through the Perl::Critic interface. You can also +create new Policy modules that suit your own tastes. + +For a command-line interface to Perl::Critic, see the documentation for +[perlcritic](https://metacpan.org/pod/perlcritic). If you want to integrate Perl::Critic with your build process, +[Test::Perl::Critic](https://metacpan.org/pod/Test::Perl::Critic) provides an interface that is suitable for test +programs. Also, [Test::Perl::Critic::Progressive](https://metacpan.org/pod/Test::Perl::Critic::Progressive) is useful for gradually +applying coding standards to legacy code. For the ultimate convenience (at +the expense of some flexibility) see the [criticism](https://metacpan.org/pod/criticism) pragma. + +If you'd like to try [Perl::Critic](https://metacpan.org/pod/Perl::Critic) without installing anything, there is a +web-service available at [http://perlcritic.com](http://perlcritic.com). The web-service does not +yet support all the configuration features that are available in the native +Perl::Critic API, but it should give you a good idea of what it does. + +Also, ActivePerl includes a very slick graphical interface to Perl-Critic +called `perlcritic-gui`. You can get a free community edition of ActivePerl +from [http://www.activestate.com](http://www.activestate.com). + +# PREREQUISITES + +Perl::Critic runs on Perl back to Perl 5.6.1. It relies on the [PPI](https://metacpan.org/pod/PPI) +module to do the heavy work of parsing Perl. + +# INTERFACE SUPPORT + +The `Perl::Critic` module is considered to be a public class. Any +changes to its interface will go through a deprecation cycle. + +# CONSTRUCTOR + +- `new( [ -profile => $FILE, -severity => $N, -theme => $string, -include => \@PATTERNS, -exclude => \@PATTERNS, -top => $N, -only => $B, -profile-strictness => $PROFILE_STRICTNESS_{WARN|FATAL|QUIET}, -force => $B, -verbose => $N ], -color => $B, -pager => $string, -allow-unsafe => $B, -criticism-fatal => $B)` +- `new()` + + Returns a reference to a new Perl::Critic object. Most arguments are just + passed directly into [Perl::Critic::Config](https://metacpan.org/pod/Perl::Critic::Config), but I have described them here + as well. The default value for all arguments can be defined in your + `.perlcriticrc` file. See the ["CONFIGURATION"](#configuration) section for more + information about that. All arguments are optional key-value pairs as + follows: + + **-profile** is a path to a configuration file. If `$FILE` is not defined, + Perl::Critic::Config attempts to find a `.perlcriticrc` configuration file in + the current directory, and then in your home directory. Alternatively, you + can set the `PERLCRITIC` environment variable to point to a file in another + location. If a configuration file can't be found, or if `$FILE` is an empty + string, then all Policies will be loaded with their default configuration. + See ["CONFIGURATION"](#configuration) for more information. + + **-severity** is the minimum severity level. Only Policy modules that have a + severity greater than `$N` will be applied. Severity values are integers + ranging from 1 (least severe violations) to 5 (most severe violations). The + default is 5. For a given `-profile`, decreasing the `-severity` will + usually reveal more Policy violations. You can set the default value for this + option in your `.perlcriticrc` file. Users can redefine the severity level + for any Policy in their `.perlcriticrc` file. See ["CONFIGURATION"](#configuration) for + more information. + + If it is difficult for you to remember whether severity "5" is the most or + least restrictive level, then you can use one of these named values: + + SEVERITY NAME ...is equivalent to... SEVERITY NUMBER + -------------------------------------------------------- + -severity => 'gentle' -severity => 5 + -severity => 'stern' -severity => 4 + -severity => 'harsh' -severity => 3 + -severity => 'cruel' -severity => 2 + -severity => 'brutal' -severity => 1 + + The names reflect how severely the code is criticized: a `gentle` criticism + reports only the most severe violations, and so on down to a `brutal` + criticism which reports even the most minor violations. + + **-theme** is special expression that determines which Policies to apply based + on their respective themes. For example, the following would load only + Policies that have a 'bugs' AND 'pbp' theme: + + my $critic = Perl::Critic->new( -theme => 'bugs && pbp' ); + + Unless the `-severity` option is explicitly given, setting `-theme` silently + causes the `-severity` to be set to 1. You can set the default value for + this option in your `.perlcriticrc` file. See the ["POLICY THEMES"](#policy-themes) section + for more information about themes. + + **-include** is a reference to a list of string `@PATTERNS`. Policy modules + that match at least one `m/$PATTERN/ixms` will always be loaded, irrespective + of all other settings. For example: + + my $critic = Perl::Critic->new(-include => ['layout'], -severity => 4); + + This would cause Perl::Critic to apply all the `CodeLayout::*` Policy modules + even though they have a severity level that is less than 4. You can set the + default value for this option in your `.perlcriticrc` file. You can also use + `-include` in conjunction with the `-exclude` option. Note that `-exclude` + takes precedence over `-include` when a Policy matches both patterns. + + **-exclude** is a reference to a list of string `@PATTERNS`. Policy modules + that match at least one `m/$PATTERN/ixms` will not be loaded, irrespective of + all other settings. For example: + + my $critic = Perl::Critic->new(-exclude => ['strict'], -severity => 1); + + This would cause Perl::Critic to not apply the `RequireUseStrict` and + `ProhibitNoStrict` Policy modules even though they have a severity level that + is greater than 1. You can set the default value for this option in your + `.perlcriticrc` file. You can also use `-exclude` in conjunction with the + `-include` option. Note that `-exclude` takes precedence over `-include` + when a Policy matches both patterns. + + **-single-policy** is a string `PATTERN`. Only one policy that matches + `m/$PATTERN/ixms` will be used. Policies that do not match will be excluded. + This option has precedence over the `-severity`, `-theme`, `-include`, + `-exclude`, and `-only` options. You can set the default value for this + option in your `.perlcriticrc` file. + + **-top** is the maximum number of Violations to return when ranked by their + severity levels. This must be a positive integer. Violations are still + returned in the order that they occur within the file. Unless the `-severity` + option is explicitly given, setting `-top` silently causes the `-severity` + to be set to 1. You can set the default value for this option in your + `.perlcriticrc` file. + + **-only** is a boolean value. If set to a true value, Perl::Critic will only + choose from Policies that are mentioned in the user's profile. If set to a + false value (which is the default), then Perl::Critic chooses from all the + Policies that it finds at your site. You can set the default value for this + option in your `.perlcriticrc` file. + + **-profile-strictness** is an enumerated value, one of + ["$PROFILE\_STRICTNESS\_WARN" in Perl::Critic::Utils::Constants](https://metacpan.org/pod/Perl::Critic::Utils::Constants#PROFILE_STRICTNESS_WARN) (the default), + ["$PROFILE\_STRICTNESS\_FATAL" in Perl::Critic::Utils::Constants](https://metacpan.org/pod/Perl::Critic::Utils::Constants#PROFILE_STRICTNESS_FATAL), and + ["$PROFILE\_STRICTNESS\_QUIET" in Perl::Critic::Utils::Constants](https://metacpan.org/pod/Perl::Critic::Utils::Constants#PROFILE_STRICTNESS_QUIET). If set to + ["$PROFILE\_STRICTNESS\_FATAL" in Perl::Critic::Utils::Constants](https://metacpan.org/pod/Perl::Critic::Utils::Constants#PROFILE_STRICTNESS_FATAL), Perl::Critic + will make certain warnings about problems found in a `.perlcriticrc` or file + specified via the **-profile** option fatal. For example, Perl::Critic normally + only `warn`s about profiles referring to non-existent Policies, but this + value makes this situation fatal. Correspondingly, + ["$PROFILE\_STRICTNESS\_QUIET" in Perl::Critic::Utils::Constants](https://metacpan.org/pod/Perl::Critic::Utils::Constants#PROFILE_STRICTNESS_QUIET) makes + Perl::Critic shut up about these things. + + **-force** is a boolean value that controls whether Perl::Critic observes the + magical `"## no critic"` annotations in your code. If set to a true value, + Perl::Critic will analyze all code. If set to a false value (which is the + default) Perl::Critic will ignore code that is tagged with these annotations. + See ["BENDING THE RULES"](#bending-the-rules) for more information. You can set the default + value for this option in your `.perlcriticrc` file. + + **-verbose** can be a positive integer (from 1 to 11), or a literal format + specification. See [Perl::Critic::Violation](https://metacpan.org/pod/Perl::Critic::Violation) for an + explanation of format specifications. You can set the default value for this + option in your `.perlcriticrc` file. + + **-unsafe** directs Perl::Critic to allow the use of Policies that are marked + as "unsafe" by the author. Such policies may compile untrusted code or do + other nefarious things. + + **-color** and **-pager** are not used by Perl::Critic but is provided for the + benefit of [perlcritic](https://metacpan.org/pod/perlcritic). + + **-criticism-fatal** is not used by Perl::Critic but is provided for the + benefit of [criticism](https://metacpan.org/pod/criticism). + + **-color-severity-highest**, **-color-severity-high**, **-color-severity- + medium**, **-color-severity-low**, and **-color-severity-lowest** are not used by + Perl::Critic, but are provided for the benefit of [perlcritic](https://metacpan.org/pod/perlcritic). + Each is set to the Term::ANSIColor color specification to be used to display + violations of the corresponding severity. + + **-files-with-violations** and **-files-without-violations** are not used by + Perl::Critic, but are provided for the benefit of [perlcritic](https://metacpan.org/pod/perlcritic), to + cause only the relevant filenames to be displayed. + +# METHODS + +- `critique( $source_code )` + + Runs the `$source_code` through the Perl::Critic engine using all the + Policies that have been loaded into this engine. If `$source_code` is a + scalar reference, then it is treated as a string of actual Perl code. If + `$source_code` is a reference to an instance of [PPI::Document](https://metacpan.org/pod/PPI::Document), then that + instance is used directly. Otherwise, it is treated as a path to a local file + containing Perl code. This method returns a list of + [Perl::Critic::Violation](https://metacpan.org/pod/Perl::Critic::Violation) objects for each violation of the loaded Policies. + The list is sorted in the order that the Violations appear in the code. If + there are no violations, this method returns an empty list. + +- `add_policy( -policy => $policy_name, -params => \%param_hash )` + + Creates a Policy object and loads it into this Critic. If the object cannot + be instantiated, it will throw a fatal exception. Otherwise, it returns a + reference to this Critic. + + **-policy** is the name of a [Perl::Critic::Policy](https://metacpan.org/pod/Perl::Critic::Policy) subclass module. The + `'Perl::Critic::Policy'` portion of the name can be omitted for brevity. + This argument is required. + + **-params** is an optional reference to a hash of Policy parameters. The + contents of this hash reference will be passed into to the constructor of the + Policy module. See the documentation in the relevant Policy module for a + description of the arguments it supports. + +- ` policies() ` + + Returns a list containing references to all the Policy objects that have been + loaded into this engine. Objects will be in the order that they were loaded. + +- ` config() ` + + Returns the [Perl::Critic::Config](https://metacpan.org/pod/Perl::Critic::Config) object that was created for or given to + this Critic. + +- ` statistics() ` + + Returns the [Perl::Critic::Statistics](https://metacpan.org/pod/Perl::Critic::Statistics) object that was created for this + Critic. The Statistics object accumulates data for all files that are + analyzed by this Critic. + +# FUNCTIONAL INTERFACE + +For those folks who prefer to have a functional interface, The `critique` +method can be exported on request and called as a static function. If the +first argument is a hashref, its contents are used to construct a new +Perl::Critic object internally. The keys of that hash should be the same as +those supported by the `Perl::Critic::new()` method. Here are some examples: + + use Perl::Critic qw(critique); + + # Use default parameters... + @violations = critique( $some_file ); + + # Use custom parameters... + @violations = critique( {-severity => 2}, $some_file ); + + # As a one-liner + %> perl -MPerl::Critic=critique -e 'print critique(shift)' some_file.pm + +None of the other object-methods are currently supported as static +functions. Sorry. + +# CONFIGURATION + +Most of the settings for Perl::Critic and each of the Policy modules can be +controlled by a configuration file. The default configuration file is called +`.perlcriticrc`. Perl::Critic will look for this file in the current +directory first, and then in your home directory. Alternatively, you can set +the `PERLCRITIC` environment variable to explicitly point to a different file +in another location. If none of these files exist, and the `-profile` option +is not given to the constructor, then all the modules that are found in the +Perl::Critic::Policy namespace will be loaded with their default +configuration. + +The format of the configuration file is a series of INI-style blocks that +contain key-value pairs separated by '='. Comments should start with '#' and +can be placed on a separate line or after the name-value pairs if you desire. + +Default settings for Perl::Critic itself can be set **before the first named +block.** For example, putting any or all of these at the top of your +configuration file will set the default value for the corresponding +constructor argument. + + severity = 3 #Integer or named level + only = 1 #Zero or One + force = 0 #Zero or One + verbose = 4 #Integer or format spec + top = 50 #A positive integer + theme = (pbp || security) && bugs #A theme expression + include = NamingConventions ClassHierarchies #Space-delimited list + exclude = Variables Modules::RequirePackage #Space-delimited list + criticism-fatal = 1 #Zero or One + color = 1 #Zero or One + allow-unsafe = 1 #Zero or One + pager = less #pager to pipe output to + +The remainder of the configuration file is a series of blocks like this: + + [Perl::Critic::Policy::Category::PolicyName] + severity = 1 + set_themes = foo bar + add_themes = baz + maximum_violations_per_document = 57 + arg1 = value1 + arg2 = value2 + +`Perl::Critic::Policy::Category::PolicyName` is the full name of a module +that implements the policy. The Policy modules distributed with Perl::Critic +have been grouped into categories according to the table of contents in Damian +Conway's book **Perl Best Practices**. For brevity, you can omit the +`'Perl::Critic::Policy'` part of the module name. + +`severity` is the level of importance you wish to assign to the Policy. All +Policy modules are defined with a default severity value ranging from 1 (least +severe) to 5 (most severe). However, you may disagree with the default +severity and choose to give it a higher or lower severity, based on your own +coding philosophy. You can set the `severity` to an integer from 1 to 5, or +use one of the equivalent names: + + SEVERITY NAME ...is equivalent to... SEVERITY NUMBER + ---------------------------------------------------- + gentle 5 + stern 4 + harsh 3 + cruel 2 + brutal 1 + +The names reflect how severely the code is criticized: a `gentle` criticism +reports only the most severe violations, and so on down to a `brutal` +criticism which reports even the most minor violations. + +`set_themes` sets the theme for the Policy and overrides its default theme. +The argument is a string of one or more whitespace-delimited alphanumeric +words. Themes are case-insensitive. See ["POLICY THEMES"](#policy-themes) for more +information. + +`add_themes` appends to the default themes for this Policy. The argument is +a string of one or more whitespace-delimited words. Themes are case- +insensitive. See ["POLICY THEMES"](#policy-themes) for more information. + +`maximum_violations_per_document` limits the number of Violations the Policy +will return for a given document. Some Policies have a default limit; see the +documentation for the individual Policies to see whether there is one. To +force a Policy to not have a limit, specify "no\_limit" or the empty string for +the value of this parameter. + +The remaining key-value pairs are configuration parameters that will be passed +into the constructor for that Policy. The constructors for most Policy +objects do not support arguments, and those that do should have reasonable +defaults. See the documentation on the appropriate Policy module for more +details. + +Instead of redefining the severity for a given Policy, you can completely +disable a Policy by prepending a '-' to the name of the module in your +configuration file. In this manner, the Policy will never be loaded, +regardless of the `-severity` given to the Perl::Critic constructor. + +A simple configuration might look like this: + + #-------------------------------------------------------------- + # I think these are really important, so always load them + + [TestingAndDebugging::RequireUseStrict] + severity = 5 + + [TestingAndDebugging::RequireUseWarnings] + severity = 5 + + #-------------------------------------------------------------- + # I think these are less important, so only load when asked + + [Variables::ProhibitPackageVars] + severity = 2 + + [ControlStructures::ProhibitPostfixControls] + allow = if unless # My custom configuration + severity = cruel # Same as "severity = 2" + + #-------------------------------------------------------------- + # Give these policies a custom theme. I can activate just + # these policies by saying `perlcritic -theme larry` + + [Modules::RequireFilenameMatchesPackage] + add_themes = larry + + [TestingAndDebugging::RequireTestLables] + add_themes = larry curly moe + + #-------------------------------------------------------------- + # I do not agree with these at all, so never load them + + [-NamingConventions::Capitalization] + [-ValuesAndExpressions::ProhibitMagicNumbers] + + #-------------------------------------------------------------- + # For all other Policies, I accept the default severity, + # so no additional configuration is required for them. + +For additional configuration examples, see the `perlcriticrc` file that is +included in this `examples` directory of this distribution. + +Damian Conway's own Perl::Critic configuration is also included in this +distribution as `examples/perlcriticrc-conway`. + +# THE POLICIES + +A large number of Policy modules are distributed with Perl::Critic. They are +described briefly in the companion document [Perl::Critic::PolicySummary](https://metacpan.org/pod/Perl::Critic::PolicySummary) and +in more detail in the individual modules themselves. Say `"perlcritic -doc +PATTERN"` to see the perldoc for all Policy modules that match the regex +`m/PATTERN/ixms` + +There are a number of distributions of additional policies on CPAN. If +[Perl::Critic](https://metacpan.org/pod/Perl::Critic) doesn't contain a policy that you want, some one may have +already written it. See the ["SEE ALSO"](#see-also) section below for a list of some +of these distributions. + +# POLICY THEMES + +Each Policy is defined with one or more "themes". Themes can be used to +create arbitrary groups of Policies. They are intended to provide an +alternative mechanism for selecting your preferred set of Policies. For +example, you may wish disable a certain subset of Policies when analyzing test +programs. Conversely, you may wish to enable only a specific subset of +Policies when analyzing modules. + +The Policies that ship with Perl::Critic have been broken into the following +themes. This is just our attempt to provide some basic logical groupings. +You are free to invent new themes that suit your needs. + + THEME DESCRIPTION + -------------------------------------------------------------------------- + core All policies that ship with Perl::Critic + pbp Policies that come directly from "Perl Best Practices" + bugs Policies that that prevent or reveal bugs + certrec Policies that CERT recommends + certrule Policies that CERT considers rules + maintenance Policies that affect the long-term health of the code + cosmetic Policies that only have a superficial effect + complexity Policies that specifically relate to code complexity + security Policies that relate to security issues + tests Policies that are specific to test programs + +Any Policy may fit into multiple themes. Say `"perlcritic -list"` to get a +listing of all available Policies and the themes that are associated with each +one. You can also change the theme for any Policy in your `.perlcriticrc` +file. See the ["CONFIGURATION"](#configuration) section for more information about that. + +Using the `-theme` option, you can create an arbitrarily complex rule that +determines which Policies will be loaded. Precedence is the same as regular +Perl code, and you can use parentheses to enforce precedence as well. +Supported operators are: + + Operator Alternative Example + ----------------------------------------------------------------- + && and 'pbp && core' + || or 'pbp || (bugs && security)' + ! not 'pbp && ! (portability || complexity)' + +Theme names are case-insensitive. If the `-theme` is set to an empty string, +then it evaluates as true all Policies. + +# BENDING THE RULES + +Perl::Critic takes a hard-line approach to your code: either you comply or you +don't. In the real world, it is not always practical (nor even possible) to +fully comply with coding standards. In such cases, it is wise to show that +you are knowingly violating the standards and that you have a Damn Good Reason +(DGR) for doing so. + +To help with those situations, you can direct Perl::Critic to ignore certain +lines or blocks of code by using annotations: + + require 'LegacyLibaray1.pl'; ## no critic + require 'LegacyLibrary2.pl'; ## no critic + + for my $element (@list) { + + ## no critic + + $foo = ""; #Violates 'ProhibitEmptyQuotes' + $barf = bar() if $foo; #Violates 'ProhibitPostfixControls' + #Some more evil code... + + ## use critic + + #Some good code... + do_something($_); + } + +The `"## no critic"` annotations direct Perl::Critic to ignore the remaining +lines of code until a `"## use critic"` annotation is found. If the `"## no +critic"` annotation is on the same line as a code statement, then only that +line of code is overlooked. To direct perlcritic to ignore the `"## no +critic"` annotations, use the `--force` option. + +A bare `"## no critic"` annotation disables all the active Policies. If you +wish to disable only specific Policies, add a list of Policy names as +arguments, just as you would for the `"no strict"` or `"no warnings"` +pragmas. For example, this would disable the `ProhibitEmptyQuotes` and +`ProhibitPostfixControls` policies until the end of the block or until the +next `"## use critic"` annotation (whichever comes first): + + ## no critic (EmptyQuotes, PostfixControls) + + # Now exempt from ValuesAndExpressions::ProhibitEmptyQuotes + $foo = ""; + + # Now exempt ControlStructures::ProhibitPostfixControls + $barf = bar() if $foo; + + # Still subjected to ValuesAndExpression::RequireNumberSeparators + $long_int = 10000000000; + +Since the Policy names are matched against the `"## no critic"` arguments as +regular expressions, you can abbreviate the Policy names or disable an entire +family of Policies in one shot like this: + + ## no critic (NamingConventions) + + # Now exempt from NamingConventions::Capitalization + my $camelHumpVar = 'foo'; + + # Now exempt from NamingConventions::Capitalization + sub camelHumpSub {} + +The argument list must be enclosed in parentheses or brackets and must contain +one or more comma-separated barewords (e.g. don't use quotes). +The `"## no critic"` annotations can be nested, and Policies named by an inner +annotation will be disabled along with those already disabled an outer +annotation. + +Some Policies like `Subroutines::ProhibitExcessComplexity` apply to an entire +block of code. In those cases, the `"## no critic"` annotation must appear +on the line where the violation is reported. For example: + + sub complicated_function { ## no critic (ProhibitExcessComplexity) + # Your code here... + } + +Policies such as `Documentation::RequirePodSections` apply to the entire +document, in which case violations are reported at line 1. + +Use this feature wisely. `"## no critic"` annotations should be used in the +smallest possible scope, or only on individual lines of code. And you should +always be as specific as possible about which Policies you want to disable +(i.e. never use a bare `"## no critic"`). If Perl::Critic complains about +your code, try and find a compliant solution before resorting to this feature. + +# THE [Perl::Critic](https://metacpan.org/pod/Perl::Critic) PHILOSOPHY + +Coding standards are deeply personal and highly subjective. The goal of +Perl::Critic is to help you write code that conforms with a set of best +practices. Our primary goal is not to dictate what those practices are, but +rather, to implement the practices discovered by others. Ultimately, you make +the rules -- Perl::Critic is merely a tool for encouraging consistency. If +there is a policy that you think is important or that we have overlooked, we +would be very grateful for contributions, or you can simply load your own +private set of policies into Perl::Critic. + +# EXTENDING THE CRITIC + +The modular design of Perl::Critic is intended to facilitate the addition of +new Policies. You'll need to have some understanding of [PPI](https://metacpan.org/pod/PPI), but most +Policy modules are pretty straightforward and only require about 20 lines of +code. Please see the [Perl::Critic::DEVELOPER](https://metacpan.org/pod/Perl::Critic::DEVELOPER) file included in this +distribution for a step-by-step demonstration of how to create new Policy +modules. + +If you develop any new Policy modules, feel free to send them to `` and I'll be happy to consider putting them into the +Perl::Critic distribution. Or if you would like to work on the Perl::Critic +project directly, you can fork our repository at +[https://github.com/Perl-Critic/Perl-Critic.git](https://github.com/Perl-Critic/Perl-Critic.git). + +The Perl::Critic team is also available for hire. If your organization has +its own coding standards, we can create custom Policies to enforce your local +guidelines. Or if your code base is prone to a particular defect pattern, we +can design Policies that will help you catch those costly defects **before** +they go into production. To discuss your needs with the Perl::Critic team, +just contact ``. + +# PREREQUISITES + +Perl::Critic requires the following modules: + +[B::Keywords](https://metacpan.org/pod/B::Keywords) + +[Config::Tiny](https://metacpan.org/pod/Config::Tiny) + +[Exception::Class](https://metacpan.org/pod/Exception::Class) + +[File::Spec](https://metacpan.org/pod/File::Spec) + +[File::Spec::Unix](https://metacpan.org/pod/File::Spec::Unix) + +[File::Which](https://metacpan.org/pod/File::Which) + +[IO::String](https://metacpan.org/pod/IO::String) + +[List::MoreUtils](https://metacpan.org/pod/List::MoreUtils) + +[List::Util](https://metacpan.org/pod/List::Util) + +[Module::Pluggable](https://metacpan.org/pod/Module::Pluggable) + +[Perl::Tidy](https://metacpan.org/pod/Perl::Tidy) + +[Pod::Spell](https://metacpan.org/pod/Pod::Spell) + +[PPI](https://metacpan.org/pod/PPI) + +[Pod::PlainText](https://metacpan.org/pod/Pod::PlainText) + +[Pod::Select](https://metacpan.org/pod/Pod::Select) + +[Pod::Usage](https://metacpan.org/pod/Pod::Usage) + +[Readonly](https://metacpan.org/pod/Readonly) + +[Scalar::Util](https://metacpan.org/pod/Scalar::Util) + +[String::Format](https://metacpan.org/pod/String::Format) + +[Task::Weaken](https://metacpan.org/pod/Task::Weaken) + +[Term::ANSIColor](https://metacpan.org/pod/Term::ANSIColor) + +[Text::ParseWords](https://metacpan.org/pod/Text::ParseWords) + +[version](https://metacpan.org/pod/version) + +# CONTACTING THE DEVELOPMENT TEAM + +You are encouraged to subscribe to the public mailing list at +[https://groups.google.com/d/forum/perl-critic](https://groups.google.com/d/forum/perl-critic). +At least one member of the development team is usually hanging around +in [irc://irc.perl.org/#perlcritic](irc://irc.perl.org/#perlcritic) and you can follow Perl::Critic on +Twitter, at [https://twitter.com/perlcritic](https://twitter.com/perlcritic). + +# SEE ALSO + +There are a number of distributions of additional Policies available. A few +are listed here: + +[Perl::Critic::More](https://metacpan.org/pod/Perl::Critic::More) + +[Perl::Critic::Bangs](https://metacpan.org/pod/Perl::Critic::Bangs) + +[Perl::Critic::Lax](https://metacpan.org/pod/Perl::Critic::Lax) + +[Perl::Critic::StricterSubs](https://metacpan.org/pod/Perl::Critic::StricterSubs) + +[Perl::Critic::Swift](https://metacpan.org/pod/Perl::Critic::Swift) + +[Perl::Critic::Tics](https://metacpan.org/pod/Perl::Critic::Tics) + +These distributions enable you to use Perl::Critic in your unit tests: + +[Test::Perl::Critic](https://metacpan.org/pod/Test::Perl::Critic) + +[Test::Perl::Critic::Progressive](https://metacpan.org/pod/Test::Perl::Critic::Progressive) + +There is also a distribution that will install all the Perl::Critic related +modules known to the development team: + +[Task::Perl::Critic](https://metacpan.org/pod/Task::Perl::Critic) + +# BUGS + +Scrutinizing Perl code is hard for humans, let alone machines. If you find +any bugs, particularly false-positives or false-negatives from a +Perl::Critic::Policy, please submit them at +[https://github.com/Perl-Critic/Perl-Critic/issues](https://github.com/Perl-Critic/Perl-Critic/issues). Thanks. + +# CREDITS + +Adam Kennedy - For creating [PPI](https://metacpan.org/pod/PPI), the heart and soul of [Perl::Critic](https://metacpan.org/pod/Perl::Critic). + +Damian Conway - For writing **Perl Best Practices**, finally :) + +Chris Dolan - For contributing the best features and Policy modules. + +Andy Lester - Wise sage and master of all-things-testing. + +Elliot Shank - The self-proclaimed quality freak. + +Giuseppe Maxia - For all the great ideas and positive encouragement. + +and Sharon, my wife - For putting up with my all-night code sessions. + +Thanks also to the Perl Foundation for providing a grant to support Chris +Dolan's project to implement twenty PBP policies. +[http://www.perlfoundation.org/april\_1\_2007\_new\_grant\_awards](http://www.perlfoundation.org/april_1_2007_new_grant_awards) + +Thanks also to this incomplete laundry list of folks who have contributed +to Perl::Critic in some way: +Gregory Oschwald, +Mike O'Regan, +Tom Hukins, +Omer Gazit, +Evan Zacks, +Paul Howarth, +Sawyer X, +Christian Walde, +Dave Rolsky, +Jakub Wilk, +Roy Ivy III, +Oliver Trosien, +Glenn Fowler, +Matt Creenan, +Alex Balhatchet, +Sebastian Paaske Tørholm, +Stuart A Johnston, +Dan Book, +Steven Humphrey, +James Raspass, +Nick Tonkin, +Harrison Katz, +Douglas Sims, +Mark Fowler, +Alan Berndt, +Neil Bowers, +Sergey Romanov, +Gabor Szabo, +Graham Knop, +Mike Eldridge, +David Steinbrunner, +Kirk Kimmel, +Guillaume Aubert, +Dave Cross, +Anirvan Chatterjee, +Todd Rinaldo, +Graham Ollis, +Karen Etheridge, +Jonas Brømsø, +Olaf Alders, +Jim Keenan, +Slaven Rezić, +Szymon Nieznański. + +# AUTHOR + +Jeffrey Ryan Thalhammer + +# COPYRIGHT + +Copyright (c) 2005-2018 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. The full text of this license can be found in +the LICENSE file included with this module. diff --git a/TODO.pod b/TODO.pod new file mode 100644 index 0000000..42d33af --- /dev/null +++ b/TODO.pod @@ -0,0 +1,677 @@ +# best viewed via "perldoc TODO.pod" + +=pod + +=for stopwords API LHS RHS REFACTORINGS FH SVN stopwords + +=head1 NAME + +Perl::Critic::TODO - Things for Perl::Critic developers to do + +=head1 SEE ALSO + +Perl-Critic-More is a separate distribution for less-widely-accepted +policies. It contains its own TODO.pod. + +=head1 NEW FEATURES + +=over + +=item * Report PBP and Safari sections in addition to PBP page numbers. + +Something like + + Readonly::Scalar my $EXPL => { + pbp_pages => [ 57 ], + pbp_section => '5.2', + safari_section => something, + }; + +=item * Include PBP references and Safari sections in the documentation. + +Perhaps these could be injected into the POD at build time, based on the data +in the code. But that data is not entirely static, so I'm not sure how it +would work for Policies that dynamically determine the PBP references. + +Perhaps it would be good enough to just create a one-off tool that would +inject the PBP and/or Safari references into the POD one time, and we could +manually deal with Policies that behave oddly. + +Much better would be to put the information in the POD in a structured manner +and parse it out in the code, something along the lines of + + =head1 METADATA + + =over + + =item Default Themes + + core bugs pbp + + =item Default Severity + + 3 + + =item Perl Best Practices Page Numbers + + 193, 195 + + =back + +and so on. + + +=item * Add a file Parameter::Behavior. + + +=item * Allow values of (at least) string-list Parameters to be specified in a file. + +For the benefit of PodSpelling, etc. + + +=item * Enhance string-list Behavior to allow specification of delimiters. + +For things like RequirePodSections. + + +=item * Add queries to --list option to F. + +List Policies based upon severity, theme, and (what I want this second) +applies_to. + +=item * Add formatting of --list output. + +Support Jeff Bisbee's use case (he dumps all the policies in severity order +with full descriptions and other metadata). + +=item * Support for C<#line 123 "filename"> directives. + +For code generators and template languages that allow inline Perl code. + +Yes, somebody has an in-house templating system where they've written a custom +test module that extracts the perl code from a template and critiques it. + +Actually, this would be useful for programs: Module::Build "fixes" shebang +lines so that there's the bit about invoking perl if the program is attempted +to be run by a Bourne shell, which throws the line numbers off when using +Test::P::C on the contents of a C directory. + +This has been implemented in PPI, but hasn't been released yet. When it does +come out, we need to change the line and file reported by Violations. + + +=item * Enhance statistics. + +- Blank line count + +- POD line count + +- Comment line count + +- Data section count + +Proposed implementation committed 15-Mar-2007 by wyant, about revision 3240. + + +=item * Detect 5.10 source and enable stuff for that. + +For example, treat C as equivalent to C. + +=item * Detect 5.12 source and enable stuff for that. + +Yes, this is long-term, and is really a list of stuff from 5.011 to enable if +it makes it into 5.12, gleaned from the perl511xdelta files: + +'use 5.011;' implies 'use strict;' and 'use feature qw{ :5.11 };' per +perl5110delta. + +'sub foo { ... }' (yes, with the subroutine body being an elipsis a.k.a. the +'yada yada' operator) compiles but fails at runtime per perl5110delta. PPI +seems to parse this sanely as of 1.206. + +'package Foo 1.23;' is equivalent to 'package Foo; our $VERSION = 1.23;' per +perl5111delta. PPI seems to parse this sanely as of 1.206. + +Nothing additional found in perl5112delta, which is the most recent as of the +addition of this item. + +=item * Detect 5.14 source and enable stuff for that. + +5.13.7 allows references in many places where arrays or hashes used to +be required (e.g. C where C<$stack> is an array +ref). Not sure what policies are affected. + +Lexical regular expression modifier defaults via (e.g.) +C). This also interacts with +C. 5.13.7. + +=item * Support a means of failing if a Policy isn't installed. + +For example, the self compliance test now depends upon a Policy in the More +distribution. + +Something like using a "+" sign in front of the Policy name in its +configuration block, analogous to the "-" sign used for disabling a policy, +e.g. "C<[+Example::Policy]>". + + +=item * Threading + +Pretty obviously, Perl::Critic is readily parallelizable, just do a document per +thread. ("readily" being conceptual, not necessarily practical) Although +there's now C, given perl's thread data +sharing model, this shouldn't be an issue. + + +=item * Add support in .run files for regexes for violation descriptions. + +=item * Add support for "## use critic (blah)". + +If I've got: + + ## no critic (SomePolicy) + + ... + + ## no critic (ADifferentPolicy) + + ... + + ## no critic (YetAnotherPolicy) + +If I want to turn C back on but neither C nor +C, I've got to do this: + + ## use critic + ## no critic (SomePolicy, ADifferentPolicy) + +Why can't I do this: + + ## use critic (SomeOtherPolicy) + + +=item * Create P::C::Node and make P::C::Document a subclass and make use of PPIx::Utilities::Node::split_ppi_node_by_namespace() to provide per-namespace caching of lookups that are now on P::C::Document. + +This is necessary to get P::C::Moose Policies correct. + + +=item * Use L to declare C<$VERSION> numbers throughout P::C + +PBP recommends using the L module. I chose not to follow that +recommendation because L didn't work with the Perl v5.6.1 that I had +at $work at that time (and I really wanted to use Perl::Critic at work). +But now the L has been updated and those bugs may have been fixed, +or perhaps we just don't care about running on Perl v5.6.1 any more. So +maybe now we can go ahead and use L. + +=back + + +=head1 BUGS/LIMITATIONS + +Document bugs for individual Policies in the Policies themselves. Users +should be aware of limitations. (And, hey, we might get patches that way.) + + +=head1 OTHER PBP POLICIES THAT SEEM FEASIBLE TO IMPLEMENT + +=over + +=item * Modules::RequireUseVersion [405-406] + +=item * Modules::RequireThreePartVersion [405-406] + + +=item * NamingConventions::RequireArrayAndHashReferenceVariablesEndWith_Ref [41-42] + +Check for C<$variable = [...]>, C<$variable = {...}>, C<< $variable->[...] >>, and +C<< $variable->{...} >>. + + +=item * Objects::ProhibitRestrictedHashes [322-323] + +Look for use of the bad methods in Hash::Util. + + +=item * Objects::ProhibitLValueAccessors [346-349] + +Look for the C<:lvalue> subroutine attribute. + + +=back + + +=head1 NON-PBP POLICIES WANTED + +=over + +=item * Subroutines::RequireArgumentValidation + +Enforce the use of Params::Validate or Params::Util or some other +argument validation mechanism. This could be one Policy that +can be configured for different validation mechanisms, or we could +have a separate Policy for each mechanism, and let the user choose +which one they want to use (I think I prefer the later). + + +=item * NamingConventions::ProhibitMisspelledSymbolNames + +The idea behind this policy is to encourage better names for variables +and subroutines by enforcing correct spelling and prohibiting the use of +home-grown abbreviations. Assuming that the author uses underscores or +camel-case, it should be possible to split symbols into words, and then look +them up in a dictionary (see PodSpelling). This policy should probably have +a similar stopwords feature as well. + + +=item * Documentation::RequireModuleAbstract + +Require a C<=head1 NAME> POD section with content that matches +C<\A \s* [\w:]+ \s+ - \s+ \S>. The single hyphen is the important bit. Also, +must be a single line. + + +=item * Expressions::RequireFatCommasInHashConstructors + +=item * ErrorHandling::RequireLocalizingGlobalErrorVariablesInDESTROY + +Prevent C<$.>, C<$@>, C<$!>, C<$^E>, and C<$?> from being cleared unexpectedly +by DESTROY methods. + + package Foo; + + sub DESTROY { + die "Died in Foo::DESTROY()"; + } + + package main; + + eval { + my $foo = Foo->new(); + + die "Died in eval." + } + print $@; # "Died in Foo::DESTROY()", not "Died in eval.". + +See L and +L. + + +=item * Expressions::ProhibitDecimalWithBitwiseOperator + +=item * Expressions::ProhibitStringsWithBitwiseOperator + + +=item * InputOutput::ProhibitMagicDiamond + +Steal the idea from L. + + +=item * NamingConventions::RequireArrayAndHashReferenceVariablesEndWith_Ref + + +=item * Programs::RequireShebang + +Anything that is a program should have a shebang line. This includes .t +files. + + +=item * Modules::RequirePackageDeclarationAsFirstStatementInModule + +See L. +Ouch. + + +=item * BuiltinFunctions::RequireConstantSprintfFormat + + +=item * BuiltinFunctions::RequireConstantUnpackFormat + +L + + +=item * Miscellanea::ProhibitObnoxiousComments + +Forbid excessive hash marks e.g. "#### This is a loud comment ####". +Make the obnoxious pattern configurable + + +=item * ValuesAndExpressions::RequireNotOperator + +Require the use of "not" instead of "!", except when this would contradict +ProhibitMixedBooleanOperators. This may be better suited for +Perl::Critic::More. + + +=item * ValuesAndExpressions::ProhibitUnusedReadonlyConstants + +We'll only be able to look at lexicals. For similar reasons, we can't do +anything about L. + + +=item * Modules::RequireExplicitImporting + +Require every C statement to have an explicit import list. You could +still get around this by calling C directly. + + +=item * Modules::ForbidImporting + +Require every C to have an explicitly empty import list. This is for +folks who like to see fully-qualified function names. Should probably provide +a list of exempt modules (like FindBin); + + +=item * ControlStructures::ProhibitIncludeViaDo + +Forbid C. Not sure about this policy name. + + +=item * Variables::ProhibitUseVars + +Disallow C and require C instead. This +contradicts Miscellanea::Prohibit5006isms. Maybe verify C before +applying this policy. Low severity. + + +=item * VariablesAndExpressions::ProhibitQuotedHashKeys + +Forbid quotes around hash keys, unless they are really needed. This is +against what Damian says. Suggested by Adam Kennedy. Low severity. + + +=item * CodeLayout::ProhibitFunctionalNew + +Good: C<< Foo::Bar->new >>, Bad: C<< new Foo::Bar >> + + +=item * RegularExpressions::ProhibitSWSWSW + +Require C instead of C. From MJD's Red Flags. + + +=item * Documentation::RequireSynopsis + + +=item * Documentation::RequireLicense + +These are simplified versions of Documentation::RequirePodSections. + + +=item * Documentation::RequireValidSynopsis + +The Synopsis section must be all indented and must be syntactically valid Perl +(as validated by PPI). + + +=item * Documentation::ProhibitEmptySections + +Any C<=headN> and C<=over> sections must not be empty. This helps catch +boilerplate (although Test::Pod should catch empty C<=over> blocks). + +On the other hand, C<=item ...> sections can be empty, since the item label is +content. + + +=item * Miscellaneous::ProhibitBoilerplate + +Complain about copy-and-paste code or docs from h2xs, Module::Starter::*, etc. + +Here's a non-PPI implementation: +L + + +=item * NamingConventions::ProhibitPackagesSubroutinesAndBarewordFileHandlesWithTheSameNames + +See +L. + + +=item * BuiltinFunctions::ProhibitExtraneousScalarCall + +Recommend that C be rewritten as C. + + +=item * RegularExpressions::ProhibitMixedDelimiters + +Ban s{foo}(bar) + + +=item * RegularExpressions::ProhibitScalarAsRegexp + +Ban naked strings as regexps, like: + + print 1 if $str =~ $regexp; + +Instead, it should be: + + print 1 if $str =~ m/$regexp/; + +or + + print 1 if $str =~ m/$regexp/xms; + + +=item * ValuesAndExpressions::RequireInterpolatedStringyEval + +Ensure that the argument to a stringy eval is not a constant string. That's +just wasteful. Real world examples include: + + eval 'use Optional::Module'; + +which is better written as + + eval { require Optional::Module; Optional::Module->import }; + +for performance gains and compile-time syntax checking. + +Question: This is very similar to BuiltinFunctions::ProhibitStringyEval. What +does the new policy buy us? Could we get the same thing with an option on the +latter to forbid un-interpolated includes even if C is turned +on? + + +=item * RegularExpressions::ProhibitUnnecessaryEscapes + +Complain if user puts a backslash escape in front of non-special characters. +For example: + + m/\!/; + +Make exceptions for C<\">, C<\'> and C<\`> since those are often inserted to +workaround bugs in syntax highlighting. + +Note that this is different inside character classes, where only C<^>, C<]> +and C<-> need to be escaped, I think. Caret only needs to be escaped at the +beginning, and dash does NOT need to be escaped at the beginning and end. See +L. + + +=item * Steal ideas from L. + +Can someone expand this entry, please? + +=item * ControlStructures::ProhibitAssigmentInConditional + +=item * ValuesAndExpressions::RequireConstantBeforeEquals + +=item * ValuesAndExpressions::RequireConstantBeforeOperator + +L + +Just about everyone has been bitten by C when they meant +to use C<==>. A safer style is C<10 == $x> because omitting the second C<=> +yields a noisy compile-time failure instead of silent runtime error. + +ProhibitAssigmentInConditional complains if the condition of a while, until, +if or unless is solely an assignment. If it's anything more complex (like +C or C), there is no warning. + +RequireConstantBeforeEquals complains if the left side of an C<==> is a +variable while the right side is a constant. + +RequireConstantBeforeOperator complains if the left side of any comparison +operator (C<==>, C, C<<>, etc) is a variable while the right side is a +constant. + + +=item * InputOutput::ProhibitUTF8IOLayer + +http://www.perlfoundation.org/perl5/index.cgi?the_utf8_perlio_layer + + +=item * BuiltinFunctions::ProhibitExit(?:InModules)? + +Forbid C in files that lack a shebang. Inspired by +L and an analogous checker in +FindBugs. + + +=item * Modules::ProhibitRedundantLoading + +Don't allow a package to "use" the same module more than once, unless +there is a "no " between them. + +See https://rt.cpan.org/Ticket/Display.html?id=38074. + + +=item * ErrorHandling::RequireLocalizingEVAL_ERRORInDESTROY + +The opposite side of ErrorHandling::RequireCheckingReturnValueOfEval. + + +=back + + +=head1 REFACTORINGS and ENHANCEMENTS + +=over + +=item * Reformat all the POD to use 78 columns instead of 70. + +This thing of having different widths for the documentation and the code is +rediculous. Don't do this until after the next non-dev release. Elliot is +considering doing a special release only including this change so that the +search.cpan.org diff tool doesn't entirely break. + + +=item * Eliminate use of IO::String + +I'm pretty sure that opening references to scalars is in 5.6, so IO::String +isn't necessary. + + +=item * Give L a proper API. + +Now that we've got the guts of L in there, we should make the +it available to users. + + +=item * Create constants for the PPI location array elements. + +=item * Some means of detecting "runaway" C<##no critic> + +Elliot was talking to a couple of users at ETech and one of their major +concerns was that they were using C<##no critic> and forgetting to do a +C<##use critic> after the problematic section. Perhaps an option to +F to scan for such things is in order. + + +=item * Change API to use named parameters + +Most of the methods on the public classes use named parameters for passing +arguments. I'd like to extend that pattern to include all object-methods. +Static methods can still use positional parameters. + + +=item * Enhance P::C::critique() to accept files, directories, or code strings + +Just like F does now. + + +=item * Add C<-cache> flag to F + +If enabled, this turns on L: + + require PPI::Cache; + my $cache_path = "/tmp/test-perl-critic-cache-$ENV{USER}"; + mkdir $cache_path, oct 700 if (! -d $cache_path); + PPI::Cache->import(path => $cache_path); + +This cache directory should perhaps include the PPI version number! At least +until PPI incorporates its own version number in the cache. + +(see F for a more robust implementation) + + +=item * Use hash-lookup instead of C function. + +In several places, Perl::Critic uses C to see if a +string is a member of a list. Instead, I suggest using a named subroutine +that does a hash-lookup like this: + + my %logical_ops = hashify( qw( ! || && ||= &&= and or not ) ); + sub is_logical_op { return exists $logical_ops{ $_[0] }; } + +Question: Why? + +Answer: Readability, mostly. Performance, maybe. + + +=back + +=head1 PPI BUGS + +We're waiting on the following bugs to get fixed in a CPAN release of PPI: + + +=over + +=item PPI::Token::descendant_of() + +Exists in svn. Replace _descendant_of() in RequireCheckingReturnValueOfEval +with that, once it is released, because it's faster and native. + + +=item Newlines + +PPI does not preserve newlines. That makes +CodeLayout::RequireConsistentNewlines impossible to implement under PPI. For +now, it's implemented by pulling the source out of the file and skipping PPI. + +It's unlikely that PPI will support mixed newlines anytime soon. + + +=item Operators + +ValuesAndExpressions::ProhibitMismatchedOperators has two workarounds for PPI +bugs with parsing operators. Many of these bugs have been fixed in PPI, so it +would be good to check if those workarounds are still needed. + + +=item Regexp methods + +Not strictly a bug -- the PPI Regexp classes have a dearth of accessor methods +as of v1.118, meaning that we have to do messy digging into internals. I +wrote Perl::Critic:Utils::PPIRegexp to encapsulate this messiness, but it +would be nicer to have an official interface in PPI. + + +=item QuoteLike::Words in the place of a ForLoop + +PPI incorrectly parses C< {}>>. + + +=back + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=pod expandtab shiftround : diff --git a/bin/perlcritic b/bin/perlcritic new file mode 100644 index 0000000..e96ca78 --- /dev/null +++ b/bin/perlcritic @@ -0,0 +1,1011 @@ +#!/usr/bin/perl + +package main; + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::Command qw< run >; + +#----------------------------------------------------------------------------- + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- +# Begin program. Don't run when loaded as a library + +# This %ENV check is to allow perlcritic to function when bundled under PAR, +# which invokes this program not as the top stack frame. -- rjbs, 2008-08-11 +exit run() if not caller or $ENV{PAR_0}; + +#----------------------------------------------------------------------------- +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords DGR INI-style vim-fu minibuffer -noprofile API +-profileproto -profile-proto ben Jore formatter Peshak pbp Komodo +screenshots tty emacs gVIM plugin Perlish templating ActivePerl +ActiveState Twitter + +=head1 NAME + +C - Command-line interface to critique Perl source. + + +=head1 SYNOPSIS + + perlcritic [-12345 | --brutal | --cruel | --harsh | --stern | --gentle] + [--severity number | name] [{-p | --profile} file | --noprofile] + [--top [ number ]] [--theme expression] [--include pattern] + [--exclude pattern] [{-s | --single-policy} pattern] + [--only | --noonly] [--profile-strictness {warn|fatal|quiet}] + [--force | --noforce] [--statistics] [--statistics-only] + [--count | -C] [--verbose {number | format}] [--allow-unsafe] + [--color | --nocolor] [--pager pager] [--quiet] + [--color-severity-highest color_specification] + [--color-severity-high color_specification] + [--color-severity-medium color_specification] + [--color-severity-low color_specification] + [--color-severity-lowest color_specification] + [--files-with-violations | -l] + [--files-without-violations | -L] + [--program-extensions file_name_extension] + {FILE | DIRECTORY | STDIN} + + perlcritic --profile-proto + + perlcritic { --list | --list-enabled | --list-themes | --doc pattern [...] } + + perlcritic { --help | --options | --man | --version } + + +=head1 DESCRIPTION + +C is a Perl source code analyzer. It is the executable front-end +to the L engine, which attempts to identify awkward, hard to +read, error-prone, or unconventional constructs in your code. Most of the +rules are based on Damian Conway's book B. However, +C is B limited to enforcing PBP, and it will even support +rules that contradict Conway. All rules can easily be configured or disabled +to your liking. + +This documentation only covers how to drive this command. For all other +information, such as API reference and alternative interfaces, please see the +documentation for L itself. + + +=head1 USAGE EXAMPLES + +Before getting into all the gory details, here are some basic usage +examples to help get you started. + + # Report only most severe violations (severity = 5) + perlcritic YourModule.pm + + # Same as above, but read input from STDIN + perlcritic + + # Recursively process all Perl files beneath directory + perlcritic /some/directory + + # Report slightly less severe violations too (severity >= 4) + perlcritic -4 YourModule.pm + + # Same as above, but using named severity level + perlcritic --stern YourModule.pm + + # Report all violations, regardless of severity (severity >= 1) + perlcritic -1 YourModule.pm + + # Same as above, but using named severity level + perlcritic --brutal YourModule.pm + + # Report only violations of things from "Perl Best Practices" + perlcritic --theme pbp YourModule.pm + + # Report top 20 most severe violations (severity >= 1) + perlcritic --top YourModule.pm + + # Report additional violations of Policies that match m/variables/xms + perlcritic --include variables YourModule.pm + + # Use defaults from somewhere other than ~/.perlcriticrc + perlcritic --profile project/specific/perlcriticrc YourModule.pm + + +=head1 ARGUMENTS + +The arguments are paths to the files you wish to analyze. You may specify +multiple files. If an argument is a directory, C will analyze all +Perl files below the directory. If no arguments are specified, then input is +read from STDIN. + + +=head1 OPTIONS + +Option names can be abbreviated to uniqueness and can be stated with singe or +double dashes, and option values can be separated from the option name by a +space or '=' (as with L). Option names are also case-sensitive. + +=over + +=item C<--profile FILE> or C<-p FILE> + +Directs C to use a profile named by FILE rather than looking for +the default F<.perlcriticrc> file in the current directory or your home +directory. See L for more information. + +=item C<--noprofile> + +Directs C not to load any configuration file, thus reverting to +the default configuration for all Policies. + +=item C<--severity N> + +Directs C to only apply Policies with a severity greater than +C. Severity values are integers ranging from 1 (least severe) to 5 (most +severe). The default is 5. For a given C<--profile>, decreasing the +C<--severity> will usually produce more violations. You can set the default +value for this option in your F<.perlcriticrc> file. You can also redefine +the C for any Policy in your F<.perlcriticrc> file. See +L<"CONFIGURATION"> for more information. + +=item C<-5 | -4 | -3 | -2 | -1> + +These are numeric shortcuts for setting the C<--severity> option. For +example, C<"-4"> is equivalent to C<"--severity 4">. If multiple shortcuts +are specified, then the most restrictive one wins. If an explicit +C<--severity> option is also given, then all shortcut options are silently +ignored. NOTE: Be careful not to put one of the number severity shortcut +options immediately after the C<--top> flag or C will interpret it +as the number of violations to report. + +=item C<--severity NAME> + +If it is difficult for you to remember whether severity "5" is the most or +least restrictive level, then you can use one of these named values: + + SEVERITY NAME ...is equivalent to... SEVERITY NUMBER + -------------------------------------------------------- + --severity gentle --severity 5 + --severity stern --severity 4 + --severity harsh --severity 3 + --severity cruel --severity 2 + --severity brutal --severity 1 + +=item C<--gentle | --stern | --harsh | --cruel | --brutal> + +These are named shortcuts for setting the C<--severity> option. For example, +C<"--cruel"> is equivalent to C<"--severity 2">. If multiple shortcuts are +specified, then the most restrictive one wins. If an explicit C<--severity> +option is also given, then all shortcut options are silently ignored. + +=item C<--theme RULE> + +Directs C to apply only Policies with themes that satisfy the +C. Themes are arbitrary names for groups of related policies. You can +combine theme names with boolean operators to create an arbitrarily complex +C. For example, the following would apply only Policies that have a +'bugs' AND 'pbp' theme: + + $> perlcritic --theme='bugs && pbp' MyModule.pm + +Unless the C<--severity> option is explicitly given, setting C<--theme> +silently causes the C<--severity> to be set to 1. You can set the default +value for this option in your F<.perlcriticrc> file. See +L for more information about themes. + +=item C<--include PATTERN> + +Directs C to apply additional Policies that match the regex +C. Use this option to temporarily override your profile and/or +the severity settings at the command-line. For example: + + perlcritic --include=layout my_file.pl + +This would cause C to apply all the C policies even +if they have a severity level that is less than the default level of 5, or +have been disabled in your F<.perlcriticrc> file. You can specify multiple +C<--include> options and you can use it in conjunction with the C<--exclude> +option. Note that C<--exclude> takes precedence over C<--include> when a +Policy matches both patterns. You can set the default value for this option +in your F<.perlcriticrc> file. + +=item C<--exclude PATTERN> + +Directs C to not apply any Policy that matches the regex +C. Use this option to temporarily override your profile and/or +the severity settings at the command-line. For example: + + perlcritic --exclude=strict my_file.pl + +This would cause C to not apply the C and +C Policies even though they have the highest severity level. +You can specify multiple C<--exclude> options and you can use it in +conjunction with the C<--include> option. Note that C<--exclude> takes +precedence over C<--include> when a Policy matches both patterns. You can set +the default value for this option in your F<.perlcriticrc> file. + +=item C<--single-policy PATTERN> or C<-s PATTERN> + +Directs C to apply just one Policy module matching the regex +C, and exclude all other Policies. This option has precedence +over the C<--severity>, C<--theme>, C<--include>, C<--exclude>, and C<--only> +options. For example: + + perlcritic --single-policy=nowarnings my_file.pl + +This would cause C to apply just the C Policy, +regardless of the severity level setting. No other Policies would be applied. + +This is equivalent to what one might intend by... + + perlcritic --exclude=. --include=nowarnings my_file.pl + +... but this won't work because the C<--exclude> option overrides the +C<--include> option. + +The equivalent of this option can be accomplished by creating a custom profile +containing only the desired policy and then running... + + perlcritic --profile=customprofile --only my_file.pl + +=item C<--top [ N ]> + +Directs C to report only the top C Policy violations in each +file, ranked by their severity. If C is not specified, it defaults to 20. +If the C<--severity> option (or one of the shortcuts) is not explicitly given, +the C<--top> option implies that the minimum severity level is "1" (i.e. +"brutal"). Users can redefine the severity for any Policy in their +F<.perlcriticrc> file. See L<"CONFIGURATION"> for more information. You can +set the default value for this option in your F<.perlcriticrc> file. NOTE: Be +careful not to put one of the severity shortcut options immediately after the +C<--top> flag or C will interpret it as the number of violations +to report. + +=item C<--force> + +Directs C to ignore the magical C<"## no critic"> annotations in +the source code. See L<"BENDING THE RULES"> for more information. You can set +the default value for this option in your F<.perlcriticrc> file. + +=item C<--statistics> + +Causes several statistics about the code being scanned and the violations +found to be reported after any other output. + +=item C<--statistics-only> + +Like the C<--statistics> option, but suppresses normal output and only shows +the statistics. + +=item C<--verbose N | FORMAT> + +Sets the verbosity level or format for reporting violations. If given a +number (C), C reports violations using one of the predefined +formats described below. If given a string (C), it is interpreted to +be an actual format specification. If the C<--verbose> option is not +specified, it defaults to either 4 or 5, depending on whether multiple files +were given as arguments to C. You can set the default value for +this option in your F<.perlcriticrc> file. + + Verbosity Format Specification + ----------- ------------------------------------------------------- + 1 "%f:%l:%c:%m\n", + 2 "%f: (%l:%c) %m\n", + 3 "%m at %f line %l\n", + 4 "%m at line %l, column %c. %e. (Severity: %s)\n", + 5 "%f: %m at line %l, column %c. %e. (Severity: %s)\n", + 6 "%m at line %l, near '%r'. (Severity: %s)\n", + 7 "%f: %m at line %l near '%r'. (Severity: %s)\n", + 8 "[%p] %m at line %l, column %c. (Severity: %s)\n", + 9 "[%p] %m at line %l, near '%r'. (Severity: %s)\n", + 10 "%m at line %l, column %c.\n %p (Severity: %s)\n%d\n", + 11 "%m at line %l, near '%r'.\n %p (Severity: %s)\n%d\n" + +Formats are a combination of literal and escape characters similar to the way +C works. See L for a full explanation +of the formatting capabilities. Valid escape characters are: + + Escape Meaning + ------- ------------------------------------------------------------ + %c Column number where the violation occurred + %d Full diagnostic discussion of the violation + %e Explanation of violation or page numbers in PBP + %F Just the name of the file where the violation occurred. + %f Path to the file where the violation occurred. + %l Line number where the violation occurred + %m Brief description of the violation + %P Full name of the Policy module that created the violation + %p Name of the Policy without the Perl::Critic::Policy:: prefix + %r The string of source code that caused the violation + %C The class of the PPI::Element that caused the violation + %s The severity level of the violation + +The purpose of these formats is to provide some compatibility with text +editors that have an interface for parsing certain kinds of input. See +L<"EDITOR INTEGRATION"> for more information about that. + +=item C<--list> + +Displays a condensed listing of all the L modules that +are found on this machine. This option lists I Policies, regardless of +your F<.perlcriticrc> or command line options. For each Policy, the name, +default severity and default themes are shown. + +=item C<--list-enabled> + +Displays a condensed listing of all the L modules that +I be enforced, if you were actually going to critique a file with this +command. This is useful when you've constructed a complicated command or +modified your F<.perlcriticrc> file and you want to see exactly which Policies +are going to be enforced (or not enforced, as the case may be). For each +Policy, the name, default severity and default themes are shown. + +=item C<--list-themes> + +Displays a list of all the themes of the L modules that +are found on this machine. + +=item C<--profile-proto> + +Displays an expanded listing of all the L modules that +are found on this machine. For each Policy, the name, default severity and +default themes are shown, as well as the name of any additional parameters +that the Policy supports. The format is suitable as a prototype for your +F<.perlcriticrc> file. + +=item C<--only> + +Directs perlcritic to apply only Policies that are explicitly mentioned in +your F<.perlcriticrc> file. This is useful if you want to use just a small +subset of Policies without having to disable all the others. You can set the +default value for this option in your F<.perlcriticrc> file. + +=item C<--profile-strictness {warn|fatal|quiet}> + +Directs perlcritic how to treat certain recoverable problems found in a +F<.perlcriticrc> or file specified via the C<--profile> option. Valid values +are C (the default), C, and C. For example, perlcritic +normally only warns about profiles referring to non-existent Policies, but +this option can make this situation fatal. You can set the default value for +this option in your F<.perlcriticrc> file. + +=item C<--count> + +=item C<-C> + +Display only the number of violations for each file. Use this feature to get +a quick handle on where a large pile of code might need the most attention. + +=item C<--color> + +=item C<--colour> + +This option is on when outputting to a tty. When set, Severity 5 and 4 are +colored red and yellow, respectively. Colorization only happens if +L is installed. For Windows environments, +L must also be installed. +Negate this switch to disable color. You can set the default value for this +option in your F<.perlcriticrc> file. + +=item C<--pager PAGER_COMMAND_STRING> + +If set, perlcritic will pipe it's output to the given PAGER_COMMAND_STRING. +You can set the default value for this option in your F<.perlcriticrc> file. + +Setting a pager turns off color by default. You will have to turn color on +explicitly. If you want color, you'll probably also want to tell your pager +to display raw characters. For C and C, use the -R switch. + +=item C<--color-severity-highest COLOR_SPECIFICATION> + +Specifies the color to be used for highest severity violations, as a +Term::ANSIColor color specification. Can also be specified as C<--colour- +severity-highest>, C<--color-severity-5>, or C<--colour-severity-5>. + +=item C<--color-severity-high COLOR_SPECIFICATION> + +Specifies the color to be used for high severity violations, as a +Term::ANSIColor color specification. Can also be specified as C<--colour- +severity-high>, C<--color-severity-4>, or C<--colour-severity-4>. + +=item C<--color-severity-medium COLOR_SPECIFICATION> + +Specifies the color to be used for medium severity violations, as a +Term::ANSIColor color specification. Can also be specified as C<--colour- +severity-medium>, C<--color-severity-3>, or C<--colour-severity-3>. + +=item C<--color-severity-low COLOR_SPECIFICATION> + +Specifies the color to be used for low severity violations, as a +Term::ANSIColor color specification. Can also be specified as C<--colour- +severity-low>, C<--color-severity-2>, or C<--colour-severity-2>. + +=item C<--color-severity-lowest COLOR_SPECIFICATION> + +Specifies the color to be used for lowest severity violations, as a +Term::ANSIColor color specification. Can also be specified as C<--colour- +severity-lowest>, C<--color-severity-1>, or C<--colour-severity-1>. + +=item C<--files-with-violations> + +Display only the names of files with violations. Use this feature with +--single-policy to find files that contain violations of a given policy. Can +also be specified as C<--l>. + +=item C<--files-without-violations> + +Display only the names of files without violations. Use this feature with +--single-policy to find files that do not contain violations of a given +policy. Can also be specified as C<--L>. + +=item C<--program-extensions file_name_extension> + +Tell C to treat files whose names end in the given file name +extension as programs, not as modules. If a leading '.' is desired it must be +explicitly specified, e.g. + + --program-extensions .pl + +The matching is case-sensitive, and the option may be specified as many times +as desired, e.g. + + --program-extensions .pl --program-extensions .cgi + +The above can also be done by quoting the file name extensions: + + --program-extensions '.pl .cgi' + +Files whose name ends in '.PL' will always be considered programs. + +=item C<--doc PATTERN> + +Displays the perldoc for all L modules that match +C. Since Policy modules tend to have rather long names, this +just provides a more convenient way to say something like: C<"perldoc +Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseH +eredocTerminator"> at the command prompt. + +=item C<--allow-unsafe> + +This option directs C to allow the use of Policies that have been +marked as "unsafe". Unsafe Policies may result in risky operations by +compiling and executing the code they analyze. All the Policies that ship in +the core L distribution are safe. However, third- party +Policies, such as those in the L distribution are not +safe. Note that "safety" is honorary -- if a Policy author marks a Policy as +safe, it is not a guarantee that it won't do nasty things. B. + +=item C<--quiet> + +Suppress the "source OK" message when no violations are found. + +=item C<--help> + +=item C<-?> + +=item C<-H> + +Displays a brief summary of options and exits. + +=item C<--options> + +Displays the descriptions of the options and exits. While this output is +long, it it nowhere near the length of the output of C<--man>. + +=item C<--man> + +Displays the complete C manual and exits. + +=item C<--version> + +=item C<-V> + +Displays the version number of C and exits. + +=back + +=head1 CONFIGURATION + +Most of the settings for Perl::Critic and each of the Policy modules can be +controlled by a configuration file. The default configuration file is called +F<.perlcriticrc>. C will look for this file in the current +directory first, and then in your home directory. Alternatively, you can set +the C environment variable to explicitly point to a different file +in another location. If none of these files exist, and the C<--profile> +option is not given on the command-line, then all Policies will be loaded with +their default configuration. + +The format of the configuration file is a series of INI-style blocks that +contain key-value pairs separated by "=". Comments should start with "#" and +can be placed on a separate line or after the name-value pairs if you desire. + +Default settings for perlcritic itself can be set B For example, putting any or all of these at the top of your +F<.perlcriticrc> file will set the default value for the corresponding +command-line argument. + + severity = 3 #Integer or named level + only = 1 #Zero or One + force = 0 #Zero or One + verbose = 4 #Integer or format spec + top = 50 #A positive integer + theme = (pbp + security) * bugs #A theme expression + include = NamingConventions ClassHierarchies #Space-delimited list + exclude = Variables Modules::RequirePackage #Space-delimited list + +The remainder of the configuration file is a series of blocks like this: + + [Perl::Critic::Policy::Category::PolicyName] + severity = 1 + set_themes = foo bar + add_themes = baz + arg1 = value1 + arg2 = value2 + +C is the full name of a module +that implements the policy. The Policy modules distributed with Perl::Critic +have been grouped into categories according to the table of contents in Damian +Conway's book B. For brevity, you can omit the +C<'Perl::Critic::Policy'> part of the module name. + +C is the level of importance you wish to assign to the Policy. All +Policy modules are defined with a default severity value ranging from 1 (least +severe) to 5 (most severe). However, you may disagree with the default +severity and choose to give it a higher or lower severity, based on your own +coding philosophy. You can set the C to an integer from 1 to 5, or +use one of the equivalent names: + + SEVERITY NAME ...is equivalent to... SEVERITY NUMBER + ---------------------------------------------------- + gentle 5 + stern 4 + harsh 3 + cruel 2 + brutal 1 + +C sets the theme for the Policy and overrides its default theme. +The argument is a string of one or more whitespace-delimited alphanumeric +words. Themes are case-insensitive. See L<"POLICY THEMES"> for more +information. + +C appends to the default themes for this Policy. The argument is +a string of one or more whitespace-delimited words. Themes are case- +insensitive. See L<"POLICY THEMES"> for more information. + +The remaining key-value pairs are configuration parameters that will be passed +into the constructor of that Policy. The constructors for most Policy modules +do not support arguments, and those that do should have reasonable defaults. +See the documentation on the appropriate Policy module for more details. + +Instead of redefining the severity for a given Policy, you can completely +disable a Policy by prepending a '-' to the name of the module in your +configuration file. In this manner, the Policy will never be loaded, +regardless of the C<--severity> given on the command line. + +A simple configuration might look like this: + + #-------------------------------------------------------------- + # I think these are really important, so always load them + + [TestingAndDebugging::RequireUseStrict] + severity = 5 + + [TestingAndDebugging::RequireUseWarnings] + severity = 5 + + #-------------------------------------------------------------- + # I think these are less important, so only load when asked + + [Variables::ProhibitPackageVars] + severity = 2 + + [ControlStructures::ProhibitPostfixControls] + allow = if unless # My custom configuration + severity = cruel # Same as "severity = 2" + + #-------------------------------------------------------------- + # Give these policies a custom theme. I can activate just + # these policies by saying "perlcritic --theme 'larry || curly'" + + [Modules::RequireFilenameMatchesPackage] + add_themes = larry + + [TestingAndDebugging::RequireTestLabels] + add_themes = curly moe + + #-------------------------------------------------------------- + # I do not agree with these at all, so never load them + + [-NamingConventions::Capitalization] + [-ValuesAndExpressions::ProhibitMagicNumbers] + + #-------------------------------------------------------------- + # For all other Policies, I accept the default severity, + # so no additional configuration is required for them. + +Note that all policies included with the Perl::Critic distribution that have +integer parameters accept underscores ("_") in their values, as with Perl +numeric literals. For example, + + [ValuesAndExpressions::RequireNumberSeparators] + min_value = 1_000 + +For additional configuration examples, see the F file that is +included in this F directory of this distribution. + +Damian Conway's own Perl::Critic configuration is also included in this +distribution as F. + + +=head1 THE POLICIES + +A large number of Policy modules are distributed with Perl::Critic. They are +described briefly in the companion document L and +in more detail in the individual modules themselves. Say C<"perlcritic --doc +PATTERN"> to see the perldoc for all Policy modules that match the regex +C + +There are a number of distributions of additional policies on CPAN. If +L doesn't contain a policy that you want, some one may have +already written it. See L for a list of some of +these distributions. + + +=head1 POLICY THEMES + +Each Policy is defined with one or more "themes". Themes can be used to +create arbitrary groups of Policies. They are intended to provide an +alternative mechanism for selecting your preferred set of Policies. For +example, you may wish disable a certain set of Policies when analyzing test +programs. Conversely, you may wish to enable only a specific subset of +Policies when analyzing modules. + +The Policies that ship with Perl::Critic are have been divided into the +following themes. This is just our attempt to provide some basic logical +groupings. You are free to invent new themes that suit your needs. + + THEME DESCRIPTION + ------------------------------------------------------------------------ + core All policies that ship with Perl::Critic + pbp Policies that come directly from "Perl Best Practices" + bugs Policies that that prevent or reveal bugs + certrec Policies that CERT recommends + certrule Policies that CERT considers rules + maintenance Policies that affect the long-term health of the code + cosmetic Policies that only have a superficial effect + complexity Policies that specificaly relate to code complexity + security Policies that relate to security issues + tests Policies that are specific to test programs + +Say C<"perlcritic --list"> to get a listing of all available policies and the +themes that are associated with each one. You can also change the theme for +any Policy in your F<.perlcriticrc> file. See the L<"CONFIGURATION"> section +for more information about that. + +Using the C<--theme> command-line option, you can create an arbitrarily +complex rule that determines which Policies to apply. Precedence is the same +as regular Perl code, and you can use parentheses to enforce precedence as +well. Supported operators are: + + Operator Altertative Example + ----------------------------------------------------------------- + && and 'pbp && core' + || or 'pbp || (bugs && security)' + ! not 'pbp && ! (portability || complexity)' + +Theme names are case-insensitive. If the C<--theme> is set to an empty +string, then it evaluates as true all Policies. + + +=head1 BENDING THE RULES + +Perl::Critic takes a hard-line approach to your code: either you comply or you +don't. In the real world, it is not always practical (or even possible) to +fully comply with coding standards. In such cases, it is wise to show that +you are knowingly violating the standards and that you have a Damn Good Reason +(DGR) for doing so. + +To help with those situations, you can direct Perl::Critic to ignore certain +lines or blocks of code by using annotations: + + require 'LegacyLibaray1.pl'; ## no critic + require 'LegacyLibrary2.pl'; ## no critic + + for my $element (@list) { + + ## no critic + + $foo = ""; #Violates 'ProhibitEmptyQuotes' + $barf = bar() if $foo; #Violates 'ProhibitPostfixControls' + #Some more evil code... + + ## use critic + + #Some good code... + do_something($_); + } + +The C<"## no critic"> annotations direct Perl::Critic to ignore the remaining +lines of code until a C<"## use critic"> annotation is found. If the C<"## no +critic"> annotation is on the same line as a code statement, then only that +line of code is overlooked. To direct perlcritic to ignore the C<"## no +critic"> annotations, use the C<--force> option. + +A bare C<"## no critic"> annotation disables all the active Policies. If you +wish to disable only specific Policies, add a list of Policy names as +arguments just as you would for the C<"no strict"> or C<"no warnings"> pragma. +For example, this would disable the C and +C policies until the end of the block or until the +next C<"## use critic"> annotation (whichever comes first): + + ## no critic (EmptyQuotes, PostfixControls); + + # Now exempt from ValuesAndExpressions::ProhibitEmptyQuotes + $foo = ""; + + # Now exempt ControlStructures::ProhibitPostfixControls + $barf = bar() if $foo; + + # Still subject to ValuesAndExpression::RequireNumberSeparators + $long_int = 10000000000; + +Since the Policy names are matched against the C<"## no critic"> arguments as +regular expressions, you can abbreviate the Policy names or disable an entire +family of Policies in one shot like this: + + ## no critic (NamingConventions) + + # Now exempt from NamingConventions::Capitalization + my $camelHumpVar = 'foo'; + + # Now exempt from NamingConventions::Capitalization + sub camelHumpSub {} + +The argument list must be enclosed in parentheses and must contain one or more +comma-separated barewords (i.e. don't use quotes). The C<"## no critic"> +annotations can be nested, and Policies named by an inner annotation will be +disabled along with those already disabled an outer annotation. + +Some Policies like C apply to an entire +block of code. In those cases, C<"## no critic"> must appear on the line +where the violation is reported. For example: + + sub complicated_function { ## no critic (ProhibitExcessComplexity) + # Your code here... + } + +Some Policies like C apply to the entire +document, in which case violations are reported at line 1. But if the file +requires a shebang line, it is impossible to put C<"## no critic"> on the +first line of the file. This is a known limitation and it will be addressed +in a future release. As a workaround, you can disable the affected policies +at the command-line or in your F<.perlcriticrc> file. But beware that this +will affect the analysis of B files. + +Use this feature wisely. C<"## no critic"> should be used in the smallest +possible scope, or only on individual lines of code. And you should always be +as specific as possible about which policies you want to disable (i.e. never +use a bare C<"## no critic">). If Perl::Critic complains about your code, try +and find a compliant solution before resorting to this feature. + + +=head1 EDITOR INTEGRATION + +For ease-of-use, C can be integrated with your favorite text +editor. The output-formatting capabilities of C are specifically +intended for use with the "grep" or "compile" modes available in editors like +C and C. In these modes, you can run an arbitrary command and the +editor will parse the output into an interactive buffer that you can click on +and jump to the relevant line of code. + +The Perl::Critic team thanks everyone who has helped integrate Perl-Critic +with their favorite editor. Your contributions in particular have made Perl- +Critic a convenient and user-friendly tool for Perl developers of all stripes. +We sincerely appreciate your hard work. + + +=head2 EMACS + +Joshua ben Jore has authored a minor-mode for emacs that allows you to run +perlcritic on the current region or buffer. You can run it on demand, or +configure it to run automatically when you save the buffer. The output appears +in a hot-linked compiler buffer. The code and installation instructions can +be found in the F directory inside this distribution. + + +=head2 VIM + +Scott Peshak has published F, which is available at +L. + + +=head2 gVIM + +Fritz Mehner recently added support for C to his fantastic gVIM +plugin. In addition to providing a very Perlish IDE, Fritz's plugin enables +one-click access to C and many other very useful utilities. And +all is seamlessly integrated into the editor. See +L for complete details. + + +=head2 EPIC + +EPIC is an open source Perl IDE based on the Eclipse platform. Features +include syntax highlighting, on-the-fly syntax check, content assist, code +completion, perldoc support, source formatting with L, +code templates, a regular expression editing tool, and integration with the +Perl debugger. Recent versions of EPIC also have built-in support for +Perl::Critic. At least one Perl::Critic contributor swears by EPIC. Go to +L for more information about EPIC. + +=head2 BBEdit + +Josh Clark has produced an excellent Perl-Critic plugin for BBEdit. See +L for +download, installation, and usage instructions. Apple users rejoice! + + +=head2 Komodo + +Komodo is a proprietary IDE for Perl and several other dynamic languages. +Starting in version 5.1.1, Komodo has built-in support for Perl-Critic, if you +have the L and L modules installed. Free trial +copies of Komodo can be obtained from the ActiveState website at +L. + + +=head2 ActivePerl + +ActivePerl includes a very slick graphical interface for configuring and +running Perl-Critic called C. A free community edition of +ActivePerl can be obtained from the ActiveState website at +L. + + +=head1 EXIT STATUS + +If C has any errors itself, exits with status == 1. If there are +no errors, but C finds Policy violations in your source code, +exits with status == 2. If there were no errors and no violations were found, +exits with status == 0. + + +=head1 THE L PHILOSOPHY + +=over + +Coding standards are deeply personal and highly subjective. The goal of +Perl::Critic is to help you write code that conforms with a set of best +practices. Our primary goal is not to dictate what those practices are, but +rather, to implement the practices discovered by others. Ultimately, you make +the rules -- Perl::Critic is merely a tool for encouraging consistency. If +there is a policy that you think is important or that we have overlooked, we +would be very grateful for contributions, or you can simply load your own +private set of policies into Perl::Critic. + +=back + + +=head1 EXTENDING THE CRITIC + +The modular design of Perl::Critic is intended to facilitate the addition of +new Policies. You'll need to have some understanding of L, but most +Policy modules are pretty straightforward and only require about 20 lines of +code. Please see the L file included in this +distribution for a step-by-step demonstration of how to create new Policy +modules. + +If you develop any new Policy modules, feel free to send them to C<< + >> and I'll be happy to consider putting them into the +Perl::Critic distribution. Or if you would like to work on the Perl::Critic +project directly, you can fork our repository at +L. + +The Perl::Critic team is also available for hire. If your organization has +its own coding standards, we can create custom Policies to enforce your local +guidelines. Or if your code base is prone to a particular defect pattern, we +can design Policies that will help you catch those costly defects B +they go into production. To discuss your needs with the Perl::Critic team, +just contact C<< >>. + + +=head1 CONTACTING THE DEVELOPMENT TEAM + +You are encouraged to subscribe to the mailing list at +L. +At least one member of the development team is usually hanging around in +L and you can follow Perl::Critic on Twitter, +at L. + + +=head1 SEE ALSO + +There are a number of distributions of additional Policies available. A few +are listed here: + +L + +L + +L + +L + +L + +L + +These distributions enable you to use Perl::Critic in your unit tests: + +L + +L + +There is also a distribution that will install all the Perl::Critic related +modules known to the development team: + +L + + +=head1 BUGS + +Scrutinizing Perl code is hard for humans, let alone machines. If you find +any bugs, particularly false-positives or false-negatives from a +Perl::Critic::Policy, please submit them at +L. Thanks. + +=head1 CREDITS + +Adam Kennedy - For creating L, the heart and soul of L. + +Damian Conway - For writing B, finally :) + +Chris Dolan - For contributing the best features and Policy modules. + +Andy Lester - Wise sage and master of all-things-testing. + +Elliot Shank - The self-proclaimed quality freak. + +Giuseppe Maxia - For all the great ideas and positive encouragement. + +and Sharon, my wife - For putting up with my all-night code sessions. + +Thanks also to the Perl Foundation for providing a grant to support Chris +Dolan's project to implement twenty PBP policies. +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/cpanfile b/cpanfile new file mode 100644 index 0000000..b763c51 --- /dev/null +++ b/cpanfile @@ -0,0 +1,71 @@ +# Validate with cpanfile-dump +# https://metacpan.org/release/Module-CPANfile +# https://metacpan.org/pod/distribution/Module-CPANfile/lib/cpanfile.pod + +requires 'B::Keywords' => '1.05'; +requires 'Carp' => 0; +requires 'Config::Tiny' => 2; +requires 'English' => 0; +requires 'Exception::Class' => '1.23'; +requires 'Exporter' => '5.63'; +requires 'Fatal' => 0; +requires 'File::Basename' => 0; +requires 'File::Find' => 0; +requires 'File::Path' => 0; +requires 'File::Spec' => 0; +requires 'File::Spec::Unix' => 0; +requires 'File::Temp' => 0; +requires 'File::Which' => 0; +requires 'Getopt::Long' => 0; +requires 'IO::String' => 0; +requires 'IPC::Open2' => 1; +requires 'List::MoreUtils' => '0.19'; +requires 'List::Util' => 0; +requires 'Module::Build' => '0.4204'; +requires 'Module::Pluggable' => '3.1'; +requires 'PPI' => '1.265'; +requires 'PPI::Document' => '1.265'; +requires 'PPI::Document::File' => '1.265'; +requires 'PPI::Node' => '1.265'; +requires 'PPI::Token::Quote::Single' => '1.265'; +requires 'PPI::Token::Whitespace' => '1.265'; +requires 'PPIx::QuoteLike' => 0; +requires 'PPIx::Regexp' => '0.027'; # Literal { deprecated in re +requires 'PPIx::Regexp::Util' => '0.068'; # is_ppi_regexp_element() +requires 'PPIx::Utilities::Node' => '1.001'; +requires 'PPIx::Utilities::Statement' => '1.001'; +requires 'Perl::Tidy' => 0; +requires 'Pod::Parser' => 0; +requires 'Pod::PlainText' => 0; +requires 'Pod::Select' => 0; +requires 'Pod::Spell' => 1; +requires 'Pod::Usage' => 0; +requires 'Readonly' => '2.00'; +requires 'Scalar::Util' => 0; +requires 'String::Format' => '1.18'; +requires 'Task::Weaken' => 0; +requires 'Term::ANSIColor' => '2.02'; +requires 'Test::Builder' => '0.92'; +requires 'Text::ParseWords' => 3; +requires 'base' => 0; +requires 'charnames' => 0; +requires 'overload' => 0; +requires 'strict' => 0; +requires 'version' => '0.77'; +requires 'warnings' => 0; + +on 'test' => sub { + requires 'Test::Deep' => 0; + requires 'Test::More' => 0; + + # For author testing + requires 'Devel::EnforceEncapsulation' => 0; + requires 'Test::Kwalitee' => 0; + requires 'Test::Memory::Cycle' => 0; + requires 'Test::Perl::Critic' => 0; + requires 'Test::Pod' => 0; + requires 'Test::Pod::Coverage' => 0; +}; + + +# vi:et:sw=4 ts=4 ft=perl diff --git a/examples/generatestats b/examples/generatestats new file mode 100755 index 0000000..9b10779 --- /dev/null +++ b/examples/generatestats @@ -0,0 +1,300 @@ +#!/usr/bin/perl + +use 5.008001; +use strict; +use warnings; + +use version; our $VERSION = qv('1.116'); + +use Carp qw{ croak }; +use English qw{ -no_match_vars }; +use Readonly; + +use File::Spec qw{ }; +use Perl6::Say; + +use Perl::Critic::Utils qw{ all_perl_files }; +use Perl::Critic; + + +if ( ! @ARGV ) { + die qq{usage: generatestats path [...]\n}; +} + +main(); + +exit 0; + + +sub main { + foreach my $path ( @ARGV ) { + say "Looking at $path."; + + my @files = all_perl_files($path); + say 'Analyzing ', scalar @files, ' files.'; + + my $results = summarize( \@files, File::Spec->canonpath($path) ); + + report($results); + + say; say; + } + + return; +} + + +sub summarize { + my ( $files, $path ) = @_; + + # Force reporting level to be really strict, just so that the statistics + # include everything. + my $critic = Perl::Critic->new( -severity => 1 ); + + my %total_severities; + my %total_policies; + my %types; + my %files; + + foreach my $file ( @{$files} ) { + my $relative_path; + my $type; + + if ($file eq $path) { + $relative_path = $file; + } else { + my $absolute_path_length = ( length $path ) + 1; + + $relative_path = substr $file, $absolute_path_length; + } + + if ($file =~ m/ [.] ([^.]+) \z /xms) { + $type = $1; + } else { + $type = ''; + } + + $types{$type}{files}++; + foreach my $violation ( $critic->critique($file) ) { + $files{ $relative_path }{ severities }{ $violation->severity() }++; + $files{ $relative_path }{ policies }{ $violation->policy() }++; + + $types{ $type }{ severities }{ $violation->severity() }++; + $types{ $type }{ policies }{ $violation->policy() }++; + + $total_severities{ $violation->severity() }++; + $total_policies{ $violation->policy() }++; + } + } + + return { + severities => \%total_severities, + policies => \%total_policies, + types => \%types, + files => \%files, + }; +} + + +sub report { + my ( $results ) = @_; + + report_totals( $results ); + report_types( $results ); + report_files( $results ); + + return; +} + + +sub report_totals { + my ( $results ) = @_; + + say; + say 'Total violations by severity:'; + report_severities( $results->{severities} ); + + say; + say 'Total violations by policy:'; + report_policies( $results->{policies} ); + + return; +} + + +sub report_types { + my ( $results ) = @_; + my $types = $results->{types}; + + say; + say 'Total files by type:'; + foreach my $type ( sort keys %{$types} ) { + say qq{\t}, $type, ': ', $types->{$type}{files}; + } + + foreach my $type ( sort keys %{$types} ) { + say; + say "Violations in $type files by severity:"; + report_severities( $types->{$type}{severities} ); + + say; + say "Violations in $type files by policy:"; + report_policies( $types->{$type}{policies} ); + } + + return; +} + + +sub report_files { + my ( $results ) = @_; + my $files = $results->{files}; + + foreach my $file ( sort keys %{$files} ) { + say; + say "Violations in $file by severity:"; + report_severities( $files->{$file}{severities} ); + + say; + say "Violations in $file by policy:"; + report_policies( $files->{$file}{policies} ); + } + + return; +} + + +sub report_severities { + my ($severities) = @_; + + foreach my $severity ( reverse sort { $a <=> $b } keys %{$severities} ) { + say qq{\t}, $severity, ': ', $severities->{$severity}; + } + + return; +} + + +sub report_policies { + my ($policies) = @_; + + foreach my $policy ( sort keys %{$policies} ) { + (my $short_policy = $policy) =~ s/ \A Perl::Critic::Policy:: //xms; + + say qq{\t}, $short_policy, ': ', $policies->{$policy}; + } + + return; +} + + +__END__ + +=pod + +=for stopwords codebase perlartistic + +=head1 NAME + +C - Produce some simple quality statistics of a codebase + + +=head1 USAGE + + generatestats path [...] + + +=head1 DESCRIPTION + +Scan a body of code and generate some statistics on violations of the +installed L policies. While there is no means of +configuring the policies here, this will take into account your +F<.perlcriticrc>, if available. + + +=head1 REQUIRED ARGUMENTS + +A list of paths to files and directories to find code in. + + +=head1 OPTIONS + +None. + + +=head1 DIAGNOSTICS + +None. + + +=head1 EXIT STATUS + +0 + + +=head1 CONFIGURATION + +None. + + +=head1 DEPENDENCIES + +L +L +L + + +=head1 INCOMPATIBILITIES + +None reported. + + +=head1 BUGS AND LIMITATIONS + +This is an example program and thus does minimal error handling. + + +=head1 AUTHOR + +Elliot Shank C<< >> + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011, Elliot Shank. + +This module is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. See L. + + +=head1 DISCLAIMER OF WARRANTY + +BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE +SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE +STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE +SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND +PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, +YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. + +IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY +COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE +SOFTWARE AS PERMITTED BY THE ABOVE LICENSE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO +LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR +THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER +SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/examples/loadanalysisdb b/examples/loadanalysisdb new file mode 100755 index 0000000..4a41d3a --- /dev/null +++ b/examples/loadanalysisdb @@ -0,0 +1,344 @@ +#!/usr/bin/perl + +use 5.008001; +use strict; +use warnings; + +use version; our $VERSION = qv('1.116'); + +use Carp qw{ croak }; +use English qw{ -no_match_vars }; +use Readonly; + +use DBI qw{ :sql_types }; +use File::Spec qw{ }; +use Perl6::Say; + +use Perl::Critic::Utils qw{ all_perl_files policy_short_name $EMPTY }; +use Perl::Critic; + + +if ( ! @ARGV ) { + die qq{usage: loadanalysisdb path [...]\n}; +} + +main(); + +exit 0; + + +sub main { + say 'Connecting to database.'; + say; + + my $database_connection = connect_to_database(); + my $insert_statement = prepare_insert_statement($database_connection); + + foreach my $path ( @ARGV ) { + say "Looking at $path."; + + my @files = all_perl_files($path); + say 'Analyzing ', scalar @files, ' files.'; + + load( \@files, File::Spec->canonpath($path), $insert_statement ); + + say; say; + } + + say 'Disconnecting from database.'; + say; + + close_insert_statement($insert_statement); + # Need to do this or DBI emits warning at disconnect + $insert_statement = undef; + + disconnect_from_database($database_connection); + + say 'Done.'; + say; + + return; +} + + +sub load { + my ( $files, $path, $insert_statement ) = @_; + + # Force reporting level to be really strict, just so that the database + # has everything. + my $critic = Perl::Critic->new( -severity => 1 ); + + foreach my $file ( @{$files} ) { + my $relative_path; + + if ($file eq $path) { + $relative_path = $file; + } else { + my $absolute_path_length = ( length $path ) + 1; + + $relative_path = substr $file, $absolute_path_length; + } + + say "Processing $relative_path."; + + foreach my $violation ( $critic->critique($file) ) { + my ($line, $column) = @{ $violation->location() }; + + execute_insert_statement( + $insert_statement, + $relative_path, + $line, + $column, + $violation->severity(), + policy_short_name( $violation->policy() ), + $violation->explanation(), + $violation->source(), + ); + } + } + + return; +} + + +sub connect_to_database { + my $database_file_name = 'perl_critic_analysis.sqlite'; + + my $database_connection = + DBI->connect( + "dbi:SQLite:dbname=$database_file_name", + $EMPTY, # login + $EMPTY, # password + { + AutoCommit => 1, # In real life, this should be 0 + RaiseError => 1, + } + ); + + defined $database_connection or + croak "Could not connect to $database_file_name."; + + return $database_connection; +} + + +sub prepare_insert_statement { + my ( $database_connection ) = @_; + + my $insert_statement = + $database_connection->prepare(<<'END_SQL'); + INSERT INTO + violation + ( + file_path, + line_number, + column_number, + severity, + policy, + explanation, + source_code + ) + VALUES + (?, ?, ?, ?, ?, ?, ?) +END_SQL + + + # The following values are bogus-- these statements are simply to tell + # the driver what the parameter types are so that we can use execute() + # without calling bind_param() each time. See "Binding Values Without + # bind_param()" on pages 126-7 of "Programming the Perl DBI". + + ## no critic (ProhibitMagicNumbers) + $insert_statement->bind_param( 1, 'x', SQL_VARCHAR); + $insert_statement->bind_param( 2, 1, SQL_INTEGER); + $insert_statement->bind_param( 3, 1, SQL_INTEGER); + $insert_statement->bind_param( 4, 1, SQL_INTEGER); + $insert_statement->bind_param( 5, 'x', SQL_VARCHAR); + $insert_statement->bind_param( 6, 'x', SQL_VARCHAR); + $insert_statement->bind_param( 7, 'x', SQL_VARCHAR); + ## use critic + + return $insert_statement; +} + + +sub execute_insert_statement { ##no critic(ProhibitManyArgs) + my ( + $statement, + $file_path, + $line_number, + $column_number, + $severity, + $policy, + $explanation, + $source_code, + ) + = @_; + + $statement->execute( + $file_path, + $line_number, + $column_number, + $severity, + $policy, + $explanation, + $source_code, + ); + + return; +} + + +sub close_insert_statement { + my ( $insert_statement ) = @_; + + $insert_statement->finish(); + + return; +} + +sub disconnect_from_database { + my ( $database_connection ) = @_; + + $database_connection->disconnect(); + + return; +} + + +__END__ + +=pod + +=for stopwords SQLite DBI analyses perlartistic + +=head1 NAME + +C - Critique a body of code and load the results into a database for later processing. + + +=head1 USAGE + + loadanalysisdb path [...] + + +=head1 DESCRIPTION + +Scan a body of code and, rather than emit the results in a textual +format, put them into a database so that analyses can be made. + +This example doesn't put anything into the database that isn't +available from L in +order to keep the code easier to understand. In a full application of +the idea presented here, one might want to include the current date +and a distribution name in the database so that progress on cleaning +up a code corpus can be tracked. + +Note the explanation attribute of +L is constant for +most policies, but some of them do provide more specific diagnostics +of the code in question. + + +=head1 REQUIRED ARGUMENTS + +A list of paths to files and directories to find code in. + + +=head1 OPTIONS + +None. + + +=head1 DIAGNOSTICS + +Errors from L. + + +=head1 EXIT STATUS + +0 + + +=head1 CONFIGURATION + +None. + + +=head1 DEPENDENCIES + +L +L +L +L + +An SQLite database named "perl_critic_analysis.sqlite" with the +following schema: + + CREATE TABLE violation ( + file_path VARCHAR(1024), + line_number INTEGER, + column_number INTEGER, + severity INTEGER, + policy VARCHAR(512), + explanation TEXT, + source_code TEXT + ) + + +=head1 INCOMPATIBILITIES + +None reported. + + +=head1 BUGS AND LIMITATIONS + +This is an example program and thus does minimal error handling. + + +=head1 AUTHOR + +Elliot Shank C<< >> + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011, Elliot Shank. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. See L. + + +=head1 DISCLAIMER OF WARRANTY + +BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT +WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER +PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, +EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. + +IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENSE, BE LIABLE +TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/examples/perlcriticrc b/examples/perlcriticrc new file mode 100644 index 0000000..7eb7640 --- /dev/null +++ b/examples/perlcriticrc @@ -0,0 +1,201 @@ +############################################################################## +# This file is an example of a Perl::Critic configuration file. This +# file is usually called ".perlcriticrc" and is usually located in +# your home directory or the working directory of your project. +# However, you can use the -profile option to tell Perl::Critic use a +# different file in another location. +# +# The area before any of the [Perl::Critic::Policy] sections is used +# to set default values for the arguments to the Perl::Critic engine. +# If you are using the "perlcritic" program, you can override these +# settings at the command-line. Or if you are using the Perl::Critic +# library, your API arguments will override these settings as well. + + +#----------------------------------------------------------------------------- +# exclude: Directs Perl::Critic to never apply Policies with names that +# match one of the patterns. To specify multiple patterns, separate them +# with whitespace. Do not put quotes around anything. + +exclude = Documentation Naming + +#----------------------------------------------------------------------------- +# include: Directs Perl::Critic to always apply Policies with names that +# match one of the patterns. To specify multiple patterns, separate them +# with whitespace. Do not put quotes around anything. + +include = CodeLayout Modules + +#----------------------------------------------------------------------------- +# force: Directs Perl::Critic to ignore the special "##no critic" +# comments embedded in the source code. The default is 0. If +# defined, this should be either 1 or 0. + +force = 1 + +#----------------------------------------------------------------------------- +# only: Directs Perl::Critic to only choose from Policies that are +# explicitly mentioned in this file. Otherwise, Perl::Critic chooses +# from all the Perl::Critic::Policy classes that are found on the +# local machine. The default is 0. If defined, this should be either +# 1 or 0. + +only = 1 + +#----------------------------------------------------------------------------- +# severity: Sets the default minimum severity level for Policies. The +# default is 5. If defined, this should be an integer from 1 to 5, +# where 5 is the highest severity. + +severity = 3 + +#----------------------------------------------------------------------------- +# theme: Sets the default theme. Only Policies that fit into this +# them shall be applied. If defined, this should be a valid theme +# expression. See the Perl::Critic POD for more details about this. + +theme = danger + risky - pbp + +#----------------------------------------------------------------------------- +# top: Directs Perl::Critic to only report the top N Policy violations, +# as ranked by their individual severity. If defined, this should be +# a positive integer. + +top = 50 + +#----------------------------------------------------------------------------- +# verbose: Sets the format for printing Policy violations. If +# defined, this should be either a format spcecification, or a numeric +# verbosity level. See the Perl::Critic POD for more details. + +verbose = 5 + +#----------------------------------------------------------------------------- +# color-severity-highest: sets the color used for displaying highest +# severity violations when coloring is in effect. This should be a color +# specification acceptable to Term::ANSIColor. See the Perl::Critic POD +# for details. Do not put quotes around the values. The default is 'bold +# red'. + +color-severity-highest = bold red underline + +#----------------------------------------------------------------------------- +# color-severity-high: sets the color used for displaying high severity +# violations when coloring is in effect. This should be a color +# specification acceptable to Term::ANSIColor. See the Perl::Critic POD +# for details. Do not put quotes around the values. The default is +# 'magenta'. + +color-severity-high = bold magenta + +#----------------------------------------------------------------------------- +# color-severity-medium: sets the color used for displaying medium +# severity violations when coloring is in effect. This should be a color +# specification acceptable to Term::ANSIColor. See the Perl::Critic POD +# for details. Do not put quotes around the values. The default is ''. + +color-severity-medium = blue + +#----------------------------------------------------------------------------- +# color-severity-low: sets the color used for displaying low severity +# violations when coloring is in effect. This should be a color +# specification acceptable to Term::ANSIColor. See the Perl::Critic POD +# for details. Do not put quotes around the values. The default is ''. + +color-severity-low = + +#----------------------------------------------------------------------------- +# color-severity-lowest: sets the color used for displaying lowest +# severity violations when coloring is in effect. This should be a color +# specification acceptable to Term::ANSIColor. See the Perl::Critic POD +# for details. Do not put quotes around the values. The default is ''. + +color-severity-lowest = + +#----------------------------------------------------------------------------- +# program-extensions: specifies the file name endings for files that should +# be interpreted as programs rather than modules. This should be a space- +# delimited list of the name endings, with leading '.' if that is desired. +# These are case-sensitive. See the Perl::Critic POD for details, but in +# general any file beginning with a shebang line, any file whose name ends +# '.PL', and any file whose name ends in one of the values specified here +# will be considered a program; any other file will be considered a module. +# Do not put quotes around the values. The default is ''. + +program-extensions = + +############################################################################## +# The rest of the file consists of several named blocks that contain +# configuration parameters for each of the Policies. The names of +# each blocks correspond to the names of the Policy modules. For +# brevity, the "Perl::Critic::Policy" portion of the name can be +# omitted. See the POD for the appropriate Policy for a complete +# description of the configuration parameters that it supports. + + +#----------------------------------------------------------------------------- +# If you vehmently disagree with a particular Policy, putting a "-" in +# front of the Policy name will effectively disables that Policy. It +# will never be applied unless you use the "-include" option to apply +# it explicitly. + +[-NamingConventions::Capitalization] +[-TestingAndDebugging::RequireUseWarnings] + +#----------------------------------------------------------------------------- +# If you agree with a Policy, but feel that it's severity level is not +# appropriate, then you can change the severity for any Policy. If +# defined this should be an integer from 1 to 5, where 5 is the +# highest severity. + +[BuiltinFunctions::RequireBlockGrep] +severity = 2 + +[CodeLayout::ProhibitHardTabs] +severity = 1 + +[ClassHierarchies::ProhibitAutoloading] +severity = 5 + +#----------------------------------------------------------------------------- +# Policies are also organized into themes. Themes are just names for +# arbitrary groups of Policies. You can define new themes and add +# them to any Policy. If defined, this should be a string of +# whitespace-delimited words. + +[RegularExpressions::RequireExtendedFormatting] +add_themes = client_foo +severity = 3 + +[RegularExpressions::RequireExtendedFormatting] +add_themes = client_foo client_bar +severity = 3 + +#----------------------------------------------------------------------------- +# Some Policies also have specialized configuration parameters. In +# all cases, these are repsented as simple name=value pairs. See the +# POD for the appropriate Policy for a complete discussion of its +# configuration parameters. + +[ControlStructures::ProhibitPostfixControls] +allow = for if +severity = 4 + +[Documentation::RequirePodSections] +lib_sections = NAME | SYNOPSIS | METHODS | AUTHOR +add_themes = my_favorites +severity = 4 + +#----------------------------------------------------------------------------- +# If you set the "only" flag, then Perl::Critic only chooses from +# Policies that are mentioned in your configuration file. This is +# helpful when you want to use only a very small subset of the +# Policies. So just create blocks for any other Policies that you +# want to use. + +[ValuesAndExpressions::ProhibitInterpolationOfLiterals] +[ValuesAndExpressions::ProhibitLeadingZeros] +[InputOutput::ProhibitBarewordFileHandles] +[Miscellanea::ProhibitTies] + + diff --git a/examples/perlcriticrc-conway b/examples/perlcriticrc-conway new file mode 100644 index 0000000..eb2d6dc --- /dev/null +++ b/examples/perlcriticrc-conway @@ -0,0 +1,283 @@ +############################################################################## +# This Perl::Critic configuration file sets the Policy severity levels +# according to Damian Conway's own personal recommendations. Feel free to +# use this as your own, or make modifications. +############################################################################## + +[Perl::Critic::Policy::BuiltinFunctions::ProhibitLvalueSubstr] +severity = 3 + +[Perl::Critic::Policy::BuiltinFunctions::ProhibitReverseSortBlock] +severity = 1 + +[Perl::Critic::Policy::BuiltinFunctions::ProhibitSleepViaSelect] +severity = 5 + +[Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval] +severity = 5 + +[Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit] +severity = 2 + +[Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalCan] +severity = 4 + +[Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa] +severity = 4 + +[Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep] +severity = 3 + +[Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap] +severity = 3 + +[Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep] +severity = 4 + +[Perl::Critic::Policy::BuiltinFunctions::RequireBlockMap] +severity = 4 + +[Perl::Critic::Policy::BuiltinFunctions::RequireGlobFunction] +severity = 5 + +[Perl::Critic::Policy::BuiltinFunctions::RequireSimpleSortBlock] +severity = 3 + +[Perl::Critic::Policy::ClassHierarchies::ProhibitAutoloading] +severity = 3 + +[Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA] +severity = 4 + +[Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless] +severity = 5 + +[Perl::Critic::Policy::CodeLayout::ProhibitHardTabs] +severity = 3 + +[Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins] +severity = 1 + +[Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists] +severity = 2 + +[Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines] +severity = 4 + +[Perl::Critic::Policy::CodeLayout::RequireTidyCode] +severity = 1 + +[Perl::Critic::Policy::CodeLayout::RequireTrailingCommas] +severity = 3 + +[Perl::Critic::Policy::ControlStructures::ProhibitCStyleForLoops] +severity = 3 + +[Perl::Critic::Policy::ControlStructures::ProhibitCascadingIfElse] +severity = 3 + +[Perl::Critic::Policy::ControlStructures::ProhibitDeepNests] +severity = 3 + +[Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions] +severity = 5 + +[Perl::Critic::Policy::ControlStructures::ProhibitPostfixControls] +severity = 4 + +[Perl::Critic::Policy::ControlStructures::ProhibitUnlessBlocks] +severity = 4 + +[Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode] +severity = 4 + +[Perl::Critic::Policy::ControlStructures::ProhibitUntilBlocks] +severity = 4 + +[Perl::Critic::Policy::Documentation::RequirePodAtEnd] +severity = 2 + +[Perl::Critic::Policy::Documentation::RequirePodSections] +severity = 2 + +[Perl::Critic::Policy::ErrorHandling::RequireCarping] +severity = 4 + +[Perl::Critic::Policy::InputOutput::ProhibitBacktickOperators] +severity = 3 + +[Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles] +severity = 5 + +[Perl::Critic::Policy::InputOutput::ProhibitInteractiveTest] +severity = 4 + +[Perl::Critic::Policy::InputOutput::ProhibitOneArgSelect] +severity = 4 + +[Perl::Critic::Policy::InputOutput::ProhibitReadlineInForLoop] +severity = 5 + +[Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen] +severity = 4 + +[Perl::Critic::Policy::InputOutput::RequireBracedFileHandleWithPrint] +severity = 3 + +[Perl::Critic::Policy::Miscellanea::ProhibitFormats] +severity = 3 + +[Perl::Critic::Policy::Miscellanea::ProhibitTies] +severity = 4 + +[-Perl::Critic::Policy::Miscellanea::RequireRcsKeywords] + +[Perl::Critic::Policy::Modules::ProhibitAutomaticExportation] +severity = 4 + +[Perl::Critic::Policy::Modules::ProhibitEvilModules] +severity = 5 + +[Perl::Critic::Policy::Modules::ProhibitMultiplePackages] +severity = 4 + +[Perl::Critic::Policy::Modules::RequireBarewordIncludes] +severity = 5 + +[Perl::Critic::Policy::Modules::RequireEndWithOne] +severity = 4 + +[Perl::Critic::Policy::Modules::RequireExplicitPackage] +severity = 4 + +[Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage] +severity = 5 + +[Perl::Critic::Policy::Modules::RequireVersionVar] +severity = 4 + +[Perl::Critic::Policy::NamingConventions::ProhibitAmbiguousNames] +severity = 3 + +[Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseSubs] +severity = 1 + +[Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseVars] +severity = 1 + +[Perl::Critic::Policy::References::ProhibitDoubleSigils] +severity = 4 + +[Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest] +severity = 4 + +[Perl::Critic::Policy::RegularExpressions::RequireExtendedFormatting] +severity = 5 + +[Perl::Critic::Policy::RegularExpressions::RequireLineBoundaryMatching] +severity = 5 + +[Perl::Critic::Policy::Subroutines::ProhibitAmpersandSigils] +severity = 2 + +[Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms] +severity = 4 + +[Perl::Critic::Policy::Subroutines::ProhibitExcessComplexity] +severity = 3 + +[Perl::Critic::Policy::Subroutines::ProhibitExplicitReturnUndef] +severity = 5 + +[Perl::Critic::Policy::Subroutines::ProhibitSubroutinePrototypes] +severity = 4 + +[Perl::Critic::Policy::Subroutines::ProtectPrivateSubs] +severity = 3 + +[Perl::Critic::Policy::Subroutines::RequireFinalReturn] +severity = 5 + +[Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict] +severity = 5 + +[Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings] +severity = 4 + +[Perl::Critic::Policy::TestingAndDebugging::ProhibitProlongedStrictureOverride] +severity = 4 + +[Perl::Critic::Policy::TestingAndDebugging::RequireTestLabels] +severity = 3 + +[Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict] +severity = 5 + +[Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings] +severity = 4 + +[Perl::Critic::Policy::ValuesAndExpressions::ProhibitConstantPragma] +severity = 4 + +[Perl::Critic::Policy::ValuesAndExpressions::ProhibitEmptyQuotes] +severity = 2 + +[Perl::Critic::Policy::ValuesAndExpressions::ProhibitEscapedCharacters] +severity = 2 + +[Perl::Critic::Policy::ValuesAndExpressions::ProhibitInterpolationOfLiterals] +severity = 1 + +[Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros] +severity = 5 + +[Perl::Critic::Policy::ValuesAndExpressions::ProhibitMismatchedOperators] +severity = 2 + +[Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators] +severity = 4 + +[Perl::Critic::Policy::ValuesAndExpressions::ProhibitNoisyQuotes] +severity = 2 + +[Perl::Critic::Policy::ValuesAndExpressions::ProhibitVersionStrings] +severity = 3 + +[Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars] +severity = 1 + +[Perl::Critic::Policy::ValuesAndExpressions::RequireNumberSeparators] +severity = 2 + +[Perl::Critic::Policy::ValuesAndExpressions::RequireQuotedHeredocTerminator] +severity = 4 + +[Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator] +severity = 4 + +[Perl::Critic::Policy::Variables::ProhibitConditionalDeclarations] +severity = 5 + +[Perl::Critic::Policy::Variables::ProhibitLocalVars] +severity = 2 + +[Perl::Critic::Policy::Variables::ProhibitMatchVars] +severity = 4 + +[Perl::Critic::Policy::Variables::ProhibitPackageVars] +severity = 3 + +[Perl::Critic::Policy::Variables::ProhibitPunctuationVars] +severity = 2 + +[Perl::Critic::Policy::Variables::ProtectPrivateVars] +severity = 3 + +[Perl::Critic::Policy::Variables::RequireInitializationForLocalVars] +severity = 5 + +[Perl::Critic::Policy::Variables::RequireLexicalLoopIterators] +severity = 5 + +[Perl::Critic::Policy::Variables::RequireNegativeIndices] +severity = 4 \ No newline at end of file diff --git a/extras/perlcritic.el b/extras/perlcritic.el new file mode 100644 index 0000000..0d91cdd --- /dev/null +++ b/extras/perlcritic.el @@ -0,0 +1,674 @@ +;;; perlcritic.el --- minor mode for Perl::Critic integration + +;;; Readme +;; +;; This is a minor mode for emacs intended to allow you to +;; automatically incorporate perlcritic into your daily code +;; writing. When enabled it can optionally prevent you from saving +;; code that doesn't pass your enabled perlcritic policies. +;; +;; Even if you don't enable the automatic code checking you can still +;; use the automatic checking or the `perlcritic' function. + + +;;; Installation instructions: +;; +;; Copy perlcritic.el to your ~/.site-lib directory. If you don't +;; have a .site-lib directory create it and add the following line +;; to your .emacs file. This location isn't special, you could use +;; a different location if you wished. +;; +;; (add-to-list 'load-path "/home/your-name/.site-lisp") +;; +;; Add the following lines to your .emacs file. This allows Emacs +;; to load your perlcritic library only when needed. +;; +;; (autoload 'perlcritic "perlcritic" "" t) +;; (autoload 'perlcritic-region "perlcritic" "" t) +;; (autoload 'perlcritic-mode "perlcritic" "" t) +;; +;; Add the following to your .emacs file to get perlcritic-mode to +;; run automatically for the `cperl-mode' and `perl-mode'. +;; +;; (eval-after-load "cperl-mode" +;; '(add-hook 'cperl-mode-hook 'perlcritic-mode)) +;; (eval-after-load "perl-mode" +;; '(add-hook 'perl-mode-hook 'perlcritic-mode)) +;; +;; +;; If you think you need perlcritic loaded all the time you can +;; make this unconditional by using the following command instead +;; of the above autoloading. +;; +;; (require 'perlcritic) +;; +;; Compile the file for extra performance. This is optional. You +;; will have to redo this everytime you modify or upgrade your +;; perlcritic.el file. +;; +;; M-x byte-compile-file ~/.site-lib/perlcritic.el +;; +;; Additional customization can be found in the Perl::Critic group +;; in the Tools section in the Programming section of your Emacs' +;; customization menus. + + +;;; TODO +;; +;; Find out how to get perlcritic customization stuff into the +;; customization menus without having to load perlcritic.el +;; first. +;; +;; This needs an installer. Is there anything I can use in +;; ExtUtils::MakeMaker, Module::Build, or Module::Install? +;; Alien::? +;; +;; XEmacs compatibility. I use GNU Emacs and don't test in +;; XEmacs. I'm happy to do what it takes to be compatible but +;; someone will have to point things out to me. +;; +;; Make all documentation strings start with a sentence that fits +;; on one line. See "Tips for Documentation Strings" in the Emacs +;; Lisp manual. +;; +;; Any FIXME, TODO, or XXX tags below. + + +;;; Change Log: +;; 0.10 +;; * Synched up regexp alist with Perl::Critic::Utils and accounted for all +;; past patterns too. +;; 0.09 +;; * Added documentation for perlcritic-top, perlcritic-include, +;; perlcritic-exclude, perlcritic-force, perlcritic-verbose. +;; * Added emacs/vim editor hints to the bottom. +;; * Corrected indentation. +;; 0.08 +;; * Fixed perlcritic-compilation-error-regexp-alist for all +;; severity levels. +;; * Added documentation strings for functions. +;; 0.07 +;; * Moved perlcritic-compilation-error-regexp-alist so it is in the +;; source before it's used. This only seems to matter when +;; perlcritic.el is compiled to bytecode. +;; * Added perlcritic-exclude, perlcritic-include + +;; 0.06 +;; * Code cleanliness. +;; * Comment cleanliness. +;; * Nice error message when perlcritic warns. +;; * Documented perlcritic-top, perlcritic-verbose. +;; * Regular expressions for the other standard -verbose levels. +;; * Reversed Changes list so the most recent is first. +;; * Standard emacs library declarations. +;; * Added autoloading metadata. +;; 0.05 +;; * perlcritic-bin invocation now shown in output. +;; * Fixed indentation. +;; * perlcritic-region is now interactive. +;; 0.04 +;; * Removed a roque file-level (setq perlcritic-top 1) +;; * Moved cl library to compile-time. +;; 0.03 +;; * compile.el integration. This makes for hotlink happiness. +;; * Better sanity when starting the *perlcritic* buffer. +;; 0.02 +;; * perlcritic-severity-level added. +;; * Touched up the installation documentation. +;; * perlcritic-pass-required is now buffer local. +;; 0.01 +;; * It's new. I copied much of this from perl-lint-mode. + +;;; Copyright and license +;; +;; 2006 Joshua ben Jore +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the same terms as Perl itself + + + + +;;; Code: + +;;; Customization and variables. +(defgroup perlcritic nil "Perl::Critic" + :prefix "perlcritic-" + :group 'tools) + +(defcustom perlcritic-bin "perlcritic" + "The perlcritic program used by `perlcritic'." + :type 'string + :group 'perlcritic) + +(defcustom perlcritic-pass-required nil + "When \\[perlcritic-mode] is enabled then this boolean controls +whether your file can be saved when there are perlcritic warnings. + +This variable is automatically buffer-local and may be overridden on a +per-file basis with File Variables." + :type '(radio + (const :tag "Require no warnings from perlcritic to save" t) + (const :tag "Allow warnings from perlcritic when saving" nil)) + :group 'perlcritic) +(make-variable-buffer-local 'perlcritic-pass-required) + +(defcustom perlcritic-profile nil + "Specify an alternate .perlcriticrc file. This is only used if +non-nil." + :type '(string) + :group 'perlcritic) +(make-variable-buffer-local 'perlcritic-profile) + +(defcustom perlcritic-noprofile nil + "Disables the use of any .perlcriticrc file." + :type '(boolean) + :group 'perlcritic) +(make-variable-buffer-local 'perlcritic-noprofile) + +(defcustom perlcritic-severity nil + "Directs perlcritic to only report violations of Policies with a +severity greater than N. Severity values are integers ranging from +1 (least severe) to 5 (most severe). The default is 5. For a given +-profile, decreasing the -severity will usually produce more +violations. Users can redefine the severity for any Policy in their +.perlcriticrc file. + +This variable is automatically buffer-local and may be overridden on a +per-file basis with File Variables." + :type '(radio + (const :tag "Show only the most severe: 5" 5) + (const :tag "4" 4) + (const :tag "3" 3) + (const :tag "2" 2) + (const :tag "Show everything including the least severe: 1" 1) + (const :tag "Default from .perlcriticrc" nil)) + :group 'perlcritic) +(make-variable-buffer-local 'perlcritic-severity) + +(defcustom perlcritic-top nil + "Directs \"perlcritic\" to report only the top N Policy violations in +each file, ranked by their severity. If the -severity option is not +explicitly given, the -top option implies that the minimum severity +level is 1. Users can redefine the severity for any Policy in their +.perlcriticrc file. + +This variable is automatically buffer-local and may be overridden on a +per-file basis with File Variables." + :type '(integer) + :group 'perlcritic) +(make-variable-buffer-local 'perlcritic-top) + +(defcustom perlcritic-include nil + "Directs \"perlcritic\" to apply additional Policies that match the regex \"/PATTERN/imx\". +Use this option to override your profile and/or the severity settings. + +For example: + + layout + +This would cause \"perlcritic\" to apply all the \"CodeLayout::*\" policies +even if they have a severity level that is less than the default level of 5, +or have been disabled in your .perlcriticrc file. You can specify multiple +`perlcritic-include' options and you can use it in conjunction with the +`perlcritic-exclude' option. Note that `perlcritic-exclude' takes precedence +over `perlcritic-include' when a Policy matches both patterns. You can set +the default value for this option in your .perlcriticrc file." + :type '(string) + :group 'perlcritic) +(make-variable-buffer-local 'perlcritic-include) + +(defcustom perlcritic-exclude nil + "Directs \"perlcritic\" to not apply any Policy that matches the regex +\"/PATTERN/imx\". Use this option to temporarily override your profile and/or +the severity settings at the command-line. For example: + + strict + +This would cause \"perlcritic\" to not apply the \"RequireUseStrict\" and +\"ProhibitNoStrict\" Policies even though they have the highest severity +level. You can specify multiple `perlcritic-exclude' options and you can use +it in conjunction with the `perlcritic-include' option. Note that +`perlcritic-exclude' takes precedence over `perlcritic-include' when a Policy +matches both patterns. You can set the default value for this option in your +.perlcriticrc file." + :type '(string) + :group 'perlcritic) +(make-variable-buffer-local 'perlcritic-exclude) + + +(defcustom perlcritic-force nil + "Directs \"perlcritic\" to ignore the magical \"## no critic\" +pseudo-pragmas in the source code. You can set the default value for this +option in your .perlcriticrc file." + :type '(boolean) + :group 'perlcritic) +(make-variable-buffer-local 'perlcritic-force) + +(defcustom perlcritic-verbose nil + "Sets the numeric verbosity level or format for reporting violations. If +given a number (\"N\"), \"perlcritic\" reports violations using one of the +predefined formats described below. If the `perlcritic-verbose' option is not +specified, it defaults to either 4 or 5, depending on whether multiple files +were given as arguments to \"perlcritic\". You can set the default value for +this option in your .perlcriticrc file. + +Verbosity Format Specification +----------- ------------------------------------------------------------- + 1 \"%f:%l:%c:%m\n\", + 2 \"%f: (%l:%c) %m\n\", + 3 \"%m at %f line %l\n\", + 4 \"%m at line %l, column %c. %e. (Severity: %s)\n\", + 5 \"%f: %m at line %l, column %c. %e. (Severity: %s)\n\", + 6 \"%m at line %l, near ’%r’. (Severity: %s)\n\", + 7 \"%f: %m at line %l near ’%r’. (Severity: %s)\n\", + 8 \"[%p] %m at line %l, column %c. (Severity: %s)\n\", + 9 \"[%p] %m at line %l, near ’%r’. (Severity: %s)\n\", +10 \"%m at line %l, column %c.\n %p (Severity: %s)\n%d\n\", +11 \"%m at line %l, near ’%r’.\n %p (Severity: %s)\n%d\n\" + +Formats are a combination of literal and escape characters similar to the way +\"sprintf\" works. See String::Format for a full explanation of the +formatting capabilities. Valid escape characters are: + +Escape Meaning +------- ---------------------------------------------------------------- +%c Column number where the violation occurred +%d Full diagnostic discussion of the violation +%e Explanation of violation or page numbers in PBP +%F Just the name of the file where the violation occurred. +%f Path to the file where the violation occurred. +%l Line number where the violation occurred +%m Brief description of the violation +%P Full name of the Policy module that created the violation +%p Name of the Policy without the Perl::Critic::Policy:: prefix +%r The string of source code that caused the violation +%s The severity level of the violation + +The purpose of these formats is to provide some compatibility with text +editors that have an interface for parsing certain kinds of input. + + +This variable is automatically buffer-local and may be overridden on a +per-file basis with File Variables." + :type '(integer) + :group 'perlcritic) +(make-variable-buffer-local 'perlcritic-verbose) + +;; TODO: Enable strings in perlcritic-verbose. +;; (defcustom perlcritic-verbose-regexp nil +;; "An optional regexp to match the warning output. +;; +;; This is used when `perlcritic-verbose' has a regexp instead of one of +;; the standard verbose levels.") +;; (make-local-variable 'perlcritic-verbose-regexp) + + +;; compile.el requires that something be the "filename." I've tagged +;; the severity with that. It happens to make it get highlighted in +;; red. The following advice on COMPILATION-FIND-FILE makes sure that +;; the "filename" is getting ignored when perlcritic is using it. + +;; These patterns are defined in Perl::Critic::Utils + +(defvar perlcritic-error-error-regexp-alist nil + "Alist that specified how to match errors in perlcritic output.") +(setq perlcritic-error-error-regexp-alist + '(;; Verbose level 1 + ;; "%f:%l:%c:%m\n" + ("^\\([^\n]+\\):\\([0-9]+\\):\\([0-9]+\\)" 1 2 3 1) + + ;; Verbose level 2 + ;; "%f: (%l:%c) %m\n" + ("^\\([^\n]+\\): (\\([0-9]+\\):\\([0-9]+\\))" 1 2 3 1) + + ;; Verbose level 3 + ;; "%m at %f line %l\n" + ("^[^\n]+ at \\([^\n]+\\) line \\([0-9]+\\)" 1 2 nil 1) + ;; "%m at line %l, column %c. %e. (Severity: %s)\n" + ("^[^\n]+ at line\\( \\)\\([0-9]+\\), column \\([0-9]+\\)." nil 2 3 1) + + ;; Verbose level 4 + ;; "%m at line %l, column %c. %e. (Severity: %s)\n" + ("^[^\n]+\\( \\)at line \\([0-9]+\\), column \\([0-9]+\\)" nil 2 3) + ;; "%f: %m at line %l, column %c. %e. (Severity: %s)\n" + ("^\\([^\n]+\\): [^\n]+ at line \\([0-9]+\\), column \\([0-9]+\\)" 1 2 3) + + ;; Verbose level 5 + ;; "%m at line %l, near '%r'. (Severity: %s)\n" + ("^[^\n]+ at line\\( \\)\\([0-9]+\\)," nil 2) + ;; "%f: %m at line %l, column %c. %e. (Severity: %s)\n" + ("^\\([^\n]+\\): [^\n]+ at line \\([0-9]+\\), column \\([0-9]+\\)" 1 2 3) + + ;; Verbose level 6 + ;; "%m at line %l, near '%r'. (Severity: %s)\\n" + ("^[^\n]+ at line\\( \\)\\([0-9]+\\)" nil 2) + ;; "%f: %m at line %l near '%r'. (Severity: %s)\n" + ("^\\([^\n]+\\): [^\n]+ at line \\([0-9]+\\)" 1 2) + + ;; Verbose level 7 + ;; "%f: %m at line %l near '%r'. (Severity: %s)\n" + ("^\\([^\n]+\\): [^\n]+ at line \\([0-9]+\\)" 1 2) + ;; "[%p] %m at line %l, column %c. (Severity: %s)\n" + ("^\\[[^\n]+\\] [^\n]+ at line\\( \\)\\([0-9]+\\), column \\([0-9]+\\)" nil 2 3) + + ;; Verbose level 8 + ;; "[%p] %m at line %l, column %c. (Severity: %s)\n" + ("^\\[[^\n]+\\] [^\n]+ at line\\( \\)\\([0-9]+\\), column \\([0-9]+\\)" nil 2 3) + ;; "[%p] %m at line %l, near '%r'. (Severity: %s)\n" + ("^\\[[^\n]+\\] [^\n]+ at line\\( \\)\\([0-9]+\\)" nil 2) + + ;; Verbose level 9 + ;; "%m at line %l, column %c.\n %p (Severity: %s)\n%d\n" + ("^[^\n]+ at line\\( \\)\\([0-9]+\\), column \\([0-9]+\\)" nil 2 3) + ;; "[%p] %m at line %l, near '%r'. (Severity: %s)\n" + ("^\\[[^\n]+\\] [^\n]+ at line\\( \\)\\([0-9]+\\)" nil 2) + + ;; Verbose level 10 + ;; "%m at line %l, near '%r'.\n %p (Severity: %s)\n%d\n" + ("^[^\n]+ at line\\( \\)\\([0-9]+\\)" nil 2) + ;; "%m at line %l, column %c.\n %p (Severity: %s)\n%d\n" + ("^[^\n]+ at line\\( \\)\\([0-9]+\\), column \\([0-9]+\\)" nil 2 3) + + ;; Verbose level 11 + ;; "%m at line %l, near '%r'.\n %p (Severity: %s)\n%d\n" + ("^[^\n]+ at line\\( \\)\\([0-9]+\\)" nil 2) + )) + + + +;; The Emacs Lisp manual says to do this with the cl library. +(eval-when-compile (require 'cl)) + +(define-compilation-mode perlcritic-error-mode "perlcritic-error" + "..." + (set (make-local-variable 'perlcritic-buffer) src-buf) + (ad-activate #'compilation-find-file)) + +;;;###autoload +(defun perlcritic () + "\\[perlcritic]] returns a either nil or t depending on whether the +current buffer passes perlcritic's check. If there are any warnings +those are displayed in a separate buffer." + (interactive) + (save-restriction + (widen) + (perlcritic-region (point-min) (point-max)))) + +;;;###autoload +(defun perlcritic-region (start end) + "\\[perlcritic-region] returns a either nil or t depending on +whether the region passes perlcritic's check. If there are any +warnings those are displayed in a separate buffer." + + (interactive "r") + + ;; Kill the perlcritic buffer so I can make a new one. + (if (get-buffer "*perlcritic*") + (kill-buffer "*perlcritic*")) + + ;; In the following lines I'll be switching between buffers + ;; freely. This upper save-excursion will keep things sane. + (save-excursion + (let ((src-buf (current-buffer)) + (err-buf (get-buffer-create "*perlcritic*"))) + + (set-buffer src-buf) + (let ((perlcritic-args (loop for p in (list + ;; Add new bin/perlcritic + ;; parameters here! + (perlcritic--param-profile) + (perlcritic--param-noprofile) + (perlcritic--param-severity) + (perlcritic--param-top) + (perlcritic--param-include) + (perlcritic--param-exclude) + (perlcritic--param-force) + (perlcritic--param-verbose)) + unless (null p) + append p))) + ; + (message "Perl critic...running") + ;; Seriously. Is this the nicest way to call + ;; CALL-PROCESS-REGION with variadic arguments? This blows! + ;; (apply FUNCTION (append STATIC-PART DYNAMIC-PART)) + (let ((rc (apply 'call-process-region + (nconc (list start end + perlcritic-bin nil + (list err-buf t) + nil) + perlcritic-args)))) + + ;; Figure out whether we're ok or not. perlcritic has to + ;; return zero and the output buffer has to be empty except + ;; for that "... source OK" line. Different versions of the + ;; perlcritic script will print different things when + ;; they're ok. I expect to see things like "some-file source + ;; OK", "SCALAR=(0x123457) source OK", "STDIN source OK", + ;; and "source OK". + (let ((perlcritic-ok (and (numberp rc) + (zerop rc) + (progn + (set-buffer err-buf) + (goto-char (point-min)) + (delete-matching-lines "source OK$") + (zerop (buffer-size)))))) + ;; Either clean up or finish setting up my output. + (if perlcritic-ok + ;; Ok! + (progn + (kill-buffer err-buf) + (message "Perl critic...ok")) + + + ;; Not ok! + (message "Perl critic...not ok") + + ;; Set up the output buffer now I know it'll be used. I + ;; scooped the guts out of compile-internal. It is + ;; CRITICAL that the errors start at least two lines + ;; from the top. compile.el normally assumes the first + ;; line is an informational `cd somedirectory' command + ;; and the second line shows the program's invocation. + ;; + ;; Since I have the space available I've put the + ;; program's invocation here. Maybe it'd make sense to + ;; put the buffer's directory here somewhere too. + (set-buffer err-buf) + (goto-char (point-min)) + (insert (reduce (lambda (a b) (concat a " " b)) + (nconc (list perlcritic-bin) + perlcritic-args)) + "\n" + ;; TODO: instead of a blank line, print the + ;; buffer's directory+file. + "\n") + (goto-char (point-min)) + ;; TODO: get `recompile' to work. + + ;; just an fyi. compilation-mode will delete my local + ;; variables so be sure to call it *first*. + (perlcritic-error-mode) + ;; (ad-deactivate #'compilation-find-file) + (display-buffer err-buf)) + + ;; Return our success or failure. + perlcritic-ok)))))) + + + + +;;; Parameters for use by perlcritic-region. +(defun perlcritic--param-profile () + "A private method that supplies the -profile FILENAME parameter for +\\[perlcritic-region]" + (if perlcritic-profile (list "-profile" perlcritic-profile))) + +(defun perlcritic--param-noprofile () + "A private method that supplies the -noprofile parameter for +\\[perlcritic-region]" + (if perlcritic-noprofile (list "-noprofile"))) + +(defun perlcritic--param-force () + "A private method that supplies the -force parameter for +\\[perlcritic-region]" + (if perlcritic-force (list "-force"))) + +(defun perlcritic--param-severity () + "A private method that supplies the -severity NUMBER parameter for +\\[perlcritic-region]" + (cond ((stringp perlcritic-severity) + (list "-severity" perlcritic-severity)) + ((numberp perlcritic-severity) + (list "-severity" (number-to-string perlcritic-severity))) + (t nil))) + +(defun perlcritic--param-top () + "A private method that supplies the -top NUMBER parameter for +\\[perlcritic-region]" + (cond ((stringp perlcritic-top) + (list "-top" perlcritic-top)) + ((numberp perlcritic-top) + (list "-top" (number-to-string perlcritic-top))) + (t nil))) + +(defun perlcritic--param-include () + "A private method that supplies the -include REGEXP parameter for +\\[perlcritic-region]" + (if perlcritic-include + (list "-include" perlcritic-include) + nil)) + +(defun perlcritic--param-exclude () + "A private method that supplies the -exclude REGEXP parameter for +\\[perlcritic-region]" + (if perlcritic-exclude + (list "-exclude" perlcritic-exclude) + nil)) + +(defun perlcritic--param-verbose () + "A private method that supplies the -verbose NUMBER parameter for +\\[perlcritic-region]" + (cond ((stringp perlcritic-verbose) + (list "-verbose" perlcritic-verbose)) + ((numberp perlcritic-verbose) + (list "-verbose" (number-to-string perlcritic-verbose))) + (t nil))) + + +;; Interactive functions for use by the user to modify parameters on +;; an adhoc basis. I'm sure there's room for significant niceness +;; here. Suggest something. Please. +(defun perlcritic-profile (profile) + "Sets perlcritic's -profile FILENAME parameter." + (interactive "sperlcritic -profile: ") + (setq perlcritic-profile (if (string= profile "") nil profile))) + +(defun perlcritic-noprofile (noprofile) + "Toggles perlcritic's -noprofile parameter." + (interactive (list (yes-or-no-p "Enable perlcritic -noprofile? "))) + (setq perlcritic-noprofile noprofile)) + +(defun perlcritic-force (force) + "Toggles perlcritic's -force parameter." + (interactive (list (yes-or-no-p "Enable perlcritic -force? "))) + (setq perlcritic-force force)) + +(defun perlcritic-severity (severity) + "Sets perlcritic's -severity NUMBER parameter." + (interactive "nperlcritic -severity: ") + (setq perlcritic-severity severity)) + +(defun perlcritic-top (top) + "Sets perlcritic's -top NUMBER parameter." + (interactive "nperlcritic -top: ") + (setq perlcritic-top top)) + +(defun perlcritic-include (include) + "Sets perlcritic's -include REGEXP parameter." + (interactive "sperlcritic -include: ") + (setq perlcritic-include include)) + +(defun perlcritic-exclude (exclude) + "Sets perlcritic's -exclude REGEXP parameter." + (interactive "sperlcritic -exclude: ") + (setq perlcritic-exclude exclude)) + +(defun perlcritic-verbose (verbose) + "Sets perlcritic's -verbose NUMBER parameter." + (interactive "nperlcritic -verbose: ") + (setq perlcritic-verbose verbose)) + + + + + +;; Hooks compile.el's compilation-find-file to enable our file-less +;; operation. We feed `perlcritic-bin' from STDIN, not from a file. +(defadvice compilation-find-file (around perlcritic-find-file) + "Lets perlcritic lookup into the buffer we just came from and don't +require that the perl document exist in a file anywhere." + (let ((debug-buffer (marker-buffer marker))) + (if (local-variable-p 'perlcritic-buffer debug-buffer) + (setq ad-return-value perlcritic-buffer) + ad-do-it))) + + + + + +;; All the scaffolding of having a minor mode. +(defvar perlcritic-mode nil + "Toggle `perlcritic-mode'") +(make-variable-buffer-local 'perlcritic-mode) + +(defun perlcritic-write-hook () + "Check perlcritic during `write-file-hooks' for `perlcritic-mode'" + (if perlcritic-mode + (save-excursion + (widen) + (mark-whole-buffer) + (let ((perlcritic-ok (perlcritic))) + (if perlcritic-pass-required + ;; Impede saving if we're not ok. + (not perlcritic-ok) + ;; Don't impede saving. We might not be ok but that + ;; doesn't matter now. + nil))) + ;; Don't impede saving. We're not in perlcritic-mode. + nil)) + +;;;###autoload +(defun perlcritic-mode (&optional arg) + "Perl::Critic checking minor mode." + (interactive "P") + + ;; Enable/disable perlcritic-mode + (setq perlcritic-mode (if (null arg) + ;; Nothing! Just toggle it. + (not perlcritic-mode) + ;; Set it. + (> (prefix-numeric-value arg) 0))) + + (if perlcritic-mode + (add-hook 'write-file-hooks 'perlcritic-write-hook nil "local") + (remove-hook 'write-file-hooks 'perlcritic-write-hook))) + +;; Make a nice name for perl critic mode. This string will appear at +;; the bottom of the screen. +(if (not (assq 'perlcritic-mode minor-mode-alist)) + (setq minor-mode-alist + (cons '(perlcritic-mode " Critic") + minor-mode-alist))) + +(provide 'perlcritic) + +;; Local Variables: +;; mode: emacs-lisp +;; tab-width: 8 +;; fill-column: 78 +;; indent-tabs-mode: nil +;; End: +;; ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : + +;;; perlcritic.el ends here diff --git a/inc/Devel/AssertOS.pm b/inc/Devel/AssertOS.pm new file mode 100644 index 0000000..2fe830b --- /dev/null +++ b/inc/Devel/AssertOS.pm @@ -0,0 +1,85 @@ +# $Id: AssertOS.pm,v 1.5 2008/10/27 20:31:21 drhyde Exp $ + +package # +Devel::AssertOS; + +use Devel::CheckOS; + +use strict; + +use vars qw($VERSION); + +$VERSION = '1.1'; + +# localising prevents the warningness leaking out of this module +local $^W = 1; # use warnings is a 5.6-ism + +=head1 NAME + +Devel::AssertOS - require that we are running on a particular OS + +=head1 DESCRIPTION + +Devel::AssertOS is a utility module for Devel::CheckOS and +Devel::AssertOS::*. It is nothing but a magic C that lets you +do this: + + use Devel::AssertOS qw(Linux FreeBSD Cygwin); + +which will die unless the platform the code is running on is Linux, FreeBSD +or Cygwin. + +=cut + +sub import { + shift; + die("Devel::AssertOS needs at least one parameter\n") unless(@_); + Devel::CheckOS::die_if_os_isnt(@_); +} + +=head1 BUGS and FEEDBACK + +I welcome feedback about my code, including constructive criticism. +Bug reports should be made using L or by email. + +You will need to include in your bug report the exact value of $^O, what +the OS is called (eg Windows Vista 64 bit Ultimate Home Edition), and, +if relevant, what "OS family" it should be in and who wrote it. + +If you are feeling particularly generous you can encourage me in my +open source endeavours by buying me something from my wishlist: + L + +=head1 SEE ALSO + +$^O in L + +L + +L + +L + +The use-devel-assertos script + +L + +=head1 AUTHOR + +David Cantrell EFE + +Thanks to David Golden for suggesting that I add this utility module. + +=head1 COPYRIGHT and LICENCE + +Copyright 2007 David Cantrell + +This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. + +=head1 CONSPIRACY + +This module is also free-as-in-mason software. + +=cut + +$^O; diff --git a/inc/Devel/AssertOS/Solaris.pm b/inc/Devel/AssertOS/Solaris.pm new file mode 100644 index 0000000..a6291d6 --- /dev/null +++ b/inc/Devel/AssertOS/Solaris.pm @@ -0,0 +1,22 @@ +# $Id: Solaris.pm,v 1.3 2008/10/27 20:31:21 drhyde Exp $ + +package # +Devel::AssertOS::Solaris; + +use Devel::CheckOS; + +$VERSION = '1.1'; + +sub os_is { $^O eq 'solaris' ? 1 : 0; } + +Devel::CheckOS::die_unsupported() unless(os_is()); + +=head1 COPYRIGHT and LICENCE + +Copyright 2007 - 2008 David Cantrell + +This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. + +=cut + +1; diff --git a/inc/Devel/CheckOS.pm b/inc/Devel/CheckOS.pm new file mode 100644 index 0000000..3bb61fc --- /dev/null +++ b/inc/Devel/CheckOS.pm @@ -0,0 +1,332 @@ +# $Id: CheckOS.pm,v 1.32 2008/11/11 23:49:49 drhyde Exp $ + +package # +Devel::CheckOS; + +use strict; +use Exporter; + +use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS); + +$VERSION = '1.61'; + +# localising prevents the warningness leaking out of this module +local $^W = 1; # use warnings is a 5.6-ism + +@ISA = qw(Exporter); +@EXPORT_OK = qw(os_is os_isnt die_if_os_is die_if_os_isnt die_unsupported list_platforms list_family_members); +%EXPORT_TAGS = ( + all => \@EXPORT_OK, + booleans => [qw(os_is os_isnt die_unsupported)], + fatal => [qw(die_if_os_is die_if_os_isnt)] +); + +=head1 NAME + +Devel::CheckOS - check what OS we're running on + +=head1 DESCRIPTION + +A learned sage once wrote on IRC: + + $^O is stupid and ugly, it wears its pants as a hat + +Devel::CheckOS provides a more friendly interface to $^O, and also lets +you check for various OS "families" such as "Unix", which includes things +like Linux, Solaris, AIX etc. + +It spares perl the embarrassment of wearing its pants on its head by +covering them with a splendid Fedora. + +=head1 SYNOPSIS + + use Devel::CheckOS qw(os_is); + print "Hey, I know this, it's a Unix system\n" if(os_is('Unix')); + + print "You've got Linux 2.6\n" if(os_is('Linux::v2_6')); + +=head1 USING IT IN Makefile.PL or Build.PL + +If you want to use this from Makefile.PL or Build.PL, do +not simply copy the module into your distribution as this may cause +problems when PAUSE and search.cpan.org index the distro. Instead, use +the use-devel-assertos script. + +=head1 FUNCTIONS + +Devel::CheckOS implements the following functions, which load subsidiary +OS-specific modules on demand to do the real work. They can be exported +by listing their names after C. You can also export +groups of functions thus: + + use Devel::CheckOS qw(:booleans); # export the boolean functions + # and 'die_unsupported' + + use Devel::CheckOS qw(:fatal); # export those that die on no match + + use Devel::CheckOS qw(:all); # export everything + +=head2 Boolean functions + +=head3 os_is + +Takes a list of OS names. If the current platform matches any of them, +it returns true, otherwise it returns false. The names can be a mixture +of OSes and OS families, eg ... + + os_is(qw(Unix VMS)); # Unix is a family, VMS is an OS + +=cut + +sub os_is { + my @targets = @_; + my $rval = 0; + foreach my $target (@targets) { + die("Devel::CheckOS: $target isn't a legal OS name\n") + unless($target =~ /^\w+(::\w+)*$/); + eval "use Devel::AssertOS::$target"; + if(!$@) { + no strict 'refs'; + $rval = 1 if(&{"Devel::AssertOS::${target}::os_is"}()); + } + } + return $rval; +} + +=head3 os_isnt + +If the current platform matches any of the parameters it returns false, +otherwise it returns true. + +=cut + +sub os_isnt { + my @targets = @_; + my $rval = 1; + foreach my $target (@targets) { + $rval = 0 if(os_is($target)); + } + return $rval; +} + +=head2 Fatal functions + +=head3 die_if_os_isnt + +As C, except that it dies instead of returning false. The die() +message matches what the CPAN-testers look for to determine if a module +doesn't support a particular platform. + +=cut + +sub die_if_os_isnt { + os_is(@_) ? 1 : die_unsupported(); +} + +=head3 die_if_os_is + +As C, except that it dies instead of returning false. + +=cut + +sub die_if_os_is { + os_isnt(@_) ? 1 : die_unsupported(); +} + +=head2 And some utility functions ... + +=head3 die_unsupported + +This function simply dies with the message "OS unsupported", which is what +the CPAN testers look for to figure out whether a platform is supported or +not. + +=cut + +sub die_unsupported { die("OS unsupported\n"); } + +=head3 list_platforms + +When called in list context, +return a list of all the platforms for which the corresponding +Devel::AssertOS::* module is available. This includes both OSes and OS +families, and both those bundled with this module and any third-party +add-ons you have installed. + +In scalar context, returns a hashref keyed by platform with the filename +of the most recent version of the supporting module that is available to you. +This is to make sure that the use-devel-assertos script Does The Right Thing +in the case where you have installed the module in one version of perl, then +upgraded perl, and installed it again in the new version. Sometimes the old +version of perl and all its modules will still be hanging around and perl +"helpfully" includes the old perl's search path in its own. + +Unfortunately, on some platforms this list may have file case +broken. eg, some platforms might return 'freebsd' instead of 'FreeBSD'. +This is because they have case-insensitive filesystems so things +should Just Work anyway. + +=cut + +my ($re_Devel, $re_AssertOS); + +sub list_platforms { + eval " # only load these if needed + use File::Find::Rule; + use File::Spec; + "; + + die($@) if($@); + if (!$re_Devel) { + my $case_flag = File::Spec->case_tolerant ? '(?i)' : ''; + $re_Devel = qr/$case_flag ^Devel$/x; + $re_AssertOS = qr/$case_flag ^AssertOS$/x; + } + + # sort by mtime, so oldest last + my @modules = sort { + (stat($a->{file}))[9] <=> (stat($b->{file}))[9] + } map { + my (undef, $dir_part, $file_part) = File::Spec->splitpath($_); + $file_part =~ s/\.pm$//; + my (@dirs) = grep {+length} File::Spec->splitdir($dir_part); + foreach my $i (reverse 1..$#dirs) { + next unless $dirs[$i] =~ $re_AssertOS + && $dirs[$i - 1] =~ $re_Devel; + splice @dirs, 0, $i + 1; + last; + } + { + module => join('::', @dirs, $file_part), + file => File::Spec->canonpath($_) + } + } File::Find::Rule->file()->name('*.pm')->in( + grep { -d } + map { File::Spec->catdir($_, qw(Devel AssertOS)) } + @INC + ); + + my %modules = map { + $_->{module} => $_->{file} + } @modules; + + if(wantarray()) { + return sort keys %modules; + } else { + return \%modules; + } +} + +=head3 list_family_members + +Takes the name of an OS 'family' and returns a list of all its members. +In list context, you get a list, in scalar context you get an arrayref. + +If called on something that isn't a family, you get an empty list (or +a ref to an empty array). + +=cut + +sub list_family_members { + my $family = shift() || + die(__PACKAGE__."::list_family_members needs a parameter\n"); + + # this will die if it's the wrong OS, but the module is loaded ... + eval qq{use Devel::AssertOS::$family}; + # ... so we can now query it + my @members = eval qq{ + no strict 'refs'; + &{"Devel::AssertOS::${family}::matches"}() + }; + return wantarray() ? @members : \@members; +} + +=head1 PLATFORMS SUPPORTED + +To see the list of platforms for which information is available, run this: + + perl -MDevel::CheckOS -e 'print join(", ", Devel::CheckOS::list_platforms())' + +Note that capitalisation is important. These are the names of the +underlying Devel::AssertOS::* modules +which do the actual platform detection, so they have to +be 'legal' filenames and module names, which unfortunately precludes +funny characters, so platforms like OS/2 are mis-spelt deliberately. +Sorry. + +Also be aware that not all of them have been properly tested. I don't +have access to most of them and have had to work from information +gleaned from L and a few other places. For a complete list of +OS families, see L. + +If you want to add your own OSes or families, see L +and please feel free to upload the results to the CPAN. + +=head1 BUGS and FEEDBACK + +I welcome feedback about my code, including constructive criticism. +Bug reports should be made using L or by email. + +You will need to include in your bug report the exact value of $^O, what +the OS is called (eg Windows Vista 64 bit Ultimate Home Edition), and, +if relevant, what "OS family" it should be in and who wrote it. + +If you are feeling particularly generous you can encourage me in my +open source endeavours by buying me something from my wishlist: + L + +=head1 SEE ALSO + +$^O in L + +L + +L + +L + +L + +The use-devel-assertos script + +L + +=head1 AUTHOR + +David Cantrell EFE + +Thanks to David Golden for the name and ideas about the interface, and +to the cpan-testers-discuss mailing list for prompting me to write it +in the first place. + +Thanks to Ken Williams, from whose L I lifted some of the +information about what should be in the Unix family. + +Thanks to Billy Abbott for finding some bugs for me on VMS. + +Thanks to Matt Kraai for information about QNX. + +Thanks to Kenichi Ishigaki and Gabor Szabo for reporting a bug on Windows, +and to the former for providing a patch. + +=head1 CVS + +L + +=head1 COPYRIGHT and LICENCE + +Copyright 2007 David Cantrell + +This software is free-as-in-speech software, and may be used, distributed, and modified under the terms of either the GNU General Public Licence version 2 or the Artistic Licence. It's up to you which one you use. The full text of the licences can be found in the files GPL2.txt and ARTISTIC.txt, respectively. + +=head1 HATS + +I recommend buying a Fedora from L. + +=head1 CONSPIRACY + +This module is also free-as-in-mason software. + +=cut + +1; diff --git a/inc/Perl/Critic/BuildUtilities.pm b/inc/Perl/Critic/BuildUtilities.pm new file mode 100644 index 0000000..3c3b09f --- /dev/null +++ b/inc/Perl/Critic/BuildUtilities.pm @@ -0,0 +1,189 @@ +package Perl::Critic::BuildUtilities; + +use 5.006001; +use strict; +use warnings; + +use English q<-no_match_vars>; + +our $VERSION = '1.126'; + +use Exporter 'import'; + +our @EXPORT_OK = qw< + required_module_versions + build_required_module_versions + emit_tar_warning_if_necessary + get_PL_files +>; + + +use Devel::CheckOS qw< os_is >; + + +sub required_module_versions { + return ( + 'B::Keywords' => 1.05, + 'Carp' => 0, + 'Config::Tiny' => 2, + 'English' => 0, + 'Exception::Class' => 1.23, + 'Exporter' => 5.63, + 'Fatal' => 0, + 'File::Basename' => 0, + 'File::Find' => 0, + 'File::Path' => 0, + 'File::Spec' => 0, + 'File::Spec::Unix' => 0, + 'File::Temp' => 0, + 'File::Which' => 0, + 'Getopt::Long' => 0, + 'IO::String' => 0, + 'IPC::Open2' => 1, + 'List::MoreUtils' => 0.19, + 'List::Util' => 0, + 'Module::Build' => 0.4204, + 'Module::Pluggable' => 3.1, + 'PPI' => '1.265', + 'PPI::Document' => '1.265', + 'PPI::Document::File' => '1.265', + 'PPI::Node' => '1.265', + 'PPI::Token::Quote::Single' => '1.265', + 'PPI::Token::Whitespace' => '1.265', + 'PPIx::QuoteLike' => 0, + 'PPIx::Regexp' => '0.027', # Literal { deprecated in re + 'PPIx::Regexp::Util' => '0.068', # is_ppi_regexp_element() + 'PPIx::Utilities::Node' => '1.001', + 'PPIx::Utilities::Statement' => '1.001', + 'Perl::Tidy' => 0, + 'Pod::Parser' => 0, + 'Pod::PlainText' => 0, + 'Pod::Select' => 0, + 'Pod::Spell' => 1, + 'Pod::Usage' => 0, + 'Readonly' => 2.00, + 'Scalar::Util' => 0, + 'String::Format' => '1.18', + 'Task::Weaken' => 0, + 'Term::ANSIColor' => '2.02', + 'Test::Builder' => 0.92, + 'Text::ParseWords' => 3, + 'base' => 0, + 'charnames' => 0, + 'overload' => 0, + 'perl' => 5.006001, + 'strict' => 0, + 'version' => 0.77, + 'warnings' => 0, + ); +} + + +sub build_required_module_versions { + return ( + 'lib' => 0, + 'Test::Deep' => 0, + 'Test::More' => 0, + ); +} + + +my @TARGET_FILES = qw< + t/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.run + t/NamingConventions/Capitalization.run + t/Variables/RequireLocalizedPunctuationVars.run +>; + +sub get_PL_files { + my %PL_files = map { ( "$_.PL" => $_ ) } @TARGET_FILES; + + return \%PL_files; +} + +sub emit_tar_warning_if_necessary { + if ( os_is( qw ) ) { + print <<'END_OF_TAR_WARNING'; +NOTE: tar(1) on some Solaris systems cannot deal well with long file +names. + +If you get warnings about missing files below, please ensure that you +extracted the Perl::Critic tarball using GNU tar. + +END_OF_TAR_WARNING + } +} + + + + +1; + +__END__ + +=head1 NAME + +Perl::Critic::BuildUtilities - Common bits of compiling Perl::Critic. + + +=head1 DESCRIPTION + +Various utilities used in assembling Perl::Critic, primary for use by +*.PL programs that generate code. + + +=head1 IMPORTABLE SUBROUTINES + +=over + +=item C + +Returns a reference to a hash with a mapping from the name of a .PL +program to an array of the parameters to be passed to it, suited for +use by L or +L. May print to C messages +about what it is doing. + + +=item C + +Prints to C a list of all the unlisted (e.g. things in core +like L), optional (e.g. +L), or potentially indirect (e.g. +L) dependencies, plus their versions, if +they're installed. + + +=item C + +On some Solaris systems, C can't deal with long file names and +thus files are not correctly extracted from the tarball. So this +prints a warning if the current system is Solaris. + + +=back + + +=head1 AUTHOR + +Elliot Shank C<< >> + + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2007-2011, Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/inc/Perl/Critic/Module/Build.pm b/inc/Perl/Critic/Module/Build.pm new file mode 100644 index 0000000..881428f --- /dev/null +++ b/inc/Perl/Critic/Module/Build.pm @@ -0,0 +1,158 @@ +package Perl::Critic::Module::Build; + +use 5.006001; + +use strict; +use warnings; + +our $VERSION = '1.126'; + +use Carp; +use English qw< $OS_ERROR $EXECUTABLE_NAME -no_match_vars >; + + +use base 'Perl::Critic::Module::Build::Standard'; + + +sub ACTION_policysummary { + my ($self) = @_; + + require Perl::Critic::PolicySummaryGenerator; + Perl::Critic::PolicySummaryGenerator->import( + qw< generate_policy_summary > + ); + + my $policy_summary_file = generate_policy_summary(); + $self->add_to_cleanup( $policy_summary_file ); + + return; +} + + +sub ACTION_nytprof { + my ($self) = @_; + + $self->depends_on('build'); + $self->_run_nytprof(); + + return; +} + + +sub authortest_dependencies { + my ($self) = @_; + + $self->depends_on('policysummary'); + $self->SUPER::authortest_dependencies(); + + return; +} + + +sub _run_nytprof { + my ($self) = @_; + + eval { require Devel::NYTProf; 1 } + or croak 'Devel::NYTProf is required to run nytprof'; + + eval { require File::Which; File::Which->import('which'); 1 } + or croak 'File::Which is required to run nytprof'; + + my $nytprofhtml = which('nytprofhtml') + or croak 'Could not find nytprofhtml in your PATH'; + + my $this_perl = $EXECUTABLE_NAME; + my @perl_args = qw(-Iblib/lib -d:NYTProf blib/script/perlcritic); + my @perlcritic_args = + qw< + --noprofile + --severity=1 + --theme=core + --exclude=TidyCode + --exclude=PodSpelling + --exclude=RcsKeywords + blib + >; + warn "Running: $this_perl @perl_args @perlcritic_args\n"; + + my $status_perlcritic = system $this_perl, @perl_args, @perlcritic_args; + croak "perlcritic failed with status $status_perlcritic" + if $status_perlcritic == 1; + + my $status_nytprofhtml = system $nytprofhtml; + croak "nytprofhtml failed with status $status_nytprofhtml" + if $status_nytprofhtml; + + return; +} + + +1; + + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Module::Build - Customization of L for L. + + +=head1 DESCRIPTION + +This is a custom subclass of L (actually, +L) that enhances existing functionality +and adds more for the benefit of installing and developing L. +The following actions have been added or redefined: + + +=head1 ACTIONS + +=over + +=item policysummary + +Generates the F file. This should only be used by +C developers. This action is also invoked by the C +action, so the F file will be generated whenever you create +a distribution with the C or C targets. + + +=item nytprof + +Runs perlcritic under the L profiler and generates +an HTML report in F. + + +=back + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/inc/Perl/Critic/Module/Build/Standard.pm b/inc/Perl/Critic/Module/Build/Standard.pm new file mode 100644 index 0000000..5409784 --- /dev/null +++ b/inc/Perl/Critic/Module/Build/Standard.pm @@ -0,0 +1,176 @@ +package Perl::Critic::Module::Build::Standard; + +use 5.006001; + +use strict; +use warnings; + +our $VERSION = '1.126'; + +use Carp; +use English qw< $OS_ERROR -no_match_vars >; + + +use base 'Module::Build'; + + +sub ACTION_authortest { + my ($self) = @_; + + $self->authortest_dependencies(); + $self->depends_on('test'); + + return; +} + + +sub ACTION_authortestcover { + my ($self) = @_; + + $self->authortest_dependencies(); + $self->depends_on('testcover'); + + return; +} + + +sub ACTION_distdir { + my ($self, @arguments) = @_; + + $self->depends_on('authortest'); + + return $self->SUPER::ACTION_distdir(@arguments); +} + + +sub ACTION_manifest { + my ($self, @arguments) = @_; + + # Make sure we get rid of files that no longer exist. + if (-e 'MANIFEST') { + unlink 'MANIFEST' or die "Can't unlink MANIFEST: $OS_ERROR"; + } + + return $self->SUPER::ACTION_manifest(@arguments); +} + + +sub tap_harness_args { + my ($self) = @_; + + return $self->_tap_harness_args() if $ENV{RUNNING_UNDER_TEAMCITY}; + return; +} + + +sub _tap_harness_args { + return {formatter_class => 'TAP::Formatter::TeamCity', merge => 1}; +} + + +sub authortest_dependencies { + my ($self) = @_; + + $self->depends_on('build'); + $self->depends_on('manifest'); + $self->depends_on('distmeta'); + + $self->test_files( qw< t xt > ); + $self->recursive_test_files(1); + + return; +} + + +1; + + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Module::Build::Standard - Customization of L for L distributions. + + +=head1 DESCRIPTION + +This is a custom subclass of L that enhances existing +functionality and adds more for the benefit of installing and +developing L. The following actions have been added +or redefined: + + +=head1 ACTIONS + +=over + +=item authortest + +Runs the regular tests plus the author tests (those in F). +It used to be the case that author tests were run if an environment +variable was set or if a F<.svn> directory existed. What ended up +happening was that people that had that environment variable set for +other purposes or who had done a checkout of the code repository would +run those tests, which would fail, and we'd get bug reports for +something not expected to run elsewhere. Now, you've got to +explicitly ask for the author tests to be run. + + +=item authortestcover + +As C is to the standard C action, C +is to the standard C action. + + +=item distdir + +In addition to the standard action, this adds a dependency upon the +C action so you can't do a release without passing the +author tests. + + +=back + + +=head1 METHODS + +In addition to the above actions: + + +=head2 C + +Sets up dependencies upon the C, C, and C actions, +adds F to the set of test directories, and turns on the recursive +search for tests. + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/inc/Perl/Critic/PolicySummaryGenerator.pm b/inc/Perl/Critic/PolicySummaryGenerator.pm new file mode 100644 index 0000000..67ccfa6 --- /dev/null +++ b/inc/Perl/Critic/PolicySummaryGenerator.pm @@ -0,0 +1,210 @@ +package Perl::Critic::PolicySummaryGenerator; + +use 5.006001; +use strict; +use warnings; + +use Exporter 'import'; + +use lib qw< blib lib >; +use Carp qw< confess >; +use English qw< -no_match_vars >; + +use Perl::Critic::Config; +use Perl::Critic::Exception::IO (); +use Perl::Critic::PolicyFactory (-test => 1); +use Perl::Critic::Utils qw< :characters >; +use Perl::Critic::Utils::POD qw< get_module_abstract_from_file >; + +use Exception::Class (); # Must be after P::C::Exception::* + +#----------------------------------------------------------------------------- + +our $VERSION = '1.126'; + +#----------------------------------------------------------------------------- + +our @EXPORT_OK = qw< generate_policy_summary >; + +#----------------------------------------------------------------------------- + +sub generate_policy_summary { + + print "\n\nGenerating Perl::Critic::PolicySummary.\n"; + + + my $configuration = + Perl::Critic::Config->new(-profile => $EMPTY, -severity => 1, -theme => 'core'); + + my @policies = $configuration->all_policies_enabled_or_not(); + my $policy_summary = 'lib/Perl/Critic/PolicySummary.pod'; + + ## no critic (RequireBriefOpen) + open my $pod_file, '>', $policy_summary + or confess "Could not open $policy_summary: $ERRNO"; + + print {$pod_file} <<'END_HEADER'; + +=head1 NAME + +Perl::Critic::PolicySummary - Descriptions of the Policy modules included with L itself. + + +=head1 DESCRIPTION + +The following Policy modules are distributed with Perl::Critic. (There are +additional Policies that can be found in add-on distributions.) The Policy +modules have been categorized according to the table of contents in Damian +Conway's book B. Since most coding standards take the +form "do this..." or "don't do that...", I have adopted the convention of +naming each module C or C. Each Policy +is listed here with its default severity. If you don't agree with the default +severity, you can change it in your F<.perlcriticrc> file (try C for a starting version). See the documentation of each +module for its specific details. + + +=head1 POLICIES + +END_HEADER + + +my $format = <<'END_POLICY'; +=head2 L<%s|%s> + +%s [Default severity %d] + +END_POLICY + +eval { + foreach my $policy (@policies) { + my $module_abstract = $policy->get_raw_abstract(); + + printf + {$pod_file} + $format, + $policy->get_short_name(), + $policy->get_long_name(), + $module_abstract, + $policy->default_severity(); + } + + 1; +} + or do { + # Yes, an assignment and not equality test. + if (my $exception = $EVAL_ERROR) { + if ( ref $exception ) { + $exception->show_trace(1); + } + + print {*STDERR} "$exception\n"; + } + else { + print {*STDERR} "Failed printing abstracts for an unknown reason.\n"; + } + + exit 1; + }; + + +print {$pod_file} <<'END_FOOTER'; + +=head1 VERSION + +This is part of L version 1.126. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut +END_FOOTER + + + close $pod_file or confess "Could not close $policy_summary: $ERRNO"; + + print "Done.\n\n"; + + return $policy_summary; + +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::PolicySummaryGenerator - Create F file. + + +=head1 DESCRIPTION + +This module contains subroutines for generating the +L POD file. This file contains a brief +summary of all the Policies that ship with L. These +summaries are extracted from the C section of the POD for each +Policy module. + +This library should be used at author-time to generate the +F file B releasing a new distribution. See +also the C action in L. + + +=head1 IMPORTABLE SUBROUTINES + +=over + +=item C + +Generates the F file which contains a brief summary of all +the Policies in this distro. Returns the relative path this file. Unlike +most of the other subroutines here, this subroutine should be used when +creating a distribution, not when building or installing an existing +distribution. + +=back + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2009-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic.pm b/lib/Perl/Critic.pm new file mode 100644 index 0000000..6f40e12 --- /dev/null +++ b/lib/Perl/Critic.pm @@ -0,0 +1,1020 @@ +package Perl::Critic; + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); +use Readonly; + +use Exporter 'import'; + +use File::Spec; +use List::MoreUtils qw< firstidx >; +use Scalar::Util qw< blessed >; + +use Perl::Critic::Exception::Configuration::Generic; +use Perl::Critic::Config; +use Perl::Critic::Violation; +use Perl::Critic::Document; +use Perl::Critic::Statistics; +use Perl::Critic::Utils qw< :characters hashify shebang_line >; + +#----------------------------------------------------------------------------- + +our $VERSION = '1.140'; + +Readonly::Array our @EXPORT_OK => qw(critique); + +#============================================================================= +# PUBLIC methods + +sub new { + my ( $class, %args ) = @_; + my $self = bless {}, $class; + $self->{_config} = $args{-config} || Perl::Critic::Config->new( %args ); + $self->{_stats} = Perl::Critic::Statistics->new(); + return $self; +} + +#----------------------------------------------------------------------------- + +sub config { + my $self = shift; + return $self->{_config}; +} + +#----------------------------------------------------------------------------- + +sub add_policy { + my ( $self, @args ) = @_; + #Delegate to Perl::Critic::Config + return $self->config()->add_policy( @args ); +} + +#----------------------------------------------------------------------------- + +sub policies { + my $self = shift; + + #Delegate to Perl::Critic::Config + return $self->config()->policies(); +} + +#----------------------------------------------------------------------------- + +sub statistics { + my $self = shift; + return $self->{_stats}; +} + +#----------------------------------------------------------------------------- + +sub critique { ## no critic (ArgUnpacking) + + #------------------------------------------------------------------- + # This subroutine can be called as an object method or as a static + # function. In the latter case, the first argument can be a + # hashref of configuration parameters that shall be used to create + # an object behind the scenes. Note that this object does not + # persist. In other words, it is not a singleton. Here are some + # of the ways this subroutine might get called: + # + # #Object style... + # $critic->critique( $code ); + # + # #Functional style... + # critique( $code ); + # critique( {}, $code ); + # critique( {-foo => bar}, $code ); + #------------------------------------------------------------------ + + my ( $self, $source_code ) = @_ >= 2 ? @_ : ( {}, $_[0] ); + $self = ref $self eq 'HASH' ? __PACKAGE__->new(%{ $self }) : $self; + return if not defined $source_code; # If no code, then nothing to do. + + my $config = $self->config(); + my $doc = + blessed($source_code) && $source_code->isa('Perl::Critic::Document') + ? $source_code + : Perl::Critic::Document->new( + '-source' => $source_code, + '-program-extensions' => [$config->program_extensions_as_regexes()], + ); + + if ( 0 == $self->policies() ) { + Perl::Critic::Exception::Configuration::Generic->throw( + message => 'There are no enabled policies.', + ) + } + + return $self->_gather_violations($doc); +} + +#============================================================================= +# PRIVATE methods + +sub _gather_violations { + my ($self, $doc) = @_; + + # Disable exempt code lines, if desired + if ( not $self->config->force() ) { + $doc->process_annotations(); + } + + # Evaluate each policy + my @policies = $self->config->policies(); + my @ordered_policies = _futz_with_policy_order(@policies); + my @violations = map { _critique($_, $doc) } @ordered_policies; + + # Accumulate statistics + $self->statistics->accumulate( $doc, \@violations ); + + # If requested, rank violations by their severity and return the top N. + if ( @violations && (my $top = $self->config->top()) ) { + my $limit = @violations < $top ? $#violations : $top-1; + @violations = Perl::Critic::Violation::sort_by_severity(@violations); + @violations = ( reverse @violations )[ 0 .. $limit ]; #Slicing... + } + + # Always return violations sorted by location + return Perl::Critic::Violation->sort_by_location(@violations); +} + +#============================================================================= +# PRIVATE functions + +sub _critique { + my ($policy, $doc) = @_; + + return if not $policy->prepare_to_scan_document($doc); + + my $maximum_violations = $policy->get_maximum_violations_per_document(); + return if defined $maximum_violations && $maximum_violations == 0; + + my @violations = (); + + TYPE: + for my $type ( $policy->applies_to() ) { + my @elements; + if ($type eq 'PPI::Document') { + @elements = ($doc); + } + else { + @elements = @{ $doc->find($type) || [] }; + } + + ELEMENT: + for my $element (@elements) { + + # Evaluate the policy on this $element. A policy may + # return zero or more violations. We only want the + # violations that occur on lines that have not been + # disabled. + + VIOLATION: + for my $violation ( $policy->violates( $element, $doc ) ) { + + my $line = $violation->location()->[0]; + if ( $doc->line_is_disabled_for_policy($line, $policy) ) { + $doc->add_suppressed_violation($violation); + next VIOLATION; + } + + push @violations, $violation; + last TYPE if defined $maximum_violations and @violations >= $maximum_violations; + } + } + } + + return @violations; +} + +#----------------------------------------------------------------------------- + +sub _futz_with_policy_order { + # The ProhibitUselessNoCritic policy is another special policy. It + # deals with the violations that *other* Policies produce. Therefore + # it needs to be run *after* all the other Policies. TODO: find + # a way for Policies to express an ordering preference somehow. + + my @policy_objects = @_; + my $magical_policy_name = 'Perl::Critic::Policy::Miscellanea::ProhibitUselessNoCritic'; + my $idx = firstidx {ref $_ eq $magical_policy_name} @policy_objects; + push @policy_objects, splice @policy_objects, $idx, 1; + return @policy_objects; +} + +#----------------------------------------------------------------------------- + +1; + + + +__END__ + +=pod + +=encoding utf8 + +=for stopwords DGR INI-style API -params pbp refactored ActivePerl ben Jore +Dolan's Twitter Alexandr Ciornii Ciornii's downloadable O'Regan +Hukins Omer Gazit Zacks Howarth Walde Rolsky Jakub Wilk Trosien Creenan +Balhatchet Paaske Tørholm Raspass Tonkin Katz Berndt Sergey Gabor Szabo +Knop Eldridge Steinbrunner Kimmel Guillaume Aubert Anirvan Chatterjee +Rinaldo Ollis Etheridge Brømsø Slaven Rezić Szymon Nieznański +Oschwald Mita + +=head1 NAME + +Perl::Critic - Critique Perl source code for best-practices. + + +=head1 SYNOPSIS + + use Perl::Critic; + my $file = shift; + my $critic = Perl::Critic->new(); + my @violations = $critic->critique($file); + print @violations; + + +=head1 DESCRIPTION + +Perl::Critic is an extensible framework for creating and applying coding +standards to Perl source code. Essentially, it is a static source code +analysis engine. Perl::Critic is distributed with a number of +L modules that attempt to enforce various coding +guidelines. Most Policy modules are based on Damian Conway's book B. However, Perl::Critic is B limited to PBP and will even +support Policies that contradict Conway. You can enable, disable, and +customize those Polices through the Perl::Critic interface. You can also +create new Policy modules that suit your own tastes. + +For a command-line interface to Perl::Critic, see the documentation for +L. If you want to integrate Perl::Critic with your build process, +L provides an interface that is suitable for test +programs. Also, L is useful for gradually +applying coding standards to legacy code. For the ultimate convenience (at +the expense of some flexibility) see the L pragma. + +If you'd like to try L without installing anything, there is a +web-service available at L. The web-service does not +yet support all the configuration features that are available in the native +Perl::Critic API, but it should give you a good idea of what it does. + +Also, ActivePerl includes a very slick graphical interface to Perl-Critic +called C. You can get a free community edition of ActivePerl +from L. + + +=head1 PREREQUISITES + +Perl::Critic runs on Perl back to Perl 5.6.1. It relies on the L +module to do the heavy work of parsing Perl. + + +=head1 INTERFACE SUPPORT + +The C module is considered to be a public class. Any +changes to its interface will go through a deprecation cycle. + + +=head1 CONSTRUCTOR + +=over + +=item C<< new( [ -profile => $FILE, -severity => $N, -theme => $string, -include => \@PATTERNS, -exclude => \@PATTERNS, -top => $N, -only => $B, -profile-strictness => $PROFILE_STRICTNESS_{WARN|FATAL|QUIET}, -force => $B, -verbose => $N ], -color => $B, -pager => $string, -allow-unsafe => $B, -criticism-fatal => $B) >> + +=item C<< new() >> + +Returns a reference to a new Perl::Critic object. Most arguments are just +passed directly into L, but I have described them here +as well. The default value for all arguments can be defined in your +F<.perlcriticrc> file. See the L<"CONFIGURATION"> section for more +information about that. All arguments are optional key-value pairs as +follows: + +B<-profile> is a path to a configuration file. If C<$FILE> is not defined, +Perl::Critic::Config attempts to find a F<.perlcriticrc> configuration file in +the current directory, and then in your home directory. Alternatively, you +can set the C environment variable to point to a file in another +location. If a configuration file can't be found, or if C<$FILE> is an empty +string, then all Policies will be loaded with their default configuration. +See L<"CONFIGURATION"> for more information. + +B<-severity> is the minimum severity level. Only Policy modules that have a +severity greater than C<$N> will be applied. Severity values are integers +ranging from 1 (least severe violations) to 5 (most severe violations). The +default is 5. For a given C<-profile>, decreasing the C<-severity> will +usually reveal more Policy violations. You can set the default value for this +option in your F<.perlcriticrc> file. Users can redefine the severity level +for any Policy in their F<.perlcriticrc> file. See L<"CONFIGURATION"> for +more information. + +If it is difficult for you to remember whether severity "5" is the most or +least restrictive level, then you can use one of these named values: + + SEVERITY NAME ...is equivalent to... SEVERITY NUMBER + -------------------------------------------------------- + -severity => 'gentle' -severity => 5 + -severity => 'stern' -severity => 4 + -severity => 'harsh' -severity => 3 + -severity => 'cruel' -severity => 2 + -severity => 'brutal' -severity => 1 + +The names reflect how severely the code is criticized: a C criticism +reports only the most severe violations, and so on down to a C +criticism which reports even the most minor violations. + +B<-theme> is special expression that determines which Policies to apply based +on their respective themes. For example, the following would load only +Policies that have a 'bugs' AND 'pbp' theme: + + my $critic = Perl::Critic->new( -theme => 'bugs && pbp' ); + +Unless the C<-severity> option is explicitly given, setting C<-theme> silently +causes the C<-severity> to be set to 1. You can set the default value for +this option in your F<.perlcriticrc> file. See the L<"POLICY THEMES"> section +for more information about themes. + + +B<-include> is a reference to a list of string C<@PATTERNS>. Policy modules +that match at least one C will always be loaded, irrespective +of all other settings. For example: + + my $critic = Perl::Critic->new(-include => ['layout'], -severity => 4); + +This would cause Perl::Critic to apply all the C Policy modules +even though they have a severity level that is less than 4. You can set the +default value for this option in your F<.perlcriticrc> file. You can also use +C<-include> in conjunction with the C<-exclude> option. Note that C<-exclude> +takes precedence over C<-include> when a Policy matches both patterns. + +B<-exclude> is a reference to a list of string C<@PATTERNS>. Policy modules +that match at least one C will not be loaded, irrespective of +all other settings. For example: + + my $critic = Perl::Critic->new(-exclude => ['strict'], -severity => 1); + +This would cause Perl::Critic to not apply the C and +C Policy modules even though they have a severity level that +is greater than 1. You can set the default value for this option in your +F<.perlcriticrc> file. You can also use C<-exclude> in conjunction with the +C<-include> option. Note that C<-exclude> takes precedence over C<-include> +when a Policy matches both patterns. + +B<-single-policy> is a string C. Only one policy that matches +C will be used. Policies that do not match will be excluded. +This option has precedence over the C<-severity>, C<-theme>, C<-include>, +C<-exclude>, and C<-only> options. You can set the default value for this +option in your F<.perlcriticrc> file. + +B<-top> is the maximum number of Violations to return when ranked by their +severity levels. This must be a positive integer. Violations are still +returned in the order that they occur within the file. Unless the C<-severity> +option is explicitly given, setting C<-top> silently causes the C<-severity> +to be set to 1. You can set the default value for this option in your +F<.perlcriticrc> file. + +B<-only> is a boolean value. If set to a true value, Perl::Critic will only +choose from Policies that are mentioned in the user's profile. If set to a +false value (which is the default), then Perl::Critic chooses from all the +Policies that it finds at your site. You can set the default value for this +option in your F<.perlcriticrc> file. + +B<-profile-strictness> is an enumerated value, one of +L (the default), +L, and +L. If set to +L, Perl::Critic +will make certain warnings about problems found in a F<.perlcriticrc> or file +specified via the B<-profile> option fatal. For example, Perl::Critic normally +only Cs about profiles referring to non-existent Policies, but this +value makes this situation fatal. Correspondingly, +L makes +Perl::Critic shut up about these things. + +B<-force> is a boolean value that controls whether Perl::Critic observes the +magical C<"## no critic"> annotations in your code. If set to a true value, +Perl::Critic will analyze all code. If set to a false value (which is the +default) Perl::Critic will ignore code that is tagged with these annotations. +See L<"BENDING THE RULES"> for more information. You can set the default +value for this option in your F<.perlcriticrc> file. + +B<-verbose> can be a positive integer (from 1 to 11), or a literal format +specification. See L for an +explanation of format specifications. You can set the default value for this +option in your F<.perlcriticrc> file. + +B<-unsafe> directs Perl::Critic to allow the use of Policies that are marked +as "unsafe" by the author. Such policies may compile untrusted code or do +other nefarious things. + +B<-color> and B<-pager> are not used by Perl::Critic but is provided for the +benefit of L. + +B<-criticism-fatal> is not used by Perl::Critic but is provided for the +benefit of L. + +B<-color-severity-highest>, B<-color-severity-high>, B<-color-severity- +medium>, B<-color-severity-low>, and B<-color-severity-lowest> are not used by +Perl::Critic, but are provided for the benefit of L. +Each is set to the Term::ANSIColor color specification to be used to display +violations of the corresponding severity. + +B<-files-with-violations> and B<-files-without-violations> are not used by +Perl::Critic, but are provided for the benefit of L, to +cause only the relevant filenames to be displayed. + +=back + + +=head1 METHODS + +=over + +=item C + +Runs the C<$source_code> through the Perl::Critic engine using all the +Policies that have been loaded into this engine. If C<$source_code> is a +scalar reference, then it is treated as a string of actual Perl code. If +C<$source_code> is a reference to an instance of L, then that +instance is used directly. Otherwise, it is treated as a path to a local file +containing Perl code. This method returns a list of +L objects for each violation of the loaded Policies. +The list is sorted in the order that the Violations appear in the code. If +there are no violations, this method returns an empty list. + +=item C<< add_policy( -policy => $policy_name, -params => \%param_hash ) >> + +Creates a Policy object and loads it into this Critic. If the object cannot +be instantiated, it will throw a fatal exception. Otherwise, it returns a +reference to this Critic. + +B<-policy> is the name of a L subclass module. The +C<'Perl::Critic::Policy'> portion of the name can be omitted for brevity. +This argument is required. + +B<-params> is an optional reference to a hash of Policy parameters. The +contents of this hash reference will be passed into to the constructor of the +Policy module. See the documentation in the relevant Policy module for a +description of the arguments it supports. + +=item C< policies() > + +Returns a list containing references to all the Policy objects that have been +loaded into this engine. Objects will be in the order that they were loaded. + +=item C< config() > + +Returns the L object that was created for or given to +this Critic. + +=item C< statistics() > + +Returns the L object that was created for this +Critic. The Statistics object accumulates data for all files that are +analyzed by this Critic. + +=back + + +=head1 FUNCTIONAL INTERFACE + +For those folks who prefer to have a functional interface, The C +method can be exported on request and called as a static function. If the +first argument is a hashref, its contents are used to construct a new +Perl::Critic object internally. The keys of that hash should be the same as +those supported by the C method. Here are some examples: + + use Perl::Critic qw(critique); + + # Use default parameters... + @violations = critique( $some_file ); + + # Use custom parameters... + @violations = critique( {-severity => 2}, $some_file ); + + # As a one-liner + %> perl -MPerl::Critic=critique -e 'print critique(shift)' some_file.pm + +None of the other object-methods are currently supported as static +functions. Sorry. + + +=head1 CONFIGURATION + +Most of the settings for Perl::Critic and each of the Policy modules can be +controlled by a configuration file. The default configuration file is called +F<.perlcriticrc>. Perl::Critic will look for this file in the current +directory first, and then in your home directory. Alternatively, you can set +the C environment variable to explicitly point to a different file +in another location. If none of these files exist, and the C<-profile> option +is not given to the constructor, then all the modules that are found in the +Perl::Critic::Policy namespace will be loaded with their default +configuration. + +The format of the configuration file is a series of INI-style blocks that +contain key-value pairs separated by '='. Comments should start with '#' and +can be placed on a separate line or after the name-value pairs if you desire. + +Default settings for Perl::Critic itself can be set B For example, putting any or all of these at the top of your +configuration file will set the default value for the corresponding +constructor argument. + + severity = 3 #Integer or named level + only = 1 #Zero or One + force = 0 #Zero or One + verbose = 4 #Integer or format spec + top = 50 #A positive integer + theme = (pbp || security) && bugs #A theme expression + include = NamingConventions ClassHierarchies #Space-delimited list + exclude = Variables Modules::RequirePackage #Space-delimited list + criticism-fatal = 1 #Zero or One + color = 1 #Zero or One + allow-unsafe = 1 #Zero or One + pager = less #pager to pipe output to + +The remainder of the configuration file is a series of blocks like this: + + [Perl::Critic::Policy::Category::PolicyName] + severity = 1 + set_themes = foo bar + add_themes = baz + maximum_violations_per_document = 57 + arg1 = value1 + arg2 = value2 + +C is the full name of a module +that implements the policy. The Policy modules distributed with Perl::Critic +have been grouped into categories according to the table of contents in Damian +Conway's book B. For brevity, you can omit the +C<'Perl::Critic::Policy'> part of the module name. + +C is the level of importance you wish to assign to the Policy. All +Policy modules are defined with a default severity value ranging from 1 (least +severe) to 5 (most severe). However, you may disagree with the default +severity and choose to give it a higher or lower severity, based on your own +coding philosophy. You can set the C to an integer from 1 to 5, or +use one of the equivalent names: + + SEVERITY NAME ...is equivalent to... SEVERITY NUMBER + ---------------------------------------------------- + gentle 5 + stern 4 + harsh 3 + cruel 2 + brutal 1 + +The names reflect how severely the code is criticized: a C criticism +reports only the most severe violations, and so on down to a C +criticism which reports even the most minor violations. + +C sets the theme for the Policy and overrides its default theme. +The argument is a string of one or more whitespace-delimited alphanumeric +words. Themes are case-insensitive. See L<"POLICY THEMES"> for more +information. + +C appends to the default themes for this Policy. The argument is +a string of one or more whitespace-delimited words. Themes are case- +insensitive. See L<"POLICY THEMES"> for more information. + +C limits the number of Violations the Policy +will return for a given document. Some Policies have a default limit; see the +documentation for the individual Policies to see whether there is one. To +force a Policy to not have a limit, specify "no_limit" or the empty string for +the value of this parameter. + +The remaining key-value pairs are configuration parameters that will be passed +into the constructor for that Policy. The constructors for most Policy +objects do not support arguments, and those that do should have reasonable +defaults. See the documentation on the appropriate Policy module for more +details. + +Instead of redefining the severity for a given Policy, you can completely +disable a Policy by prepending a '-' to the name of the module in your +configuration file. In this manner, the Policy will never be loaded, +regardless of the C<-severity> given to the Perl::Critic constructor. + +A simple configuration might look like this: + + #-------------------------------------------------------------- + # I think these are really important, so always load them + + [TestingAndDebugging::RequireUseStrict] + severity = 5 + + [TestingAndDebugging::RequireUseWarnings] + severity = 5 + + #-------------------------------------------------------------- + # I think these are less important, so only load when asked + + [Variables::ProhibitPackageVars] + severity = 2 + + [ControlStructures::ProhibitPostfixControls] + allow = if unless # My custom configuration + severity = cruel # Same as "severity = 2" + + #-------------------------------------------------------------- + # Give these policies a custom theme. I can activate just + # these policies by saying `perlcritic -theme larry` + + [Modules::RequireFilenameMatchesPackage] + add_themes = larry + + [TestingAndDebugging::RequireTestLables] + add_themes = larry curly moe + + #-------------------------------------------------------------- + # I do not agree with these at all, so never load them + + [-NamingConventions::Capitalization] + [-ValuesAndExpressions::ProhibitMagicNumbers] + + #-------------------------------------------------------------- + # For all other Policies, I accept the default severity, + # so no additional configuration is required for them. + +For additional configuration examples, see the F file that is +included in this F directory of this distribution. + +Damian Conway's own Perl::Critic configuration is also included in this +distribution as F. + + +=head1 THE POLICIES + +A large number of Policy modules are distributed with Perl::Critic. They are +described briefly in the companion document L and +in more detail in the individual modules themselves. Say C<"perlcritic -doc +PATTERN"> to see the perldoc for all Policy modules that match the regex +C + +There are a number of distributions of additional policies on CPAN. If +L doesn't contain a policy that you want, some one may have +already written it. See the L section below for a list of some +of these distributions. + + +=head1 POLICY THEMES + +Each Policy is defined with one or more "themes". Themes can be used to +create arbitrary groups of Policies. They are intended to provide an +alternative mechanism for selecting your preferred set of Policies. For +example, you may wish disable a certain subset of Policies when analyzing test +programs. Conversely, you may wish to enable only a specific subset of +Policies when analyzing modules. + +The Policies that ship with Perl::Critic have been broken into the following +themes. This is just our attempt to provide some basic logical groupings. +You are free to invent new themes that suit your needs. + + THEME DESCRIPTION + -------------------------------------------------------------------------- + core All policies that ship with Perl::Critic + pbp Policies that come directly from "Perl Best Practices" + bugs Policies that that prevent or reveal bugs + certrec Policies that CERT recommends + certrule Policies that CERT considers rules + maintenance Policies that affect the long-term health of the code + cosmetic Policies that only have a superficial effect + complexity Policies that specifically relate to code complexity + security Policies that relate to security issues + tests Policies that are specific to test programs + + +Any Policy may fit into multiple themes. Say C<"perlcritic -list"> to get a +listing of all available Policies and the themes that are associated with each +one. You can also change the theme for any Policy in your F<.perlcriticrc> +file. See the L<"CONFIGURATION"> section for more information about that. + +Using the C<-theme> option, you can create an arbitrarily complex rule that +determines which Policies will be loaded. Precedence is the same as regular +Perl code, and you can use parentheses to enforce precedence as well. +Supported operators are: + + Operator Alternative Example + ----------------------------------------------------------------- + && and 'pbp && core' + || or 'pbp || (bugs && security)' + ! not 'pbp && ! (portability || complexity)' + +Theme names are case-insensitive. If the C<-theme> is set to an empty string, +then it evaluates as true all Policies. + + +=head1 BENDING THE RULES + +Perl::Critic takes a hard-line approach to your code: either you comply or you +don't. In the real world, it is not always practical (nor even possible) to +fully comply with coding standards. In such cases, it is wise to show that +you are knowingly violating the standards and that you have a Damn Good Reason +(DGR) for doing so. + +To help with those situations, you can direct Perl::Critic to ignore certain +lines or blocks of code by using annotations: + + require 'LegacyLibaray1.pl'; ## no critic + require 'LegacyLibrary2.pl'; ## no critic + + for my $element (@list) { + + ## no critic + + $foo = ""; #Violates 'ProhibitEmptyQuotes' + $barf = bar() if $foo; #Violates 'ProhibitPostfixControls' + #Some more evil code... + + ## use critic + + #Some good code... + do_something($_); + } + +The C<"## no critic"> annotations direct Perl::Critic to ignore the remaining +lines of code until a C<"## use critic"> annotation is found. If the C<"## no +critic"> annotation is on the same line as a code statement, then only that +line of code is overlooked. To direct perlcritic to ignore the C<"## no +critic"> annotations, use the C<--force> option. + +A bare C<"## no critic"> annotation disables all the active Policies. If you +wish to disable only specific Policies, add a list of Policy names as +arguments, just as you would for the C<"no strict"> or C<"no warnings"> +pragmas. For example, this would disable the C and +C policies until the end of the block or until the +next C<"## use critic"> annotation (whichever comes first): + + ## no critic (EmptyQuotes, PostfixControls) + + # Now exempt from ValuesAndExpressions::ProhibitEmptyQuotes + $foo = ""; + + # Now exempt ControlStructures::ProhibitPostfixControls + $barf = bar() if $foo; + + # Still subjected to ValuesAndExpression::RequireNumberSeparators + $long_int = 10000000000; + +Since the Policy names are matched against the C<"## no critic"> arguments as +regular expressions, you can abbreviate the Policy names or disable an entire +family of Policies in one shot like this: + + ## no critic (NamingConventions) + + # Now exempt from NamingConventions::Capitalization + my $camelHumpVar = 'foo'; + + # Now exempt from NamingConventions::Capitalization + sub camelHumpSub {} + +The argument list must be enclosed in parentheses or brackets and must contain +one or more comma-separated barewords (e.g. don't use quotes). +The C<"## no critic"> annotations can be nested, and Policies named by an inner +annotation will be disabled along with those already disabled an outer +annotation. + +Some Policies like C apply to an entire +block of code. In those cases, the C<"## no critic"> annotation must appear +on the line where the violation is reported. For example: + + sub complicated_function { ## no critic (ProhibitExcessComplexity) + # Your code here... + } + +Policies such as C apply to the entire +document, in which case violations are reported at line 1. + +Use this feature wisely. C<"## no critic"> annotations should be used in the +smallest possible scope, or only on individual lines of code. And you should +always be as specific as possible about which Policies you want to disable +(i.e. never use a bare C<"## no critic">). If Perl::Critic complains about +your code, try and find a compliant solution before resorting to this feature. + + +=head1 THE L PHILOSOPHY + +Coding standards are deeply personal and highly subjective. The goal of +Perl::Critic is to help you write code that conforms with a set of best +practices. Our primary goal is not to dictate what those practices are, but +rather, to implement the practices discovered by others. Ultimately, you make +the rules -- Perl::Critic is merely a tool for encouraging consistency. If +there is a policy that you think is important or that we have overlooked, we +would be very grateful for contributions, or you can simply load your own +private set of policies into Perl::Critic. + + +=head1 EXTENDING THE CRITIC + +The modular design of Perl::Critic is intended to facilitate the addition of +new Policies. You'll need to have some understanding of L, but most +Policy modules are pretty straightforward and only require about 20 lines of +code. Please see the L file included in this +distribution for a step-by-step demonstration of how to create new Policy +modules. + +If you develop any new Policy modules, feel free to send them to C<< + >> and I'll be happy to consider putting them into the +Perl::Critic distribution. Or if you would like to work on the Perl::Critic +project directly, you can fork our repository at +L. + +The Perl::Critic team is also available for hire. If your organization has +its own coding standards, we can create custom Policies to enforce your local +guidelines. Or if your code base is prone to a particular defect pattern, we +can design Policies that will help you catch those costly defects B +they go into production. To discuss your needs with the Perl::Critic team, +just contact C<< >>. + + +=head1 PREREQUISITES + +Perl::Critic requires the following modules: + +L + +L + +L + +L + +L + +L + +L + +L + +L + +L + +L + +L + +L + +L + +L + +L + +L + +L + +L + +L + +L + +L + +L + + +=head1 CONTACTING THE DEVELOPMENT TEAM + +You are encouraged to subscribe to the public mailing list at +L. +At least one member of the development team is usually hanging around +in L and you can follow Perl::Critic on +Twitter, at L. + + +=head1 SEE ALSO + +There are a number of distributions of additional Policies available. A few +are listed here: + +L + +L + +L + +L + +L + +L + +These distributions enable you to use Perl::Critic in your unit tests: + +L + +L + +There is also a distribution that will install all the Perl::Critic related +modules known to the development team: + +L + + +=head1 BUGS + +Scrutinizing Perl code is hard for humans, let alone machines. If you find +any bugs, particularly false-positives or false-negatives from a +Perl::Critic::Policy, please submit them at +L. Thanks. + +=head1 CREDITS + +Adam Kennedy - For creating L, the heart and soul of L. + +Damian Conway - For writing B, finally :) + +Chris Dolan - For contributing the best features and Policy modules. + +Andy Lester - Wise sage and master of all-things-testing. + +Elliot Shank - The self-proclaimed quality freak. + +Giuseppe Maxia - For all the great ideas and positive encouragement. + +and Sharon, my wife - For putting up with my all-night code sessions. + +Thanks also to the Perl Foundation for providing a grant to support Chris +Dolan's project to implement twenty PBP policies. +L + +Thanks also to this incomplete laundry list of folks who have contributed +to Perl::Critic in some way: +Daniel Mita, +Gregory Oschwald, +Mike O'Regan, +Tom Hukins, +Omer Gazit, +Evan Zacks, +Paul Howarth, +Sawyer X, +Christian Walde, +Dave Rolsky, +Jakub Wilk, +Roy Ivy III, +Oliver Trosien, +Glenn Fowler, +Matt Creenan, +Alex Balhatchet, +Sebastian Paaske Tørholm, +Stuart A Johnston, +Dan Book, +Steven Humphrey, +James Raspass, +Nick Tonkin, +Harrison Katz, +Douglas Sims, +Mark Fowler, +Alan Berndt, +Neil Bowers, +Sergey Romanov, +Gabor Szabo, +Graham Knop, +Mike Eldridge, +David Steinbrunner, +Kirk Kimmel, +Guillaume Aubert, +Dave Cross, +Anirvan Chatterjee, +Todd Rinaldo, +Graham Ollis, +Karen Etheridge, +Jonas Brømsø, +Olaf Alders, +Jim Keenan, +Slaven Rezić, +Szymon Nieznański. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2019 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. The full text of this license can be found in +the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Annotation.pm b/lib/Perl/Critic/Annotation.pm new file mode 100644 index 0000000..2bc66da --- /dev/null +++ b/lib/Perl/Critic/Annotation.pm @@ -0,0 +1,410 @@ +package Perl::Critic::Annotation; + +use 5.006001; +use strict; +use warnings; + +use Carp qw(confess); +use English qw(-no_match_vars); + +use Perl::Critic::PolicyFactory; +use Perl::Critic::Utils qw(:characters hashify); +use Readonly; + +#----------------------------------------------------------------------------- + +our $VERSION = '1.140'; + +Readonly::Scalar my $LAST_ELEMENT => -1; + +#============================================================================= +# CLASS methods + +sub create_annotations { + my ($class, $doc) = @_; + + my @annotations = (); + my $comment_elements_ref = $doc->find('PPI::Token::Comment') || return; + my $annotation_rx = qr{\A (?: [#]! .*? )? \s* [#][#] \s* no \s+ critic}xms; + for my $annotation_element ( grep { $_ =~ $annotation_rx } @{$comment_elements_ref} ) { + push @annotations, Perl::Critic::Annotation->new( -element => $annotation_element); + } + + return @annotations; +} + +#----------------------------------------------------------------------------- + +sub new { + my ($class, @args) = @_; + my $self = bless {}, $class; + $self->_init(@args); + return $self; +} + +#============================================================================= +# OBJECT methods + +sub _init { + my ($self, %args) = @_; + my $annotation_element = $args{-element} || confess '-element argument is required'; + $self->{_element} = $annotation_element; + + my %disabled_policies = _parse_annotation( $annotation_element ); + $self->{_disables_all_policies} = %disabled_policies ? 0 : 1; + $self->{_disabled_policies} = \%disabled_policies; + + # Grab surrounding nodes to determine the context. + # This determines whether the annotation applies to + # the current line or the block that follows. + my $annotation_line = $annotation_element->logical_line_number(); + my $parent = $annotation_element->parent(); + my $grandparent = $parent ? $parent->parent() : undef; + + # Handle case when it appears on the shebang line. In this + # situation, it only affects the first line, not the whole doc + if ( $annotation_element =~ m{\A [#]!}xms) { + $self->{_effective_range} = [$annotation_line, $annotation_line]; + return $self; + } + + # Handle single-line usage on simple statements. In this + # situation, it only affects the line that it appears on. + if ( _is_single_line_annotation_on_simple_statement( $annotation_element ) + ) { + $self->{_effective_range} = [$annotation_line, $annotation_line]; + return $self; + } + + # Handle single-line usage on compound statements. In this + # situation -- um -- I'm not sure how this works, but it does. + if ( ref $parent eq 'PPI::Structure::Block' ) { + if ( ref $grandparent eq 'PPI::Statement::Compound' + || ref $grandparent eq 'PPI::Statement::Sub' ) { + if ( $parent->logical_line_number() == $annotation_line ) { + my $grandparent_line = $grandparent->logical_line_number(); + $self->{_effective_range} = [$grandparent_line, $grandparent_line]; + return $self; + } + } + } + + + # Handle multi-line usage. This is either a "no critic" .. + # "use critic" region or a block where "no critic" is in effect + # until the end of the scope. The start is the always the "no + # critic" which we already found. So now we have to search for the end. + my $end = $annotation_element; + my $use_critic = qr{\A \s* [#][#] \s* use \s+ critic}xms; + + SIB: + while ( my $esib = $end->next_sibling() ) { + $end = $esib; # keep track of last sibling encountered in this scope + last SIB if $esib->isa('PPI::Token::Comment') && $esib =~ $use_critic; + } + + # PPI parses __END__ as a PPI::Statement::End, and everything following is + # a child of that statement. That means if we encounter an __END__, we + # need to descend into it and continue the analysis. + if ( $end->isa( 'PPI::Statement::End' ) and my $kid = $end->child( 0 ) ) { + $end = $kid; + SIB: + while ( my $esib = $end->next_sibling() ) { + $end = $esib; + last SIB if $esib->isa( 'PPI::Token::Comment' ) && + $esib->content() =~ $use_critic; + } + } + + # We either found an end or hit the end of the scope. + my $ending_line = $end->logical_line_number(); + $self->{_effective_range} = [$annotation_line, $ending_line]; + return $self; +} + +#----------------------------------------------------------------------------- + +sub element { + my ($self) = @_; + return $self->{_element}; +} + +#----------------------------------------------------------------------------- + +sub effective_range { + my $self = shift; + return @{ $self->{_effective_range} }; +} + +#----------------------------------------------------------------------------- + +sub disabled_policies { + my $self = shift; + return keys %{ $self->{_disabled_policies} }; +} + +#----------------------------------------------------------------------------- + +sub disables_policy { + my ($self, $policy_name) = @_; + return 1 if $self->{_disabled_policies}->{$policy_name}; + return 1 if $self->disables_all_policies(); + return 0; +} + +#----------------------------------------------------------------------------- + +sub disables_all_policies { + my ($self) = @_; + return $self->{_disables_all_policies}; +} + +#----------------------------------------------------------------------------- + +sub disables_line { + my ($self, $line_number) = @_; + my $effective_range = $self->{_effective_range}; + return 1 if $line_number >= $effective_range->[0] + and $line_number <= $effective_range->[$LAST_ELEMENT]; + return 0; +} + +#----------------------------------------------------------------------------- + +# Recognize a single-line annotation on a simple statement. +sub _is_single_line_annotation_on_simple_statement { + my ( $annotation_element ) = @_; + my $annotation_line = $annotation_element->logical_line_number(); + + # If there is no sibling, we are clearly not a single-line annotation of + # any sort. + my $sib = $annotation_element->sprevious_sibling() + or return 0; + + # The easy case: the sibling (whatever it is) is on the same line as the + # annotation. + $sib->logical_line_number() == $annotation_line + and return 1; + + # If the sibling is a node, we may have an annotation on one line of a + # statement that was split over multiple lines. So we descend through the + # children, keeping the last significant child of each, until we bottom + # out. If the ultimate significant descendant is on the same line as the + # annotation, we accept the annotation as a single-line annotation. + if ( $sib->isa( 'PPI::Node' ) && + $sib->logical_line_number() < $annotation_line + ) { + my $neighbor = $sib; + while ( $neighbor->isa( 'PPI::Node' ) + and my $kid = $neighbor->schild( $LAST_ELEMENT ) ) { + $neighbor = $kid; + } + if ( $neighbor && + $neighbor->logical_line_number() == $annotation_line + ) { + return 1; + } + } + + # We do not understand any other sort of single-line annotation. Accepting + # the annotation as such (if it is) is Someone Else's Problem. + return 0; +} + +#----------------------------------------------------------------------------- + +sub _parse_annotation { + + my ($annotation_element) = @_; + + ############################################################################# + # This regex captures the list of Policy name patterns that are to be + # disabled. It is generally assumed that the element has already been + # verified as a no-critic annotation. So if this regex does not match, + # then it implies that all Policies are to be disabled. + # + my $no_critic = qr{\#\# \s* no \s+ critic \s* (?:qw)? [(["'] ([\s\w:,]+) }xms; + # -------------------------- ------- ----- ----------- + # | | | | + # "## no critic" with optional spaces | | | + # | | | + # Policy list may be prefixed with "qw" | | + # | | + # Optional Policy list must begin with one of these | + # | + # Capture entire Policy list (with delimiters) here + # + ############################################################################# + + my @disabled_policy_names = (); + if ( my ($patterns_string) = $annotation_element =~ $no_critic ) { + + # Compose the specified modules into a regex alternation. Wrap each + # in a no-capturing group to permit "|" in the modules specification. + + my @policy_name_patterns = grep { $_ ne $EMPTY } + split m{\s *[,\s] \s*}xms, $patterns_string; + my $re = join $PIPE, map {"(?:$_)"} @policy_name_patterns; + my @site_policy_names = Perl::Critic::PolicyFactory::site_policy_names(); + @disabled_policy_names = grep {m/$re/ixms} @site_policy_names; + + # It is possible that the Policy patterns listed in the annotation do not + # match any of the site policy names. This could happen when running + # on a machine that does not have the same set of Policies as the author. + # So we must return something here, otherwise all Policies will be + # disabled. We probably need to add a mechanism to (optionally) warn + # about this, just to help the author avoid writing invalid Policy names. + + if (not @disabled_policy_names) { + @disabled_policy_names = @policy_name_patterns; + } + } + + return hashify(@disabled_policy_names); +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Annotation - A "## no critic" annotation in a document. + + +=head1 SYNOPSIS + + use Perl::Critic::Annotation; + $annotation = Perl::Critic::Annotation->new( -element => $no_critic_ppi_element ); + + $bool = $annotation->disables_line( $number ); + $bool = $annotation->disables_policy( $policy_object ); + $bool = $annotation->disables_all_policies(); + + ($start, $end) = $annotation->effective_range(); + @disabled_policy_names = $annotation->disabled_policies(); + + +=head1 DESCRIPTION + +C represents a single C<"## no critic"> +annotation in a L. The Annotation takes care of parsing +the annotation and keeps track of which lines and Policies it affects. +It is intended to encapsulate the details of the no-critic +annotations, and to provide a way for Policy objects to interact with +the annotations (via a L). + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 CLASS METHODS + +=over + +=item create_annotations( -doc => $doc ) + +Given a L, finds all the C<"## no critic"> +annotations and constructs a new C for each +one and returns them. The order of the returned objects is not +defined. It is generally expected that clients will use this +interface rather than calling the C +constructor directly. + + +=back + + +=head1 CONSTRUCTOR + +=over + +=item C<< new( -element => $ppi_annotation_element ) >> + +Returns a reference to a new Annotation object. The B<-element> +argument is required and should be a C that +conforms to the C<"## no critic"> syntax. + + +=back + + +=head1 METHODS + +=over + +=item C<< disables_line( $line ) >> + +Returns true if this Annotation disables C<$line> for any (or all) +Policies. + + +=item C<< disables_policy( $policy_object ) >> + +=item C<< disables_policy( $policy_name ) >> + +Returns true if this Annotation disables C<$polciy_object> or +C<$policy_name> at any (or all) lines. + + +=item C<< disables_all_policies() >> + +Returns true if this Annotation disables all Policies at any (or all) +lines. If this method returns true, C will return +an empty list. + + +=item C<< effective_range() >> + +Returns a two-element list, representing the first and last line +numbers where this Annotation has effect. + + +=item C<< disabled_policies() >> + +Returns a list of the names of the Policies that are affected by this +Annotation. If this list is empty, then it means that all Policies +are affected by this Annotation, and C should +return true. + + +=item C<< element() >> + +Returns the L where this annotation started. This is +typically an instance of L. + + +=back + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/CORE_DEVELOPER.pod b/lib/Perl/Critic/CORE_DEVELOPER.pod new file mode 100644 index 0000000..d51ad53 --- /dev/null +++ b/lib/Perl/Critic/CORE_DEVELOPER.pod @@ -0,0 +1,314 @@ +=pod + +=head1 NAME + +Perl::Critic::CORE_DEVELOPER - Hints for working on the Perl::Critic core. + + +=head1 DESCRIPTION + +This document is a grab-bag of notes for those who are working on the +underpinnings of Perl::Critic. They are intended to be informative, +but unfortunately can not really be considered authoritative. It is in +the nature of the task being described that the user of this document +will end up working out the details for him- or herself based on the +actual work being performed. B + + +=head1 BECOMING A CORE DEVELOPER + +Here are my thoughts on how to get started. Note that the steps are +not numbered because I'm not sure there is a clear order to them. The +items with two stars in front of them are from the mailing list; the +ones with one star are my opinion. Although sometimes I have felt it +helpful to comment on the two-star items, just to make things +thoroughly unclear. + +* If you're unsure of yourself, install Perl::Critic, then download +the source and rummage around in it. + +** Subscribe to the developers' mailing list. There are instructions +in L. The F mailing list +is another good one. + +** If you are working on a GitHub issue, you should update the ticket to +say that you are, to keep other people from duplicating your effort. + +* I personally would update GitHub at the point I was reasonably confident +I could hack it, just to prevent myself from having to update GitHub +again in a week or so saying "oops, bit off more than I could chew." +But that's me talking. + +* Development requires using Module::Build rather than +ExtUtils::MakeMaker. In other words, + + $ perl Build.PL + $ ./Build + $ ./Build test + +* You need to run the suite of author tests by running + + $ ./Build authortest + +(but not 'make authortest', which is one of the reasons you should +start with F rather than F) These should run +cleanly before you declare your work done. My advice, though, is not +to worry about them until your code is functionally correct. + + +=head2 Modules required for authortest + +The authortest requires a B of modules above and beyond those +required to run C. The list probably depends on which +C you are testing, so the following should not be +considered definitive. You need the following in addition to B +optional modules for Perl::Critic itself. + + Devel::EnforceEncapsulation + Perl::Critic::More + Test::Kwalitee + Test::Memory::Cycle + Test::Perl::Critic + Test::Pod + Test::Pod::Coverage + Test::Without::Module + +You can find out what the optional modules are by looking at +C in +F. + +In the absence of C, the relevant tests are +simply skipped. In the absence of the other modules, the tests die +horribly. Of course, either way they do not get run, so the +difference is mainly one of aesthetics. + +Under Perl 5.12 and above, L 1.11 needs to +be patched to handle a C as a first-class Perl object. See +L for the +details. + + +=head1 ADDING A GLOBAL CONFIGURATION ITEM + +Perlcritic handles global configuration items and command line options +in very similar ways. These notes will cover adding both a global +configuration item and a corresponding, same-named command option. +These notes can not, of course, cover implementing the functionality +of the new item, just the mechanics of getting the item into +Perl::Critic. + + +=head2 Naming Conventions + +All names are lower-case, except for the names of constants (if any), +which are upper-case. When a name contains multiple words, dashes +will be used to separate the words in the configuration item name and +the command line option, and underscores will be used in the accessor +and attribute value names, and constant names if any. + +For example, if "new item" is being added, the configuration item is +"new-item", the command option is "--new-item", the accessors are +C, and the value of the attribute will be stored in +C<< $self->{_new_item} >>. If there are constants involved, their +names will start with C. These names will be used in the +following discussion. + + +=head2 Implementation + +There are several files that must be modified to get your new +configuration item and/or command line option. + + +=head3 F + +If there are manifest constants connected with your implementation +they go here. You may well at least have a + + $NEW_ITEM_DEFAULT + +to define. All the constants for your new item must be exported, and +should be exported not only individually but all together with export +tag + + new_item + + +=head3 F + +If your new item is a command option, its L +specification must be defined in C<_get_option_specification()>. If +your new configuration item does not have a corresponding command +option, you do not need to make any changes to this file. + + +=head3 F + +If your new item is a global configuration item, you need to add the +code to handle it here. Specifically: + +You must add code to the C<_init()> method to store the value of your +item as an attribute value, defaulting it if necessary. Using our +naming convention, a single-valued item would be stored like this: + + $self->{_new_item} = dor(delete $args{'new-item'}, + $NEW_ITEM_DEFAULT); + +If the item has synonyms (e.g. both 'color' and 'colour' meaning the +same thing), the C call must check for all of them. If the +item took a list of values, they would be parsed apart and stored as +an array reference. + +You must also add and document an accessor for your new item. This +would look something like this: + + sub new_item { + my ($self) = @_; + return $self->{_new_item}; + } + +In the case of multi-valued items, the accessor must return the array +reference, so the above specimen code works in that case also. + +Note that no validation is done here -- this class is simply a bridge +between the physical F<.perlcriticrc> file and +L, which is where the +action is. + +If your new item is a command option without a corresponding global +configuration item, you do not need to modify this file. + + +=head3 F + +You must write a C<_validate_and_store_new_item()> method to validate +and store the value of the new item. The signature of this method +depends on the details of your new item, but it must include at least +the value of the item, B there is no corresponding global +configuration item. If it is possible to get validation failures, it +will also need an errors object to add the validation exception to. +Because the details vary, the best way to proceed is probably to find +a method similar to the one you want to write, and implement from +there. The C<_validate_and_store_top()> method is a reasonable +starting point for an item having a single value. The validated value +needs to be stored in C<< $self->{_new_item} >>. + +You must call C<_validate_and_store_new_item()> in the C<_init()> +method. + +You must write and document an accessor method for the value of the +new item. The typical accessor method for a single-valued item is + + sub new_item { + my ($self) = @_; + return $self->{_new_item}; + } + +but the accessor for a multi-valued item must return a list: + + sub new_item { + my ($self) = @_; + return @{ $self->{_new_item} }; + } + +Last, you must document the item itself. + + +=head3 F + +If your new item has a corresponding global configuration item, you +must update the C method to include the item in the +string. Your implementation of the item must be such that the +generated string is the same as the input string for the item, except +for whitespace. + +If your new item has no corresponding global configuration item, you +do not need to change this file. + + +=head3 F + +If your new item has a corresponding command option, you must document +it here. If it does not, you do not need to change this file. + + +=head3 F + +If your new item has a corresponding global configuration item, you +must add it here. If it does not, you do not need to change this file. + + +=head2 Testing + +The following test files must be considered for modification: + + t/00_modules.t + t/01_config.t + t/01_config_bad_perlcritic.t + t/04_options_processor.t + t/07_command.t + t/10_user_profile.t + t/16_roundtrip_defaults.t + +Depending on your new item, you may not need to change all of these, +but you should at least review them. Depending on what your new item +actually does, other test files may need to be modified as well. + + +=head1 DEPRECATING AND REMOVING A PUBLIC SUBROUTINE OR METHOD + +This is something to be done cautiously. The code in question may only +exist to serve Perl::Critic, but if it is documented as public it may +well be in use "in the wild", either in add-ons to Perl::Critic or by +users of Perl::Critic. + +Before deprecating public code, the potential deprecator must discuss +the issues on the Perl::Critic developers' mailing list. There are +instructions on how to subscribe to this list in +L. + +Once agreement is reached, the technical details of the deprecation +are fairly simple. + +You must insert something like the following in the code to be +deprecated: + + warnings::warnif( + 'deprecated', + 'Perl::Critic::Utils::foo() deprecated, use blah::foo() instead.', + ); + +You should have the deprecated subroutine delegate its functionality +to the new subroutine, if that is practical (it may not be). + +You must update the documentation to say that the old code is +deprecated, and what the replacement is. + +After the old code has been deprecated for a couple production +releases, it can be removed. + + +=head1 AUTHOR + +Thomas R. Wyant, III F + + +=head1 COPYRIGHT + +Copyright (c) 2009-2011 Thomas R. Wyant, III + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=70 ft=pod expandtab shiftround : diff --git a/lib/Perl/Critic/Command.pm b/lib/Perl/Critic/Command.pm new file mode 100644 index 0000000..c9bb996 --- /dev/null +++ b/lib/Perl/Critic/Command.pm @@ -0,0 +1,733 @@ +package Perl::Critic::Command; + +use 5.006001; +use strict; +use warnings; + +use English qw< -no_match_vars >; +use Readonly; + +use Getopt::Long qw< GetOptions >; +use List::Util qw< first max >; +use Pod::Usage qw< pod2usage >; + +use Perl::Critic::Exception::Parse (); +use Perl::Critic::Utils qw< + :characters :severities policy_short_name + $DEFAULT_VERBOSITY $DEFAULT_VERBOSITY_WITH_FILE_NAME +>; +use Perl::Critic::Utils::Constants qw< $_MODULE_VERSION_TERM_ANSICOLOR >; +use Perl::Critic::Violation qw<>; + +#----------------------------------------------------------------------------- + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exporter 'import'; + +Readonly::Array our @EXPORT_OK => qw< run >; + +Readonly::Hash our %EXPORT_TAGS => ( + all => [ @EXPORT_OK ], +); + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DEFAULT_VIOLATIONS_FOR_TOP => 20; + +Readonly::Scalar my $EXIT_SUCCESS => 0; +Readonly::Scalar my $EXIT_NO_FILES => 1; +Readonly::Scalar my $EXIT_HAD_VIOLATIONS => 2; +Readonly::Scalar my $EXIT_HAD_FILE_PROBLEMS => 3; + +#----------------------------------------------------------------------------- + +my @files = (); +my $critic = undef; +my $output = \*STDOUT; + +#----------------------------------------------------------------------------- + +sub _out { + my @lines = @_; + return print {$output} @lines; +} + +#----------------------------------------------------------------------------- + +sub run { + my %options = _get_options(); + @files = _get_input(@ARGV); + + my ($violations, $had_error_in_file) = _critique(\%options, @files); + + return $EXIT_HAD_FILE_PROBLEMS if $had_error_in_file; + return $EXIT_NO_FILES if not defined $violations; + return $EXIT_HAD_VIOLATIONS if $violations; + + return $EXIT_SUCCESS; +} + +#----------------------------------------------------------------------------- + +sub _get_options { + + my %opts = _parse_command_line(); + _dispatch_special_requests( %opts ); + _validate_options( %opts ); + + # Convert severity shortcut options. If multiple shortcuts + # are given, the lowest one wins. If an explicit --severity + # option has been given, then the shortcuts are ignored. The + # @SEVERITY_NAMES variable is exported by Perl::Critic::Utils. + $opts{-severity} ||= first { exists $opts{"-$_"} } @SEVERITY_NAMES; + $opts{-severity} ||= first { exists $opts{"-$_"} } ($SEVERITY_LOWEST .. $SEVERITY_HIGHEST); + + + # If --top is specified, default the severity level to 1, unless an + # explicit severity is defined. This provides us flexibility to + # report top-offenders across just some or all of the severity levels. + # We also default the --top count to twenty if none is given + if ( exists $opts{-top} ) { + $opts{-severity} ||= 1; + $opts{-top} ||= $DEFAULT_VIOLATIONS_FOR_TOP; + } + + #Override profile, if --noprofile is specified + if ( exists $opts{-noprofile} ) { + $opts{-profile} = $EMPTY; + } + + return %opts; +} + +#----------------------------------------------------------------------------- + +sub _parse_command_line { + my %opts; + my @opt_specs = _get_option_specification(); + Getopt::Long::Configure('no_ignore_case'); + GetOptions( \%opts, @opt_specs ) || pod2usage(); #Exits + + # I've adopted the convention of using key-value pairs for + # arguments to most functions. And to increase legibility, + # I have also adopted the familiar command-line practice + # of denoting argument names with a leading dash (-). + my %dashed_opts = map { ( "-$_" => $opts{$_} ) } keys %opts; + return %dashed_opts; +} + +#----------------------------------------------------------------------------- + +sub _dispatch_special_requests { + my (%opts) = @_; + if ( $opts{-help} ) { pod2usage( -verbose => 0 ) } # Exits + if ( $opts{-options} ) { pod2usage( -verbose => 1 ) } # Exits + if ( $opts{-man} ) { pod2usage( -verbose => 2 ) } # Exits + if ( $opts{-version} ) { _display_version() } # Exits + if ( $opts{-list} ) { _render_all_policy_listing() } # Exits + if ( $opts{'-list-enabled'} ) { _render_policy_listing(%opts) } # Exits + if ( $opts{'-list-themes'} ) { _render_theme_listing() } # Exits + if ( $opts{'-profile-proto'} ) { _render_profile_prototype() } # Exits + if ( $opts{-doc} ) { _render_policy_docs( %opts ) } # Exits + return 1; +} + +#----------------------------------------------------------------------------- + +sub _validate_options { + my (%opts) = @_; + my $msg = $EMPTY; + + + if ( $opts{-noprofile} && $opts{-profile} ) { + $msg .= qq{Warning: Cannot use -noprofile with -profile option.\n}; + } + + if ( $opts{-verbose} && $opts{-verbose} !~ m{(?: \d+ | %[mfFlcCedrpPs] )}xms) { + $msg .= qq; + $msg .= qq; + } + + if ( exists $opts{-top} && $opts{-top} < 0 ) { + $msg .= qq; + $msg .= qq; + } + + if ( + exists $opts{-severity} + && ( + $opts{-severity} < $SEVERITY_LOWEST + || $opts{-severity} > $SEVERITY_HIGHEST + ) + ) { + $msg .= qq; + $msg .= qq; + $msg .= qq<"$SEVERITY_HIGHEST" (highest).\n>; + } + + + if ( $msg ) { + pod2usage( -exitstatus => 1, -message => $msg, -verbose => 0); #Exits + } + + + return 1; +} + +#----------------------------------------------------------------------------- + +sub _get_input { + + my @args = @_; + + if ( !@args || (@args == 1 && $args[0] eq q{-}) ) { + + # Reading code from STDIN. All the code is slurped into + # a string. PPI will barf if the string is just whitespace. + my $code_string = do { local $RS = undef; <> }; + + # Notice if STDIN was closed (pipe error, etc) + if ( ! defined $code_string ) { + $code_string = $EMPTY; + } + + $code_string =~ m{ \S+ }xms || die qq{Nothing to critique.\n}; + return \$code_string; #Convert to SCALAR ref for PPI + } + else { + + # Test to make sure all the specified files or directories + # actually exist. If any one of them is bogus, then die. + if ( my $nonexistent = first { ! -e } @args ) { + my $msg = qq{No such file or directory: '$nonexistent'}; + pod2usage( -exitstatus => 1, -message => $msg, -verbose => 0); + } + + # Reading code from files or dirs. If argument is a file, + # then we process it as-is (even though it may not actually + # be Perl code). If argument is a directory, recursively + # search the directory for files that look like Perl code. + return map { (-d) ? Perl::Critic::Utils::all_perl_files($_) : $_ } @args; + } +} + +#------------------------------------------------------------------------------ + +sub _critique { + + my ( $opts_ref, @files_to_critique ) = @_; + @files_to_critique || die "No perl files were found.\n"; + + # Perl::Critic has lots of dependencies, so loading is delayed + # until it is really needed. This hack reduces startup time for + # doing other things like getting the version number or dumping + # the man page. Arguably, those things are pretty rare, but hey, + # why not save a few seconds if you can. + + require Perl::Critic; + $critic = Perl::Critic->new( %{$opts_ref} ); + $critic->policies() || die "No policies selected.\n"; + + _set_up_pager($critic->config()->pager()); + + my $number_of_violations = undef; + my $had_error_in_file = 0; + + for my $file (@files_to_critique) { + + eval { + my @violations = $critic->critique($file); + $number_of_violations += scalar @violations; + + if (not $opts_ref->{'-statistics-only'}) { + _render_report( $file, $opts_ref, @violations ) + } + 1; + } + or do { + if ( my $exception = Perl::Critic::Exception::Parse->caught() ) { + $had_error_in_file = 1; + warn qq; + } + elsif ($EVAL_ERROR) { + # P::C::Exception::Fatal includes the stack trace in its + # stringification. + die qq; + } + else { + die qq, + q<$@/$EVAL_ERROR >, ## no critic (RequireInterpolationOfMetachars) + qq; + } + } + } + + if ( $opts_ref->{-statistics} or $opts_ref->{'-statistics-only'} ) { + my $stats = $critic->statistics(); + _report_statistics( $opts_ref, $stats ); + } + + return $number_of_violations, $had_error_in_file; +} + +#------------------------------------------------------------------------------ + +sub _render_report { + my ( $file, $opts_ref, @violations ) = @_; + + # Only report the files, if asked. + my $number_of_violations = scalar @violations; + if ( $opts_ref->{'-files-with-violations'} || + $opts_ref->{'-files-without-violations'} ) { + not ref $file + and $opts_ref->{$number_of_violations ? '-files-with-violations' : + '-files-without-violations'} + and _out "$file\n"; + return $number_of_violations; + } + + # Only report the number of violations, if asked. + if( $opts_ref->{-count} ){ + ref $file || _out "$file: "; + _out "$number_of_violations\n"; + return $number_of_violations; + } + + # Hail all-clear unless we should shut up. + if( !@violations && !$opts_ref->{-quiet} ) { + ref $file || _out "$file "; + _out "source OK\n"; + return 0; + } + + # Otherwise, format and print violations + my $verbosity = $critic->config->verbose(); + # $verbosity can be numeric or string, so use "eq" for comparison; + $verbosity = + ($verbosity eq $DEFAULT_VERBOSITY && @files > 1) + ? $DEFAULT_VERBOSITY_WITH_FILE_NAME + : $verbosity; + my $fmt = Perl::Critic::Utils::verbosity_to_format( $verbosity ); + if (not -f $file) { $fmt =~ s< \%[fF] >xms; } #HACK! + Perl::Critic::Violation::set_format( $fmt ); + + my $color = $critic->config->color(); + _out $color ? _colorize_by_severity(@violations) : @violations; + + return $number_of_violations; +} + +#----------------------------------------------------------------------------- + +sub _set_up_pager { + my ($pager_command) = @_; + return if not $pager_command; + return if not _at_tty(); + + open my $pager, q<|->, $pager_command ## no critic (InputOutput::RequireBriefOpen) + or die qq; + + $output = $pager; + + return; +} + +#----------------------------------------------------------------------------- + +sub _report_statistics { + my ($opts_ref, $statistics) = @_; + + if ( + not $opts_ref->{'-statistics-only'} + and ( + $statistics->total_violations() + or not $opts_ref->{-quiet} and $statistics->modules() + ) + ) { + _out "\n"; # There's prior output that we want to separate from. + } + + my $files = _commaify($statistics->modules()); + my $subroutines = _commaify($statistics->subs()); + my $statements = _commaify($statistics->statements_other_than_subs()); + my $lines = _commaify($statistics->lines()); + my $width = max map { length } $files, $subroutines, $statements; + + _out sprintf "%*s %s.\n", $width, $files, 'files'; + _out sprintf "%*s %s.\n", $width, $subroutines, 'subroutines/methods'; + _out sprintf "%*s %s.\n", $width, $statements, 'statements'; + + my $lines_of_blank = _commaify( $statistics->lines_of_blank() ); + my $lines_of_comment = _commaify( $statistics->lines_of_comment() ); + my $lines_of_data = _commaify( $statistics->lines_of_data() ); + my $lines_of_perl = _commaify( $statistics->lines_of_perl() ); + my $lines_of_pod = _commaify( $statistics->lines_of_pod() ); + + $width = + max map { length } + $lines_of_blank, $lines_of_comment, $lines_of_data, + $lines_of_perl, $lines_of_pod; + _out sprintf "\n%s %s:\n", $lines, 'lines, consisting of'; + _out sprintf " %*s %s.\n", $width, $lines_of_blank, 'blank lines'; + _out sprintf " %*s %s.\n", $width, $lines_of_comment, 'comment lines'; + _out sprintf " %*s %s.\n", $width, $lines_of_data, 'data lines'; + _out sprintf " %*s %s.\n", $width, $lines_of_perl, 'lines of Perl code'; + _out sprintf " %*s %s.\n", $width, $lines_of_pod, 'lines of POD'; + + my $average_sub_mccabe = $statistics->average_sub_mccabe(); + if (defined $average_sub_mccabe) { + _out + sprintf + "\nAverage McCabe score of subroutines was %.2f.\n", + $average_sub_mccabe; + } + + _out "\n"; + + _out _commaify($statistics->total_violations()), " violations.\n"; + + my $violations_per_file = $statistics->violations_per_file(); + if (defined $violations_per_file) { + _out + sprintf + "Violations per file was %.3f.\n", + $violations_per_file; + } + my $violations_per_statement = $statistics->violations_per_statement(); + if (defined $violations_per_statement) { + _out + sprintf + "Violations per statement was %.3f.\n", + $violations_per_statement; + } + my $violations_per_line = $statistics->violations_per_line_of_code(); + if (defined $violations_per_line) { + _out + sprintf + "Violations per line of code was %.3f.\n", + $violations_per_line; + } + + if ( $statistics->total_violations() ) { + _out "\n"; + + my %severity_violations = %{ $statistics->violations_by_severity() }; + my @severities = reverse sort keys %severity_violations; + $width = + max + map { length _commaify( $severity_violations{$_} ) } + @severities; + foreach my $severity (@severities) { + _out + sprintf + "%*s severity %d violations.\n", + $width, + _commaify( $severity_violations{$severity} ), + $severity; + } + + _out "\n"; + + my %policy_violations = %{ $statistics->violations_by_policy() }; + my @policies = sort keys %policy_violations; + $width = + max + map { length _commaify( $policy_violations{$_} ) } + @policies; + foreach my $policy (@policies) { + _out + sprintf + "%*s violations of %s.\n", + $width, + _commaify($policy_violations{$policy}), + policy_short_name($policy); + } + } + + return; +} + +#----------------------------------------------------------------------------- + +# Only works for integers. +sub _commaify { + my ( $number ) = @_; + + while ($number =~ s/ \A ( [-+]? \d+ ) ( \d{3} ) /$1,$2/xms) { + # nothing + } + + return $number; +} + +#----------------------------------------------------------------------------- + +sub _get_option_specification { + + return qw< + 5 4 3 2 1 + version + brutal + count|C + cruel + doc=s + exclude=s@ + force! + gentle + harsh + help|?|H + include=s@ + list + list-enabled + list-themes + man + color|colour! + noprofile + only! + options + pager=s + profile|p=s + profile-proto + quiet + severity=i + single-policy|s=s + stern + statistics! + statistics-only! + profile-strictness=s + theme=s + top:i + allow-unsafe + verbose=s + color-severity-highest|colour-severity-highest|color-severity-5|colour-severity-5=s + color-severity-high|colour-severity-high|color-severity-4|colour-severity-4=s + color-severity-medium|colour-severity-medium|color-severity-3|colour-severity-3=s + color-severity-low|colour-severity-low|color-severity-2|colour-severity-2=s + color-severity-lowest|colour-severity-lowest|color-severity-1|colour-severity-1=s + files-with-violations|l + files-without-violations|L + program-extensions=s@ + >; +} + +#----------------------------------------------------------------------------- + +sub _colorize_by_severity { + my @violations = @_; + return @violations if _this_is_windows() && !eval 'require Win32::Console::ANSI; 1'; + return @violations if not eval { + require Term::ANSIColor; + Term::ANSIColor->VERSION( $_MODULE_VERSION_TERM_ANSICOLOR ); + 1; + }; + + my $config = $critic->config(); + my %color_of = ( + $SEVERITY_HIGHEST => $config->color_severity_highest(), + $SEVERITY_HIGH => $config->color_severity_high(), + $SEVERITY_MEDIUM => $config->color_severity_medium(), + $SEVERITY_LOW => $config->color_severity_low(), + $SEVERITY_LOWEST => $config->color_severity_lowest(), + ); + + return map { _colorize( "$_", $color_of{$_->severity()} ) } @violations; + +} + +#----------------------------------------------------------------------------- + +sub _colorize { + my ($string, $color) = @_; + return $string if not defined $color; + return $string if $color eq $EMPTY; + # $terminator is a purely cosmetic change to make the color end at the end + # of the line rather than right before the next line. It is here because + # if you use background colors, some console windows display a little + # fragment of colored background before the next uncolored (or + # differently-colored) line. + my $terminator = chomp $string ? "\n" : $EMPTY; + return Term::ANSIColor::colored( $string, $color ) . $terminator; +} + +#----------------------------------------------------------------------------- + +sub _this_is_windows { + return 1 if $OSNAME =~ m/MSWin32/xms; + return 0; +} + +#----------------------------------------------------------------------------- + +sub _at_tty { + return -t STDOUT; ## no critic (ProhibitInteractiveTest); +} + +#----------------------------------------------------------------------------- + +sub _render_all_policy_listing { + # Force P-C parameters, to catch all Policies on this site + my %pc_params = (-profile => $EMPTY, -severity => $SEVERITY_LOWEST); + return _render_policy_listing( %pc_params ); +} + +#----------------------------------------------------------------------------- + +sub _render_policy_listing { + my %pc_params = @_; + + require Perl::Critic::PolicyListing; + require Perl::Critic; + + my @policies = Perl::Critic->new( %pc_params )->policies(); + my $listing = Perl::Critic::PolicyListing->new( -policies => \@policies ); + _out $listing; + + exit $EXIT_SUCCESS; +} + +#----------------------------------------------------------------------------- + +sub _render_theme_listing { + + require Perl::Critic::ThemeListing; + require Perl::Critic; + + my %pc_params = (-profile => $EMPTY, -severity => $SEVERITY_LOWEST); + my @policies = Perl::Critic->new( %pc_params )->policies(); + my $listing = Perl::Critic::ThemeListing->new( -policies => \@policies ); + _out $listing; + + exit $EXIT_SUCCESS; +} + +#----------------------------------------------------------------------------- + +sub _render_profile_prototype { + + require Perl::Critic::ProfilePrototype; + require Perl::Critic; + + my %pc_params = (-profile => $EMPTY, -severity => $SEVERITY_LOWEST); + my @policies = Perl::Critic->new( %pc_params )->policies(); + my $prototype = Perl::Critic::ProfilePrototype->new( -policies => \@policies ); + _out $prototype; + + exit $EXIT_SUCCESS; +} + +#----------------------------------------------------------------------------- + +sub _render_policy_docs { + + my (%opts) = @_; + my $pattern = delete $opts{-doc}; + + require Perl::Critic; + $critic = Perl::Critic->new(%opts); + _set_up_pager($critic->config()->pager()); + + require Perl::Critic::PolicyFactory; + my @site_policies = Perl::Critic::PolicyFactory->site_policy_names(); + my @matching_policies = grep { /$pattern/ixms } @site_policies; + + # "-T" means don't send to pager + my @perldoc_output = map {`perldoc -T $_`} @matching_policies; ## no critic (ProhibitBacktick) + _out @perldoc_output; + + exit $EXIT_SUCCESS; +} + +#----------------------------------------------------------------------------- + +sub _display_version { + _out "$VERSION\n"; + exit $EXIT_SUCCESS; +} + +#----------------------------------------------------------------------------- +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords +Twitter + +=head1 NAME + +Perl::Critic::Command - Guts of L. + + +=head1 SYNOPSIS + + use Perl::Critic::Command qw< run >; + + local @ARGV = qw< --statistics-only lib bin >; + run(); + + +=head1 DESCRIPTION + +This is the implementation of the L command. You can use +this to run the command without going through a command interpreter. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. However, its interface is +experimental, and will likely change. + + +=head1 IMPORTABLE SUBROUTINES + +=over + +=item C + +Does the equivalent of the L command. Unfortunately, at +present, this doesn't take any parameters but uses C<@ARGV> to get its +input instead. Count on this changing; don't count on the current +interface. + + +=back + + +=head1 TO DO + +Make C take parameters. The equivalent of C<@ARGV> should be +passed as a reference. + +Turn this into an object. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Config.pm b/lib/Perl/Critic/Config.pm new file mode 100644 index 0000000..3f58a96 --- /dev/null +++ b/lib/Perl/Critic/Config.pm @@ -0,0 +1,1392 @@ +package Perl::Critic::Config; + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); +use Readonly; + +use List::MoreUtils qw(any none apply); +use Scalar::Util qw(blessed); + +use Perl::Critic::Exception::AggregateConfiguration; +use Perl::Critic::Exception::Configuration; +use Perl::Critic::Exception::Configuration::Option::Global::ParameterValue; +use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal }; +use Perl::Critic::PolicyFactory; +use Perl::Critic::Theme qw( $RULE_INVALID_CHARACTER_REGEX cook_rule ); +use Perl::Critic::UserProfile qw(); +use Perl::Critic::Utils qw{ + :booleans :characters :severities :internal_lookup :classification + :data_conversion +}; +use Perl::Critic::Utils::Constants qw< + :profile_strictness + $_MODULE_VERSION_TERM_ANSICOLOR +>; +use Perl::Critic::Utils::DataConversion qw< boolean_to_number dor >; + +#----------------------------------------------------------------------------- + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $SINGLE_POLICY_CONFIG_KEY => 'single-policy'; + +#----------------------------------------------------------------------------- +# Constructor + +sub new { + + my ( $class, %args ) = @_; + my $self = bless {}, $class; + $self->_init( %args ); + return $self; +} + +#----------------------------------------------------------------------------- + +sub _init { + my ( $self, %args ) = @_; + + # -top or -theme imply that -severity is 1, unless it is already defined + if ( defined $args{-top} || defined $args{-theme} ) { + $args{-severity} ||= $SEVERITY_LOWEST; + } + + my $errors = Perl::Critic::Exception::AggregateConfiguration->new(); + + # Construct the UserProfile to get default options. + my $profile_source = $args{-profile}; # Can be file path or data struct + my $profile = Perl::Critic::UserProfile->new( -profile => $profile_source ); + my $options_processor = $profile->options_processor(); + $self->{_profile} = $profile; + + $self->_validate_and_save_profile_strictness( + $args{'-profile-strictness'}, + $errors, + ); + + # If given, these options should always have a true value. + $self->_validate_and_save_regex( + 'include', $args{-include}, $options_processor->include(), $errors + ); + $self->_validate_and_save_regex( + 'exclude', $args{-exclude}, $options_processor->exclude(), $errors + ); + $self->_validate_and_save_regex( + $SINGLE_POLICY_CONFIG_KEY, + $args{ qq/-$SINGLE_POLICY_CONFIG_KEY/ }, + $options_processor->single_policy(), + $errors, + ); + $self->_validate_and_save_color_severity( + 'color_severity_highest', $args{'-color-severity-highest'}, + $options_processor->color_severity_highest(), $errors + ); + $self->_validate_and_save_color_severity( + 'color_severity_high', $args{'-color-severity-high'}, + $options_processor->color_severity_high(), $errors + ); + $self->_validate_and_save_color_severity( + 'color_severity_medium', $args{'-color-severity-medium'}, + $options_processor->color_severity_medium(), $errors + ); + $self->_validate_and_save_color_severity( + 'color_severity_low', $args{'-color-severity-low'}, + $options_processor->color_severity_low(), $errors + ); + $self->_validate_and_save_color_severity( + 'color_severity_lowest', $args{'-color-severity-lowest'}, + $options_processor->color_severity_lowest(), $errors + ); + + $self->_validate_and_save_verbosity($args{-verbose}, $errors); + $self->_validate_and_save_severity($args{-severity}, $errors); + $self->_validate_and_save_top($args{-top}, $errors); + $self->_validate_and_save_theme($args{-theme}, $errors); + $self->_validate_and_save_pager($args{-pager}, $errors); + $self->_validate_and_save_program_extensions( + $args{'-program-extensions'}, $errors); + + # If given, these options can be true or false (but defined) + # We normalize these to numeric values by multiplying them by 1; + $self->{_force} = boolean_to_number( dor( $args{-force}, $options_processor->force() ) ); + $self->{_only} = boolean_to_number( dor( $args{-only}, $options_processor->only() ) ); + $self->{_color} = boolean_to_number( dor( $args{-color}, $options_processor->color() ) ); + $self->{_unsafe_allowed} = + boolean_to_number( + dor( $args{'-allow-unsafe'}, $options_processor->allow_unsafe() + ) ); + $self->{_criticism_fatal} = + boolean_to_number( + dor( $args{'-criticism-fatal'}, $options_processor->criticism_fatal() ) + ); + + + # Construct a Factory with the Profile + my $factory = + Perl::Critic::PolicyFactory->new( + -profile => $profile, + -errors => $errors, + '-profile-strictness' => $self->profile_strictness(), + ); + $self->{_factory} = $factory; + + # Initialize internal storage for Policies + $self->{_all_policies_enabled_or_not} = []; + $self->{_policies} = []; + + # "NONE" means don't load any policies + if ( not defined $profile_source or $profile_source ne 'NONE' ) { + # Heavy lifting here... + $self->_load_policies($errors); + } + + if ( $errors->has_exceptions() ) { + $errors->rethrow(); + } + + return $self; +} + +#----------------------------------------------------------------------------- + +sub add_policy { + + my ( $self, %args ) = @_; + + if ( not $args{-policy} ) { + throw_internal q{The -policy argument is required}; + } + + my $policy = $args{-policy}; + + # If the -policy is already a blessed object, then just add it directly. + if ( blessed $policy ) { + $self->_add_policy_if_enabled($policy); + return $self; + } + + # NOTE: The "-config" option is supported for backward compatibility. + my $params = $args{-params} || $args{-config}; + + my $factory = $self->{_factory}; + my $policy_object = + $factory->create_policy(-name=>$policy, -params=>$params); + $self->_add_policy_if_enabled($policy_object); + + return $self; +} + +#----------------------------------------------------------------------------- + +sub _add_policy_if_enabled { + my ( $self, $policy_object ) = @_; + + my $config = $policy_object->__get_config() + or throw_internal + q{Policy was not set up properly because it does not have } + . q{a value for its config attribute.}; + + push @{ $self->{_all_policies_enabled_or_not} }, $policy_object; + if ( $policy_object->initialize_if_enabled( $config ) ) { + $policy_object->__set_enabled($TRUE); + push @{ $self->{_policies} }, $policy_object; + } + else { + $policy_object->__set_enabled($FALSE); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _load_policies { + + my ( $self, $errors ) = @_; + my $factory = $self->{_factory}; + my @policies = $factory->create_all_policies( $errors ); + + return if $errors->has_exceptions(); + + for my $policy ( @policies ) { + + # If -single-policy is true, only load policies that match it + if ( $self->single_policy() ) { + if ( $self->_policy_is_single_policy( $policy ) ) { + $self->add_policy( -policy => $policy ); + } + next; + } + + # Always exclude unsafe policies, unless instructed not to + next if not ( $policy->is_safe() or $self->unsafe_allowed() ); + + # To load, or not to load -- that is the question. + my $load_me = $self->only() ? $FALSE : $TRUE; + + ## no critic (ProhibitPostfixControls) + $load_me = $FALSE if $self->_policy_is_disabled( $policy ); + $load_me = $TRUE if $self->_policy_is_enabled( $policy ); + $load_me = $FALSE if $self->_policy_is_unimportant( $policy ); + $load_me = $FALSE if not $self->_policy_is_thematic( $policy ); + $load_me = $TRUE if $self->_policy_is_included( $policy ); + $load_me = $FALSE if $self->_policy_is_excluded( $policy ); + + + next if not $load_me; + $self->add_policy( -policy => $policy ); + } + + # When using -single-policy, only one policy should ever be loaded. + if ($self->single_policy() && scalar $self->policies() != 1) { + $self->_add_single_policy_exception_to($errors); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _policy_is_disabled { + my ($self, $policy) = @_; + my $profile = $self->_profile(); + return $profile->policy_is_disabled( $policy ); +} + +#----------------------------------------------------------------------------- + +sub _policy_is_enabled { + my ($self, $policy) = @_; + my $profile = $self->_profile(); + return $profile->policy_is_enabled( $policy ); +} + +#----------------------------------------------------------------------------- + +sub _policy_is_thematic { + my ($self, $policy) = @_; + my $theme = $self->theme(); + return $theme->policy_is_thematic( -policy => $policy ); +} + +#----------------------------------------------------------------------------- + +sub _policy_is_unimportant { + my ($self, $policy) = @_; + my $policy_severity = $policy->get_severity(); + my $min_severity = $self->{_severity}; + return $policy_severity < $min_severity; +} + +#----------------------------------------------------------------------------- + +sub _policy_is_included { + my ($self, $policy) = @_; + my $policy_long_name = ref $policy; + my @inclusions = $self->include(); + return any { $policy_long_name =~ m/$_/ixms } @inclusions; +} + +#----------------------------------------------------------------------------- + +sub _policy_is_excluded { + my ($self, $policy) = @_; + my $policy_long_name = ref $policy; + my @exclusions = $self->exclude(); + return any { $policy_long_name =~ m/$_/ixms } @exclusions; +} + +#----------------------------------------------------------------------------- + +sub _policy_is_single_policy { + my ($self, $policy) = @_; + + my @patterns = $self->single_policy(); + return if not @patterns; + + my $policy_long_name = ref $policy; + return any { $policy_long_name =~ m/$_/ixms } @patterns; +} + +#----------------------------------------------------------------------------- + +sub _new_global_value_exception { + my ($self, @args) = @_; + + return + Perl::Critic::Exception::Configuration::Option::Global::ParameterValue + ->new(@args); +} + +#----------------------------------------------------------------------------- + +sub _add_single_policy_exception_to { + my ($self, $errors) = @_; + + my $message_suffix = $EMPTY; + my $patterns = join q{", "}, $self->single_policy(); + + if (scalar $self->policies() == 0) { + $message_suffix = + q{did not match any policies (in combination with } + . q{other policy restrictions).}; + } + else { + $message_suffix = qq{matched multiple policies:\n\t}; + $message_suffix .= join qq{,\n\t}, apply { chomp } sort $self->policies(); + } + + $errors->add_exception( + $self->_new_global_value_exception( + option_name => $SINGLE_POLICY_CONFIG_KEY, + option_value => $patterns, + message_suffix => $message_suffix, + ) + ); + + return; +} + +#----------------------------------------------------------------------------- + +sub _validate_and_save_regex { + my ($self, $option_name, $args_value, $default_value, $errors) = @_; + + my $full_option_name; + my $source; + my @regexes; + + if ($args_value) { + $full_option_name = "-$option_name"; + + if (ref $args_value) { + @regexes = @{ $args_value }; + } + else { + @regexes = ( $args_value ); + } + } + + if (not @regexes) { + $full_option_name = $option_name; + $source = $self->_profile()->source(); + + if (ref $default_value) { + @regexes = @{ $default_value }; + } + elsif ($default_value) { + @regexes = ( $default_value ); + } + } + + my $found_errors; + foreach my $regex (@regexes) { + eval { qr/$regex/ixms } + or do { + my $cleaned_error = $EVAL_ERROR || ''; + $cleaned_error =~ + s/ [ ] at [ ] .* Config [.] pm [ ] line [ ] \d+ [.] \n? \z/./xms; + + $errors->add_exception( + $self->_new_global_value_exception( + option_name => $option_name, + option_value => $regex, + source => $source, + message_suffix => qq{is not valid: $cleaned_error}, + ) + ); + + $found_errors = 1; + } + } + + if (not $found_errors) { + my $option_key = $option_name; + $option_key =~ s/ - /_/xmsg; + + $self->{"_$option_key"} = \@regexes; + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _validate_and_save_profile_strictness { + my ($self, $args_value, $errors) = @_; + + my $option_name; + my $source; + my $profile_strictness; + + if ($args_value) { + $option_name = '-profile-strictness'; + $profile_strictness = $args_value; + } + else { + $option_name = 'profile-strictness'; + + my $profile = $self->_profile(); + $source = $profile->source(); + $profile_strictness = $profile->options_processor()->profile_strictness(); + } + + if ( not $PROFILE_STRICTNESSES{$profile_strictness} ) { + $errors->add_exception( + $self->_new_global_value_exception( + option_name => $option_name, + option_value => $profile_strictness, + source => $source, + message_suffix => q{is not one of "} + . join ( q{", "}, (sort keys %PROFILE_STRICTNESSES) ) + . q{".}, + ) + ); + + $profile_strictness = $PROFILE_STRICTNESS_FATAL; + } + + $self->{_profile_strictness} = $profile_strictness; + + return; +} + +#----------------------------------------------------------------------------- + +sub _validate_and_save_verbosity { + my ($self, $args_value, $errors) = @_; + + my $option_name; + my $source; + my $verbosity; + + if ($args_value) { + $option_name = '-verbose'; + $verbosity = $args_value; + } + else { + $option_name = 'verbose'; + + my $profile = $self->_profile(); + $source = $profile->source(); + $verbosity = $profile->options_processor()->verbose(); + } + + if ( + is_integer($verbosity) + and not is_valid_numeric_verbosity($verbosity) + ) { + $errors->add_exception( + $self->_new_global_value_exception( + option_name => $option_name, + option_value => $verbosity, + source => $source, + message_suffix => + 'is not the number of one of the pre-defined verbosity formats.', + ) + ); + } + else { + $self->{_verbose} = $verbosity; + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _validate_and_save_severity { + my ($self, $args_value, $errors) = @_; + + my $option_name; + my $source; + my $severity; + + if ($args_value) { + $option_name = '-severity'; + $severity = $args_value; + } + else { + $option_name = 'severity'; + + my $profile = $self->_profile(); + $source = $profile->source(); + $severity = $profile->options_processor()->severity(); + } + + if ( is_integer($severity) ) { + if ( + $severity >= $SEVERITY_LOWEST and $severity <= $SEVERITY_HIGHEST + ) { + $self->{_severity} = $severity; + } + else { + $errors->add_exception( + $self->_new_global_value_exception( + option_name => $option_name, + option_value => $severity, + source => $source, + message_suffix => + "is not between $SEVERITY_LOWEST (low) and $SEVERITY_HIGHEST (high).", + ) + ); + } + } + elsif ( not any { $_ eq lc $severity } @SEVERITY_NAMES ) { + $errors->add_exception( + $self->_new_global_value_exception( + option_name => $option_name, + option_value => $severity, + source => $source, + message_suffix => + q{is not one of the valid severity names: "} + . join (q{", "}, @SEVERITY_NAMES) + . q{".}, + ) + ); + } + else { + $self->{_severity} = severity_to_number($severity); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _validate_and_save_top { + my ($self, $args_value, $errors) = @_; + + my $option_name; + my $source; + my $top; + + if (defined $args_value and $args_value ne q{}) { + $option_name = '-top'; + $top = $args_value; + } + else { + $option_name = 'top'; + + my $profile = $self->_profile(); + $source = $profile->source(); + $top = $profile->options_processor()->top(); + } + + if ( is_integer($top) and $top >= 0 ) { + $self->{_top} = $top; + } + else { + $errors->add_exception( + $self->_new_global_value_exception( + option_name => $option_name, + option_value => $top, + source => $source, + message_suffix => q{is not a non-negative integer.}, + ) + ); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _validate_and_save_theme { + my ($self, $args_value, $errors) = @_; + + my $option_name; + my $source; + my $theme_rule; + + if ($args_value) { + $option_name = '-theme'; + $theme_rule = $args_value; + } + else { + $option_name = 'theme'; + + my $profile = $self->_profile(); + $source = $profile->source(); + $theme_rule = $profile->options_processor()->theme(); + } + + if ( $theme_rule =~ m/$RULE_INVALID_CHARACTER_REGEX/xms ) { + my $bad_character = $1; + + $errors->add_exception( + $self->_new_global_value_exception( + option_name => $option_name, + option_value => $theme_rule, + source => $source, + message_suffix => + qq{contains an illegal character ("$bad_character").}, + ) + ); + } + else { + my $rule_as_code = cook_rule($theme_rule); + $rule_as_code =~ s/ [\w\d]+ / 1 /gxms; + + # eval of an empty string does not reset $@ in Perl 5.6. + local $EVAL_ERROR = $EMPTY; + eval $rule_as_code; ## no critic (ProhibitStringyEval, RequireCheckingReturnValueOfEval) + + if ($EVAL_ERROR) { + $errors->add_exception( + $self->_new_global_value_exception( + option_name => $option_name, + option_value => $theme_rule, + source => $source, + message_suffix => q{is not syntactically valid.}, + ) + ); + } + else { + eval { + $self->{_theme} = + Perl::Critic::Theme->new( -rule => $theme_rule ); + } + or do { + $errors->add_exception_or_rethrow( $EVAL_ERROR ); + }; + } + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _validate_and_save_pager { + my ($self, $args_value, $errors) = @_; + + my $pager; + if ( $args_value ) { + $pager = defined $args_value ? $args_value : $EMPTY; + } + elsif ( $ENV{PERLCRITIC_PAGER} ) { + $pager = $ENV{PERLCRITIC_PAGER}; + } + else { + my $profile = $self->_profile(); + $pager = $profile->options_processor()->pager(); + } + + if ($pager eq '$PAGER') { ## no critic (RequireInterpolationOfMetachars) + $pager = $ENV{PAGER}; + } + $pager ||= $EMPTY; + + $self->{_pager} = $pager; + + return; +} + +#----------------------------------------------------------------------------- + +sub _validate_and_save_color_severity { + my ($self, $option_name, $args_value, $default_value, $errors) = @_; + + my $source; + my $color_severity; + my $full_option_name; + + if (defined $args_value) { + $full_option_name = "-$option_name"; + $color_severity = lc $args_value; + } + else { + $full_option_name = $option_name; + $source = $self->_profile()->source(); + $color_severity = lc $default_value; + } + $color_severity =~ s/ \s+ / /xmsg; + $color_severity =~ s/ \A\s+ //xms; + $color_severity =~ s/ \s+\z //xms; + $full_option_name =~ s/ _ /-/xmsg; + + # Should we really be validating this? + my $found_errors; + if ( + eval { + require Term::ANSIColor; + Term::ANSIColor->VERSION( $_MODULE_VERSION_TERM_ANSICOLOR ); + 1; + } + ) { + $found_errors = + not Term::ANSIColor::colorvalid( words_from_string($color_severity) ); + } + + # If we do not have Term::ANSIColor we can not validate, but we store the + # values anyway for the benefit of Perl::Critic::ProfilePrototype. + + if ($found_errors) { + $errors->add_exception( + $self->_new_global_value_exception( + option_name => $full_option_name, + option_value => $color_severity, + source => $source, + message_suffix => 'is not valid.', + ) + ); + } + else { + my $option_key = $option_name; + $option_key =~ s/ - /_/xmsg; + + $self->{"_$option_key"} = $color_severity; + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _validate_and_save_program_extensions { + my ($self, $args_value, $errors) = @_; + + delete $self->{_program_extensions_as_regexes}; + + my $extension_list = q{ARRAY} eq ref $args_value ? + [map {words_from_string($_)} @{ $args_value }] : + $self->_profile()->options_processor()->program_extensions(); + + my %program_extensions = hashify( @{ $extension_list } ); + + $self->{_program_extensions} = [keys %program_extensions]; + + return; + +} + +#----------------------------------------------------------------------------- +# Begin ACCESSSOR methods + +sub _profile { + my ($self) = @_; + return $self->{_profile}; +} + +#----------------------------------------------------------------------------- + +sub all_policies_enabled_or_not { + my ($self) = @_; + return @{ $self->{_all_policies_enabled_or_not} }; +} + +#----------------------------------------------------------------------------- + +sub policies { + my ($self) = @_; + return @{ $self->{_policies} }; +} + +#----------------------------------------------------------------------------- + +sub exclude { + my ($self) = @_; + return @{ $self->{_exclude} }; +} + +#----------------------------------------------------------------------------- + +sub force { + my ($self) = @_; + return $self->{_force}; +} + +#----------------------------------------------------------------------------- + +sub include { + my ($self) = @_; + return @{ $self->{_include} }; +} + +#----------------------------------------------------------------------------- + +sub only { + my ($self) = @_; + return $self->{_only}; +} + +#----------------------------------------------------------------------------- + +sub profile_strictness { + my ($self) = @_; + return $self->{_profile_strictness}; +} + +#----------------------------------------------------------------------------- + +sub severity { + my ($self) = @_; + return $self->{_severity}; +} + +#----------------------------------------------------------------------------- + +sub single_policy { + my ($self) = @_; + return @{ $self->{_single_policy} }; +} + +#----------------------------------------------------------------------------- + +sub theme { + my ($self) = @_; + return $self->{_theme}; +} + +#----------------------------------------------------------------------------- + +sub top { + my ($self) = @_; + return $self->{_top}; +} + +#----------------------------------------------------------------------------- + +sub verbose { + my ($self) = @_; + return $self->{_verbose}; +} + +#----------------------------------------------------------------------------- + +sub color { + my ($self) = @_; + return $self->{_color}; +} + +#----------------------------------------------------------------------------- + +sub pager { + my ($self) = @_; + return $self->{_pager}; +} + +#----------------------------------------------------------------------------- + +sub unsafe_allowed { + my ($self) = @_; + return $self->{_unsafe_allowed}; +} + +#----------------------------------------------------------------------------- + +sub criticism_fatal { + my ($self) = @_; + return $self->{_criticism_fatal}; +} + +#----------------------------------------------------------------------------- + +sub site_policy_names { + return Perl::Critic::PolicyFactory::site_policy_names(); +} + +#----------------------------------------------------------------------------- + +sub color_severity_highest { + my ($self) = @_; + return $self->{_color_severity_highest}; +} + +#----------------------------------------------------------------------------- + +sub color_severity_high { + my ($self) = @_; + return $self->{_color_severity_high}; +} + +#----------------------------------------------------------------------------- + +sub color_severity_medium { + my ($self) = @_; + return $self->{_color_severity_medium}; +} + +#----------------------------------------------------------------------------- + +sub color_severity_low { + my ($self) = @_; + return $self->{_color_severity_low}; +} + +#----------------------------------------------------------------------------- + +sub color_severity_lowest { + my ($self) = @_; + return $self->{_color_severity_lowest}; +} + +#----------------------------------------------------------------------------- + +sub program_extensions { + my ($self) = @_; + return @{ $self->{_program_extensions} }; +} + +#----------------------------------------------------------------------------- + +sub program_extensions_as_regexes { + my ($self) = @_; + + return @{ $self->{_program_extensions_as_regexes} } + if $self->{_program_extensions_as_regexes}; + + my %program_extensions = hashify( $self->program_extensions() ); + $program_extensions{'.PL'} = 1; + return @{ + $self->{_program_extensions_as_regexes} = [ + map { qr< @{[quotemeta $_]} \z >smx } sort keys %program_extensions + ] + }; +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=for stopwords colour INI-style -params + +=head1 NAME + +Perl::Critic::Config - The final derived Perl::Critic configuration, combined from any profile file and command-line parameters. + + +=head1 DESCRIPTION + +Perl::Critic::Config takes care of finding and processing +user-preferences for L. The Config object +defines which Policy modules will be loaded into the Perl::Critic +engine and how they should be configured. You should never really +need to instantiate Perl::Critic::Config directly because the +Perl::Critic constructor will do it for you. + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 CONSTRUCTOR + +=over + +=item C<< new(...) >> + +Not properly documented because you shouldn't be using this. + + +=back + +=head1 METHODS + +=over + +=item C<< add_policy( -policy => $policy_name, -params => \%param_hash ) >> + +Creates a Policy object and loads it into this Config. If the object +cannot be instantiated, it will throw a fatal exception. Otherwise, +it returns a reference to this Critic. + +B<-policy> is the name of a +L subclass module. The +C<'Perl::Critic::Policy'> portion of the name can be omitted for +brevity. This argument is required. + +B<-params> is an optional reference to a hash of Policy parameters. +The contents of this hash reference will be passed into to the +constructor of the Policy module. See the documentation in the +relevant Policy module for a description of the arguments it supports. + + +=item C< all_policies_enabled_or_not() > + +Returns a list containing references to all the Policy objects that +have been seen. Note that the state of these objects is not +trustworthy. In particular, it is likely that some of them are not +prepared to examine any documents. + + +=item C< policies() > + +Returns a list containing references to all the Policy objects that +have been enabled and loaded into this Config. + + +=item C< exclude() > + +Returns the value of the C<-exclude> attribute for this Config. + + +=item C< include() > + +Returns the value of the C<-include> attribute for this Config. + + +=item C< force() > + +Returns the value of the C<-force> attribute for this Config. + + +=item C< only() > + +Returns the value of the C<-only> attribute for this Config. + + +=item C< profile_strictness() > + +Returns the value of the C<-profile-strictness> attribute for this +Config. + + +=item C< severity() > + +Returns the value of the C<-severity> attribute for this Config. + + +=item C< single_policy() > + +Returns the value of the C<-single-policy> attribute for this Config. + + +=item C< theme() > + +Returns the L object that was +created for this Config. + + +=item C< top() > + +Returns the value of the C<-top> attribute for this Config. + + +=item C< verbose() > + +Returns the value of the C<-verbose> attribute for this Config. + + +=item C< color() > + +Returns the value of the C<-color> attribute for this Config. + + +=item C< pager() > + +Returns the value of the C<-pager> attribute for this Config. + + +=item C< unsafe_allowed() > + +Returns the value of the C<-allow-unsafe> attribute for this Config. + + +=item C< criticism_fatal() > + +Returns the value of the C<-criticism-fatal> attribute for this Config. + + +=item C< color_severity_highest() > + +Returns the value of the C<-color-severity-highest> attribute for this +Config. + + +=item C< color_severity_high() > + +Returns the value of the C<-color-severity-high> attribute for this +Config. + + +=item C< color_severity_medium() > + +Returns the value of the C<-color-severity-medium> attribute for this +Config. + + +=item C< color_severity_low() > + +Returns the value of the C<-color-severity-low> attribute for this +Config. + + +=item C< color_severity_lowest() > + +Returns the value of the C<-color-severity-lowest> attribute for this +Config. + +=item C< program_extensions() > + +Returns the value of the C<-program_extensions> attribute for this Config. +This is an array of the file name extensions that represent program files. + +=item C< program_extensions_as_regexes() > + +Returns the value of the C<-program_extensions> attribute for this Config, as +an array of case-sensitive regexes matching the ends of the file names that +represent program files. + +=back + + +=head1 SUBROUTINES + +Perl::Critic::Config has a few static subroutines that are used +internally, but may be useful to you in some way. + + +=over + +=item C + +Returns a list of all the Policy modules that are currently installed +in the Perl::Critic:Policy namespace. These will include modules that +are distributed with Perl::Critic plus any third-party modules that +have been installed. + + +=back + + +=head1 CONFIGURATION + +Most of the settings for Perl::Critic and each of the Policy modules +can be controlled by a configuration file. The default configuration +file is called F<.perlcriticrc>. +L will look for this file +in the current directory first, and then in your home directory. +Alternatively, you can set the C environment variable to +explicitly point to a different file in another location. If none of +these files exist, and the C<-profile> option is not given to the +constructor, then all Policies will be loaded with their default +configuration. + +The format of the configuration file is a series of INI-style blocks +that contain key-value pairs separated by '='. Comments should start +with '#' and can be placed on a separate line or after the name-value +pairs if you desire. + +Default settings for Perl::Critic itself can be set B For example, putting any or all of these at the top of +your configuration file will set the default value for the +corresponding Perl::Critic constructor argument. + + severity = 3 #Integer from 1 to 5 + only = 1 #Zero or One + force = 0 #Zero or One + verbose = 4 #Integer or format spec + top = 50 #A positive integer + theme = risky + (pbp * security) - cosmetic #A theme expression + include = NamingConventions ClassHierarchies #Space-delimited list + exclude = Variables Modules::RequirePackage #Space-delimited list + color = 1 #Zero or One + allow_unsafe = 1 #Zero or One + color-severity-highest = bold red #Term::ANSIColor + color-severity-high = magenta #Term::ANSIColor + color-severity-medium = #no coloring + color-severity-low = #no coloring + color-severity-lowest = #no coloring + program-extensions = #Space-delimited list + +The remainder of the configuration file is a series of blocks like +this: + + [Perl::Critic::Policy::Category::PolicyName] + severity = 1 + set_themes = foo bar + add_themes = baz + arg1 = value1 + arg2 = value2 + +C is the full name of a +module that implements the policy. The Policy modules distributed +with Perl::Critic have been grouped into categories according to the +table of contents in Damian Conway's book B. For +brevity, you can omit the C<'Perl::Critic::Policy'> part of the module +name. + +C is the level of importance you wish to assign to the +Policy. All Policy modules are defined with a default severity value +ranging from 1 (least severe) to 5 (most severe). However, you may +disagree with the default severity and choose to give it a higher or +lower severity, based on your own coding philosophy. + +The remaining key-value pairs are configuration parameters that will +be passed into the constructor of that Policy. The constructors for +most Policy modules do not support arguments, and those that do should +have reasonable defaults. See the documentation on the appropriate +Policy module for more details. + +Instead of redefining the severity for a given Policy, you can +completely disable a Policy by prepending a '-' to the name of the +module in your configuration file. In this manner, the Policy will +never be loaded, regardless of the C<-severity> given to the +Perl::Critic::Config constructor. + +A simple configuration might look like this: + + #-------------------------------------------------------------- + # I think these are really important, so always load them + + [TestingAndDebugging::RequireUseStrict] + severity = 5 + + [TestingAndDebugging::RequireUseWarnings] + severity = 5 + + #-------------------------------------------------------------- + # I think these are less important, so only load when asked + + [Variables::ProhibitPackageVars] + severity = 2 + + [ControlStructures::ProhibitPostfixControls] + allow = if unless #My custom configuration + severity = 2 + + #-------------------------------------------------------------- + # Give these policies a custom theme. I can activate just + # these policies by saying (-theme => 'larry + curly') + + [Modules::RequireFilenameMatchesPackage] + add_themes = larry + + [TestingAndDebugging::RequireTestLables] + add_themes = curly moe + + #-------------------------------------------------------------- + # I do not agree with these at all, so never load them + + [-NamingConventions::Capitalization] + [-ValuesAndExpressions::ProhibitMagicNumbers] + + #-------------------------------------------------------------- + # For all other Policies, I accept the default severity, theme + # and other parameters, so no additional configuration is + # required for them. + +For additional configuration examples, see the F file +that is included in this F directory of this distribution. + + +=head1 THE POLICIES + +A large number of Policy modules are distributed with Perl::Critic. +They are described briefly in the companion document +L and in more +detail in the individual modules themselves. + + +=head1 POLICY THEMES + +Each Policy is defined with one or more "themes". Themes can be used +to create arbitrary groups of Policies. They are intended to provide +an alternative mechanism for selecting your preferred set of Policies. +For example, you may wish disable a certain subset of Policies when +analyzing test programs. Conversely, you may wish to enable only a +specific subset of Policies when analyzing modules. + +The Policies that ship with Perl::Critic are have been broken into the +following themes. This is just our attempt to provide some basic +logical groupings. You are free to invent new themes that suit your +needs. + + THEME DESCRIPTION + -------------------------------------------------------------------------- + core All policies that ship with Perl::Critic + pbp Policies that come directly from "Perl Best Practices" + bugs Policies that prevent or reveal bugs + maintenance Policies that affect the long-term health of the code + cosmetic Policies that only have a superficial effect + complexity Policies that specificaly relate to code complexity + security Policies that relate to security issues + tests Policies that are specific to test programs + +Say C<`perlcritic -list`> to get a listing of all available policies +and the themes that are associated with each one. You can also change +the theme for any Policy in your F<.perlcriticrc> file. See the +L<"CONFIGURATION"> section for more information about that. + +Using the C<-theme> option, you can combine theme names with +mathematical and boolean operators to create an arbitrarily complex +expression that represents a custom "set" of Policies. The following +operators are supported + + Operator Alternative Meaning + ---------------------------------------------------------------------------- + * and Intersection + - not Difference + + or Union + +Operator precedence is the same as that of normal mathematics. You +can also use parenthesis to enforce precedence. Here are some +examples: + + Expression Meaning + ---------------------------------------------------------------------------- + pbp * bugs All policies that are "pbp" AND "bugs" + pbp and bugs Ditto + + bugs + cosmetic All policies that are "bugs" OR "cosmetic" + bugs or cosmetic Ditto + + pbp - cosmetic All policies that are "pbp" BUT NOT "cosmetic" + pbp not cosmetic Ditto + + -maintenance All policies that are NOT "maintenance" + not maintenance Ditto + + (pbp - bugs) * complexity All policies that are "pbp" BUT NOT "bugs", + AND "complexity" + (pbp not bugs) and complexity Ditto + +Theme names are case-insensitive. If C<-theme> is set to an empty +string, then it is equivalent to the set of all Policies. A theme +name that doesn't exist is equivalent to an empty set. Please See +L for a discussion on set theory. + + +=head1 SEE ALSO + +L, +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/DEVELOPER.pod b/lib/Perl/Critic/DEVELOPER.pod new file mode 100644 index 0000000..0e965b5 --- /dev/null +++ b/lib/Perl/Critic/DEVELOPER.pod @@ -0,0 +1,1104 @@ +=pod + +=for stopwords lookup RequireBlockGrep + +=head1 NAME + +Perl::Critic::DEVELOPER - How to make new Perl::Critic::Policy modules. + + +=head1 DESCRIPTION + +For developers who want to create custom coding standards, the +following tells how to create a Policy module for +L. Although the Perl::Critic distribution +already includes a number of Policies based on Damian Conway's book +I (which will be referred to via "I" from +here on), Perl::Critic is not limited to his guidelines and can be +used to enforce any practice, preference, or style that you want to +follow. You can even write Policies to enforce contradictory +guidelines. All you need to do is write a corresponding +L subclass, which may +require as little as 10 lines of code. + + +=head1 BACKGROUND + +The heart of Perl::Critic is L, a parser and lexer for Perl. +PPI transforms Perl source code into a Document Object Model (DOM). +Each token in the document is represented by a PPI class, such as +L or +L, and then organized into +structure classes, like +L and +L. The root +node of the hierarchy is the L. + +The L engine traverses each node in the +L tree and invokes each of the +L subclasses at the +appropriate node. The Policy can inspect the node, look at the +surrounding nodes, and do whatever else it wants. If the Policy +decides that a coding standard has been violated, it returns one +or more L objects. +If there are no violations, then the Policy returns nothing. + +Policies are usually written based on existing policies, so let's look +at one to see how it works. The F Policy is +relatively simple and demonstrates most of the important issues. The +goal of this Policy is to enforce that every call to C uses a +block for the first argument and not an expression. The reasons for +this Policy are discussed in detail in I. + + +=head1 EXAMPLE POLICY + +First, the Policy module needs to have a name. Perl::Critic uses +L to automatically discover all +modules in the C namespace. Also, we've adopted +the convention of grouping Policies into directories according to the +chapters of I. Since the goal of this Policy is to enforce the +use of block arguments to C and it comes from the "Builtin +Functions" chapter of I, we call it +C<"Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep">. + + package Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep; + +Next, we set some pragmas and load the modules that we'll need. All +Policy modules inherit from the +L class, which provides +no-op implementations of the basic methods. Our job is to override +these methods to make them do something useful. + +Technically, C and C are optional, but we +don't want Perl::Critic to be a hypocrite, now do we? + + use strict; + use warnings; + + use Readonly; + + use Perl::Critic::Utils qw{ :severities :classification :ppi }; + use base 'Perl::Critic::Policy'; + + our $VERSION = '1.05'; + +Next, we'll declare a description and explanation for this Policy. +The description is always just a string that basically says "this is +what's wrong." The explanation can be either a string with further +details, or a reference to an array of integers that correspond to +page numbers in I. We make them read-only because they never +change. (See +L +for why we don't C.) + + Readonly::Scalar my $DESC => q{Expression form of "grep"}; + Readonly::Scalar my $EXPL => [ 169 ]; + +Most policies don't need to override the C +method provided by L. +However, if your Policy is configurable via F<.perlcriticrc>, you +should implement a C method and need to +implement C to examine the C<$config> values. +Since this Policy isn't configurable, we'll declare that by providing +an implementation of C that returns an empty +list. + + sub supported_parameters { return () } + +Next, we define the C method, which must return an +integer indicating the severity of violating this Policy. Severity +values range from 1 to 5, where 5 is the "most severe." In general, +level 5 is reserved for things that are frequently misused and/or +cause bugs. Level 1 is for things that are highly subjective or +purely cosmetic. The L +package exports several severity constants that you can use here via +the C<:severities> tag. + + sub default_severity { return $SEVERITY_HIGH } + +Likewise, the C method returns a list of theme +names. Themes are intended to be named groups of Policies. All +Policies that ship with Perl::Critic have a C<"core"> theme. Since +use of C without blocks often leads to bugs, we include a +C<"bugs"> theme. And since this Policy comes directly from I, +this Policy should be a member of the C<"pbp"> theme. + + sub default_themes { return qw( core bugs pbp ) } + +As a Policy author, you can assign any themes you want to the Policy. +If you're publishing a suite of custom Policies, we suggest that you +create a unique theme that covers all the Policies in the +distribution. That way, users can easily enable or disable all of +your policies at once. For example, Policies in the +L distribution all have a +C<"more"> theme. + +Next, we indicate what elements of the code this Policy will analyze, +like statements or variables or conditionals or POD. These elements +are specified as PPI classes such as L, +L, +L or +L respectively. The C +method returns a list of PPI package names. (You can get that list of +available package names via C.) As Perl::Critic +traverses the document, it will call the C method from +this module whenever it encounters one of the PPI types that are given +here. In this case, we just want to test calls to C. Since the +token "grep" is a L, we return that +package name from the C method. + + sub applies_to { return 'PPI::Token::Word' } + +If your Policy needs to analyze several different types of elements, +the C method may return the name of several PPI packages. +If your Policy needs to examine the file as a whole, then the +C method should return L. +Since there is only one PPI::Document element, your Policy would only +be invoked once per file. + +Now comes the interesting part. The C method does all the +work. It is always called with 2 arguments: a reference to the +current PPI element that Perl::Critic is traversing, and a reference +to the entire PPI document. [And since this is an object method, there +will be an additional argument that is a reference to this object +(C<$self>), but you already knew that!] Since this Policy does not +need access to the document as a whole, we ignore the last parameter +by assigning to C. + + sub violates { + my ( $self, $elem, undef ) = @_; + +The C method then often performs some tests to make sure +we have the right "type" of element. In our example, we know that the +element will be a L because that's +what we declared back in the C method. However, we +didn't specify exactly which "word" we were looking for. Evaluating a +PPI element in a string context returns the literal form of the code. +(You can also use the C method.) So we make sure that this +C is, in fact, "grep". If it's not, then we don't +need to bother examining it. + + return if $elem ne 'grep'; + +The C class is also used for barewords and methods +called on object references. It is possible for someone to declare a +bareword hash key as C<< %hash = ( grep => 'foo') >>. We don't want +to test those types of elements because they don't represent function +calls to C. So we use one of handy utility functions from +L to make sure that this +"grep" is actually in the right context. (The C +subroutine is brought in via the C<:classification> tag.) + + return if ! is_function_call($elem); + +Now that we know this element is a call to the C function, we +can look at the nearby elements to see what kind of arguments are +being passed to it. In the following paragraphs, we discuss how to do +this manually in order to explore L; after that, we'll show +how this Policy actually uses facilities provided by +L to get this done. + +Every PPI element is linked to its siblings, parent, and children (if +it has any). Since those siblings could just be whitespace, we use +the C to get the next code-sibling (the "s" in +C stands for "significant"). + + my $sib = $elem->snext_sibling() or return; + +In Perl, the parenthesis around argument lists are usually optional, +and PPI packs the elements into a +L object when parentheses +are used. So if the sibling is a C, we pull out +the first (significant) child of that list. This child will be the +first argument to C. If parentheses were not used, then the +sibling itself is the first argument. + + my $arg = $sib->isa('PPI::Structure::List') ? $sib->schild(0) : $sib; + +In actuality, this sort of function argument lookup is common, so +there is a L subroutine available via +the C<:ppi> tag. So we use that instead. + + my $arg = first_arg($elem); + +Finally, we now have a reference to the first argument to C. If +that argument is a block (i.e. something in curly braces), then it +will be a L, in which +case our Policy is satisfied and we just return nothing. + + return if !$arg; + return if $arg->isa('PPI::Structure::Block'); + +But if it is not a L, +then we know that this call to C must be using the expression +form, and that violates our Policy. So we create and return a new +L object via the +L method, passing in the +description, explanation, and a reference to the PPI element that +caused the violation. And that's all there is to it! + + return $self->violation( $DESC, $EXPL, $elem ); + } + + 1; + +One last thing -- people are going to need to understand what is wrong +with the code when your Policy finds a problem. It isn't reasonable +to include all the details in your violation description or +explanation. So please include a DESCRIPTION section in the POD for +your Policy. It should succinctly describe the behavior and +motivation for your Policy and include a few examples of both good and +bad code. Here's an example: + + =pod + + =head1 NAME + + Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep + + + =head1 DESCRIPTION + + The expression forms of C and C are awkward and hard to read. + Use the block forms instead. + + @matches = grep /pattern/, @list; #not ok + @matches = grep { /pattern/ } @list; #ok + + @mapped = map transform($_), @list; #not ok + @mapped = map { transform($_) } @list; #ok + + =cut + +When your policy has a section like this, users can invoke +L with a C<--verbose> parameter of C<10> or +C<11> or with a "%d" escape to see it along with the rest of the +output for violations of your policy. + + +=head1 MAKING YOUR POLICY CONFIGURABLE + +L takes care of gathering configuration +information for your Policy, from whatever source the user specifies. +(See L for the details of how a user +specifies the values you're going to receive.) What your Policy ends +up receiving for the value of a parameter is a string with leading and +trailing whitespace removed. By default, you will need to handle +conversion of that string to a useful form yourself. However, if you +provide some metadata about your parameters, the parameter handling +will be taken care of for you. (Additionally, tools that deal with +Policies themselves can use this information to enhance their +functionality. See the L C<--profile-proto> +option for an example.) + +You can look at +L +for a simple example of a configurable Policy and +L +for a more complex one. + +=head2 Do It All Yourself + +The C method for a Policy receives one +argument: an instance of +L. This method +is only called if the user's configuration has enabled the policy. It +returns a boolean stating whether the Policy should continue to be +enabled. Generally, the only reason to return C<$FALSE> is when some +external requirement is missing. For example, +L +used to disable itself if L was not installed +(that is until we made it no longer optional for the Perl-Critic +distribution). + +A basic, do-nothing implementation of C would +be: + + use Perl::Critic::Utils qw< :booleans >; + + ... + + sub initialize_if_enabled { + my ( $self, $config ) = @_; + + return $TRUE; + } + +As stated above, what you get in C<$config> are trimmed strings. For +example, if the user's F<.perlcritic> contains + + [Your::Policy] + foo = bar baz + factor = 5.52 + selections = 2 78 92 + +then C<$config> will contain the equivalent of + + my $config = { + foo => 'bar baz', + factor => '5.52', + selections => '2 78 92', + }; + +To make this available to the C method, the values are +usually put into C<$self> under the name of the configuration item +prefixed with an underscore. E.g. + + sub initialize_if_enabled { + my ( $self, $config ) = @_; + + $self->{_foo} = $config->get{foo}; + $self->{_factor} = $config->get{factor}; + $self->{_selections} = $config->get{selections}; + + return $TRUE; + } + +Often, you'll want to convert the configuration values into something +more useful. In this example, C is supposed to be a list +of integers. L contains a +number of functions that can help you with this. Assuming that +C wants to have C as an array, you'll want to +have something like this: + + use Perl::Critic::Utils qw{ :booleans :characters :data_conversion }; + + sub initialize_if_enabled { + my ( $self, $config ) = @_; + + $self->{_foo} = $config->get{foo}; + $self->{_factor} = $config->get{factor}; + + my $selections = $config->get{selections}; + $selections = defined $selections ? $selections : $EMPTY_STRING; + $self->{_selections} = [ words_from_string($selections) ]; + + return $TRUE; + } + +Since C contains numbers, it may be desirable to change +the assignment to look like + + $self->{_selections} = [ map { $_ + 0 } words_from_string($selections) ]; + +If C needs to quickly determine whether a particular value +is in C, you would want to use a hash instead of an array, +like this: + + $self->{_selections} = { hashify( words_from_string($selections) ) }; + +For an example of a Policy that has some simple, but non-standard +configuration handling, see +L. + + +=head2 Note On Constructors + +It used to be the case that Policies handled configuration by +implementing a constructor. However, there was no requirement to call +the base constructor; as long as the Policy ended up being a blessed +hash reference, everything was fine. Unfortunately, this meant that +Policies would be loaded and their prerequisites would be Cd, +even if the Policy wasn't enabled, slowing things down. Also, this +severely restricted the core of L's ability +to enhance things. Use of constructors is deprecated and is +incompatible with C metadata below. Kindly +use C, instead, to do any sort of set up that +you need. + + + +=head2 Providing Basic Configuration Information Via C + +As minimum for a well behaved Policy, you should implement +C in order to tell the rest of C +what configuration values the Policy looks for, even if it is only to +say that the Policy is not configurable. In the simple form, this +function returns a list of the names of the parameters the Policy +supports. So, for an non-configurable Policy, as in the +C example above, this looked like + + sub supported_parameters { return () } + +For the example being used in the C section +above, this would be + + sub supported_parameters { return qw< foo factor selections >; } + +Given this information, C can tell the user when they +have specified a parameter for a Policy which isn't valid, e.g. when +they've misspelled the name of the parameter, and can emit the +parameter as part of a F<.perlcriticrc> prototype. + +You can provide even more information about your Policy's +configuration by giving each parameter a description and a string +representation of the default value for the parameter. You do this by +having the values in the list returned by C be +hash references instead of strings, with keys of C, +C, and C. For example, + + sub supported_parameters { + return ( + { + name => 'allowed_values', + description => + 'Individual and ranges of values to allow, and/or "all_integers".', + default_string => '0 1 2', + }, + { + name => 'allowed_types', + description => 'Kind of literals to allow.', + default_string => 'Float', + }, + ); + } + +Note that use of constructors is +L with specifying parameters in +this way. + + +=head2 Using C to Get It Done For You + +The C discussion above showed how you could +help others with your Policy, but didn't do anything to make your life +as a Policy author easier; you still need to implement +C to access any configuration that the user +has specified. To have the configuration automatically handled for +you, you need to declare how your parameters act by specifying a value +for their C. For example, the following declares that a +parameter allows the user to choose from five specific values and that +the user can select any combination of them: + + sub supported_parameters { + return ( + { + name => 'allowed_types', + description => 'Kind of literals to allow.', + default_string => 'Float', + behavior => 'enumeration', + enumeration_values => [ qw{ Binary Exp Float Hex Octal } ], + enumeration_allow_multiple_values => 1, + }, + ); + } + +When you specify a behavior, parsing and validation of the +user-specified and default values is done for you and your +C method can retrieve the value under the key of the +parameter name prefixed with an underscore, e.g., for the above +declaration, the parsed and validated value can be accessed via +C<< $self->{_allowed_types} >>. + +The behaviors provide additional functionality to C; for +more on this, see +L and +L. + +The following discusses each of the supported behaviors and the +options they support. For the full details of a behavior, see the +documentation for the implementing class. + + +=head3 "string" + +Implemented in +L. + +The most basic of behaviors, the value of the parameter will be stored +in the Policy as a string. + +This behavior is not configurable. + +=head4 C example + + sub supported_parameters { + return ( + { + name => 'a_string', + description => 'An example string.', + default_string => 'blah blah blah', + behavior => 'string', + }, + ); + } + + +=head4 Access example + + sub violates { + my ($self, $element, $document) = @_; + + ... + my $string = $self->{_a_string}; + ... + } + + +=head3 "boolean" + +Implemented in +L. + +The value of the parameter will be either +L<$TRUE|Perl::Critic::Utils/$TRUE> or +L<$FALSE|Perl::Critic::Utils/$FALSE>. + +This behavior is not configurable. + +=head4 C example + + sub supported_parameters { + return ( + { + name => 'a_boolean', + description => 'An example boolean.', + default_string => '1', + behavior => 'boolean', + }, + ); + } + + +=head4 Access example + + sub violates { + my ($self, $element, $document) = @_; + + ... + my $is_whatever = $self->{_a_boolean}; + if ($is_whatever) { + ... + } + ... + } + + +=head3 "integer" + +Implemented in +L. + +The value is validated against C +(with an special check for "0"). Notice that this means that +underscores are allowed in input values as with Perl numeric literals. + +This takes two options, C and C, +which specify endpoints of an inclusive range to restrict the value +to. Either, neither, or both may be specified. + +=head4 C example + + sub supported_parameters { + return ( + { + name => 'an_integer', + description => 'An example integer.', + default_string => '5', + behavior => 'integer', + integer_minimum => 0, + integer_maximum => 10, + }, + ); + } + + +=head4 Access example + + sub violates { + my ($self, $element, $document) = @_; + + ... + my $integer = $self->{_an_integer}; + if ($integer > $TURNING_POINT) { + ... + } + ... + } + + +=head3 "string list" + +Implemented in +L. + +The values will be derived by splitting the input string on blanks. +(See L.) The parameter will +be stored as a reference to a hash, with the values being the keys. + +This takes one optional option, C, of a +reference to an array of strings that will always be included in the +parameter value, e.g. if the value of this option is C<[ qw{ a b c } +]> and the user specifies a value of C<'c d e'>, then the value of the +parameter will contain C<'a'>, C<'b'>, C<'c'>, C<'d'>, and C<'e'>. + +=head4 C example + + sub supported_parameters { + return ( + { + name => 'a_string_list', + description => 'An example list.', + default_string => 'red pink blue', + behavior => 'string list', + list_always_present_values => [ qw{ green purple} ], + }, + ); + } + + +=head4 Access example + + sub violates { + my ($self, $element, $document) = @_; + + ... + my $list = $self->{_a_string_list}; + my @list = keys %{$list}; + ... + return if not $list->{ $element->content() }; + ... + } + + +=head3 "enumeration" + +Implemented in +L. + +The values will be derived by splitting the input string on blanks. +(See L.) Depending upon the +value of the C option, the +parameter will be stored as a string or a reference to a hash, with +the values being the keys. + +This behavior takes one required option and one optional one. A value +for C of a reference to an array of valid strings +is required. A true value can be specified for +C to allow the user to pick more +than one value, but this defaults to false. + +=head4 C example + + use Perl::Critic::Utils qw{ :characters }; + + sub supported_parameters { + return ( + { + name => 'a_single_valued_enumeration', + description => + 'An example enumeration that can only have a single value.', + default_string => $EMPTY, + behavior => 'enumeration', + enumeration_values => [ qw{ block statement pod operator } ], + enumeration_allow_multiple_values => 0, + }, + { + name => 'a_multi_valued_enumeration', + description => + 'An example enumeration that can have multiple values.', + default_string => 'fe', + behavior => 'enumeration', + enumeration_values => [ qw{ fe fi fo fum } ], + enumeration_allow_multiple_values => 1, + }, + ); + } + + +=head4 Access example + + sub violates { + my ($self, $element, $document) = @_; + + ... + my $single_value = $self->{_a_single_valued_enumeration}; + ... + my $multi_value = $self->{_a_multi_valued_enumeration}; + if ( $multi_value->{fum} ) { + ... + } + ... + } + + +=head2 Using a Custom Parser + +If none of the behaviors does exactly what you want it to, you can +provide your own parser for a parameter. The reason for doing this as +opposed to using an implementation of C is +that it allows you to use a behavior to provide its extra +functionality and it provides a means for a C +configuration program, e.g. an IDE that integrates C, to +validate your parameter as the user modifies its value. + +The way you declare that you have a custom parser is to include a +reference to it in the parameter specification with the C key. +For example: + + sub supported_parameters { + return ( + { + name => 'file_name', + description => 'A file for to read a list of values from.', + default_string => undef, + behavior => 'string', + parser => \&_parse_file_name, + }, + ); + } + +A parser is a method on a subclass of +L that takes two +parameters: the +L that is +being specified and the value string provided by the user. The method +is responsible for dealing with any default value and for saving the +parsed value for later use by the C method. + +An example parser (without enough error handling) for the above +example declaration: + + use Path::Tiny; + + use Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue + qw{ throw_policy_value }; + + sub _parse_file_name { + my ($self, $parameter, $config_string) = @_; + + my @thingies; + + if ($config_string) { + if (not -r $config_string) { + throw_policy_value + policy => $self->get_short_name(), + option_name => $parameter->get_name(), + option_value => $config_string, + message_suffix => 'is not readable.'; + } + + @thingies = path($config_string)->slurp; + } + + $self->{_thingies} = \@thingies; + + return; + } + +Note that, if the value for the parameter is not valid, an instance of +L +is thrown. This allows C to include that problem along +with any other problems found with the user's configuration in a +single error message. + + +=head2 Using Both C and C + +There are cases where a Policy needs additional initialization beyond +configuration or where the way it acts depends upon the combination of +multiple parameters. In such situations, you will need to create an +implementation of C. If you want to take +advantage of the supplied parameter handling from within +implementation of C, note that the +information from C will already have been +used, with user-supplied parameter values validated and placed into +the Policy by the time C has been called. It +is likely that you will not need to refer the contents of the +C<$config> parameter; just pull the information you need out of +C<$self>. In fact, any value for the parameter values will be gone. + + + +=head2 Summary of permitted hash keys in C. + + +=head3 All types + + +=over + +=item - "name" (mandatory) + +=item - "description" (optional) + +=item - "behavior" (optional) + +Currently, one of: + +=over + +=item "boolean" + +=item "enumeration" + +=item "integer" + +=item "string" + +=item "string list" + +=back + +=item - "default_string" (optional) + +A string representation of the default value of the parameter. + +=item - "parser" (optional) + +A code ref to a custom parser for the parameter. + +=back + +=head3 Enumerations + +=over + +=item - "enumeration_values" (mandatory) + +A mandatory reference to an array of strings. + +=item - "enumeration_allow_multiple_values" (optional) + +Boolean indicating whether or not the user is restricted to a single +value. + +=back + +=head3 Integers + +=over + +=item - "integer_minimum" (optional) + +Minimum allowed value, inclusive. + +=item - "integer_maximum" (optional) + +Maximum allowed value, inclusive. + +=back + +=head3 String lists + +=over + +=item - "list_always_present_values" (optional) + +A reference to an array of values that should always be included in +the value of the parameter. + +=back + + +=head1 ADDITIONAL FEATURES + +=head2 C + +Certain problems that a Policy detects can be endemic to a particular +file; if there's one violation, there's likely to be many. A good +example of this is +L; +if there's one line before C, there's a good chance that +the entire file is missing C. In such cases, it's not +much help to the user to report every single violation. If you've got +such a policy, you should override +L +method to provide a limit. The user can override this value with a +value for "maximum_violations_per_document" in their F<.perlcriticrc>. + +See the source code for +L +and +L +for examples. + + +=head2 C + +Most L Policies are purely I. In other words, +they never compile or execute any of the source code that they +analyze. However it is possible to write I Policies that do +compile or execute code, which may result in unsafe operations (see +L for an example). So +the C method is used to indicate whether a Policy can be +trusted to not cause mischief. By default, C returns true. +But if you are writing a Policy that will compile or execute any of +the source code that it analyzes, then you should override the +C method to return false. + + +=head1 DISTRIBUTING YOUR POLICIES + +=head2 Create a Distribution + +You need to come up with a name for your set of policies. Sets of +add-on policies are generally named C>, +e.g. L. + +The module representing the distribution will not actually have any +functionality; it's just documentation and a name for users to use +when installing via L/L. The important +part is that this will include a list of the included policies, with +descriptions of each. + +A typical implementation will look like: + + package Perl::Critic::Example; + + use strict; + use warnings; + + our $VERSION = '1.000000'; + + 1; # Magic true value required at end of module + + __END__ + + =head1 NAME + + Perl::Critic::Example - Policies for Perl::Critic that act as an example. + + =head1 AFFILIATION + + This module has no functionality, but instead contains documentation + for this distribution and acts as a means of pulling other modules + into a bundle. All of the Policy modules contained herein will have + an "AFFILIATION" section announcing their participation in this + grouping. + + + =head1 SYNOPSIS + + Some L policies that will help you keep your + code nice and compliant. + + + =head1 DESCRIPTION + + The included policies are: + + =over + + =item L + + Complains about some example documentation issues. [Default severity: 3] + + + =item L + + All modules must have at least one variable. [Default severity: 3] + + + =back + + + =head1 CONFIGURATION AND ENVIRONMENT + + All policies included are in the "example" theme. See the + L documentation for how to make use of this. + + +=head2 Themes + +Users can choose which policies to enable using themes. You should +implement C so that users can take advantage of +this. In particular, you should use a theme named after your +distribution in all your policies; this should match the value listed +in the C POD section as shown above. + + default_themes { return qw< example math > } + +If you're looking for ideas of what themes to use, have a look at the +output of C. + + +=head2 Documentation + +=head3 AFFILIATION + +Since all policies have to go somewhere under the +C namespace, it isn't always clear what +distribution a policy came from when browsing through their +documentation. For this reason, you should include an C +section in the POD for all of your policies that state where the +policy comes from. For example: + + =head1 AFFILIATION + + This policy is part of L. + + +=head3 CONFIGURATION + +In order to make it clear what can be done with a policy, you should +always include a C section in your POD, even if it's +only to say: + + =head1 CONFIGURATION + + This Policy is not configurable except for the standard options. + +=head1 TESTING YOUR POLICY + +The L distribution also contains a framework for testing your +Policy. See L for the details. + +=head1 HINT + +When you're trying to figure out what L is going to hand you +for a chunk of code, there is a F program in the +L distribution that will help you. For +example, when developing the above RequireBlockGrep example, you might +want to try + + tools/ppidump '@matches = grep /pattern/, @list;' + +and + + tools/ppidump '@matches = grep { /pattern/ } @list;' + +to see the differences between the two cases. + +Alternatively, see the C documentation at +L +and the C documentation at +L. + + +=head1 VERSION + +This is part of L version 1.116. + + +=head1 SEE ALSO + +Chas. Owens has a blog post about developing in-house policies at +L. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=70 ft=pod expandtab shiftround : diff --git a/lib/Perl/Critic/Document.pm b/lib/Perl/Critic/Document.pm new file mode 100644 index 0000000..fb95ec7 --- /dev/null +++ b/lib/Perl/Critic/Document.pm @@ -0,0 +1,882 @@ +package Perl::Critic::Document; + +use 5.006001; +use strict; +use warnings; + +use Carp qw< confess >; + +use List::Util qw< reduce >; +use Scalar::Util qw< blessed refaddr weaken >; +use version; + +use PPI::Document; +use PPI::Document::File; +use PPIx::Utilities::Node qw< split_ppi_node_by_namespace >; + +use Perl::Critic::Annotation; +use Perl::Critic::Exception::Parse qw< throw_parse >; +use Perl::Critic::Utils qw< :booleans :characters shebang_line >; + +use PPIx::Regexp 0.010 qw< >; + +#----------------------------------------------------------------------------- + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +our $AUTOLOAD; +sub AUTOLOAD { ## no critic (ProhibitAutoloading,ArgUnpacking) + my ( $function_name ) = $AUTOLOAD =~ m/ ([^:\']+) \z /xms; + return if $function_name eq 'DESTROY'; + my $self = shift; + return $self->{_doc}->$function_name(@_); +} + +#----------------------------------------------------------------------------- + +sub new { + my ($class, @args) = @_; + + my $self = bless {}, $class; + + $self->_init_common(); + $self->_init_from_external_source(@args); + + return $self; +} + +#----------------------------------------------------------------------------- + +sub _new_for_parent_document { + my ($class, $ppi_document, $parent_document) = @_; + + my $self = bless {}, $class; + + $self->_init_common(); + + $self->{_doc} = $ppi_document; + $self->{_is_module} = $parent_document->is_module(); + + return $self; +} + +#----------------------------------------------------------------------------- + +sub _init_common { + my ($self) = @_; + + $self->{_annotations} = []; + $self->{_suppressed_violations} = []; + $self->{_disabled_line_map} = {}; + + return; +} + +#----------------------------------------------------------------------------- + +sub _init_from_external_source { ## no critic (Subroutines::RequireArgUnpacking) + my $self = shift; + my %args; + + if (@_ == 1) { + warnings::warnif( + 'deprecated', + 'Perl::Critic::Document->new($source) deprecated, use Perl::Critic::Document->new(-source => $source) instead.' ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars) + ); + %args = ('-source' => shift); + } else { + %args = @_; + } + + my $source_code = $args{'-source'}; + + # $source_code can be a file name, or a reference to a + # PPI::Document, or a reference to a scalar containing source + # code. In the last case, PPI handles the translation for us. + + my $ppi_document = + _is_ppi_doc($source_code) + ? $source_code + : ref $source_code + ? PPI::Document->new($source_code) + : PPI::Document::File->new($source_code); + + # Bail on error + if (not defined $ppi_document) { + my $errstr = PPI::Document::errstr(); + my $file = ref $source_code ? undef : $source_code; + throw_parse + message => qq, + file_name => $file; + } + + $self->{_doc} = $ppi_document; + $self->index_locations(); + $self->_disable_shebang_fix(); + $self->{_filename_override} = $args{'-filename-override'}; + $self->{_is_module} = $self->_determine_is_module(\%args); + + return; +} + +#----------------------------------------------------------------------------- + +sub _is_ppi_doc { + my ($ref) = @_; + return blessed($ref) && $ref->isa('PPI::Document'); +} + +#----------------------------------------------------------------------------- + +sub ppi_document { + my ($self) = @_; + return $self->{_doc}; +} + +#----------------------------------------------------------------------------- + +sub isa { ## no critic ( Subroutines::ProhibitBuiltinHomonyms ) + my ($self, @args) = @_; + return $self->SUPER::isa(@args) + || ( (ref $self) && $self->{_doc} && $self->{_doc}->isa(@args) ); +} + +#----------------------------------------------------------------------------- + +sub find { + my ($self, $wanted, @more_args) = @_; + + # This method can only find elements by their class names. For + # other types of searches, delegate to the PPI::Document + if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) { + return $self->{_doc}->find($wanted, @more_args); + } + + # Build the class cache if it doesn't exist. This happens at most + # once per Perl::Critic::Document instance. %elements of will be + # populated as a side-effect of calling the $finder_sub coderef + # that is produced by the caching_finder() closure. + if ( !$self->{_elements_of} ) { + + my %cache = ( 'PPI::Document' => [ $self ] ); + + # The cache refers to $self, and $self refers to the cache. This + # creates a circular reference that leaks memory (i.e. $self is not + # destroyed until execution is complete). By weakening the reference, + # we allow perl to collect the garbage properly. + weaken( $cache{'PPI::Document'}->[0] ); + + my $finder_coderef = _caching_finder( \%cache ); + $self->{_doc}->find( $finder_coderef ); + $self->{_elements_of} = \%cache; + } + + # find() must return false-but-defined on fail + return $self->{_elements_of}->{$wanted} || q{}; +} + +#----------------------------------------------------------------------------- + +sub find_first { + my ($self, $wanted, @more_args) = @_; + + # This method can only find elements by their class names. For + # other types of searches, delegate to the PPI::Document + if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) { + return $self->{_doc}->find_first($wanted, @more_args); + } + + my $result = $self->find($wanted); + return $result ? $result->[0] : $result; +} + +#----------------------------------------------------------------------------- + +sub find_any { + my ($self, $wanted, @more_args) = @_; + + # This method can only find elements by their class names. For + # other types of searches, delegate to the PPI::Document + if ( ( ref $wanted ) || !$wanted || $wanted !~ m/ \A PPI:: /xms ) { + return $self->{_doc}->find_any($wanted, @more_args); + } + + my $result = $self->find($wanted); + return $result ? 1 : $result; +} + +#----------------------------------------------------------------------------- + +sub namespaces { + my ($self) = @_; + + return keys %{ $self->_nodes_by_namespace() }; +} + +#----------------------------------------------------------------------------- + +sub subdocuments_for_namespace { + my ($self, $namespace) = @_; + + my $subdocuments = $self->_nodes_by_namespace()->{$namespace}; + + return $subdocuments ? @{$subdocuments} : (); +} + +#----------------------------------------------------------------------------- + +sub ppix_regexp_from_element { + my ( $self, $element ) = @_; + + if ( blessed( $element ) && $element->isa( 'PPI::Element' ) ) { + my $addr = refaddr( $element ); + return $self->{_ppix_regexp_from_element}{$addr} + if exists $self->{_ppix_regexp_from_element}{$addr}; + return ( $self->{_ppix_regexp_from_element}{$addr} = + PPIx::Regexp->new( $element, + default_modifiers => + $self->_find_use_re_modifiers_in_scope_from_element( + $element ), + ) ); + } else { + return PPIx::Regexp->new( $element ); + } +} + +sub _find_use_re_modifiers_in_scope_from_element { + my ( $self, $elem ) = @_; + my @found; + foreach my $use_re ( @{ $self->find( 'PPI::Statement::Include' ) || [] } ) + { + 're' eq $use_re->module() + or next; + $self->element_is_in_lexical_scope_after_statement_containing( + $elem, $use_re ) + or next; + my $prefix = 'no' eq $use_re->type() ? q{-} : $EMPTY; + push @found, + map { "$prefix$_" } + grep { m{ \A / }smx } + map { + $_->isa( 'PPI::Token::Quote' ) ? $_->string() : + $_->isa( 'PPI::Token::QuoteLike::Words' ) ? $_->literal() : + $_->content() } + $use_re->schildren(); + } + return \@found; +} + +#----------------------------------------------------------------------------- + +# This got hung on the Perl::Critic::Document, rather than living in +# Perl::Critic::Utils::PPI, because of the possibility that caching of scope +# objects would turn out to be desirable. + +sub element_is_in_lexical_scope_after_statement_containing { + my ( $self, $inner_elem, $outer_elem ) = @_; + + # If the outer element defines a scope, we're true if and only if + # the outer element contains the inner element. + $outer_elem->scope() + and return $inner_elem->descendant_of( $outer_elem ); + + # In the more general case: + + # The last element of the statement containing the outer element + # must be before the inner element. If not, we know we're false, + # without walking the parse tree. + + my $stmt = $outer_elem->statement() + or return; + my $last_elem = $stmt->last_element() + or return; + + my $stmt_loc = $last_elem->location() + or return; + + my $inner_loc = $inner_elem->location() + or return; + + $stmt_loc->[0] > $inner_loc->[0] + and return; + $stmt_loc->[0] == $inner_loc->[0] + and $stmt_loc->[1] > $inner_loc->[1] + and return; + + # Since we know the inner element is after the outer element, find + # the element that defines the scope of the statement that contains + # the outer element. + + my $parent = $stmt; + while ( ! $parent->scope() ) { + $parent = $parent->parent() + or return; + } + + # We're true if and only if the scope of the outer element contains + # the inner element. + + return $inner_elem->descendant_of( $parent ); + +} + +#----------------------------------------------------------------------------- + +sub filename { + my ($self) = @_; + + if (defined $self->{_filename_override}) { + return $self->{_filename_override}; + } + else { + my $doc = $self->{_doc}; + return $doc->can('filename') ? $doc->filename() : undef; + } +} + +#----------------------------------------------------------------------------- + +sub highest_explicit_perl_version { + my ($self) = @_; + + my $highest_explicit_perl_version = + $self->{_highest_explicit_perl_version}; + + if ( not exists $self->{_highest_explicit_perl_version} ) { + my $includes = $self->find( \&_is_a_version_statement ); + + if ($includes) { + # Note: this doesn't use List::Util::max() because that function + # doesn't use the overloaded ">=" etc of a version object. The + # reduce() style lets version.pm take care of all comparing. + # + # For reference, max() ends up looking at the string converted to + # an NV, or something like that. An underscore like "5.005_04" + # provokes a warning and is chopped off at "5.005" thus losing the + # minor part from the comparison. + # + # An underscore "5.005_04" is supposed to mean an alpha release + # and shouldn't be used in a perl version. But it's shown in + # perlfunc under "use" (as a number separator), and appears in + # several modules supplied with perl 5.10.0 (like version.pm + # itself!). At any rate if version.pm can understand it then + # that's enough for here. + $highest_explicit_perl_version = + reduce { $a >= $b ? $a : $b } + map { version->new( $_->version() ) } + @{$includes}; + } + else { + $highest_explicit_perl_version = undef; + } + + $self->{_highest_explicit_perl_version} = + $highest_explicit_perl_version; + } + + return $highest_explicit_perl_version if $highest_explicit_perl_version; + return; +} + +#----------------------------------------------------------------------------- + +sub uses_module { + my ($self, $module_name) = @_; + + return exists $self->_modules_used()->{$module_name}; +} + +#----------------------------------------------------------------------------- + +sub process_annotations { + my ($self) = @_; + + my @annotations = Perl::Critic::Annotation->create_annotations($self); + $self->add_annotation(@annotations); + return $self; +} + +#----------------------------------------------------------------------------- + +sub line_is_disabled_for_policy { + my ($self, $line, $policy) = @_; + my $policy_name = ref $policy || $policy; + + # HACK: This Policy is special. If it is active, it cannot be + # disabled by a "## no critic" annotation. Rather than create a general + # hook in Policy.pm for enabling this behavior, we chose to hack + # it here, since this isn't the kind of thing that most policies do + + return 0 if $policy_name eq + 'Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic'; + + return 1 if $self->{_disabled_line_map}->{$line}->{$policy_name}; + return 1 if $self->{_disabled_line_map}->{$line}->{ALL}; + return 0; +} + +#----------------------------------------------------------------------------- + +sub add_annotation { + my ($self, @annotations) = @_; + + # Add annotation to our private map for quick lookup + for my $annotation (@annotations) { + + my ($start, $end) = $annotation->effective_range(); + my @affected_policies = $annotation->disables_all_policies ? + qw(ALL) : $annotation->disabled_policies(); + + # TODO: Find clever way to do this with hash slices + for my $line ($start .. $end) { + for my $policy (@affected_policies) { + $self->{_disabled_line_map}->{$line}->{$policy} = 1; + } + } + } + + push @{ $self->{_annotations} }, @annotations; + return $self; +} + +#----------------------------------------------------------------------------- + +sub annotations { + my ($self) = @_; + return @{ $self->{_annotations} }; +} + +#----------------------------------------------------------------------------- + +sub add_suppressed_violation { + my ($self, $violation) = @_; + push @{$self->{_suppressed_violations}}, $violation; + return $self; +} + +#----------------------------------------------------------------------------- + +sub suppressed_violations { + my ($self) = @_; + return @{ $self->{_suppressed_violations} }; +} + +#----------------------------------------------------------------------------- + +sub is_program { + my ($self) = @_; + + return not $self->is_module(); +} + +#----------------------------------------------------------------------------- + +sub is_module { + my ($self) = @_; + + return $self->{_is_module}; +} + +#----------------------------------------------------------------------------- +# PRIVATE functions & methods + +sub _is_a_version_statement { + my (undef, $element) = @_; + + return 0 if not $element->isa('PPI::Statement::Include'); + return 1 if $element->version(); + return 0; +} + +#----------------------------------------------------------------------------- + +sub _caching_finder { + my $cache_ref = shift; # These vars will persist for the life + my %isa_cache = (); # of the code ref that this sub returns + + + # Gather up all the PPI elements and sort by @ISA. Note: if any + # instances used multiple inheritance, this implementation would + # lead to multiple copies of $element in the $elements_of lists. + # However, PPI::* doesn't do multiple inheritance, so we are safe + + return sub { + my (undef, $element) = @_; + my $classes = $isa_cache{ref $element}; + if ( !$classes ) { + $classes = [ ref $element ]; + # Use a C-style loop because we append to the classes array inside + for ( my $i = 0; $i < @{$classes}; $i++ ) { ## no critic(ProhibitCStyleForLoops) + no strict 'refs'; ## no critic(ProhibitNoStrict) + push @{$classes}, @{"$classes->[$i]::ISA"}; + $cache_ref->{$classes->[$i]} ||= []; + } + $isa_cache{$classes->[0]} = $classes; + } + + for my $class ( @{$classes} ) { + push @{$cache_ref->{$class}}, $element; + } + + return 0; # 0 tells find() to keep traversing, but not to store this $element + }; +} + +#----------------------------------------------------------------------------- + +sub _disable_shebang_fix { + my ($self) = @_; + + # When you install a program using ExtUtils::MakeMaker or Module::Build, it + # inserts some magical code into the top of the file (just after the + # shebang). This code allows people to call your program using a shell, + # like `sh my_script`. Unfortunately, this code causes several Policy + # violations, so we disable them as if they had "## no critic" annotations. + + my $first_stmnt = $self->schild(0) || return; + + # Different versions of MakeMaker and Build use slightly different shebang + # fixing strings. This matches most of the ones I've found in my own Perl + # distribution, but it may not be bullet-proof. + + my $fixin_rx = qr<^eval 'exec .* \$0 \$[{]1[+]"\$@"}'\s*[\r\n]\s*if.+;>ms; ## no critic (ExtendedFormatting) + if ( $first_stmnt =~ $fixin_rx ) { + my $line = $first_stmnt->location->[0]; + $self->{_disabled_line_map}->{$line}->{ALL} = 1; + $self->{_disabled_line_map}->{$line + 1}->{ALL} = 1; + } + + return $self; +} + +#----------------------------------------------------------------------------- + +sub _determine_is_module { + my ($self, $args) = @_; + + my $file_name = $self->filename(); + if ( + defined $file_name + and ref $args->{'-program-extensions'} eq 'ARRAY' + ) { + foreach my $ext ( @{ $args->{'-program-extensions'} } ) { + my $regex = + ref $ext eq 'Regexp' + ? $ext + : qr< @{ [ quotemeta $ext ] } \z >xms; + + return $FALSE if $file_name =~ m/$regex/smx; + } + } + + return $FALSE if shebang_line($self); + return $FALSE if defined $file_name && $file_name =~ m/ [.] PL \z /smx; + + return $TRUE; +} + +#----------------------------------------------------------------------------- + +sub _nodes_by_namespace { + my ($self) = @_; + + my $nodes = $self->{_nodes_by_namespace}; + + return $nodes if $nodes; + + my $ppi_document = $self->ppi_document(); + if (not $ppi_document) { + return $self->{_nodes_by_namespace} = {}; + } + + my $raw_nodes_map = split_ppi_node_by_namespace($ppi_document); + + my %wrapped_nodes; + while ( my ($namespace, $raw_nodes) = each %{$raw_nodes_map} ) { + $wrapped_nodes{$namespace} = [ + map { __PACKAGE__->_new_for_parent_document($_, $self) } + @{$raw_nodes} + ]; + } + + return $self->{_nodes_by_namespace} = \%wrapped_nodes; +} + +#----------------------------------------------------------------------------- + +# Note: must use exists on return value to determine membership because all +# the values are false, unlike the result of hashify(). +sub _modules_used { + my ($self) = @_; + + my $mapping = $self->{_modules_used}; + + return $mapping if $mapping; + + my $includes = $self->find('PPI::Statement::Include'); + if (not $includes) { + return $self->{_modules_used} = {}; + } + + my %mapping; + for my $module ( + grep { $_ } map { $_->module() || $_->pragma() } @{$includes} + ) { + # Significanly ess memory than $h{$k} => 1. Thanks Mr. Lembark. + $mapping{$module} = (); + } + + return $self->{_modules_used} = \%mapping; +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +=pod + +=for stopwords pre-caches + +=head1 NAME + +Perl::Critic::Document - Caching wrapper around a PPI::Document. + + +=head1 SYNOPSIS + + use PPI::Document; + use Perl::Critic::Document; + my $doc = PPI::Document->new('Foo.pm'); + $doc = Perl::Critic::Document->new(-source => $doc); + ## Then use the instance just like a PPI::Document + + +=head1 DESCRIPTION + +Perl::Critic does a lot of iterations over the PPI document tree via +the C method. To save some time, this class +pre-caches a lot of the common C calls in a single traversal. +Then, on subsequent requests we return the cached data. + +This is implemented as a facade, where method calls are handed to the +stored C instance. + + +=head1 CAVEATS + +This facade does not implement the overloaded operators from +L (that is, the C +work). Therefore, users of this facade must not rely on that syntactic +sugar. So, for example, instead of C you should +write C<< my $source = $doc->content(); >> + +Perhaps there is a CPAN module out there which implements a facade +better than we do here? + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 CONSTRUCTOR + +=over + +=item C<< new(-source => $source_code, '-filename-override' => $filename, '-program-extensions' => [program_extensions]) >> + +Create a new instance referencing a PPI::Document instance. The +C<$source_code> can be the name of a file, a reference to a scalar +containing actual source code, or a L or +L. + +In the event that C<$source_code> is a reference to a scalar containing actual +source code or a L, the resulting +L will not have a filename. +This may cause L to incorrectly +classify the source code as a module or script. To avoid this problem, you +can optionally set the C<-filename-override> to force the +L to have a particular +C<$filename>. Do not use this option if C<$source_code> is already the name +of a file, or is a reference to a L. + +The '-program-extensions' argument is optional, and is a reference to a list +of strings and/or regular expressions. The strings will be made into regular +expressions matching the end of a file name, and any document whose file name +matches one of the regular expressions will be considered a program. + +If -program-extensions is not specified, or if it does not determine the +document type, the document will be considered to be a program if the source +has a shebang line or its file name (if any) matches C<< m/ [.] PL \z /smx >>. + +=back + +=head1 METHODS + +=over + +=item C<< ppi_document() >> + +Accessor for the wrapped PPI::Document instance. Note that altering +this instance in any way can cause unpredictable failures in +Perl::Critic's subsequent analysis because some caches may fall out of +date. + + +=item C<< find($wanted) >> + +=item C<< find_first($wanted) >> + +=item C<< find_any($wanted) >> + +Caching wrappers around the PPI methods. If C<$wanted> is a simple PPI class +name, then the cache is employed. Otherwise we forward the call to the +corresponding method of the C instance. + + +=item C<< namespaces() >> + +Returns a list of the namespaces (package names) in the document. + + +=item C<< subdocuments_for_namespace($namespace) >> + +Returns a list of sub-documents containing the elements in the given +namespace. For example, given that the current document is for the source + + foo(); + package Foo; + package Bar; + package Foo; + +this method will return two Ls +for a parameter of C<"Foo">. For more, see +L. + + +=item C<< ppix_regexp_from_element($element) >> + +Caching wrapper around C<< PPIx::Regexp->new($element) >>. If +C<$element> is a C the cache is employed, otherwise it +just returns the results of C<< PPIx::Regexp->new() >>. In either case, +it returns C unless the argument is something that +L actually understands. + +=item C<< element_is_in_lexical_scope_after_statement_containing( $inner, $outer ) >> + +Is the C<$inner> element in lexical scope after the statement containing +the C<$outer> element? + +In the case where C<$outer> is itself a scope-defining element, returns true +if C<$outer> contains C<$inner>. In any other case, C<$inner> must be +after the last element of the statement containing C<$outer>, and the +innermost scope for C<$outer> also contains C<$inner>. + +This is not the same as asking whether C<$inner> is visible from +C<$outer>. + + +=item C<< filename() >> + +Returns the filename for the source code if applicable +(PPI::Document::File) or C otherwise (PPI::Document). + + +=item C<< isa( $classname ) >> + +To be compatible with other modules that expect to get a +PPI::Document, the Perl::Critic::Document class masquerades as the +PPI::Document class. + + +=item C<< highest_explicit_perl_version() >> + +Returns a L object for the highest Perl version +requirement declared in the document via a C or C +statement. Returns nothing if there is no version statement. + + +=item C<< uses_module($module_or_pragma_name) >> + +Answers whether there is a C, C, or C of the given name in +this document. Note that there is no differentiation of modules vs. pragmata +here. + + +=item C<< process_annotations() >> + +Causes this Document to scan itself and mark which lines & +policies are disabled by the C<"## no critic"> annotations. + + +=item C<< line_is_disabled_for_policy($line, $policy_object) >> + +Returns true if the given C<$policy_object> or C<$policy_name> has +been disabled for at C<$line> in this Document. Otherwise, returns false. + + +=item C<< add_annotation( $annotation ) >> + +Adds an C<$annotation> object to this Document. + + +=item C<< annotations() >> + +Returns a list containing all the +Ls that +were found in this Document. + + +=item C<< add_suppressed_violation($violation) >> + +Informs this Document that a C<$violation> was found but not reported +because it fell on a line that had been suppressed by a C<"## no critic"> +annotation. Returns C<$self>. + + +=item C<< suppressed_violations() >> + +Returns a list of references to all the +Ls +that were found in this Document but were suppressed. + + +=item C<< is_program() >> + +Returns whether this document is considered to be a program. + + +=item C<< is_module() >> + +Returns whether this document is considered to be a Perl module. + +=back + +=head1 AUTHOR + +Chris Dolan + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception.pm b/lib/Perl/Critic/Exception.pm new file mode 100644 index 0000000..11ce128 --- /dev/null +++ b/lib/Perl/Critic/Exception.pm @@ -0,0 +1,96 @@ +package Perl::Critic::Exception; + +use 5.006001; +use strict; +use warnings; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception' => { + isa => 'Exception::Class::Base', + description => 'A problem discovered by Perl::Critic.', + }, +); + +use Exporter 'import'; + +#----------------------------------------------------------------------------- + +sub short_class_name { + my ( $self ) = @_; + + return substr ref $self, (length 'Perl::Critic') + 2; +} + +#----------------------------------------------------------------------------- + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception - A problem identified by L. + +=head1 DESCRIPTION + +A base class for all problems discovered by +L. This exists to enable differentiating +exceptions from L code from those +originating in other modules. + +This is an abstract class. It should never be instantiated. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 METHODS + +=over + +=item C + +Retrieve the name of the class of this object with C<'Perl::Critic::'> +stripped off. + + +=back + + +=head1 AUTHOR + +Elliot Shank + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/AggregateConfiguration.pm b/lib/Perl/Critic/Exception/AggregateConfiguration.pm new file mode 100644 index 0000000..30f5533 --- /dev/null +++ b/lib/Perl/Critic/Exception/AggregateConfiguration.pm @@ -0,0 +1,202 @@ +package Perl::Critic::Exception::AggregateConfiguration; + +use 5.006001; +use strict; +use warnings; + +use Carp qw{ confess }; +use English qw(-no_match_vars); +use Readonly; + +use Perl::Critic::Utils qw{ :characters }; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception::AggregateConfiguration' => { + isa => 'Perl::Critic::Exception', + description => 'A collected set of configuration exceptions.', + fields => [ qw{ exceptions } ], + alias => 'throw_aggregate', + }, +); + +#----------------------------------------------------------------------------- + +Readonly::Array our @EXPORT_OK => qw< throw_aggregate >; + +#----------------------------------------------------------------------------- + +sub new { + my ($class, %options) = @_; + + my $exceptions = $options{exceptions}; + if (not $exceptions) { + $options{exceptions} = []; + } + + return $class->SUPER::new(%options); +} + +#----------------------------------------------------------------------------- + +sub add_exception { + my ( $self, $exception ) = @_; + + push @{ $self->exceptions() }, $exception; + + return; +} + +#----------------------------------------------------------------------------- + +sub add_exceptions_from { + my ( $self, $aggregate ) = @_; + + push @{ $self->exceptions() }, @{ $aggregate->exceptions() }; + + return; +} + +#----------------------------------------------------------------------------- + +sub add_exception_or_rethrow { + my ( $self, $eval_error ) = @_; + + return if not $eval_error; + confess $eval_error if not ref $eval_error; + + if ( $eval_error->isa('Perl::Critic::Exception::Configuration') ) { + $self->add_exception($eval_error); + } + elsif ( + $eval_error->isa('Perl::Critic::Exception::AggregateConfiguration') + ) { + $self->add_exceptions_from($eval_error); + } + else { + die $eval_error; ## no critic (RequireCarping) + } + + return; +} + +#----------------------------------------------------------------------------- + +sub has_exceptions { + my ( $self ) = @_; + + return @{ $self->exceptions() } ? 1 : 0; +} + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $MESSAGE_PREFIX => $EMPTY; +Readonly::Scalar my $MESSAGE_SUFFIX => "\n"; +Readonly::Scalar my $MESSAGE_SEPARATOR => $MESSAGE_SUFFIX . $MESSAGE_PREFIX; + +sub full_message { + my ( $self ) = @_; + + my $message = $MESSAGE_PREFIX; + $message .= join $MESSAGE_SEPARATOR, @{ $self->exceptions() }; + $message .= $MESSAGE_SUFFIX; + + return $message; +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::AggregateConfiguration - A collection of a set of problems found in the configuration and/or command-line options. + +=head1 DESCRIPTION + +A set of configuration settings can have multiple problems. This is +an object for collecting all the problems found so that the user can +see them in one run. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 METHODS + +=over + +=item C + +Accumulate the parameter with rest of the exceptions. + + +=item C + +Accumulate the exceptions from another instance of this class. + + +=item C + +Returns a reference to an array of the collected exceptions. + + +=item C + +If the parameter is an instance of +L +or +L, +add it. Otherwise, C with the parameter, if it is a reference, +or C with it. If the parameter is false, simply returns. + + +=item C + +Answer whether any configuration problems have been found. + + +=item C + +Concatenate the exception messages. See +L. + + +=back + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/Configuration.pm b/lib/Perl/Critic/Exception/Configuration.pm new file mode 100644 index 0000000..e993216 --- /dev/null +++ b/lib/Perl/Critic/Exception/Configuration.pm @@ -0,0 +1,89 @@ +package Perl::Critic::Exception::Configuration; + +use 5.006001; +use strict; +use warnings; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception::Configuration' => { + isa => 'Perl::Critic::Exception', + description => 'A problem with Perl::Critic configuration, whether from a file or a command line or some other source.', + fields => [ qw{ source } ], + }, +); + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::Configuration - A problem with L configuration. + +=head1 DESCRIPTION + +A representation of a problem found with the configuration of +L, whether from a F<.perlcriticrc>, another profile +file, or command line. + +This is an abstract class. It should never be instantiated. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 METHODS + +=over + +=item C + +Where the configuration information came from, if it could be determined. + + +=back + + +=head1 SEE ALSO + +L +L + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/Configuration/Generic.pm b/lib/Perl/Critic/Exception/Configuration/Generic.pm new file mode 100644 index 0000000..74887e7 --- /dev/null +++ b/lib/Perl/Critic/Exception/Configuration/Generic.pm @@ -0,0 +1,95 @@ +package Perl::Critic::Exception::Configuration::Generic; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception::Configuration::Generic' => { + isa => 'Perl::Critic::Exception::Configuration', + description => + q{A problem with Perl::Critic configuration that isn't related to an option.}, + alias => 'throw_generic', + }, +); + +#----------------------------------------------------------------------------- + +Readonly::Array our @EXPORT_OK => qw< throw_generic >; + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::Configuration::Generic - A problem with L configuration that doesn't involve an option. + +=head1 DESCRIPTION + +A representation of a problem found with the configuration of +L, whether from a F<.perlcriticrc>, another +profile file, or command line. + +This covers things like file reading and parsing errors. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 CLASS METHODS + +=over + +=item C<< throw( message => $message, source => $source ) >> + +See L. + + +=item C<< new( message => $message, source => $source ) >> + +See L. + + +=back + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/Configuration/NonExistentPolicy.pm b/lib/Perl/Critic/Exception/Configuration/NonExistentPolicy.pm new file mode 100644 index 0000000..028194c --- /dev/null +++ b/lib/Perl/Critic/Exception/Configuration/NonExistentPolicy.pm @@ -0,0 +1,113 @@ +package Perl::Critic::Exception::Configuration::NonExistentPolicy; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception::Configuration::NonExistentPolicy' => { + isa => 'Perl::Critic::Exception::Configuration', + description => 'The configuration referred to a non-existant policy.', + fields => [ qw{ policy } ], + }, +); + +#----------------------------------------------------------------------------- + +Readonly::Array our @EXPORT_OK => qw< throw_extra_parameter >; + +#----------------------------------------------------------------------------- + +sub full_message { + my ( $self ) = @_; + + my $policy = $self->policy(); + + return qq; +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::Configuration::NonExistentPolicy - The configuration referred to a non-existent policy. + +=head1 DESCRIPTION + +A representation of the configuration attempting to specify a +L that is not known, whether from a +F<.perlcriticrc>, another profile file, or command line. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 CLASS METHODS + +=over + +=item C<< throw( policy => $policy ) >> + +See L. + + +=item C<< new( policy => $policy ) >> + +See L. + + +=back + + +=head1 METHODS + +=over + +=item C + +Provide a standard message. See L. + + +=back + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/Configuration/Option.pm b/lib/Perl/Critic/Exception/Configuration/Option.pm new file mode 100644 index 0000000..4955ece --- /dev/null +++ b/lib/Perl/Critic/Exception/Configuration/Option.pm @@ -0,0 +1,141 @@ +package Perl::Critic::Exception::Configuration::Option; + +use 5.006001; +use strict; +use warnings; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Perl::Critic::Exception::Fatal::Internal; + +use Exception::Class ( # this must come after "use P::C::Exception::*" + 'Perl::Critic::Exception::Configuration::Option' => { + isa => 'Perl::Critic::Exception::Configuration', + description => 'A problem with an option in the Perl::Critic configuration, whether from a file or a command line or some other source.', + fields => [ qw{ option_name option_value message_suffix } ], + }, +); + +#----------------------------------------------------------------------------- + +sub message { + my $self = shift; + + return $self->full_message(); +} + +#----------------------------------------------------------------------------- + +sub error { + my $self = shift; + + return $self->full_message(); +} + +#----------------------------------------------------------------------------- + +## no critic (Subroutines::RequireFinalReturn) +sub full_message { + Perl::Critic::Exception::Fatal::Internal->throw( + 'Subclass failed to override abstract method.' + ); +} +## use critic + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::Configuration::Option - A problem with an option in the L configuration. + +=head1 DESCRIPTION + +A representation of a problem found with an option in the +configuration of L, whether from a +F<.perlcriticrc>, another profile file, or command line. + +This is an abstract class. It should never be instantiated. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 METHODS + +=over + +=item C + +The name of the option that was found to be in error. + + +=item C + +The value of the option that was found to be in error. + + +=item C + +Any text that should be applied to end of the standard message for +this kind of exception. + + +=item C + +=item C + +Overridden to call C. I.e. any message string in the +superclass is ignored. + + +=item C + +Overridden to turn it into an abstract method to force subclasses to +implement it. + + +=back + + +=head1 SEE ALSO + +L +L + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/Configuration/Option/Global.pm b/lib/Perl/Critic/Exception/Configuration/Option/Global.pm new file mode 100644 index 0000000..02a0d73 --- /dev/null +++ b/lib/Perl/Critic/Exception/Configuration/Option/Global.pm @@ -0,0 +1,70 @@ +package Perl::Critic::Exception::Configuration::Option::Global; + +use 5.006001; +use strict; +use warnings; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception::Configuration::Option::Global' => { + isa => 'Perl::Critic::Exception::Configuration::Option', + description => 'A problem with global Perl::Critic configuration.', + }, +); + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::Configuration::Option::Global - A problem with L global configuration. + +=head1 DESCRIPTION + +A representation of a problem found with the global configuration of +L, whether from a F<.perlcriticrc>, another +profile file, or command line. + +This is an abstract class. It should never be instantiated. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/Configuration/Option/Global/ExtraParameter.pm b/lib/Perl/Critic/Exception/Configuration/Option/Global/ExtraParameter.pm new file mode 100644 index 0000000..5de6bbd --- /dev/null +++ b/lib/Perl/Critic/Exception/Configuration/Option/Global/ExtraParameter.pm @@ -0,0 +1,122 @@ +package Perl::Critic::Exception::Configuration::Option::Global::ExtraParameter; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception::Configuration::Option::Global::ExtraParameter' => { + isa => 'Perl::Critic::Exception::Configuration::Option::Global', + description => 'The configuration referred to a non-existant global option.', + alias => 'throw_extra_global', + }, +); + +#----------------------------------------------------------------------------- + +Readonly::Array our @EXPORT_OK => qw< throw_extra_global >; + +#----------------------------------------------------------------------------- + +sub full_message { + my ( $self ) = @_; + + my $source = $self->source(); + if ($source) { + $source = qq{ (found in "$source")}; + } + else { + $source = q{}; + } + + my $option_name = $self->option_name(); + + return qq{"$option_name" is not a supported option$source.}; +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::Configuration::Option::Global::ExtraParameter - The configuration referred to a non-existent global option. + +=head1 DESCRIPTION + +A representation of the configuration attempting to specify a value +for an option that L doesn't have, whether +from a F<.perlcriticrc>, another profile file, or command line. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 CLASS METHODS + +=over + +=item C<< throw( option_name => $option_name, source => $source ) >> + +See L. + + +=item C<< new( option_name => $option_name, source => $source ) >> + +See L. + + +=back + + +=head1 METHODS + +=over + +=item C + +Provide a standard message for values for non-existent parameters for +policies. See L. + + +=back + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/Configuration/Option/Global/ParameterValue.pm b/lib/Perl/Critic/Exception/Configuration/Option/Global/ParameterValue.pm new file mode 100644 index 0000000..11275b7 --- /dev/null +++ b/lib/Perl/Critic/Exception/Configuration/Option/Global/ParameterValue.pm @@ -0,0 +1,131 @@ +package Perl::Critic::Exception::Configuration::Option::Global::ParameterValue; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use Perl::Critic::Utils qw{ :characters }; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception::Configuration::Option::Global::ParameterValue' => { + isa => 'Perl::Critic::Exception::Configuration::Option::Global', + description => 'A problem with the value of a global parameter.', + alias => 'throw_global_value', + }, +); + +#----------------------------------------------------------------------------- + +Readonly::Array our @EXPORT_OK => qw< throw_global_value >; + +#----------------------------------------------------------------------------- + +sub full_message { + my ( $self ) = @_; + + my $source = $self->source(); + if ($source) { + $source = qq{ found in "$source"}; + } + else { + $source = $EMPTY; + } + + my $option_name = $self->option_name(); + my $option_value = + defined $self->option_value() + ? $DQUOTE . $self->option_value() . $DQUOTE + : ''; + my $message_suffix = $self->message_suffix() || $EMPTY; + + return + qq{The value for the global "$option_name" option } + . qq{($option_value)$source $message_suffix}; +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::Configuration::Option::Global::ParameterValue - A problem with the value of a global parameter. + +=head1 DESCRIPTION + +A representation of a problem found with the value of a global +parameter, whether from a F<.perlcriticrc>, another profile file, or +command line. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 CLASS METHODS + +=over + +=item C<< throw( option_name => $option_name, option_value => $option_value, source => $source, message_suffix => $message_suffix ) >> + +See L. + + +=item C<< new( option_name => $option_name, option_value => $option_value, source => $source, message_suffix => $message_suffix ) >> + +See L. + + +=back + + +=head1 METHODS + +=over + +=item C + +Provide a standard message for global configuration problems. See +L. + + +=back + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/Configuration/Option/Policy.pm b/lib/Perl/Critic/Exception/Configuration/Option/Policy.pm new file mode 100644 index 0000000..fb4be3d --- /dev/null +++ b/lib/Perl/Critic/Exception/Configuration/Option/Policy.pm @@ -0,0 +1,97 @@ +package Perl::Critic::Exception::Configuration::Option::Policy; + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::Utils qw{ &policy_short_name }; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception::Configuration::Option::Policy' => { + isa => 'Perl::Critic::Exception::Configuration::Option', + description => 'A problem with the configuration of a policy.', + fields => [ qw{ policy } ], + }, +); + +#----------------------------------------------------------------------------- + +sub new { + my ($class, %options) = @_; + + my $policy = $options{policy}; + if ($policy) { + $options{policy} = policy_short_name($policy); + } + + return $class->SUPER::new(%options); +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::Configuration::Option::Policy - A problem with configuration of a policy. + +=head1 DESCRIPTION + +A representation of a problem found with the configuration of a +L, whether from a +F<.perlcriticrc>, another profile file, or command line. + +This is an abstract class. It should never be instantiated. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 METHODS + +=over + +=item C + +The short name of the policy that had configuration problems. + + +=back + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/Configuration/Option/Policy/ExtraParameter.pm b/lib/Perl/Critic/Exception/Configuration/Option/Policy/ExtraParameter.pm new file mode 100644 index 0000000..8905b73 --- /dev/null +++ b/lib/Perl/Critic/Exception/Configuration/Option/Policy/ExtraParameter.pm @@ -0,0 +1,125 @@ +package Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter' => { + isa => 'Perl::Critic::Exception::Configuration::Option::Policy', + description => 'The configuration of a policy referred to a non-existant parameter.', + alias => 'throw_extra_parameter', + }, +); + +#----------------------------------------------------------------------------- + +Readonly::Array our @EXPORT_OK => qw< throw_extra_parameter >; + +#----------------------------------------------------------------------------- + +sub full_message { + my ( $self ) = @_; + + my $source = $self->source(); + if ($source) { + $source = qq{ (found in "$source")}; + } + else { + $source = q{}; + } + + my $policy = $self->policy(); + my $option_name = $self->option_name(); + + return + qq{The $policy policy doesn't take a "$option_name" option$source.}; +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter - The configuration referred to a non-existent parameter for a policy. + +=head1 DESCRIPTION + +A representation of the configuration attempting to specify a value +for a parameter that a L +doesn't have, whether from a F<.perlcriticrc>, another profile file, +or command line. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 CLASS METHODS + +=over + +=item C<< throw( policy => $policy, option_name => $option_name, source => $source ) >> + +See L. + + +=item C<< new( policy => $policy, option_name => $option_name, source => $source ) >> + +See L. + + +=back + + +=head1 METHODS + +=over + +=item C + +Provide a standard message for values for non-existent parameters for +policies. See L. + + +=back + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/Configuration/Option/Policy/ParameterValue.pm b/lib/Perl/Critic/Exception/Configuration/Option/Policy/ParameterValue.pm new file mode 100644 index 0000000..af86c43 --- /dev/null +++ b/lib/Perl/Critic/Exception/Configuration/Option/Policy/ParameterValue.pm @@ -0,0 +1,132 @@ +package Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use Perl::Critic::Utils qw{ :characters }; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue' => { + isa => 'Perl::Critic::Exception::Configuration::Option::Policy', + description => 'A problem with the value of a parameter for a policy.', + alias => 'throw_policy_value', + }, +); + +#----------------------------------------------------------------------------- + +Readonly::Array our @EXPORT_OK => qw< throw_policy_value >; + +#----------------------------------------------------------------------------- + +sub full_message { + my ( $self ) = @_; + + my $source = $self->source(); + if ($source) { + $source = qq{ found in "$source"}; + } + else { + $source = $EMPTY; + } + + my $policy = $self->policy(); + my $option_name = $self->option_name(); + my $option_value = + defined $self->option_value() + ? $DQUOTE . $self->option_value() . $DQUOTE + : ''; + my $message_suffix = $self->message_suffix() || $EMPTY; + + return + qq{The value for the $policy "$option_name" option } + . qq{($option_value)$source $message_suffix}; +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue - A problem with the value of a parameter for a policy. + +=head1 DESCRIPTION + +A representation of a problem found with the value of a parameter for +a L, whether from a +F<.perlcriticrc>, another profile file, or command line. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 CLASS METHODS + +=over + +=item C<< throw( policy => $policy, option_name => $option_name, option_value => $option_value, source => $source, message_suffix => $message_suffix ) >> + +See L. + + +=item C<< new( policy => $policy, option_name => $option_name, option_value => $option_value, source => $source, message_suffix => $message_suffix ) >> + +See L. + + +=back + + +=head1 METHODS + +=over + +=item C + +Provide a standard message for policy parameter value problems. See +L. + + +=back + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/Fatal.pm b/lib/Perl/Critic/Exception/Fatal.pm new file mode 100644 index 0000000..35950fb --- /dev/null +++ b/lib/Perl/Critic/Exception/Fatal.pm @@ -0,0 +1,112 @@ +package Perl::Critic::Exception::Fatal; + +use 5.006001; +use strict; +use warnings; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception::Fatal' => { + isa => 'Perl::Critic::Exception', + description => + 'A problem that should cause Perl::Critic to stop running.', + }, +); + +#----------------------------------------------------------------------------- + +sub new { + my ($class, @args) = @_; + my $self = $class->SUPER::new(@args); + + $self->show_trace(1); + + return $self; +} + +#----------------------------------------------------------------------------- + +sub full_message { + my ( $self ) = @_; + + return + $self->short_class_name() + . q{: } + . $self->description() + . "\n\n" + . $self->message() + . "\n\n" + . gmtime $self->time() + . "\n\n"; +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::Fatal - A problem that should cause L to stop running. + +=head1 DESCRIPTION + +Something went wrong and processing should not continue. You should +never specifically look for this exception or one of its subclasses. + +Note: the constructor invokes L to +force stack-traces to be included in the standard stringification. + +This is an abstract class. It should never be instantiated. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 METHODS + +=over + +=item C + +Overrides L to include extra +information. + + +=back + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/Fatal/Generic.pm b/lib/Perl/Critic/Exception/Fatal/Generic.pm new file mode 100644 index 0000000..f022589 --- /dev/null +++ b/lib/Perl/Critic/Exception/Fatal/Generic.pm @@ -0,0 +1,79 @@ +package Perl::Critic::Exception::Fatal::Generic; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception::Fatal::Generic' => { + isa => 'Perl::Critic::Exception::Fatal', + description => 'A general problem was found.', + alias => 'throw_generic', + }, +); + +#----------------------------------------------------------------------------- + +Readonly::Array our @EXPORT_OK => qw< throw_generic >; + +#----------------------------------------------------------------------------- + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::Fatal::Generic - A problem for which there is no specialized information. + +=head1 DESCRIPTION + +A general problem, e.g. I/O errors and problems that may or not be bugs. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 METHODS + +Only inherited ones. + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/Fatal/Internal.pm b/lib/Perl/Critic/Exception/Fatal/Internal.pm new file mode 100644 index 0000000..a9379fb --- /dev/null +++ b/lib/Perl/Critic/Exception/Fatal/Internal.pm @@ -0,0 +1,80 @@ +package Perl::Critic::Exception::Fatal::Internal; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception::Fatal::Internal' => { + isa => 'Perl::Critic::Exception::Fatal', + description => 'A problem with the Perl::Critic code was found, a.k.a. a bug.', + alias => 'throw_internal', + }, +); + +#----------------------------------------------------------------------------- + +Readonly::Array our @EXPORT_OK => qw< throw_internal >; + +#----------------------------------------------------------------------------- + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::Fatal::Internal - A problem with the L implementation, i.e. a bug. + +=head1 DESCRIPTION + +A representation of a bug found in the code of +L. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 METHODS + +Only inherited ones. + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/Fatal/PolicyDefinition.pm b/lib/Perl/Critic/Exception/Fatal/PolicyDefinition.pm new file mode 100644 index 0000000..71b743c --- /dev/null +++ b/lib/Perl/Critic/Exception/Fatal/PolicyDefinition.pm @@ -0,0 +1,80 @@ +package Perl::Critic::Exception::Fatal::PolicyDefinition; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception::Fatal::PolicyDefinition' => { + isa => 'Perl::Critic::Exception::Fatal', + description => 'A bug in a policy was found.', + alias => 'throw_policy_definition', + }, +); + +#----------------------------------------------------------------------------- + +Readonly::Array our @EXPORT_OK => qw< throw_policy_definition >; + +#----------------------------------------------------------------------------- + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::Fatal::PolicyDefinition - A bug in a policy. + +=head1 DESCRIPTION + +A bug in a policy was found, e.g. it didn't implement a method that it should +have. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 METHODS + +Only inherited ones. + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/IO.pm b/lib/Perl/Critic/Exception/IO.pm new file mode 100644 index 0000000..9e4b66f --- /dev/null +++ b/lib/Perl/Critic/Exception/IO.pm @@ -0,0 +1,96 @@ +package Perl::Critic::Exception::IO; + +use 5.006001; +use strict; +use warnings; + +use Carp qw{ confess }; +use English qw(-no_match_vars); +use Readonly; + +use Perl::Critic::Utils qw{ :characters }; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception::IO' => { + isa => 'Perl::Critic::Exception', + description => 'An input/output problem.', + fields => [ qw< file_name errno > ], + alias => 'throw_io', + }, +); + +#----------------------------------------------------------------------------- + +Readonly::Array our @EXPORT_OK => qw< throw_io >; + +#----------------------------------------------------------------------------- + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::IO - A problem with input or output. + +=head1 DESCRIPTION + +The outside world can do nasty things to your poor, innocent code. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 METHODS + +=over + +=item C + +Returns the name of the file that the problem was found with, if available. + + +=item C + +The value of C<$ERRNO>/C<$!> at the time the problem was found. + + +=back + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Exception/Parse.pm b/lib/Perl/Critic/Exception/Parse.pm new file mode 100644 index 0000000..90f0814 --- /dev/null +++ b/lib/Perl/Critic/Exception/Parse.pm @@ -0,0 +1,91 @@ +package Perl::Critic::Exception::Parse; + +use 5.006001; +use strict; +use warnings; + +use English qw< -no_match_vars >; +use Carp qw< confess >; +use Readonly; + +use Perl::Critic::Utils qw< :characters >; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exception::Class ( + 'Perl::Critic::Exception::Parse' => { + isa => 'Perl::Critic::Exception', + description => 'A problem parsing source code.', + fields => [ qw< file_name > ], + alias => 'throw_parse', + }, +); + +#----------------------------------------------------------------------------- + +Readonly::Array our @EXPORT_OK => qw< throw_parse >; + +#----------------------------------------------------------------------------- + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Exception::Parse - The code doesn't look like code. + +=head1 DESCRIPTION + +There was a problem with PPI parsing source code. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 METHODS + +=over + +=item C + +Returns the name of the file that the problem was found with, if available. + + +=back + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2008-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/OptionsProcessor.pm b/lib/Perl/Critic/OptionsProcessor.pm new file mode 100644 index 0000000..db69ba0 --- /dev/null +++ b/lib/Perl/Critic/OptionsProcessor.pm @@ -0,0 +1,451 @@ +package Perl::Critic::OptionsProcessor; + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); + +use Perl::Critic::Exception::AggregateConfiguration; +use Perl::Critic::Exception::Configuration::Option::Global::ExtraParameter; +use Perl::Critic::Utils qw< + :booleans :characters :severities :data_conversion $DEFAULT_VERBOSITY +>; +use Perl::Critic::Utils::Constants qw< + $PROFILE_STRICTNESS_DEFAULT + :color_severity + >; +use Perl::Critic::Utils::DataConversion qw< dor >; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +sub new { + my ($class, %args) = @_; + my $self = bless {}, $class; + $self->_init( %args ); + return $self; +} + +#----------------------------------------------------------------------------- + +sub _init { + my ( $self, %args ) = @_; + + # Multi-value defaults + my $exclude = dor(delete $args{exclude}, $EMPTY); + $self->{_exclude} = [ words_from_string( $exclude ) ]; + + my $include = dor(delete $args{include}, $EMPTY); + $self->{_include} = [ words_from_string( $include ) ]; + + my $program_extensions = dor(delete $args{'program-extensions'}, $EMPTY); + $self->{_program_extensions} = [ words_from_string( $program_extensions) ]; + + # Single-value defaults + $self->{_force} = dor(delete $args{force}, $FALSE); + $self->{_only} = dor(delete $args{only}, $FALSE); + $self->{_profile_strictness} = + dor(delete $args{'profile-strictness'}, $PROFILE_STRICTNESS_DEFAULT); + $self->{_single_policy} = dor(delete $args{'single-policy'}, $EMPTY); + $self->{_severity} = dor(delete $args{severity}, $SEVERITY_HIGHEST); + $self->{_theme} = dor(delete $args{theme}, $EMPTY); + $self->{_top} = dor(delete $args{top}, $FALSE); + $self->{_verbose} = dor(delete $args{verbose}, $DEFAULT_VERBOSITY); + $self->{_criticism_fatal} = dor(delete $args{'criticism-fatal'}, $FALSE); + $self->{_pager} = dor(delete $args{pager}, $EMPTY); + $self->{_allow_unsafe} = dor(delete $args{'allow-unsafe'}, $FALSE); + + $self->{_color_severity_highest} = dor( + delete $args{'color-severity-highest'}, + delete $args{'colour-severity-highest'}, + delete $args{'color-severity-5'}, + delete $args{'colour-severity-5'}, + $PROFILE_COLOR_SEVERITY_HIGHEST_DEFAULT, + ); + $self->{_color_severity_high} = dor( + delete $args{'color-severity-high'}, + delete $args{'colour-severity-high'}, + delete $args{'color-severity-4'}, + delete $args{'colour-severity-4'}, + $PROFILE_COLOR_SEVERITY_HIGH_DEFAULT, + ); + $self->{_color_severity_medium} = dor( + delete $args{'color-severity-medium'}, + delete $args{'colour-severity-medium'}, + delete $args{'color-severity-3'}, + delete $args{'colour-severity-3'}, + $PROFILE_COLOR_SEVERITY_MEDIUM_DEFAULT, + ); + $self->{_color_severity_low} = dor( + delete $args{'color-severity-low'}, + delete $args{'colour-severity-low'}, + delete $args{'color-severity-2'}, + delete $args{'colour-severity-2'}, + $PROFILE_COLOR_SEVERITY_LOW_DEFAULT, + ); + $self->{_color_severity_lowest} = dor( + delete $args{'color-severity-lowest'}, + delete $args{'colour-severity-lowest'}, + delete $args{'color-severity-1'}, + delete $args{'colour-severity-1'}, + $PROFILE_COLOR_SEVERITY_LOWEST_DEFAULT, + ); + + # If we're using a pager or not outputing to a tty don't use colors. + # Can't use IO::Interactive here because we /don't/ want to check STDIN. + my $default_color = ($self->pager() or not -t *STDOUT) ? $FALSE : $TRUE; ## no critic (ProhibitInteractiveTest) + $self->{_color} = dor(delete $args{color}, delete $args{colour}, $default_color); + + # If there's anything left, complain. + _check_for_extra_options(%args); + + return $self; +} + +#----------------------------------------------------------------------------- + +sub _check_for_extra_options { + my %args = @_; + + if ( my @remaining = sort keys %args ){ + my $errors = Perl::Critic::Exception::AggregateConfiguration->new(); + + foreach my $option_name (@remaining) { + $errors->add_exception( + Perl::Critic::Exception::Configuration::Option::Global::ExtraParameter->new( + option_name => $option_name, + ) + ) + } + + $errors->rethrow(); + } + + return; +} + +#----------------------------------------------------------------------------- +# Public ACCESSOR methods + +sub severity { + my ($self) = @_; + return $self->{_severity}; +} + +#----------------------------------------------------------------------------- + +sub theme { + my ($self) = @_; + return $self->{_theme}; +} + +#----------------------------------------------------------------------------- + +sub exclude { + my ($self) = @_; + return $self->{_exclude}; +} + +#----------------------------------------------------------------------------- + +sub include { + my ($self) = @_; + return $self->{_include}; +} + +#----------------------------------------------------------------------------- + +sub only { + my ($self) = @_; + return $self->{_only}; +} + +#----------------------------------------------------------------------------- + +sub profile_strictness { + my ($self) = @_; + return $self->{_profile_strictness}; +} + +#----------------------------------------------------------------------------- + +sub single_policy { + my ($self) = @_; + return $self->{_single_policy}; +} + +#----------------------------------------------------------------------------- + +sub verbose { + my ($self) = @_; + return $self->{_verbose}; +} + +#----------------------------------------------------------------------------- + +sub color { + my ($self) = @_; + return $self->{_color}; +} + +#----------------------------------------------------------------------------- + +sub pager { + my ($self) = @_; + return $self->{_pager}; +} + +#----------------------------------------------------------------------------- + +sub allow_unsafe { + my ($self) = @_; + return $self->{_allow_unsafe}; +} + +#----------------------------------------------------------------------------- + +sub criticism_fatal { + my ($self) = @_; + return $self->{_criticism_fatal}; +} + +#----------------------------------------------------------------------------- + +sub force { + my ($self) = @_; + return $self->{_force}; +} + +#----------------------------------------------------------------------------- + +sub top { + my ($self) = @_; + return $self->{_top}; +} + +#----------------------------------------------------------------------------- + +sub color_severity_highest { + my ($self) = @_; + return $self->{_color_severity_highest}; +} + +#----------------------------------------------------------------------------- + +sub color_severity_high { + my ($self) = @_; + return $self->{_color_severity_high}; +} + +#----------------------------------------------------------------------------- + +sub color_severity_medium { + my ($self) = @_; + return $self->{_color_severity_medium}; +} + +#----------------------------------------------------------------------------- + +sub color_severity_low { + my ($self) = @_; + return $self->{_color_severity_low}; +} + +#----------------------------------------------------------------------------- + +sub color_severity_lowest { + my ($self) = @_; + return $self->{_color_severity_lowest}; +} + +#----------------------------------------------------------------------------- + +sub program_extensions { + my ($self) = @_; + return $self->{_program_extensions}; +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::OptionsProcessor - The global configuration default values, combined with command-line values. + + +=head1 DESCRIPTION + +This is a helper class that encapsulates the default parameters for +constructing a L object. +There are no user-serviceable parts here. + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 CONSTRUCTOR + +=over + +=item C< new( %DEFAULT_PARAMS ) > + +Returns a reference to a new C object. +You can override the coded defaults by passing in name-value pairs +that correspond to the methods listed below. + +This is usually only invoked by +L, which passes +in the global values from a F<.perlcriticrc> file. This object +contains no information for individual Policies. + +=back + +=head1 METHODS + +=over + +=item C< exclude() > + +Returns a reference to a list of the default exclusion patterns. If +onto by +L. there +are no default exclusion patterns, then the list will be empty. + + +=item C< force() > + +Returns the default value of the C flag (Either 1 or 0). + + +=item C< include() > + +Returns a reference to a list of the default inclusion patterns. If +there are no default exclusion patterns, then the list will be empty. + + +=item C< only() > + +Returns the default value of the C flag (Either 1 or 0). + + +=item C< profile_strictness() > + +Returns the default value of C as an unvalidated +string. + + +=item C< single_policy() > + +Returns the default C pattern. (As a string.) + + +=item C< severity() > + +Returns the default C setting. (1..5). + + +=item C< theme() > + +Returns the default C setting. (As a string). + + +=item C< top() > + +Returns the default C setting. (Either 0 or a positive integer). + + +=item C< verbose() > + +Returns the default C setting. (Either a number or format +string). + + +=item C< color() > + +Returns the default C setting. (Either 1 or 0). + + +=item C< pager() > + +Returns the default C setting. (Either empty string or the pager +command string). + + +=item C< allow_unsafe() > + +Returns the default C setting. (Either 1 or 0). + + +=item C< criticism_fatal() > + +Returns the default C setting (Either 1 or 0). + +=item C< color_severity_highest() > + +Returns the color to be used for coloring highest severity violations. + +=item C< color_severity_high() > + +Returns the color to be used for coloring high severity violations. + +=item C< color_severity_medium() > + +Returns the color to be used for coloring medium severity violations. + +=item C< color_severity_low() > + +Returns the color to be used for coloring low severity violations. + +=item C< color_severity_lowest() > + +Returns the color to be used for coloring lowest severity violations. + +=item C< program_extensions() > + +Returns a reference to the array of file name extensions to be interpreted as +representing Perl programs. + +=back + + +=head1 SEE ALSO + +L, +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy.pm b/lib/Perl/Critic/Policy.pm new file mode 100644 index 0000000..3749d00 --- /dev/null +++ b/lib/Perl/Critic/Policy.pm @@ -0,0 +1,910 @@ +package Perl::Critic::Policy; + +use 5.006001; +use strict; +use warnings; + +use English qw< -no_match_vars >; +use Readonly; + +use File::Spec (); +use String::Format qw< stringf >; + +use overload ( q<""> => 'to_string', cmp => '_compare' ); + +use Perl::Critic::Utils qw< + :characters + :booleans + :severities + :data_conversion + interpolate + is_integer + policy_long_name + policy_short_name + severity_to_number +>; +use Perl::Critic::Utils::DataConversion qw< dor >; +use Perl::Critic::Utils::POD qw< + get_module_abstract_for_module + get_raw_module_abstract_for_module +>; +use Perl::Critic::Exception::AggregateConfiguration; +use Perl::Critic::Exception::Configuration; +use Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter; +use Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue; +use Perl::Critic::Exception::Fatal::PolicyDefinition + qw< throw_policy_definition >; +use Perl::Critic::PolicyConfig qw<>; +use Perl::Critic::PolicyParameter qw<>; +use Perl::Critic::Violation qw<>; + +use Exception::Class; # this must come after "use P::C::Exception::*" + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $NO_LIMIT => 'no_limit'; + +#----------------------------------------------------------------------------- + +my $format = '%p'; #Default stringy format + +#----------------------------------------------------------------------------- + +sub new { + my ($class, %config) = @_; + + my $self = bless {}, $class; + + my $config_object; + if ($config{_config_object}) { + $config_object = $config{_config_object}; + } + else { + $config_object = + Perl::Critic::PolicyConfig->new( + $self->get_short_name(), + \%config, + ); + } + + $self->__set_config( $config_object ); + + my @parameters; + my $parameter_metadata_available = 0; + + if ( $class->can('supported_parameters') ) { + $parameter_metadata_available = 1; + @parameters = + map + { Perl::Critic::PolicyParameter->new($_) } + $class->supported_parameters(); + } + $self->{_parameter_metadata_available} = $parameter_metadata_available; + $self->{_parameters} = \@parameters; + + my $errors = Perl::Critic::Exception::AggregateConfiguration->new(); + foreach my $parameter ( @parameters ) { + eval { + $parameter->parse_and_validate_config_value( $self, $config_object ); + } + or do { + $errors->add_exception_or_rethrow($EVAL_ERROR); + }; + + $config_object->remove( $parameter->get_name() ); + } + + if ($parameter_metadata_available) { + $config_object->handle_extra_parameters( $self, $errors ); + } + + if ( $errors->has_exceptions() ) { + $errors->rethrow(); + } + + return $self; +} + +#----------------------------------------------------------------------------- + +sub is_safe { + return $TRUE; +} + +#----------------------------------------------------------------------------- + +sub initialize_if_enabled { + return $TRUE; +} + +#----------------------------------------------------------------------------- + +sub prepare_to_scan_document { + return $TRUE; +} + +#----------------------------------------------------------------------------- + +sub __get_parameter_name { + my ( $self, $parameter ) = @_; + + return '_' . $parameter->get_name(); +} + +#----------------------------------------------------------------------------- + +sub __set_parameter_value { + my ( $self, $parameter, $value ) = @_; + + $self->{ $self->__get_parameter_name($parameter) } = $value; + + return; +} + +#----------------------------------------------------------------------------- + +sub __set_base_parameters { + my ($self) = @_; + + my $config = $self->__get_config(); + my $errors = Perl::Critic::Exception::AggregateConfiguration->new(); + + $self->_set_maximum_violations_per_document($errors); + + my $user_severity = $config->get_severity(); + if ( defined $user_severity ) { + my $normalized_severity = severity_to_number( $user_severity ); + $self->set_severity( $normalized_severity ); + } + + my $user_set_themes = $config->get_set_themes(); + if ( defined $user_set_themes ) { + my @set_themes = words_from_string( $user_set_themes ); + $self->set_themes( @set_themes ); + } + + my $user_add_themes = $config->get_add_themes(); + if ( defined $user_add_themes ) { + my @add_themes = words_from_string( $user_add_themes ); + $self->add_themes( @add_themes ); + } + + if ( $errors->has_exceptions() ) { + $errors->rethrow(); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _set_maximum_violations_per_document { + my ($self, $errors) = @_; + + my $config = $self->__get_config(); + + if ( $config->is_maximum_violations_per_document_unlimited() ) { + return; + } + + my $user_maximum_violations = + $config->get_maximum_violations_per_document(); + + if ( not is_integer($user_maximum_violations) ) { + $errors->add_exception( + new_parameter_value_exception( + 'maximum_violations_per_document', + $user_maximum_violations, + undef, + "does not look like an integer.\n" + ) + ); + + return; + } + elsif ( $user_maximum_violations < 0 ) { + $errors->add_exception( + new_parameter_value_exception( + 'maximum_violations_per_document', + $user_maximum_violations, + undef, + "is not greater than or equal to zero.\n" + ) + ); + + return; + } + + $self->set_maximum_violations_per_document( + $user_maximum_violations + ); + + return; +} + +#----------------------------------------------------------------------------- + +# Unparsed configuration, P::C::PolicyConfig. Compare with get_parameters(). +sub __get_config { + my ($self) = @_; + + return $self->{_config}; +} + +sub __set_config { + my ($self, $config) = @_; + + $self->{_config} = $config; + + return; +} + + #----------------------------------------------------------------------------- + +sub get_long_name { + my ($self) = @_; + + return policy_long_name(ref $self); +} + +#----------------------------------------------------------------------------- + +sub get_short_name { + my ($self) = @_; + + return policy_short_name(ref $self); +} + +#----------------------------------------------------------------------------- + +sub is_enabled { + my ($self) = @_; + + return $self->{_enabled}; +} + +#----------------------------------------------------------------------------- + +sub __set_enabled { + my ($self, $new_value) = @_; + + $self->{_enabled} = $new_value; + + return; +} + +#----------------------------------------------------------------------------- + +sub applies_to { + return qw(PPI::Element); +} + +#----------------------------------------------------------------------------- + +sub set_maximum_violations_per_document { + my ($self, $maximum_violations_per_document) = @_; + + $self->{_maximum_violations_per_document} = + $maximum_violations_per_document; + + return $self; +} + +#----------------------------------------------------------------------------- + +sub get_maximum_violations_per_document { + my ($self) = @_; + + return + exists $self->{_maximum_violations_per_document} + ? $self->{_maximum_violations_per_document} + : $self->default_maximum_violations_per_document(); +} + +#----------------------------------------------------------------------------- + +sub default_maximum_violations_per_document { + return; +} + +#----------------------------------------------------------------------------- + +sub set_severity { + my ($self, $severity) = @_; + $self->{_severity} = $severity; + return $self; +} + +#----------------------------------------------------------------------------- + +sub get_severity { + my ($self) = @_; + return $self->{_severity} || $self->default_severity(); +} + +#----------------------------------------------------------------------------- + +sub default_severity { + return $SEVERITY_LOWEST; +} + +#----------------------------------------------------------------------------- + +sub set_themes { + my ($self, @themes) = @_; + $self->{_themes} = [ sort @themes ]; + return $self; +} + +#----------------------------------------------------------------------------- + +sub get_themes { + my ($self) = @_; + my @themes = defined $self->{_themes} ? @{ $self->{_themes} } : $self->default_themes(); + my @sorted_themes = sort @themes; + return @sorted_themes; +} + +#----------------------------------------------------------------------------- + +sub add_themes { + my ($self, @additional_themes) = @_; + #By hashifying the themes, we squish duplicates + my %merged = hashify( $self->get_themes(), @additional_themes); + $self->{_themes} = [ keys %merged]; + return $self; +} + +#----------------------------------------------------------------------------- + +sub default_themes { + return (); +} + +#----------------------------------------------------------------------------- + +sub get_abstract { + my ($self) = @_; + + return get_module_abstract_for_module( ref $self ); +} + +#----------------------------------------------------------------------------- + +sub get_raw_abstract { + my ($self) = @_; + + return get_raw_module_abstract_for_module( ref $self ); +} + +#----------------------------------------------------------------------------- + +sub parameter_metadata_available { + my ($self) = @_; + + return $self->{_parameter_metadata_available}; +} + +#----------------------------------------------------------------------------- + +sub get_parameters { + my ($self) = @_; + + return $self->{_parameters}; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ($self) = @_; + + return throw_policy_definition + $self->get_short_name() . q/ does not implement violates()./; +} + +#----------------------------------------------------------------------------- + +sub violation { ## no critic (ArgUnpacking) + my ( $self, $desc, $expl, $elem ) = @_; + # HACK!! Use goto instead of an explicit call because P::C::V::new() uses caller() + my $sev = $self->get_severity(); + @_ = ('Perl::Critic::Violation', $desc, $expl, $elem, $sev ); + goto &Perl::Critic::Violation::new; +} + +#----------------------------------------------------------------------------- + +sub new_parameter_value_exception { + my ( $self, $option_name, $option_value, $source, $message_suffix ) = @_; + + return Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue->new( + policy => $self->get_short_name(), + option_name => $option_name, + option_value => $option_value, + source => $source, + message_suffix => $message_suffix + ); +} + +#----------------------------------------------------------------------------- + +## no critic (Subroutines::RequireFinalReturn) +sub throw_parameter_value_exception { + my ( $self, $option_name, $option_value, $source, $message_suffix ) = @_; + + $self->new_parameter_value_exception( + $option_name, $option_value, $source, $message_suffix + ) + ->throw(); +} +## use critic + + +#----------------------------------------------------------------------------- + +# Static methods. + +sub set_format { return $format = $_[0] } ## no critic(ArgUnpacking) +sub get_format { return $format } + +#----------------------------------------------------------------------------- + +sub to_string { + my ($self, @args) = @_; + + # Wrap the more expensive ones in sub{} to postpone evaluation + my %fspec = ( + 'P' => sub { $self->get_long_name() }, + 'p' => sub { $self->get_short_name() }, + 'a' => sub { dor($self->get_abstract(), $EMPTY) }, + 'O' => sub { $self->_format_parameters(@_) }, + 'U' => sub { $self->_format_lack_of_parameter_metadata(@_) }, + 'S' => sub { $self->default_severity() }, + 's' => sub { $self->get_severity() }, + 'T' => sub { join $SPACE, $self->default_themes() }, + 't' => sub { join $SPACE, $self->get_themes() }, + 'V' => sub { dor( $self->default_maximum_violations_per_document(), $NO_LIMIT ) }, + 'v' => sub { dor( $self->get_maximum_violations_per_document(), $NO_LIMIT ) }, + ); + return stringf(get_format(), %fspec); +} + +sub _format_parameters { + my ($self, $parameter_format) = @_; + + return $EMPTY if not $self->parameter_metadata_available(); + + my $separator; + if ($parameter_format) { + $separator = $EMPTY; + } else { + $separator = $SPACE; + $parameter_format = '%n'; + } + + return + join + $separator, + map { $_->to_formatted_string($parameter_format) } @{ $self->get_parameters() }; +} + +sub _format_lack_of_parameter_metadata { + my ($self, $message) = @_; + + return $EMPTY if $self->parameter_metadata_available(); + return interpolate($message) if $message; + + return + 'Cannot programmatically discover what parameters this policy takes.'; +} + +#----------------------------------------------------------------------------- +# Apparently, some perls do not implicitly stringify overloading +# objects before doing a comparison. This causes a couple of our +# sorting tests to fail. To work around this, we overload C to +# do it explicitly. +# +# 20060503 - More information: This problem has been traced to +# Test::Simple versions <= 0.60, not perl itself. Upgrading to +# Test::Simple v0.62 will fix the problem. But rather than forcing +# everyone to upgrade, I have decided to leave this workaround in +# place. + +sub _compare { return "$_[0]" cmp "$_[1]" } + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy - Base class for all Policy modules. + + +=head1 DESCRIPTION + +Perl::Critic::Policy is the abstract base class for all Policy +objects. If you're developing your own Policies, your job is to +implement and override its methods in a subclass. To work with the +L engine, your implementation must behave +as described below. For a detailed explanation on how to make new +Policy modules, please see the +L document included +in this distribution. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 METHODS + +=over + +=item C<< new( ... ) >> + +Don't call this. As a Policy author, do not implement this. Use the +C method for your Policy setup. See the +L documentation for more. + + +=item C<< initialize_if_enabled( $config ) >> + +This receives an instance of +L as a +parameter, and is only invoked if this Policy is enabled by the user. +Thus, this is the preferred place for subclasses to do any +initialization. + +Implementations of this method should return a boolean value +indicating whether the Policy should continue to be enabled. For most +subclasses, this will always be C<$TRUE>. Policies that depend upon +external modules or other system facilities that may or may not be +available should test for the availability of these dependencies and +return C<$FALSE> if they are not. + + +=item C<< prepare_to_scan_document( $document ) >> + +The parameter is about to be scanned by this Policy. Whatever this +Policy wants to do in terms of preparation should happen here. +Returns a boolean value indicating whether the document should be +scanned at all; if this is a false value, this Policy won't be applied +to the document. By default, does nothing but return C<$TRUE>. + + +=item C< violates( $element, $document ) > + +Given a L and a +L, returns one or more +L objects if the +C<$element> violates this Policy. If there are no violations, then it +returns an empty list. If the Policy encounters an exception, then it +should C with an error message and let the caller decide how to +handle it. + +C is an abstract method and it will abort if you attempt +to invoke it directly. It is the heart of all Policy modules, and +your subclass B override this method. + + +=item C< violation( $description, $explanation, $element ) > + +Returns a reference to a new C object. The +arguments are a description of the violation (as string), an +explanation for the policy (as string) or a series of page numbers in +PBP (as an ARRAY ref), a reference to the L element that +caused the violation. + +These are the same as the constructor to +L, but without the +severity. The Policy itself knows the severity. + + +=item C< new_parameter_value_exception( $option_name, $option_value, $source, $message_suffix ) > + +Create a +L +for this Policy. + + +=item C< throw_parameter_value_exception( $option_name, $option_value, $source, $message_suffix ) > + +Create and throw a +L. +Useful in parameter parser implementations. + + +=item C< get_long_name() > + +Return the full package name of this policy. + + +=item C< get_short_name() > + +Return the name of this policy without the "Perl::Critic::Policy::" +prefix. + + +=item C< is_enabled() > + +Answer whether this policy is really active or not. Returns a true +value if it is, a false, yet defined, value if it isn't, and an +undefined value if it hasn't yet been decided whether it will be. + + +=item C< applies_to() > + +Returns a list of the names of PPI classes that this Policy cares +about. By default, the result is C. Overriding this +method in Policy subclasses should lead to significant performance +increases. + + +=item C< default_maximum_violations_per_document() > + +Returns the default maximum number of violations for this policy to +report per document. By default, this not defined, but subclasses may +override this. + + +=item C< get_maximum_violations_per_document() > + +Returns the maximum number of violations this policy will report for a +single document. If this is not defined, then there is no limit. If +L has not been invoked, then +L is returned. + + +=item C< set_maximum_violations_per_document() > + +Specify the maximum violations that this policy should report for a +document. + + +=item C< default_severity() > + +Returns the default severity for violating this Policy. See the +C<$SEVERITY> constants in L +for an enumeration of possible severity values. By default, this +method returns C<$SEVERITY_LOWEST>. Authors of Perl::Critic::Policy +subclasses should override this method to return a value that they +feel is appropriate for their Policy. In general, Polices that are +widely accepted or tend to prevent bugs should have a higher severity +than those that are more subjective or cosmetic in nature. + + +=item C< get_severity() > + +Returns the severity of violating this Policy. If the severity has +not been explicitly defined by calling C, then the +C is returned. See the C<$SEVERITY> constants in +L for an enumeration of +possible severity values. + + +=item C< set_severity( $N ) > + +Sets the severity for violating this Policy. Clients of +Perl::Critic::Policy objects can call this method to assign a +different severity to the Policy if they don't agree with the +C. See the C<$SEVERITY> constants in +L for an enumeration of +possible values. + + +=item C< default_themes() > + +Returns a sorted list of the default themes associated with this +Policy. The default method returns an empty list. Policy authors +should override this method to return a list of themes that are +appropriate for their policy. + + +=item C< get_themes() > + +Returns a sorted list of the themes associated with this Policy. If +you haven't added themes or set the themes explicitly, this method +just returns the default themes. + + +=item C< set_themes( @THEME_LIST ) > + +Sets the themes associated with this Policy. Any existing themes are +overwritten. Duplicate themes will be removed. + + +=item C< add_themes( @THEME_LIST ) > + +Appends additional themes to this Policy. Any existing themes are +preserved. Duplicate themes will be removed. + + +=item C< get_abstract() > + +Retrieve the abstract for this policy (the part of the NAME section of +the POD after the module name), if it is available. + + +=item C< get_raw_abstract() > + +Retrieve the abstract for this policy (the part of the NAME section of +the POD after the module name), if it is available, in the unparsed +form. + + +=item C< parameter_metadata_available() > + +Returns whether information about the parameters is available. + + +=item C< get_parameters() > + +Returns a reference to an array containing instances of +L. + +Note that this will return an empty list if the parameters for this +policy are unknown. In order to differentiate between this +circumstance and the one where this policy does not take any +parameters, it is necessary to call C. + + +=item C + +Class method. Sets the format for all Policy objects when they are +evaluated in string context. The default is C<"%p\n">. See +L<"OVERLOADS"> for formatting options. + + +=item C + +Class method. Returns the current format for all Policy objects when +they are evaluated in string context. + + +=item C + +Returns a string representation of the policy. The content of the +string depends on the current value returned by C. +See L<"OVERLOADS"> for the details. + + +=item C + +Answer whether this Policy can be used to analyze untrusted code, i.e. the +Policy doesn't have any potential side effects. + +This method returns a true value by default. + +An "unsafe" policy might attempt to compile the code, which, if you have +C or C blocks that affect files or connect to databases, is not +a safe thing to do. If you are writing a such a Policy, then you should +override this method to return false. + +By default L will not run unsafe policies. + + + +=back + + +=head1 DOCUMENTATION + +When your Policy module first Cs +L, it will try and +extract the DESCRIPTION section of your Policy module's POD. This +information is displayed by Perl::Critic if the verbosity level is set +accordingly. Therefore, please include a DESCRIPTION section in the +POD for any Policy modules that you author. Thanks. + + +=head1 OVERLOADS + +Perl::Critic::Violation overloads the C<""> operator to produce neat +little messages when evaluated in string context. + +Formats are a combination of literal and escape characters similar to +the way C works. If you want to know the specific formatting +capabilities, look at L. Valid escape +characters are: + + +=over + +=item C<%P> + +Name of the Policy module. + + +=item C<%p> + +Name of the Policy without the C prefix. + + +=item C<%a> + +The policy abstract. + + +=item C<%O> + +List of supported policy parameters. Takes an option of a format +string for L. +For example, this can be used like C<%{%n - %d\n}O> to get a list of +parameter names followed by their descriptions. + + +=item C<%U> + +A message stating that the parameters for the policy are unknown if +C returns false. Takes an option of +what the message should be, which defaults to "Cannot programmatically +discover what parameters this policy takes.". The value of this +option is interpolated in order to expand the standard escape +sequences (C<\n>, C<\t>, etc.). + + +=item C<%S> + +The default severity level of the policy. + + +=item C<%s> + +The current severity level of the policy. + + +=item C<%T> + +The default themes for the policy. + + +=item C<%t> + +The current themes for the policy. + + +=item C<%V> + +The default maximum number of violations per document of the policy. + + +=item C<%v> + +The current maximum number of violations per document of the policy. + + +=back + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitBooleanGrep.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitBooleanGrep.pm new file mode 100644 index 0000000..c39ecd6 --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitBooleanGrep.pm @@ -0,0 +1,155 @@ +package Perl::Critic::Policy::BuiltinFunctions::ProhibitBooleanGrep; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification hashify }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{"grep" used in boolean context}; +Readonly::Scalar my $EXPL => [71,72]; + +Readonly::Hash my %POSTFIX_CONDITIONALS => hashify( qw(if unless while until) ); +Readonly::Hash my %BOOLEAN_OPERATORS => hashify( qw(&& || ! not or and)); + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw( core pbp performance certrec ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->content() ne 'grep'; + return if not is_function_call($elem); + return if not _is_in_boolean_context($elem); + + return $self->violation( $DESC, $EXPL, $elem ); +} + +#----------------------------------------------------------------------------- + +sub _is_in_boolean_context { + my ($token) = @_; + + return _does_prev_sibling_cause_boolean($token) || _does_parent_cause_boolean($token); +} + +sub _does_prev_sibling_cause_boolean { + my ($token) = @_; + + my $prev = $token->sprevious_sibling; + return if !$prev; + return 1 if $prev->isa('PPI::Token::Word') and $POSTFIX_CONDITIONALS{$prev}; + return if not ($prev->isa('PPI::Token::Operator') and $BOOLEAN_OPERATORS{$prev}); + my $next = $token->snext_sibling; + return 1 if not $next; # bizarre: grep with no arguments + + # loose heuristic: unparenthesized grep has no following non-boolean operators + return 1 if not $next->isa('PPI::Structure::List'); + + $next = $next->snext_sibling; + return 1 if not $next; + return 1 if $next->isa('PPI::Token::Operator') and $BOOLEAN_OPERATORS{$next}; + return; +} + +sub _does_parent_cause_boolean { + my ($token) = @_; + + my $prev = $token->sprevious_sibling; + return if $prev; + my $parent = $token->statement->parent; + for (my $node = $parent; $node; $node = $node->parent) { ## no critic (CStyleForLoop) + next if $node->isa('PPI::Structure::List'); + return 1 if $node->isa('PPI::Structure::Condition'); + } + + return; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::ProhibitBooleanGrep - Use C instead of C in boolean context. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Using C in boolean context is a common idiom for checking if any +elements in a list match a condition. This works because boolean +context is a subset of scalar context, and grep returns the number of +matches in scalar context. A non-zero number of matches means a +match. + +But consider the case of a long array where the first element is a +match. Boolean C still checks all of the rest of the elements +needlessly. Instead, a better solution is to use the C function +from L, which short-circuits after +the first successful match to save time. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 CAVEATS + +The algorithm for detecting boolean context takes a LOT of shortcuts. +There are lots of known false negatives. But, I was conservative in +writing this, so I hope there are no false positives. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitComplexMappings.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitComplexMappings.pm new file mode 100644 index 0000000..9f87050 --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitComplexMappings.pm @@ -0,0 +1,147 @@ +package Perl::Critic::Policy::BuiltinFunctions::ProhibitComplexMappings; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Map blocks should have a single statement}; +Readonly::Scalar my $EXPL => [ 113 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'max_statements', + description => + 'The maximum number of statements to allow within a map block.', + default_string => '1', + behavior => 'integer', + integer_minimum => 1, + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core pbp maintenance complexity) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->content() ne 'map'; + return if ! is_function_call($elem); + + my $sib = $elem->snext_sibling(); + return if !$sib; + + my $arg = $sib; + if ( $arg->isa('PPI::Structure::List') ) { + $arg = $arg->schild(0); + # Forward looking: PPI might change in v1.200 so schild(0) is a PPI::Statement::Expression + if ( $arg && $arg->isa('PPI::Statement::Expression') ) { + $arg = $arg->schild(0); + } + } + # If it's not a block, it's an expression-style map, which is only one statement by definition + return if !$arg; + return if !$arg->isa('PPI::Structure::Block'); + + # If we get here, we found a sort with a block as the first arg + return if $self->{_max_statements} >= $arg->schildren() + && 0 == grep {$_->isa('PPI::Statement::Compound')} $arg->schildren(); + + # more than one child statements + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::ProhibitComplexMappings - Map blocks should have a single statement. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +The map function can be confusing to novices in the best of +circumstances. Mappings with multiple statements are even worse. +They're also a maintainer's nightmare because any added complexity +decreases readability precipitously. Why? Because map is +traditionally a one-liner converting one array to another. Trying to +cram lots of functionality into a one-liner is a bad idea in general. + +The best solutions to a complex mapping are: 1) write a subroutine +that performs the manipulation and call that from map; 2) rewrite the +map as a for loop. + + +=head1 CAVEATS + +This policy currently misses some compound statements inside of the +map. For example, the following code incorrectly does not trigger a +violation: + + map { do { foo(); bar() } } @list + + +=head1 CONFIGURATION + +By default this policy flags any mappings with more than one +statement. While we do not recommend it, you can increase this limit +as follows in a F<.perlcriticrc> file: + + [BuiltinFunctions::ProhibitComplexMappings] + max_statements = 2 + + +=head1 AUTHOR + +Chris Dolan + + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitLvalueSubstr.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitLvalueSubstr.pm new file mode 100644 index 0000000..0a77ff0 --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitLvalueSubstr.pm @@ -0,0 +1,126 @@ +package Perl::Critic::Policy::BuiltinFunctions::ProhibitLvalueSubstr; + +use 5.006001; +use strict; +use warnings; +use Readonly; +use version 0.77 (); + +use Perl::Critic::Utils qw{ :severities :classification :language }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Lvalue form of "substr" used}; +Readonly::Scalar my $EXPL => [ 165 ]; + +Readonly::Scalar my $ASSIGNMENT_PRECEDENCE => precedence_of( q{=} ); +Readonly::Scalar my $MINIMUM_PERL_VERSION => version->new( 5.005 ); + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core maintenance pbp ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub prepare_to_scan_document { + my ( $self, $document ) = @_; + # perl5005delta says that is when the fourth argument to substr() + # was introduced, so ... (RT #59112) + my $version = $document->highest_explicit_perl_version(); + return ! $version || $version >= $MINIMUM_PERL_VERSION; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, undef) = @_; + + return if $elem->content() ne 'substr'; + return if ! is_function_call($elem); + + my $sib = $elem; + while ($sib = $sib->snext_sibling()) { + if ( $sib->isa( 'PPI::Token::Operator' ) ) { + my $rslt = $ASSIGNMENT_PRECEDENCE <=> precedence_of( + $sib->content() ); + return if $rslt < 0; + return $self->violation( $DESC, $EXPL, $sib ) if $rslt == 0; + } + } + return; #ok! +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=for stopwords perlfunc substr 4th + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::ProhibitLvalueSubstr - Use 4-argument C instead of writing C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway discourages the use of C as an lvalue, instead +recommending that the 4-argument version of C be used +instead. + + substr($something, 1, 2) = $newvalue; # not ok + substr($something, 1, 2, $newvalue); # ok + +The four-argument form of C was introduced in Perl 5.005. +This policy does not report violations on code which explicitly +specifies an earlier version of Perl (e.g. C). + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L<"substr" in perlfunc|perlfunc/substr> (or C). + +L<"4th argument to substr" in perl5005delta|perl5005delta/4th argument to substr> + + +=head1 AUTHOR + +Graham TerMarsch + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Graham TerMarsch. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitReverseSortBlock.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitReverseSortBlock.pm new file mode 100644 index 0000000..957f26b --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitReverseSortBlock.pm @@ -0,0 +1,130 @@ +package Perl::Critic::Policy::BuiltinFunctions::ProhibitReverseSortBlock; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Forbid $b before $a in sort blocks}; ## no critic (InterpolationOfMetachars) +Readonly::Scalar my $EXPL => [ 152 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw(core pbp cosmetic) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, $doc) = @_; + + return if $elem->content() ne 'sort'; + return if ! is_function_call($elem); + + my $sib = $elem->snext_sibling(); + return if !$sib; + + my $arg = $sib; + if ( $arg->isa('PPI::Structure::List') ) { + $arg = $arg->schild(0); + # Forward looking: PPI might change in v1.200 so schild(0) is a PPI::Statement::Expression + if ( $arg && $arg->isa('PPI::Statement::Expression') ) { + $arg = $arg->schild(0); + } + } + return if !$arg || !$arg->isa('PPI::Structure::Block'); + + # If we get here, we found a sort with a block as the first arg + + # Look at each statement in the block separately. + # $a is +1, $b is -1, sum should always be >= 0. + # This may go badly if there are conditionals or loops or other + # sub-statements... + for my $statement ($arg->children) { + my @sort_vars = $statement =~ m/\$([ab])\b/gxms; + my $count = 0; + for my $sort_var (@sort_vars) { + if ($sort_var eq 'a') { + $count++; + } else { + $count--; + if ($count < 0) { + # Found too many C<$b>s too early + return $self->violation( $DESC, $EXPL, $elem ); + } + } + } + } + return; #ok +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::ProhibitReverseSortBlock - Forbid $b before $a in sort blocks. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway says that it is much clearer to use C than to flip +C<$a> and C<$b> around in a C block. He also suggests that, in +newer perls, C is specifically looked for and optimized, and +in the case of a simple reversed string C, using C with +a C with no block is faster even in old perls. + + my @foo = sort { $b cmp $a } @bar; #not ok + my @foo = reverse sort @bar; #ok + + my @foo = sort { $b <=> $a } @bar; #not ok + my @foo = reverse sort { $a <=> $b } @bar; #ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitShiftRef.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitShiftRef.pm new file mode 100644 index 0000000..dbee126 --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitShiftRef.pm @@ -0,0 +1,189 @@ +package Perl::Critic::Policy::BuiltinFunctions::ProhibitShiftRef; + +use 5.006001; +use strict; +use warnings; +use Readonly; +use version 0.77 (); + +use Perl::Critic::Utils qw{ :severities :classification :language }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{\shift used}; +Readonly::Scalar my $EXPL => [165]; + +Readonly::Scalar my $MINIMUM_PERL_VERSION => version->new(5.008008); + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core bugs tests ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub prepare_to_scan_document { + my ( $self, $document ) = @_; + + # The earliest version tested was 5.8.8 + my $version = $document->highest_explicit_perl_version(); + return !$version || $version >= $MINIMUM_PERL_VERSION; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->content() ne 'shift'; + + my $prev = $elem->sprevious_sibling(); + if ( !$prev ) { + + # If there is no previous token, we are probably nested in a block. + # Grab the statement and see if it's in a block. For simplicity, we + # assume the block only contains a 'shift' statement, which may not be + # reliable. + if ( my $stmt = $elem->statement ) { + + my $block = $stmt->parent(); + if ( $block && $block->isa('PPI::Structure::Block') ) { + $prev = $block->sprevious_sibling(); + } + } + } + + if ( $prev && $prev->isa('PPI::Token::Cast') && $prev->content() eq q{\\} ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + + return; +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=encoding utf8 + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::ProhibitShiftRef - Prohibit C<\shift> in code + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Prohibit the use of C<\shift>, as it is associated with bugs in Perl and its +modules. + +=head2 Background + +Often, C<\shift> is used to create references that act much like an alias. By +creating an "alias" that is named, the code becomes more readable. For example, + + sub routine { + my $longstring = \shift; + print $$longstring; + } + +is more readable than + + sub routine { + print $_[0]; # longstring + } + +Unfortunately, this added readability brings with it new and exciting issues, +detailed in the next section. + +=head2 Problems with C<\shift> + +By avoiding C<\shift>, several issues in Perl can be averted, including: + +=over + +=item Memory leak since Perl 5.22 + +Issue #126676 was introduced in Perl 5.21.4 and is triggered when C<\shift> is +used. The bug has not been resolved as of Perl 5.28. + +In short, the bug causes the ref counter for the aliased variable to be +incremented when running the subroutine, but it is not subsequently decremented +after the subroutine returns. In addition to leaking memory, this issue can +also delay the cleanup of objects until Global Destruction, which can cause +further issues. + +For more information, see L. + +=item Devel::Cover crashes + +A separate, longstanding issue in Devel::Cover (since at least 1.21), causes +test code to segfault occasionally. This prevents the coverage data from being +written out, resulting in bad metrics. + +The bug itself isn't actually caused by C<\shift>, instead it shows up in code +like the following: + + sub myopen { + open ${ \$_[0] }, ">test"; + } + +However, this code would rarely be seen in production. It would more likely +manifest with C<\shift>, as it does below: + + sub myopen { + my $fh = \shift; + open $$fh, ">test"; + } + +So while C<\shift> isn't the cause, it's often associated with the problem. + +For more information, see L. + +=back + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L + +L + + +=head1 AUTHOR + +=for stopwords Lindee + +Chris Lindee + + +=head1 COPYRIGHT + +=for stopwords cPanel + +Copyright (c) 2018 cPanel, L.L.C. + +All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitSleepViaSelect.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitSleepViaSelect.pm new file mode 100644 index 0000000..d8f5c8f --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitSleepViaSelect.pm @@ -0,0 +1,114 @@ +package Perl::Critic::Policy::BuiltinFunctions::ProhibitSleepViaSelect; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification :ppi }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{"select" used to emulate "sleep"}; +Readonly::Scalar my $EXPL => [168]; +Readonly::Scalar my $SELECT_ARGUMENT_COUNT => 4; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw( core pbp bugs ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, undef) = @_; + + return if $elem->content() ne 'select'; + return if ! is_function_call($elem); + + my @arguments = parse_arg_list($elem); + return if $SELECT_ARGUMENT_COUNT != @arguments; + + foreach my $argument ( @arguments[0..2] ) { + return if $argument->[0] ne 'undef'; + } + + if ( $arguments[-1]->[0] ne 'undef' ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + + return; #ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords perlfunc + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::ProhibitSleepViaSelect - Use L instead of something like C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway discourages the use of C for performing non-integer +sleeps. Although documented in L, it's something +that generally requires the reader to read C to +figure out what it should be doing. Instead, Conway recommends that +you use the C module when you want to sleep. + + select undef, undef, undef, 0.25; # not ok + + use Time::HiRes; + sleep( 0.25 ); # ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L. + + +=head1 AUTHOR + +Graham TerMarsch + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Graham TerMarsch. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringyEval.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringyEval.pm new file mode 100644 index 0000000..bc13add --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringyEval.pm @@ -0,0 +1,184 @@ +package Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use PPI::Document; + +use Perl::Critic::Utils qw{ :booleans :severities :classification :ppi $SCOLON }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Expression form of "eval"}; +Readonly::Scalar my $EXPL => [ 161 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'allow_includes', + description => q, + default_string => '0', + behavior => 'boolean', + }, + ); +} +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw( core pbp bugs certrule ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->content() ne 'eval'; + return if not is_function_call($elem); + + my $argument = first_arg($elem); + return if not $argument; + return if $argument->isa('PPI::Structure::Block'); + return if + $self->{_allow_includes} and _string_eval_is_an_include($argument); + + return $self->violation( $DESC, $EXPL, $elem ); +} + +sub _string_eval_is_an_include { + my ($eval_argument) = @_; + + return if not $eval_argument->isa('PPI::Token::Quote'); + + my $string = $eval_argument->string(); + my $document; + + eval { $document = PPI::Document->new(\$string); 1 } + or return; + + my @statements = $document->schildren; + + return if @statements > 2; + my $include = $statements[0]; + return if not defined $include; # RT 60179 + return if not $include->isa('PPI::Statement::Include'); + return if $include->type() eq 'no'; + + if ( + $eval_argument->isa('PPI::Token::Quote::Single') + or $eval_argument->isa('PPI::Token::Quote::Literal') + ) { + # Don't allow funky inclusion of arbitrary code (note we do allow + # interpolated values in interpolating strings because they can't + # entirely screw with the syntax). + return if $include->find('PPI::Token::Symbol'); + } + + return $TRUE if @statements == 1; + + my $follow_on = $statements[1]; + return if not $follow_on->isa('PPI::Statement'); + + my @follow_on_components = $follow_on->schildren(); + + return if @follow_on_components > 2; + return if not $follow_on_components[0]->isa('PPI::Token::Number'); + return $TRUE if @follow_on_components == 1; + + return $follow_on_components[1]->content() eq $SCOLON; +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords SIGNES + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval - Write C instead of C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +The string form of C is recompiled every time it is executed, +whereas the block form is only compiled once. Also, the string form +doesn't give compile-time warnings. + + eval "print $foo"; # not ok + eval {print $foo}; # ok + + +=head1 CONFIGURATION + +There is an C boolean option for this Policy. If set, then +strings that look like they only include a single "use" or "require" statement +(with the possible following statement that consists of a single number) are +allowed. With this option set, the following are flagged as indicated: + + eval 'use Foo'; # ok + eval 'require Foo'; # ok + eval "use $thingy;"; # ok + eval "require $thingy;"; # ok + eval "use $thingy; 1;"; # ok + eval "require $thingy; 1;"; # ok + + eval 'use Foo; blah;'; # still not ok + eval 'require Foo; 2; 1;'; # still not ok + eval 'use $thingy;'; # still not ok + eval 'no Foo'; # still not ok + +If you don't understand why the number is allowed, see +L. + +This option inspired by Ricardo SIGNES' +L. + + +=head1 SEE ALSO + +L + +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringySplit.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringySplit.pm new file mode 100644 index 0000000..a366fe7 --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringySplit.pm @@ -0,0 +1,113 @@ +package Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :characters :severities :classification :ppi }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{String delimiter used with "split"}; +Readonly::Scalar my $EXPL => q{Express it as a regex instead}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core pbp cosmetic certrule ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->content() ne 'split'; + return if ! is_function_call($elem); + + my @args = parse_arg_list($elem); + my $pattern = @args ? $args[0]->[0] : return; + + if ( $pattern->isa('PPI::Token::Quote') && $pattern->string() ne $SPACE ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + + return; #ok +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit - Write C instead of C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +The C function always interprets the PATTERN argument as a +regular expression, even if you specify it as a string. This causes +much confusion if the string contains regex metacharacters. So for +clarity, always express the PATTERN argument as a regex. + + $string = 'Fred|Barney'; + @names = split '|', $string; #not ok, is ('F', 'r', 'e', 'd', '|', 'B', 'a' ...) + @names = split m/[|]/, $string; #ok, is ('Fred', Barney') + +When the PATTERN is a single space the C function has special +behavior, so Perl::Critic forgives that usage. See C<"perldoc -f +split"> for more information. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L + +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalCan.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalCan.pm new file mode 100644 index 0000000..2fe386a --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalCan.pm @@ -0,0 +1,104 @@ +package Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalCan; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{UNIVERSAL::can should not be used as a function}; +Readonly::Scalar my $EXPL => q{Use eval{$obj->can($pkg)} instead}; ## no critic (RequireInterp); + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core maintenance certrule ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + return if !($elem eq 'can' || $elem eq 'UNIVERSAL::can'); + return if ! is_function_call($elem); # this also permits 'use UNIVERSAL::can;' + + return $self->violation( $DESC, $EXPL, $elem ); +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalCan - Write C<< eval { $foo->can($name) } >> instead of C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + + print UNIVERSAL::can($obj, 'Foo::Bar') ? 'yes' : 'no'; #not ok + print eval { $obj->can('Foo::Bar') } ? 'yes' : 'no'; #ok + +As of Perl 5.9.3, the use of UNIVERSAL::can as a function has been +deprecated and the method form is preferred instead. Formerly, the +functional form was recommended because it gave valid results even +when the object was C or an unblessed scalar. However, the +functional form makes it impossible for packages to override C, +a technique which is crucial for implementing mock objects and some +facades. + +See L for a more thorough discussion of +this topic. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalIsa.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalIsa.pm new file mode 100644 index 0000000..d609c73 --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalIsa.pm @@ -0,0 +1,105 @@ +package Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{UNIVERSAL::isa should not be used as a function}; +Readonly::Scalar my $EXPL => q{Use eval{$obj->isa($pkg)} instead}; ## no critic (RequireInterp); + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core maintenance certrule ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + return if !($elem eq 'isa' || $elem eq 'UNIVERSAL::isa'); + return if ! is_function_call($elem); # this also permits 'use UNIVERSAL::isa;' + + return $self->violation( $DESC, $EXPL, $elem ); +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa - Write C<< eval { $foo->isa($pkg) } >> instead of C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + + print UNIVERSAL::isa($obj, 'Foo::Bar') ? 'yes' : 'no'; #not ok + print eval { $obj->isa('Foo::Bar') } ? 'yes' : 'no'; #ok + +As of Perl 5.9.3, the use of C as a function has been +deprecated and the method form is preferred instead. Formerly, the +functional form was recommended because it gave valid results even +when the object was C or an unblessed scalar. However, the +functional form makes it impossible for packages to override C, +a technique which is crucial for implementing mock objects and some +facades. + +Another alternative to UNIVERSAL::isa is the C<_INSTANCE> method of +Param::Util, which is faster. + +See the CPAN module L for an incendiary +discussion of this topic. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Chris Dolan + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUselessTopic.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUselessTopic.pm new file mode 100644 index 0000000..9d97753 --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUselessTopic.pm @@ -0,0 +1,212 @@ +package Perl::Critic::Policy::BuiltinFunctions::ProhibitUselessTopic; + +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification :ppi }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +## no critic ( ValuesAndExpressions::RequireInterpolationOfMetachars ) +## The numerous $_ variables make false positives. +Readonly::Scalar my $DESC => q{Useless use of $_}; +Readonly::Scalar my $EXPL_FILETEST => q{$_ should be omitted when using a filetest operator}; +Readonly::Scalar my $EXPL_FUNCTION => q{$_ should be omitted when calling "%s"}; +Readonly::Scalar my $EXPL_FUNCTION_SPLIT => q{$_ should be omitted when calling "split" with two arguments}; + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw( core ) } +sub applies_to { return 'PPI::Token::Operator', 'PPI::Token::Word' } + +my @filetest_operators = qw( -r -w -x -o -R -W -X -O -e -z -s -f -d -l -p -S -b -c -u -g -k -T -B -M -A -C ); +my %filetest_operators = map { ($_ => 1) } @filetest_operators; + +my @topical_funcs = qw( + abs alarm + chomp chop chr chroot cos + defined + eval exp + fc + glob + hex + int + lc lcfirst length log lstat + mkdir + oct ord + pos print + quotemeta + readlink readpipe ref require reverse rmdir + say sin split sqrt stat study + uc ucfirst unlink unpack +); +my %topical_funcs = map { ($_ => 1) } @topical_funcs; + +my %applies_to = ( %topical_funcs, %filetest_operators ); + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if not exists $applies_to{ $elem->content }; + + my $content = $elem->content; + + # Are we looking at a filetest? + if ( $filetest_operators{ $content } ) { + # Is there a $_ following it? + my $op_node = $elem->snext_sibling; + if ( $op_node && $op_node->isa('PPI::Token::Magic') ) { + my $op = $op_node->content; + if ( $op eq '$_' ) { + return $self->violation( $DESC, $EXPL_FILETEST, $elem ); + } + } + return; + } + + if ( $topical_funcs{ $content } && is_perl_builtin( $elem ) ) { + my $is_split = $content eq 'split'; + + my @args = parse_arg_list( $elem ); + + my $nth_arg_for_topic; + if ( $is_split ) { + return if @args != 2; # Ignore split( /\t/ ) or split( /\t/, $_, 3 ) + $nth_arg_for_topic = 2; + } + else { + $nth_arg_for_topic = 1; + } + + if ( @args == $nth_arg_for_topic ) { + my $topic_arg = $args[ $nth_arg_for_topic - 1 ]; + my @tokens = @{$topic_arg}; + if ( (@tokens == 1) && ($tokens[0]->content eq '$_') ) { + my $msg = $is_split ? $EXPL_FUNCTION_SPLIT : (sprintf $EXPL_FUNCTION, $content); + return $self->violation( $DESC, $msg, $elem ); + } + } + return; + } + + return; +} + + +1; + +__END__ + +=pod + +=for stopwords filetest + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::ProhibitUselessTopic - Don't pass $_ to built-in functions that assume it, or to most filetest operators. + +=head1 AFFILIATION + +This Policy is part of the L distribution. + +=head1 DESCRIPTION + +There are a number of places where C<$_>, or "the topic" variable, +is unnecessary. + +=head2 Topic unnecessary for certain Perl built-in functions + +Many Perl built-in functions will operate on C<$_> if no argument +is passed. For example, the C function will operate on +C<$_> by default. This snippet: + + for ( @list ) { + if ( length( $_ ) == 4 ) { ... + +is more idiomatically written as: + + for ( @list ) { + if ( length == 4 ) { ... + +In the case of the C function, the second argument is the +one that defaults to C<$_>. This snippet: + + for ( @list ) { + my @args = split /\t/, $_; + +is better written as: + + for ( @list ) { + my @args = split /\t/; + +There is one built-in that this policy does B check for: +C called with C<$_>. + +The C function only operates on C<$_> if called in scalar +context. Therefore: + + for ( @list ) { + my $backwards = reverse $_; + +is better written as: + + for ( @list ) { + my $backwards = reverse; + +However, the distinction for scalar vs. list context on C +is not yet working. See L below. + +=head2 Topic unnecessary for most filetest operators + +Another place that C<$_> is unnecessary is with a filetest operator. + + # These are identical. + my $size = -s $_; + my $size = -s; + + # These are identical. + if ( -r $_ ) { ... + if ( -r ) { ... + +The exception is after the C<-t> filetest operator, which instead of +defaulting to C<$_> defaults to C. + + # These are NOT identical. + if ( -t $_ ) { ... + if ( -t ) { ... # Checks STDIN, not $_ + +=head1 KNOWN BUGS + +This policy flags a false positive on C called in list +context, since C in list context does I assume C<$_>. + + my $s = reverse( $_ ); # $_ is useless. + my @a = reverse( $_ ); # $_ is not useless here. + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + +=head1 AUTHOR + +Andy Lester + +=head1 COPYRIGHT + +Copyright (c) 2013 Andy Lester + +This library is free software; you can redistribute it and/or modify it +under the terms of the Artistic License 2.0. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidGrep.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidGrep.pm new file mode 100644 index 0000000..b39b4a6 --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidGrep.pm @@ -0,0 +1,100 @@ +package Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification is_in_void_context }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{"grep" used in void context}; +Readonly::Scalar my $EXPL => q{Use a "for" loop instead}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core maintenance ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->content() ne 'grep'; + return if not is_function_call($elem); + return if not is_in_void_context($elem); + + return $self->violation( $DESC, $EXPL, $elem ); +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep - Don't use C in void contexts. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +C and C are intended to be pure functions, not mutators. +If you want to iterate with side-effects, then you should use a proper +C or C loop. + + grep{ print frobulate($_) } @list; #not ok + print map{ frobulate($_) } @list; #ok + + grep{ $_ = lc $_ } @list; #not ok + for( @list ){ $_ = lc $_ }; #ok + + map{ push @frobbed, frobulate($_) } @list; #not ok + @frobbed = map { frobulate($_) } @list; #ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidMap.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidMap.pm new file mode 100644 index 0000000..c9df43d --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidMap.pm @@ -0,0 +1,100 @@ +package Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification is_in_void_context }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{"map" used in void context}; +Readonly::Scalar my $EXPL => q{Use a "for" loop instead}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core maintenance ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->content() ne 'map'; + return if not is_function_call($elem); + return if not is_in_void_context($elem); + + return $self->violation( $DESC, $EXPL, $elem ); +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap - Don't use C in void contexts. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +C and C are intended to be pure functions, not mutators. +If you want to iterate with side-effects, then you should use a proper +C or C loop. + + grep{ print frobulate($_) } @list; #not ok + print map{ frobulate($_) } @list; #ok + + grep{ $_ = lc $_ } @list; #not ok + for( @list ){ $_ = lc $_ }; #ok + + map{ push @frobbed, frobulate($_) } @list; #not ok + @frobbed = map { frobulate($_) } @list; #ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockGrep.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockGrep.pm new file mode 100644 index 0000000..9a3229f --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockGrep.pm @@ -0,0 +1,103 @@ +package Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep; + +# DEVELOPER NOTE: this module is used as an example in DEVELOPER.pod. +# If you make changes in here, please reflect those changes in the +# examples. + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification :ppi }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Expression form of "grep"}; +Readonly::Scalar my $EXPL => [ 169 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core bugs pbp ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->content() ne 'grep'; + return if ! is_function_call($elem); + + my $arg = first_arg($elem); + return if !$arg; + return if $arg->isa('PPI::Structure::Block'); + + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep - Write C instead of C. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + +=head1 DESCRIPTION + +The expression forms of C and C are awkward and hard to +read. Use the block forms instead. + + @matches = grep /pattern/, @list; #not ok + @matches = grep { /pattern/ } @list; #ok + + @mapped = map transform($_), @list; #not ok + @mapped = map { transform($_) } @list; #ok + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + +=head1 SEE ALSO + +L + +L + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2013 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockMap.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockMap.pm new file mode 100644 index 0000000..58966c8 --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockMap.pm @@ -0,0 +1,100 @@ +package Perl::Critic::Policy::BuiltinFunctions::RequireBlockMap; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification :ppi }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Expression form of "map"}; +Readonly::Scalar my $EXPL => [ 169 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core bugs pbp ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem ne 'map'; + return if ! is_function_call($elem); + + my $arg = first_arg($elem); + return if !$arg; + return if $arg->isa('PPI::Structure::Block'); + + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::RequireBlockMap - Write C instead of C. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + +=head1 DESCRIPTION + +The expression forms of C and C are awkward and hard to +read. Use the block forms instead. + + @matches = grep /pattern/, @list; #not ok + @matches = grep { /pattern/ } @list; #ok + + @mapped = map transform($_), @list; #not ok + @mapped = map { transform($_) } @list; #ok + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + +=head1 SEE ALSO + +L + +L + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2013 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/RequireGlobFunction.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/RequireGlobFunction.pm new file mode 100644 index 0000000..0af4673 --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/RequireGlobFunction.pm @@ -0,0 +1,93 @@ +package Perl::Critic::Policy::BuiltinFunctions::RequireGlobFunction; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $GLOB_RX => qr< [*?] >xms; +Readonly::Scalar my $DESC => q{Glob written as <...>}; +Readonly::Scalar my $EXPL => [ 167 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw( core pbp bugs ) } +sub applies_to { return 'PPI::Token::QuoteLike::Readline' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + if ( $elem =~ $GLOB_RX ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::RequireGlobFunction - Use C instead of <*>. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway discourages the use of the C<< <..> >> construct for globbing, as +it is easily confused with the angle bracket file input operator. +Instead, he recommends the use of the C function as it makes +it much more obvious what you're attempting to do. + + @files = <*.pl>; # not ok + @files = glob '*.pl'; # ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Graham TerMarsch + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Graham TerMarsch. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/BuiltinFunctions/RequireSimpleSortBlock.pm b/lib/Perl/Critic/Policy/BuiltinFunctions/RequireSimpleSortBlock.pm new file mode 100644 index 0000000..3fda44a --- /dev/null +++ b/lib/Perl/Critic/Policy/BuiltinFunctions/RequireSimpleSortBlock.pm @@ -0,0 +1,111 @@ +package Perl::Critic::Policy::BuiltinFunctions::RequireSimpleSortBlock; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Sort blocks should have a single statement}; +Readonly::Scalar my $EXPL => [ 149 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core pbp maintenance complexity) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->content() ne 'sort'; + return if ! is_function_call($elem); + + my $sib = $elem->snext_sibling(); + return if !$sib; + + my $arg = $sib; + if ( $arg->isa('PPI::Structure::List') ) { + $arg = $arg->schild(0); + # Forward looking: PPI might change in v1.200 so schild(0) is a PPI::Statement::Expression + if ( $arg && $arg->isa('PPI::Statement::Expression') ) { + $arg = $arg->schild(0); + } + } + return if !$arg || !$arg->isa('PPI::Structure::Block'); + + # If we get here, we found a sort with a block as the first arg + return if ( 1 >= $arg->schildren() ); + + # more than one child statements + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::BuiltinFunctions::RequireSimpleSortBlock - Sort blocks should have a single statement. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway advises that sort functions should be simple. Any complicated +operations on list elements should be computed and cached (perhaps via +a Schwartzian Transform) before the sort, rather than computed inside +the sort block, because the sort block is called C times +instead of just C times. + +This policy prohibits the most blatant case of complicated sort +blocks: multiple statements. Future policies may wish to examine the +sort block in more detail -- looking for subroutine calls or large +numbers of operations. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Chris Dolan + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ClassHierarchies/ProhibitAutoloading.pm b/lib/Perl/Critic/Policy/ClassHierarchies/ProhibitAutoloading.pm new file mode 100644 index 0000000..4257970 --- /dev/null +++ b/lib/Perl/Critic/Policy/ClassHierarchies/ProhibitAutoloading.pm @@ -0,0 +1,93 @@ +package Perl::Critic::Policy::ClassHierarchies::ProhibitAutoloading; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{AUTOLOAD method declared}; +Readonly::Scalar my $EXPL => [ 393 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core maintenance pbp ) } +sub applies_to { return 'PPI::Statement::Sub' } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, undef) = @_; + + if( $elem->name eq 'AUTOLOAD' ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::ClassHierarchies::ProhibitAutoloading - AUTOLOAD methods should be avoided. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Declaring a subroutine with the name C<"AUTOLOAD"> will violate this +Policy. The C mechanism is an easy way to generate methods +for your classes, but unless they are carefully written, those classes +are difficult to inherit from. And over time, the C method +will become more and more complex as it becomes responsible for +dispatching more and more functions. You're better off writing +explicit accessor methods. Editor macros can help make this a little +easier. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ClassHierarchies/ProhibitExplicitISA.pm b/lib/Perl/Critic/Policy/ClassHierarchies/ProhibitExplicitISA.pm new file mode 100644 index 0000000..9a024e6 --- /dev/null +++ b/lib/Perl/Critic/Policy/ClassHierarchies/ProhibitExplicitISA.pm @@ -0,0 +1,94 @@ +package Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{@ISA used instead of "use base"}; ## no critic (RequireInterpolation) +Readonly::Scalar my $EXPL => [ 360 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core maintenance pbp certrec ) } +sub applies_to { return 'PPI::Token::Symbol' } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, undef) = @_; + + if( $elem eq q{@ISA} ) { ## no critic (RequireInterpolation) + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA - Employ C instead of C<@ISA>. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway recommends employing C instead of the usual +C because the former happens at compile time and +the latter at runtime. The L pragma also automatically loads +C for you so you save a line of easily-forgotten code. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 NOTE + +Some people prefer L over L. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ClassHierarchies/ProhibitOneArgBless.pm b/lib/Perl/Critic/Policy/ClassHierarchies/ProhibitOneArgBless.pm new file mode 100644 index 0000000..50e9d51 --- /dev/null +++ b/lib/Perl/Critic/Policy/ClassHierarchies/ProhibitOneArgBless.pm @@ -0,0 +1,96 @@ +package Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :booleans :severities :classification :ppi }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{One-argument "bless" used}; +Readonly::Scalar my $EXPL => [ 365 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw( core pbp bugs ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, undef) = @_; + + return if $elem->content() ne 'bless'; + return if ! is_function_call($elem); + + if( scalar parse_arg_list($elem) == 1 ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless - Write C instead of just C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Always use the two-argument form of C because it allows +subclasses to inherit your constructor. + + sub new { + my $class = shift; + my $self = bless {}; # not ok + my $self = bless {}, $class; # ok + return $self; + } + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/CodeLayout/ProhibitHardTabs.pm b/lib/Perl/Critic/Policy/CodeLayout/ProhibitHardTabs.pm new file mode 100644 index 0000000..ca3c75d --- /dev/null +++ b/lib/Perl/Critic/Policy/CodeLayout/ProhibitHardTabs.pm @@ -0,0 +1,162 @@ +package Perl::Critic::Policy::CodeLayout::ProhibitHardTabs; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :booleans :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Hard tabs used}; +Readonly::Scalar my $EXPL => [ 20 ]; + +#----------------------------------------------------------------------------- + +# The following regex should probably be "qr{^ .* [^\t]+ \t}xms" but it doesn't +# match when I expect it to. I haven't figured out why, so I used "\S" to +# approximately mean "not a tab", and that seemed to work. + +Readonly::Scalar my $NON_LEADING_TAB_REGEX => qr{^ .* \S+ \t }xms; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'allow_leading_tabs', + description => 'Allow hard tabs before first non-whitespace character.', + default_string => '1', + behavior => 'boolean', + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core cosmetic pbp ) } +sub applies_to { return 'PPI::Token' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + $elem =~ m{ \t }xms || return; + + # The __DATA__ element is exempt + return if $elem->parent->isa('PPI::Statement::Data'); + + # If allowed, permit leading tabs in situations where whitespace s not significant. + if ( $self->_allow_leading_tabs() ) { + + return if $elem->location->[1] == 1; + + return if _is_extended_regex($elem) + && $elem !~ $NON_LEADING_TAB_REGEX; + + return if $elem->isa('PPI::Token::QuoteLike::Words') + && $elem !~ $NON_LEADING_TAB_REGEX; + } + + # If we get here, then it must be a violation... + return $self->violation( $DESC, $EXPL, $elem ); +} + +#----------------------------------------------------------------------------- + +sub _allow_leading_tabs { + my ( $self ) = @_; + return $self->{_allow_leading_tabs}; +} + +#----------------------------------------------------------------------------- + +sub _is_extended_regex { + my ($elem) = @_; + + $elem->isa('PPI::Token::Regexp') + || $elem->isa('PPI::Token::QuoteLike::Regexp') + || return; + + # Look for the /x modifier near the end + return $elem =~ m{\b [gimso]* x [gimso]* $}xms; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=head1 NAME + +Perl::Critic::Policy::CodeLayout::ProhibitHardTabs - Use spaces instead of tabs. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Putting hard tabs in your source code (or POD) is one of the worst +things you can do to your co-workers and colleagues, especially if +those tabs are anywhere other than a leading position. Because +various applications and devices represent tabs differently, they can +cause you code to look vastly different to other people. Any decent +editor can be configured to expand tabs into spaces. +L also does this for you. + +This Policy catches all tabs in your source code, including POD, +quotes, and HEREDOCs. The contents of the C<__DATA__> section are not +examined. + + +=head1 CONFIGURATION + +Hard tabs in a string are always forbidden (use "\t" instead). But +hard tabs in a leading position are allowed when they are used to indent +code statements, C word lists, and regular expressions with the C +modifier. However, if you want to forbid all tabs everywhere, then add +this to your F<.perlcriticrc> file: + + [CodeLayout::ProhibitHardTabs] + allow_leading_tabs = 0 + + +=head1 NOTES + +Beware that Perl::Critic may report the location of the string that +contains the tab, not the actual location of the tab, so you may need +to do some hunting. I'll try and fix this in the future. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/CodeLayout/ProhibitParensWithBuiltins.pm b/lib/Perl/Critic/Policy/CodeLayout/ProhibitParensWithBuiltins.pm new file mode 100644 index 0000000..b3d4fd8 --- /dev/null +++ b/lib/Perl/Critic/Policy/CodeLayout/ProhibitParensWithBuiltins.pm @@ -0,0 +1,259 @@ +package Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ + :booleans :severities :data_conversion :classification :language +}; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Array my @ALLOW => qw( my our local return state ); +Readonly::Hash my %ALLOW => hashify( @ALLOW ); + +Readonly::Scalar my $DESC => q{Builtin function called with parentheses}; +Readonly::Scalar my $EXPL => [ 13 ]; + +Readonly::Scalar my $PRECENDENCE_OF_LIST => precedence_of(q{>>}) + 1; +Readonly::Scalar my $PRECEDENCE_OF_COMMA => precedence_of(q{,}); + +#----------------------------------------------------------------------------- +# These are all the functions that are considered named unary +# operators. These frequently require parentheses because they have lower +# precedence than ordinary function calls. + +Readonly::Array my @NAMED_UNARY_OPS => qw( + alarm glob rand + caller gmtime readlink + chdir hex ref + chroot int require + cos lc return + defined lcfirst rmdir + delete length scalar + do localtime sin + eval lock sleep + exists log sqrt + exit lstat srand + getgrp my stat + gethostbyname oct uc + getnetbyname ord ucfirst + getprotobyname quotemeta umask + undef +); +Readonly::Hash my %NAMED_UNARY_OPS => hashify( @NAMED_UNARY_OPS ); + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw( core pbp cosmetic ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if exists $ALLOW{$elem}; + return if not is_perl_builtin($elem); + return if not is_function_call($elem); + + my $sibling = $elem->snext_sibling(); + return if not $sibling; + if ( $sibling->isa('PPI::Structure::List') ) { + my $elem_after_parens = $sibling->snext_sibling(); + + return if _is_named_unary_with_operator_inside_parens_exemption($elem, $sibling); + return if _is_named_unary_with_operator_following_parens_exemption($elem, $elem_after_parens); + return if _is_precedence_exemption($elem_after_parens); + return if _is_equals_exemption($sibling); + return if _is_sort_exemption($elem, $sibling); + + # If we get here, it must be a violation + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +#----------------------------------------------------------------------------- +# EXCEPTION 1: If the function is a named unary and there is an +# operator with higher precedence right after the parentheses. +# Example: int( 1.5 ) + 0.5; + +sub _is_named_unary_with_operator_following_parens_exemption { + my ($elem, $elem_after_parens) = @_; + + if ( _is_named_unary( $elem ) && $elem_after_parens ){ + # Smaller numbers mean higher precedence + my $precedence = precedence_of( $elem_after_parens ); + return $TRUE if defined $precedence && $precedence < $PRECENDENCE_OF_LIST; + } + + return $FALSE; +} + +sub _is_named_unary { + my ($elem) = @_; + + return exists $NAMED_UNARY_OPS{$elem->content}; +} + +#----------------------------------------------------------------------------- +# EXCEPTION 2, If there is an operator immediately after the +# parentheses, and that operator has precedence greater than +# or equal to a comma. +# Example: join($delim, @list) . "\n"; + +sub _is_precedence_exemption { + my ($elem_after_parens) = @_; + + if ( $elem_after_parens ){ + # Smaller numbers mean higher precedence + my $precedence = precedence_of( $elem_after_parens ); + return $TRUE if defined $precedence && $precedence <= $PRECEDENCE_OF_COMMA; + } + + return $FALSE; +} + +#----------------------------------------------------------------------------- +# EXCEPTION 3: If the first operator within the parentheses is '=' +# Example: chomp( my $foo = ); + +sub _is_equals_exemption { + my ($sibling) = @_; + + if ( my $first_op = $sibling->find_first('PPI::Token::Operator') ){ + return $TRUE if $first_op eq q{=}; + } + + return $FALSE; +} + +#----------------------------------------------------------------------------- +# EXCEPTION 4: sort with default comparator but a function for the list data +# Example: sort(foo(@x)) + +sub _is_sort_exemption { + my ($elem, $sibling) = @_; + + if ( $elem eq 'sort' ) { + my $first_arg = $sibling->schild(0); + if ( $first_arg && $first_arg->isa('PPI::Statement::Expression') ) { + $first_arg = $first_arg->schild(0); + } + if ( $first_arg && $first_arg->isa('PPI::Token::Word') ) { + my $next_arg = $first_arg->snext_sibling; + return $TRUE if $next_arg && $next_arg->isa('PPI::Structure::List'); + } + } + + return $FALSE; +} + +#----------------------------------------------------------------------------- +# EXCEPTION 5: If the function is a named unary and there is an operator +# inside the parentheses. +# Example: length($foo || $bar); + +sub _is_named_unary_with_operator_inside_parens_exemption { + my ($elem, $parens) = @_; + return _is_named_unary($elem) && _contains_operators($parens); +} + +sub _contains_operators { + my ($parens) = @_; + return $TRUE if $parens->find_first('PPI::Token::Operator'); + return $FALSE; +} + +#----------------------------------------------------------------------------- +1; + +__END__ + + +=pod + +=for stopwords disambiguates builtins + +=head1 NAME + +Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins - Write C instead of C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway suggests that all built-in functions be called without +parentheses around the argument list. This reduces visual clutter and +disambiguates built-in functions from user functions. Exceptions are +made for C, C, and C which require parentheses when +called with multiple arguments. + + open($handle, '>', $filename); #not ok + open $handle, '>', $filename; #ok + + split(/$pattern/, @list); #not ok + split /$pattern/, @list; #ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 NOTES + +Coding with parentheses can sometimes lead to verbose and awkward +constructs, so I think the intent of Conway's guideline is to remove +only the F parentheses. This policy makes exceptions for +some common situations where parentheses are usually required. +However, you may find other situations where the parentheses are +necessary to enforce precedence, but they cause still violations. In +those cases, consider using the '## no critic' comments to silence +Perl::Critic. + + +=head1 BUGS + +Some builtin functions (particularly those that take a variable number +of scalar arguments) should probably get parentheses. This policy +should be enhanced to allow the user to specify a list of builtins +that are exempt from the policy. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/CodeLayout/ProhibitQuotedWordLists.pm b/lib/Perl/Critic/Policy/CodeLayout/ProhibitQuotedWordLists.pm new file mode 100644 index 0000000..0c39855 --- /dev/null +++ b/lib/Perl/Critic/Policy/CodeLayout/ProhibitQuotedWordLists.pm @@ -0,0 +1,181 @@ +package Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use Perl::Critic::Utils qw{ :characters :severities :classification}; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{List of quoted literal words}; +Readonly::Scalar my $EXPL => q{Use 'qw()' instead}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'min_elements', + description => 'The minimum number of words in a list that will be complained about.', + default_string => '2', + behavior => 'integer', + integer_minimum => 1, + }, + { + name => 'strict', + description => 'Complain even if there are non-word characters in the values.', + default_string => '0', + behavior => 'boolean', + }, + ); +} + +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw( core cosmetic ) } +sub applies_to { return 'PPI::Structure::List' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + # Don't worry about subroutine calls + my $sibling = $elem->sprevious_sibling(); + return if not $sibling; + + return if $sibling->isa('PPI::Token::Symbol'); + return if $sibling->isa('PPI::Token::Operator') and $sibling eq '->'; + return if $sibling->isa('PPI::Token::Word') and not is_included_module_name($sibling); + + # Get the list elements + my $expr = $elem->schild(0); + return if not $expr; + my @children = $expr->schildren(); + return if not @children; + + my $count = 0; + for my $child ( @children ) { + next if $child->isa('PPI::Token::Operator') && $child eq $COMMA; + + # All elements must be literal strings, + # and must contain 1 or more word characters. + + return if not _is_literal($child); + + my $string = $child->string(); + return if $string =~ m{ \s }xms; + return if $string eq $EMPTY; + return if not $self->{_strict} and $string !~ m{\A [\w-]+ \z}xms; + $count++; + } + + # Were there enough? + return if $count < $self->{_min_elements}; + + # If we get here, then all elements were literals + return $self->violation( $DESC, $EXPL, $elem ); +} + +sub _is_literal { + my $elem = shift; + return $elem->isa('PPI::Token::Quote::Single') + || $elem->isa('PPI::Token::Quote::Literal'); +} + +1; + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists - Write C instead of C<('foo', 'bar', 'baz')>. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway doesn't mention this, but I think C is an underused +feature of Perl. Whenever you need to declare a list of one-word +literals, the C operator is wonderfully concise, and makes it +easy to add to the list in the future. + + @list = ('foo', 'bar', 'baz'); #not ok + @list = qw(foo bar baz); #ok + + use Foo ('foo', 'bar', 'baz'); #not ok + use Foo qw(foo bar baz); #ok + +=head1 CONFIGURATION + +This policy can be configured to only pay attention to word lists with +at least a particular number of elements. By default, this value is +2, which means that lists containing zero or one elements are ignored. +The minimum list size to be looked at can be specified by giving a +value for C in F<.perlcriticrc> like this: + + [CodeLayout::ProhibitQuotedWordLists] + min_elements = 4 + +This would cause this policy to only complain about lists containing +four or more words. + +By default, this policy won't complain if any of the values in the list +contain non-word characters. If you want it to, set the C +option to a true value. + + [CodeLayout::ProhibitQuotedWordLists] + strict = 1 + + +=head1 NOTES + +In the PPI parlance, a "list" is almost anything with parentheses. +I've tried to make this Policy smart by targeting only "lists" that +could be sensibly expressed with C. However, there may be some +edge cases that I haven't covered. If you find one, send me a note. + + +=head1 IMPORTANT CHANGES + +This policy was formerly called C which seemed a +little counter-intuitive. If you get lots of "Cannot load policy +module" errors, then you probably need to change C +to C in your F<.perlcriticrc> file. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/CodeLayout/ProhibitTrailingWhitespace.pm b/lib/Perl/Critic/Policy/CodeLayout/ProhibitTrailingWhitespace.pm new file mode 100644 index 0000000..483e1c0 --- /dev/null +++ b/lib/Perl/Critic/Policy/CodeLayout/ProhibitTrailingWhitespace.pm @@ -0,0 +1,143 @@ +package Perl::Critic::Policy::CodeLayout::ProhibitTrailingWhitespace; + +use 5.006001; +use strict; +use warnings; +use English qw(-no_match_vars); +use Readonly; + +use charnames qw{}; + +use PPI::Token::Whitespace; +use Perl::Critic::Utils qw{ :characters :severities }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => q{Don't use whitespace at the end of lines}; + +## no critic (RequireInterpolationOfMetachars) +Readonly::Hash my %C_STYLE_ESCAPES => + ( + ord "\t" => q{\t}, + ord "\n" => q{\n}, + ord "\r" => q{\r}, + ord "\f" => q{\f}, + ord "\b" => q{\b}, + ord "\a" => q{\a}, + ord "\e" => q{\e}, + ); +## use critic + +#----------------------------------------------------------------------------- + +sub supported_parameters { return qw{ } } +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw( core maintenance ) } +sub applies_to { return 'PPI::Token::Whitespace' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $token, undef ) = @_; + + if ( $token->content() =~ m< ( (?! \n) \s )+ \n >xms ) { + my $extra_whitespace = $1; + + my $description = q{Found "}; + $description .= + join + $EMPTY, + map { _escape($_) } split $EMPTY, $extra_whitespace; + $description .= q{" at the end of the line}; + + return $self->violation( $description, $EXPL, $token ); + } + + return; +} + +sub _escape { + my $character = shift; + my $ordinal = ord $character; + + if (my $c_escape = $C_STYLE_ESCAPES{$ordinal}) { + return $c_escape; + } + + + # Apparently, the charnames.pm that ships with older perls does not + # support the C function, and newer versions of the module are + # not distributed separately from perl itself So if the C method + # is not supported, then just substitute something. + + + ## no critic (RequireInterpolationOfMetachars) + if ( charnames->can( 'viacode' ) ) { + return q/\N{/ . charnames::viacode($ordinal) . q/}/; + } + else { + return '\N{WHITESPACE CHAR}'; + } +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Policy::CodeLayout::ProhibitTrailingWhitespace - Don't use whitespace at the end of lines. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Anything that is not readily visually detectable is a bad thing in +general, and more specifically, as different people edit the same +code, their editors may automatically strip out trailing whitespace, +causing spurious differences between different versions of the same +file (i.e. code in a source control system). + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Elliot Shank C<< >> + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/CodeLayout/RequireConsistentNewlines.pm b/lib/Perl/Critic/Policy/CodeLayout/RequireConsistentNewlines.pm new file mode 100644 index 0000000..00fa588 --- /dev/null +++ b/lib/Perl/Critic/Policy/CodeLayout/RequireConsistentNewlines.pm @@ -0,0 +1,125 @@ +package Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use PPI::Token::Whitespace; +use English qw(-no_match_vars); +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +Readonly::Scalar my $LINE_END => qr/\015{1,2}\012|[\012\015]/mxs; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Use the same newline through the source}; +Readonly::Scalar my $EXPL => q{Change your newlines to be the same throughout}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core bugs ) } +sub applies_to { return 'PPI::Document' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, undef, $doc ) = @_; + + my $filename = $doc->filename(); + return if !$filename; + + my $fh; + return if !open $fh, '<', $filename; + local $RS = undef; + my $source = <$fh>; + close $fh or return; + + my $newline; # undef until we find the first one + my $line = 1; + my @v; + while ( $source =~ m/\G([^\012\015]*)($LINE_END)/cgmxs ) { + my $code = $1; + my $nl = $2; + my $col = length $code; + $newline ||= $nl; + if ( $nl ne $newline ) { + my $token = PPI::Token::Whitespace->new( $nl ); + # TODO this is a terrible violation of encapsulation, but absent a + # mechanism to override the line numbers in the violation, I do + # not know what to do about it. + $token->{_location} = [$line, $col, $col, $line, $filename]; + push @v, $self->violation( $DESC, $EXPL, $token ); + } + $line++; + } + return @v; +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=for stopwords GnuPG + +=head1 NAME + +Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines - Use the same newline through the source. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Source code files are divided into lines with line endings of C<\r>, +C<\n> or C<\r\n>. Mixing these different line endings causes problems +in many text editors and, notably, Module::Signature and GnuPG. + + +=head1 CAVEAT + +This policy works outside of PPI because PPI automatically normalizes +source code to local newline conventions. So, this will only work if +we know the filename of the source code. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/CodeLayout/RequireTidyCode.pm b/lib/Perl/Critic/Policy/CodeLayout/RequireTidyCode.pm new file mode 100644 index 0000000..660e1fc --- /dev/null +++ b/lib/Perl/Critic/Policy/CodeLayout/RequireTidyCode.pm @@ -0,0 +1,206 @@ +package Perl::Critic::Policy::CodeLayout::RequireTidyCode; + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); +use IO::String qw< >; +use Readonly; + +use Perl::Tidy qw< >; + +use Perl::Critic::Utils qw{ :booleans :characters :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Code is not tidy}; +Readonly::Scalar my $EXPL => [ 33 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'perltidyrc', + description => 'The Perl::Tidy configuration file to use, if any.', + default_string => undef, + }, + ); +} + +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw(core pbp cosmetic) } +sub applies_to { return 'PPI::Document' } + +#----------------------------------------------------------------------------- + +sub initialize_if_enabled { + my ($self, $config) = @_; + + # Set configuration if defined + if (defined $self->{_perltidyrc} && $self->{_perltidyrc} eq $EMPTY) { + my $rc = $EMPTY; + $self->{_perltidyrc} = \$rc; + } + + return $TRUE; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + + # Perl::Tidy seems to produce slightly different output, depending + # on the trailing whitespace in the input. As best I can tell, + # Perl::Tidy will truncate any extra trailing newlines, and if the + # input has no trailing newline, then it adds one. But when you + # re-run it through Perl::Tidy here, that final newline gets lost, + # which causes the policy to insist that the code is not tidy. + # This only occurs when Perl::Tidy is writing the output to a + # scalar, but does not occur when writing to a file. I may + # investigate further, but for now, this seems to do the trick. + + my $source = $doc->serialize(); + $source =~ s{ \s+ \Z}{\n}xms; + + # Remove the shell fix code from the top of program, if applicable + ## no critic (ProhibitComplexRegexes) + my $shebang_re = qr< [#]! [^\015\012]+ [\015\012]+ >xms; + my $shell_re = qrxms; + $source =~ s/\A ($shebang_re) $shell_re /$1/xms; + + my $dest = $EMPTY; + my $stderr = $EMPTY; + + + # Perl::Tidy gets confused if @ARGV has arguments from + # another program. Also, we need to override the + # stdout and stderr redirects that the user may have + # configured in their .perltidyrc file. + # Also override -b because we are using dest and source. + local @ARGV = qw(-nst -nse -nb); + + # Trap Perl::Tidy errors, just in case it dies + my $eval_worked = eval { + + # Perl::Tidy 20120619 no longer accepts a scalar reference for stdio. + my $handle = IO::String->new( $stderr ); + + # Beginning with version 20120619, Perl::Tidy modifies $source. So we + # make a copy so we can get a good comparison after tidying. Doing an + # s/// on $source after the fact appears not to work with previous + # versions of Perl::Tidy. + my $source_copy = $source; + + # In version 20120619 (and possibly earlier), Perl::Tidy assigns the + # stderr parameter directly to *STDERR. So when our $stderr goes out + # of scope, the handle gets closed. Subsequent calls to warn() will + # then cause a fatal exception. See RT #78182 for more details. In + # the meantime, we workaround it by localizing STDERR first. + local *STDERR = \*STDERR; + + Perl::Tidy::perltidy( + source => \$source_copy, + destination => \$dest, + stderr => $handle, + defined $self->{_perltidyrc} ? (perltidyrc => $self->{_perltidyrc}) : (), + ); + 1; + }; + + if ($stderr or not $eval_worked) { + # Looks like perltidy had problems + return $self->violation( 'perltidy had errors!!', $EXPL, $elem ); + } + + if ( $source ne $dest ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + + return; #ok! +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=for stopwords perltidy + +=head1 NAME + +Perl::Critic::Policy::CodeLayout::RequireTidyCode - Must run code through L. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway does make specific recommendations for whitespace and +curly-braces in your code, but the most important thing is to adopt a +consistent layout, regardless of the specifics. And the easiest way +to do that is to use L. This policy will +complain if you're code hasn't been run through Perl::Tidy. + + +=head1 CONFIGURATION + +This policy can be configured to tell Perl::Tidy to use a particular +F file or no configuration at all. By default, Perl::Tidy +is told to look in its default location for configuration. +Perl::Critic can be told to tell Perl::Tidy to use a specific +configuration file by putting an entry in a F<.perlcriticrc> file like +this: + + [CodeLayout::RequireTidyCode] + perltidyrc = /usr/share/perltidy.conf + +As a special case, setting C to the empty string tells +Perl::Tidy not to load any configuration file at all and just use +Perl::Tidy's own default style. + + [CodeLayout::RequireTidyCode] + perltidyrc = + + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/CodeLayout/RequireTrailingCommas.pm b/lib/Perl/Critic/Policy/CodeLayout/RequireTrailingCommas.pm new file mode 100644 index 0000000..97106c7 --- /dev/null +++ b/lib/Perl/Critic/Policy/CodeLayout/RequireTrailingCommas.pm @@ -0,0 +1,123 @@ +package Perl::Critic::Policy::CodeLayout::RequireTrailingCommas; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :characters :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{List declaration without trailing comma}; +Readonly::Scalar my $EXPL => [ 17 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw(core pbp cosmetic) } +sub applies_to { return 'PPI::Structure::List' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + $elem =~ m{ \n }xms || return; + + # Is it an assignment of some kind? + my $sib = $elem->sprevious_sibling(); + return if !$sib; + $sib->isa('PPI::Token::Operator') && $sib =~ m{ = }xms || return; + + # List elements are children of an expression + my $expr = $elem->schild(0); + return if !$expr; + + # Does the list have more than 1 element? + # This means list element, not PPI element. + my @children = $expr->schildren(); + return if 1 >= grep { $_->isa('PPI::Token::Operator') + && $_ eq $COMMA } @children; + + # Is the final element a comma? + my $final = $children[-1]; + if ( ! ($final->isa('PPI::Token::Operator') && $final eq $COMMA) ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + + return; #ok! +} + +1; + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::CodeLayout::RequireTrailingCommas - Put a comma at the end of every multi-line list declaration, including the last one. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway suggests that all elements in a multi-line list should be +separated by commas, including the last element. This makes it a +little easier to re-order the list by cutting and pasting. + + my @list = ($foo, + $bar, + $baz); #not ok + + my @list = ($foo, + $bar, + $baz,); #ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 NOTES + +In the PPI parlance, a "list" is almost anything with parentheses. +I've tried to make this Policy smart by targeting only "lists" that +have at least one element and are being assigned to something. +However, there may be some edge cases that I haven't covered. If you +find one, send me a note. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ControlStructures/ProhibitCStyleForLoops.pm b/lib/Perl/Critic/Policy/ControlStructures/ProhibitCStyleForLoops.pm new file mode 100644 index 0000000..3357fd8 --- /dev/null +++ b/lib/Perl/Critic/Policy/ControlStructures/ProhibitCStyleForLoops.pm @@ -0,0 +1,103 @@ +package Perl::Critic::Policy::ControlStructures::ProhibitCStyleForLoops; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :characters :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{C-style "for" loop used}; +Readonly::Scalar my $EXPL => [ 100 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw( core pbp maintenance ) } +sub applies_to { return 'PPI::Structure::For' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + if ( _is_cstyle($elem) ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +sub _is_cstyle { + my $elem = shift; + my $nodes_ref = $elem->find('PPI::Token::Structure'); + return if !$nodes_ref; + my @semis = grep { $_ eq $SCOLON } @{$nodes_ref}; + return scalar @semis == 2; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ControlStructures::ProhibitCStyleForLoops - Write C instead of C. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +The 3-part C loop that Perl inherits from C is butt-ugly, and +only really necessary if you need irregular counting. The very +Perlish C<..> operator is much more elegant and readable. + + for($i=0; $i<=$max; $i++){ #ick! + do_something($i); + } + + for(0..$max){ #very nice + do_something($_); + } + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ControlStructures/ProhibitCascadingIfElse.pm b/lib/Perl/Critic/Policy/ControlStructures/ProhibitCascadingIfElse.pm new file mode 100644 index 0000000..f53413f --- /dev/null +++ b/lib/Perl/Critic/Policy/ControlStructures/ProhibitCascadingIfElse.pm @@ -0,0 +1,129 @@ +package Perl::Critic::Policy::ControlStructures::ProhibitCascadingIfElse; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Cascading if-elsif chain}; +Readonly::Scalar my $EXPL => [ 117, 118 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'max_elsif', + description => 'The maximum number of alternatives that will be allowed.', + default_string => '2', + behavior => 'integer', + integer_minimum => 1, + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core pbp maintenance complexity ) } +sub applies_to { return 'PPI::Statement::Compound' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if ($elem->type() ne 'if'); + + if ( _count_elsifs($elem) > $self->{_max_elsif} ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +sub _count_elsifs { + my $elem = shift; + return + grep { $_->isa('PPI::Token::Word') && $_->content() eq 'elsif' } $elem->schildren(); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords lookup + +=head1 NAME + +Perl::Critic::Policy::ControlStructures::ProhibitCascadingIfElse - Don't write long "if-elsif-elsif-elsif-elsif...else" chains. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Long C chains are hard to digest, especially if they are +longer than a single page or screen. If testing for equality, use a +hash lookup instead. If you're using perl 5.10 or later, use +C/C. + + if ($condition1) { #ok + $foo = 1; + } + elsif ($condition2) { #ok + $foo = 2; + } + elsif ($condition3) { #ok + $foo = 3; + } + elsif ($condition4) { #too many! + $foo = 4; + } + else { #ok + $foo = $default; + } + +=head1 CONFIGURATION + +This policy can be configured with a maximum number of C +alternatives to allow. The default is 2. This can be specified via a +C item in the F<.perlcriticrc> file: + + [ControlStructures::ProhibitCascadingIfElse] + max_elsif = 3 + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ControlStructures/ProhibitDeepNests.pm b/lib/Perl/Critic/Policy/ControlStructures/ProhibitDeepNests.pm new file mode 100644 index 0000000..dc62a76 --- /dev/null +++ b/lib/Perl/Critic/Policy/ControlStructures/ProhibitDeepNests.pm @@ -0,0 +1,118 @@ +package Perl::Critic::Policy::ControlStructures::ProhibitDeepNests; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Code structure is deeply nested}; +Readonly::Scalar my $EXPL => q{Consider refactoring}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'max_nests', + description => 'The maximum number of nested constructs to allow.', + default_string => '5', + behavior => 'integer', + integer_minimum => 1, + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw(core maintenance complexity) } +sub applies_to { return 'PPI::Statement::Compound' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + my $nest_count = 1; #For _this_ element + my $parent = $elem; + + while ( $parent = $parent->parent() ){ + if( $parent->isa('PPI::Statement::Compound') ) { + $nest_count++; + } + } + + if ( $nest_count > $self->{_max_nests} ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + + +1; + +__END__ + + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords refactored + +=head1 NAME + +Perl::Critic::Policy::ControlStructures::ProhibitDeepNests - Don't write deeply nested loops and conditionals. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Deeply nested code is often hard to understand and may be a sign that +it needs to be refactored. There are several good books on how to +refactor code. I like Martin Fowler's "Refactoring: Improving The +Design of Existing Code". + + +=head1 CONFIGURATION + +The maximum number of nested control structures can be configured via +a value for C in a F<.perlcriticrc> file. Each for-loop, +if-else, while, and until block is counted as one nest. Postfix forms +of these constructs are not counted. The default maximum is 5. +Customization in a F<.perlcriticrc> file looks like this: + + [ControlStructures::ProhibitDeepNests] + max_nests = 3 + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ControlStructures/ProhibitLabelsWithSpecialBlockNames.pm b/lib/Perl/Critic/Policy/ControlStructures/ProhibitLabelsWithSpecialBlockNames.pm new file mode 100644 index 0000000..26b7399 --- /dev/null +++ b/lib/Perl/Critic/Policy/ControlStructures/ProhibitLabelsWithSpecialBlockNames.pm @@ -0,0 +1,118 @@ +package Perl::Critic::Policy::ControlStructures::ProhibitLabelsWithSpecialBlockNames; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use Perl::Critic::Utils qw{ :severities hashify }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +Readonly::Hash my %SPECIAL_BLOCK_NAMES => + hashify( qw< BEGIN END INIT CHECK UNITCHECK > ); + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q; +Readonly::Scalar my $EXPL => + q; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw< core bugs > } +sub applies_to { return qw< PPI::Token::Label > } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, undef) = @_; + + # Does the function call have enough arguments? + my $label = $elem->content(); + $label =~ s/ \s* : \z //xms; + return if not $SPECIAL_BLOCK_NAMES{ $label }; + + return $self->violation( $DESC, $EXPL, $elem ); +} + + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=for stopwords Lauen O'Regan + +=pod + +=head1 NAME + +Perl::Critic::Policy::ControlStructures::ProhibitLabelsWithSpecialBlockNames - Don't use labels that are the same as the special block names. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +When using one of the special Perl blocks C, C, C, +C, and C, it is easy to mistakenly add a colon to the +end of the block name. E.g.: + + # a BEGIN block that gets executed at compile time. + BEGIN { <...code...> } + + # an ordinary labeled block that gets executed at run time. + BEGIN: { <...code...> } + +The labels "BEGIN:", "END:", etc. are probably errors. This policy +prohibits the special Perl block names from being used as labels. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +The Perl Buzz article on this issue at +L. + + +=head1 ACKNOWLEDGMENT + +Randy Lauen for identifying the problem. + + +=head1 AUTHOR + +Mike O'Regan + + +=head1 COPYRIGHT + +Copyright (c) 2008-2011 Mike O'Regan. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ControlStructures/ProhibitMutatingListFunctions.pm b/lib/Perl/Critic/Policy/ControlStructures/ProhibitMutatingListFunctions.pm new file mode 100644 index 0000000..5833dbd --- /dev/null +++ b/lib/Perl/Critic/Policy/ControlStructures/ProhibitMutatingListFunctions.pm @@ -0,0 +1,348 @@ +package Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use List::MoreUtils qw( none any ); + +use Perl::Critic::Utils qw{ + :booleans :characters :severities :data_conversion :classification :ppi +}; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Array my @BUILTIN_LIST_FUNCS => qw( map grep ); +Readonly::Array my @CPAN_LIST_FUNCS => _get_cpan_list_funcs(); + +#----------------------------------------------------------------------------- + +sub _get_cpan_list_funcs { + return qw( List::Util::first ), + map { 'List::MoreUtils::'.$_ } _get_list_moreutils_funcs(); +} + +#----------------------------------------------------------------------------- + +sub _get_list_moreutils_funcs { + return qw(any all none notall true false firstidx first_index + lastidx last_index insert_after insert_after_string); +} + +#----------------------------------------------------------------------------- + +sub _is_topic { + my $elem = shift; + return defined $elem + && $elem->isa('PPI::Token::Magic') + && $elem->content() eq q{$_}; ##no critic (InterpolationOfMetachars) +} + + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Don't modify $_ in list functions}; ##no critic (InterpolationOfMetachars) +Readonly::Scalar my $EXPL => [ 114 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'list_funcs', + description => 'The base set of functions to check.', + default_string => join ($SPACE, @BUILTIN_LIST_FUNCS, @CPAN_LIST_FUNCS ), + behavior => 'string list', + }, + { + name => 'add_list_funcs', + description => 'The set of functions to check, in addition to those given in list_funcs.', + default_string => $EMPTY, + behavior => 'string list', + }, + ); +} + +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw(core bugs pbp certrule ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub initialize_if_enabled { + my ($self, $config) = @_; + + $self->{_all_list_funcs} = { + hashify keys %{ $self->{_list_funcs} }, keys %{ $self->{_add_list_funcs} } + }; + + return $TRUE; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, $doc) = @_; + + # Is this element a list function? + return if not $self->{_all_list_funcs}->{$elem}; + return if not is_function_call($elem); + + # Only the block form of list functions can be analyzed. + return if not my $first_arg = first_arg( $elem ); + return if not $first_arg->isa('PPI::Structure::Block'); + return if not $self->_has_topic_side_effect( $first_arg, $doc ); + + # Must be a violation + return $self->violation( $DESC, $EXPL, $elem ); +} + +#----------------------------------------------------------------------------- + +sub _has_topic_side_effect { + my ( $self, $node, $doc ) = @_; + + # Search through all significant elements in the block, + # testing each element to see if it mutates the topic. + my $tokens = $node->find( 'PPI::Token' ) || []; + for my $elem ( @{ $tokens } ) { + next if not $elem->significant(); + return 1 if _is_assignment_to_topic( $elem ); + return 1 if $self->_is_topic_mutating_regex( $elem, $doc ); + return 1 if _is_topic_mutating_func( $elem ); + return 1 if _is_topic_mutating_substr( $elem ); + } + return; +} + +#----------------------------------------------------------------------------- + +sub _is_assignment_to_topic { + my $elem = shift; + return if not _is_topic( $elem ); + + my $sib = $elem->snext_sibling(); + if ($sib && $sib->isa('PPI::Token::Operator')) { + return 1 if _is_assignment_operator( $sib ); + } + + my $psib = $elem->sprevious_sibling(); + if ($psib && $psib->isa('PPI::Token::Operator')) { + return 1 if _is_increment_operator( $psib ); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _is_topic_mutating_regex { + my ( $self, $elem, $doc ) = @_; + return if ! ( $elem->isa('PPI::Token::Regexp::Substitute') + || $elem->isa('PPI::Token::Regexp::Transliterate') ); + + # Exempt PPI::Token::Regexp::Transliterate objects IF the replacement + # string is empty AND neither the /d or /s flags are specified, OR the + # replacement string equals the match string AND neither the /c or /s + # flags are specified. RT 44515. + # + # NOTE that, at least as of 5.14.2, tr/// does _not_ participate in the + # 'use re /modifiers' mechanism. And a good thing, too, since the + # modifiers that _are_ common (/s and /d) mean something completely + # different in tr///. + if ( $elem->isa( 'PPI::Token::Regexp::Transliterate') ) { + my $subs = $elem->get_substitute_string(); + my %mods = $elem->get_modifiers(); + $mods{r} and return; # Introduced in Perl 5.13.7 + if ( $EMPTY eq $subs ) { + $mods{d} or $mods{s} or return; + } elsif ( $elem->get_match_string() eq $subs ) { + $mods{c} or $mods{s} or return; + } + } + + # As of 5.13.2, the substitute built-in supports the /r modifier, which + # causes the operation to return the modified string and leave the + # original unmodified. This does not parse under earlier Perls, so there + # is no version check. + + if ( $elem->isa( 'PPI::Token::Regexp::Substitute' ) ) { + my $re = $doc->ppix_regexp_from_element( $elem ) + or return; + $re->modifier_asserted( 'r' ) + and return; + } + + # If the previous sibling does not exist, then + # the regex implicitly binds to $_ + my $prevsib = $elem->sprevious_sibling; + return 1 if not $prevsib; + + # If the previous sibling does exist, then it + # should be a binding operator. + return 1 if not _is_binding_operator( $prevsib ); + + # Check if the sibling before the biding operator + # is explicitly set to $_ + my $bound_to = $prevsib->sprevious_sibling; + return _is_topic( $bound_to ); +} + +#----------------------------------------------------------------------------- + +sub _is_topic_mutating_func { + my $elem = shift; + return if not $elem->isa('PPI::Token::Word'); + my @mutator_funcs = qw(chop chomp undef); + return if not any { $elem->content() eq $_ } @mutator_funcs; + return if not is_function_call( $elem ); + + # If these functions have no argument, + # they default to mutating $_ + my $first_arg = first_arg( $elem ); + if (not defined $first_arg) { + # undef does not default to $_, unlike the others + return if $elem->content() eq 'undef'; + return 1; + } + return _is_topic( $first_arg ); +} + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $MUTATING_SUBSTR_ARG_COUNT => 4; + +sub _is_topic_mutating_substr { + my $elem = shift; + return if $elem->content() ne 'substr'; + return if not is_function_call( $elem ); + + # check and see if the first arg is $_ + my @args = parse_arg_list( $elem ); + return @args >= $MUTATING_SUBSTR_ARG_COUNT && _is_topic( $args[0]->[0] ); +} + +#----------------------------------------------------------------------------- + +{ + ##no critic(ArgUnpacking) + + my %assignment_ops = hashify qw( + = *= /= += -= %= **= x= .= &= |= ^= &&= ||= <<= >>= //= ++ -- + ); + sub _is_assignment_operator { return exists $assignment_ops{$_[0]} } + + my %increment_ops = hashify qw( ++ -- ); + sub _is_increment_operator { return exists $increment_ops{$_[0]} } + + my %binding_ops = hashify qw( =~ !~ ); + sub _is_binding_operator { return exists $binding_ops{$_[0]} } +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions - Don't modify C<$_> in list functions. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +C, C and other list operators are intended to transform +arrays into other arrays by applying code to the array elements one by +one. For speed, the elements are referenced via a C<$_> alias rather +than copying them. As a consequence, if the code block of the C +or C modify C<$_> in any way, then it is actually modifying the +source array. This IS technically allowed, but those side effects can +be quite surprising, especially when the array being passed is C<@_> +or perhaps C! Instead authors should restrict in-place +array modification to C constructs instead, or +use C. + +=head1 CONFIGURATION + +By default, this policy applies to the following list functions: + + map grep + List::Util qw(first) + List::MoreUtils qw(any all none notall true false firstidx + first_index lastidx last_index insert_after + insert_after_string) + +This list can be overridden the F<.perlcriticrc> file like this: + + [ControlStructures::ProhibitMutatingListFunctions] + list_funcs = map grep List::Util::first + +Or, one can just append to the list like so: + + [ControlStructures::ProhibitMutatingListFunctions] + add_list_funcs = Foo::Bar::listmunge + +=head1 LIMITATIONS + +This policy deliberately does not apply to C or +C. + +Currently, the policy only detects explicit external module usage like +this: + + my @out = List::MoreUtils::any {s/^foo//} @in; + +and not like this: + + use List::MoreUtils qw(any); + my @out = any {s/^foo//} @in; + +This policy looks only for modifications of C<$_>. Other naughtiness +could include modifying C<$a> and C<$b> in C and the like. +That's beyond the scope of this policy. + + +=head1 SEE ALSO + +There is discussion of this policy at +L. + + +=head1 AUTHOR + +Chris Dolan + +Michael Wolf + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : + diff --git a/lib/Perl/Critic/Policy/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.pm b/lib/Perl/Critic/Policy/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.pm new file mode 100644 index 0000000..9ce740c --- /dev/null +++ b/lib/Perl/Critic/Policy/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.pm @@ -0,0 +1,202 @@ +package Perl::Critic::Policy::ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions; + +use 5.006001; +use strict; +use warnings; +use English qw(-no_match_vars); +use Readonly; + +use Perl::Critic::Utils qw< :characters :severities :classification hashify >; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => [99]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return qw< > } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core maintenance pbp ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $token, undef ) = @_; + + return if $token->content() ne 'until' && $token->content() ne 'unless'; + + return if is_hash_key($token); + return if is_subroutine_name($token); + return if is_method_call($token); + return if is_included_module_name($token); + + return + map + { $self->_violation_for_operator( $_, $token ) } + _get_negative_operators( $token ); +} + +#----------------------------------------------------------------------------- + +sub _get_negative_operators { + my ($token) = @_; + + my @operators; + foreach my $element ( _get_condition_elements($token) ) { + if ( $element->isa('PPI::Node') ) { + my $operators = $element->find( \&_is_negative_operator ); + if ($operators) { + push @operators, @{$operators}; + } + } + else { + if ( _is_negative_operator( undef, $element ) ) { + push @operators, $element; + } + } + } + + return @operators; +} + +#----------------------------------------------------------------------------- + +sub _get_condition_elements { + my ($token) = @_; + + my $statement = $token->statement(); + return if not $statement; + + if ($statement->isa('PPI::Statement::Compound')) { + my $condition = $token->snext_sibling(); + + return if not $condition; + return if not $condition->isa('PPI::Structure::Condition'); + + return ( $condition ); + } + + my @condition_elements; + my $element = $token; + while ( + $element = $element->snext_sibling() + and $element->content() ne $SCOLON + ) { + push @condition_elements, $element; + } + + return @condition_elements; +} + +#----------------------------------------------------------------------------- + +Readonly::Hash my %NEGATIVE_OPERATORS => hashify( + qw/ + ! not + !~ ne != + < > <= >= <=> + lt gt le ge cmp + / +); + +sub _is_negative_operator { + my (undef, $element) = @_; + + return + $element->isa('PPI::Token::Operator') + && $NEGATIVE_OPERATORS{$element}; +} + +#----------------------------------------------------------------------------- + +sub _violation_for_operator { + my ($self, $operator, $control_structure) = @_; + + return + $self->violation( + qq, + $EXPL, + $control_structure, + ); +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Policy::ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions - Don't use operators like C, C, and C within C and C. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + + until ($foo ne 'blah') { #not ok + ... + } + + while ($foo eq 'blah') { #ok + ... + } + +A number of people have problems figuring out the meaning of doubly +negated expressions. C and C are both negative +constructs, so any negative (e.g. C) or reversible operators (e.g. +C) included in their conditional expressions are double negations. +Conway considers the following operators to be difficult to understand +within C and C: + + ! not + !~ ne != + < > <= >= <=> + lt gt le ge cmp + + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Elliot Shank C<< >> + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ControlStructures/ProhibitPostfixControls.pm b/lib/Perl/Critic/Policy/ControlStructures/ProhibitPostfixControls.pm new file mode 100644 index 0000000..efafab7 --- /dev/null +++ b/lib/Perl/Critic/Policy/ControlStructures/ProhibitPostfixControls.pm @@ -0,0 +1,207 @@ +package Perl::Critic::Policy::ControlStructures::ProhibitPostfixControls; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :characters :severities :data_conversion :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Hash my %PAGES_OF => ( + if => [ 93, 94 ], + unless => [ 96, 97 ], + until => [ 96, 97 ], + for => [ 96 ], + foreach => [ 96 ], + while => [ 96 ], + when => q, +); + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'allow', + description => 'The permitted postfix controls.', + default_string => $EMPTY, + behavior => 'enumeration', + enumeration_values => [ sort keys %PAGES_OF ], + enumeration_allow_multiple_values => 1, + }, + { + name => 'flowcontrol', + description => 'The exempt flow control functions.', + default_string => 'carp cluck confess croak die exit goto warn', + behavior => 'string list', + }, + ); +} + +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core pbp cosmetic) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + my $expl = $PAGES_OF{$elem}; + return if not $expl; + + return if is_hash_key($elem); + return if is_method_call($elem); + return if is_subroutine_name($elem); + return if is_included_module_name($elem); + return if is_package_declaration($elem); + + # Skip controls that are allowed + return if exists $self->{_allow}->{ $elem->content() }; + + # Skip Compound variety (these are good) + my $stmnt = $elem->statement(); + return if not $stmnt; + return if $stmnt->isa('PPI::Statement::Compound'); + return if $stmnt->isa('PPI::Statement::When'); + + # Handle special cases + my $content = $elem->content(); + if ($content eq 'if' or $content eq 'when') { + # Postfix 'if' allowed with loop breaks, or other + # flow-controls like 'die', 'warn', and 'croak' + return if $stmnt->isa('PPI::Statement::Break'); + return if defined $self->{_flowcontrol}{ $stmnt->schild(0)->content() }; + } + + # If we get here, it must be postfix. + my $desc = qq{Postfix control "$content" used}; + return $self->violation($desc, $expl, $elem); +} + +1; + +__END__ + +=pod + +=for stopwords flowcontrol brian foy + +=head1 NAME + +Perl::Critic::Policy::ControlStructures::ProhibitPostfixControls - Write C instead of C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway discourages using postfix control structures (C, C, +C, C, C, C) because they hide control +flow. The C and C controls are particularly evil +because they lead to double-negatives that are hard to comprehend. +The only tolerable usage of a postfix C/C is when it follows +a loop break such as C, C, C, or C. + + do_something() if $condition; # not ok + if ($condition) { do_something() } # ok + + do_something() while $condition; # not ok + while ($condition) { do_something() } # ok + + do_something() unless $condition; # not ok + do_something() unless ! $condition; # really bad + if (! $condition) { do_something() } # ok + + do_something() until $condition; # not ok + do_something() until ! $condition; # really bad + while (! $condition) { do_something() } # ok + + do_something($_) for @list; # not ok + + LOOP: + for my $n (0..100) { + next if $condition; # ok + last LOOP if $other_condition; # also ok + + next when m< 0 \z >xms; # fine too + } + + +=head1 CONFIGURATION + +A set of constructs to be ignored by this policy can specified by +giving a value for 'allow' of a string of space-delimited keywords: +C, C, C, C, C, and/or C. An +example of specifying allowed flow-control structures in a +F<.perlcriticrc> file: + + [ControlStructures::ProhibitPostfixControls] + allow = for if until + +By default, all postfix control keywords are prohibited. + +The set of flow-control functions that are exempt from the restriction +can also be configured with the 'flowcontrol' directive in your +F<.perlcriticrc> file: + + [ControlStructures::ProhibitPostfixControls] + flowcontrol = warn die carp croak cluck confess goto exit + +This is useful if you're using additional modules that add things like +C or C. + + +=head1 NOTES + +The C, C, and C functions are frequently used as +flow-controls just like C or C. So this Policy does +permit you to use a postfix C when the statement begins with one +of those functions. It is also pretty common to use C, C, +and C with a postfix C, so those are allowed too. + +The C keyword was added to the language after Perl Best +Practices was written. This policy treats C the same way it +does C, i.e. it's allowed after flow-control constructs. Thanks +to brian d foy for the +L. + + +=head1 BUGS + +Look for the C case and change the explanation to point +to page 123 when it is found. RT #37905. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ControlStructures/ProhibitUnlessBlocks.pm b/lib/Perl/Critic/Policy/ControlStructures/ProhibitUnlessBlocks.pm new file mode 100644 index 0000000..ad19c9e --- /dev/null +++ b/lib/Perl/Critic/Policy/ControlStructures/ProhibitUnlessBlocks.pm @@ -0,0 +1,98 @@ +package Perl::Critic::Policy::ControlStructures::ProhibitUnlessBlocks; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{"unless" block used}; +Readonly::Scalar my $EXPL => [ 97 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core pbp cosmetic) } +sub applies_to { return 'PPI::Statement::Compound' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + if ( $elem->first_element() eq 'unless' ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ControlStructures::ProhibitUnlessBlocks - Write C instead of C. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway discourages using C because it leads to +double-negatives that are hard to understand. Instead, reverse the +logic and use C. + + unless($condition) { do_something() } #not ok + unless(! $no_flag) { do_something() } #really bad + if( ! $condition) { do_something() } #ok + +This Policy only covers the block-form of C. For the postfix +variety, see C. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ControlStructures/ProhibitUnreachableCode.pm b/lib/Perl/Critic/Policy/ControlStructures/ProhibitUnreachableCode.pm new file mode 100644 index 0000000..5911369 --- /dev/null +++ b/lib/Perl/Critic/Policy/ControlStructures/ProhibitUnreachableCode.pm @@ -0,0 +1,229 @@ +package Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :data_conversion :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +Readonly::Array my @TERMINALS => qw( die exit croak confess ); +Readonly::Hash my %TERMINALS => hashify( @TERMINALS ); + +Readonly::Array my @CONDITIONALS => qw( if unless foreach while until for ); +Readonly::Hash my %CONDITIONALS => hashify( @CONDITIONALS ); + +Readonly::Array my @OPERATORS => qw( && || // and or err ? ); +Readonly::Hash my %OPERATORS => hashify( @OPERATORS ); + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Unreachable code}; +Readonly::Scalar my $EXPL => q{Consider removing it}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core bugs certrec ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + my $statement = $elem->statement(); + return if not $statement; + + # We check to see if this is an interesting token before calling + # is_function_call(). This weeds out most candidate tokens and + # prevents us from having to make an expensive function call. + + return if ( !exists $TERMINALS{$elem} ) && + ( !$statement->isa('PPI::Statement::Break') ); + + return if not is_function_call($elem); + + # Scan the enclosing statement for conditional keywords or logical + # operators. If any are found, then this the following statements + # could _potentially_ be executed, so this policy is satisfied. + + # NOTE: When the first operand in an boolean expression is + # C or C, etc., the second operand is technically + # unreachable. But this policy doesn't catch that situation. + + for my $child ( $statement->schildren() ) { + return if $child->isa('PPI::Token::Operator') && exists $OPERATORS{$child}; + return if $child->isa('PPI::Token::Word') && exists $CONDITIONALS{$child}; + } + + return $self->_gather_violations($statement); +} + +sub _gather_violations { + my ($self, $statement) = @_; + + # If we get here, then the statement contained an unconditional + # die or exit or return. Then all the subsequent sibling + # statements are unreachable, except for those that have labels, + # which could be reached from anywhere using C. Subroutine + # declarations are also exempt for the same reason. "use" and + # "our" statements are exempt because they happen at compile time. + + my @violations = (); + while ( $statement = $statement->snext_sibling() ) { + my @children = $statement->schildren(); + last if @children && $children[0]->isa('PPI::Token::Label'); + next if $statement->isa('PPI::Statement::Sub'); + next if $statement->isa('PPI::Statement::End'); + next if $statement->isa('PPI::Statement::Data'); + next if $statement->isa('PPI::Statement::Package'); + + next if $statement->isa('PPI::Statement::Include') && + $statement->type() ne 'require'; + + next if $statement->isa('PPI::Statement::Variable') && + $statement->type() eq 'our'; + + push @violations, $self->violation( $DESC, $EXPL, $statement ); + } + + return @violations; +} + +1; + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode - Don't write code after an unconditional C. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +This policy prohibits code following a statement which unconditionally +alters the program flow. This includes calls to C, C, +C, C, C and C. Due to common usage, +C and C from L are also included. + +Code is reachable if any of the following conditions are true: + +=over + +=item * Flow-altering statement has a conditional attached to it + +=item * Statement is on the right side of an operator C<&&>, C<||>, C, C, C, or C. + +=item * Code is prefixed with a label (can potentially be reached via C) + +=item * Code is a subroutine + +=back + +=head1 EXAMPLES + + # not ok + + exit; + print "123\n"; + + # ok + + exit if !$xyz; + print "123\n"; + + # not ok + + for ( 1 .. 10 ) { + next; + print 1; + } + + # ok + + for ( 1 .. 10 ) { + next if $_ == 5; + print 1; + } + + # not ok + + sub foo { + my $bar = shift; + return; + print 1; + } + + # ok + + sub foo { + my $bar = shift; + return if $bar->baz(); + print 1; + } + + + # not ok + + die; + print "123\n"; + + # ok + + die; + LABEL: print "123\n"; + + # not ok + + croak; + do_something(); + + # ok + + croak; + sub do_something {} + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Peter Guzis + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Peter Guzis. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ControlStructures/ProhibitUntilBlocks.pm b/lib/Perl/Critic/Policy/ControlStructures/ProhibitUntilBlocks.pm new file mode 100644 index 0000000..d36abc1 --- /dev/null +++ b/lib/Perl/Critic/Policy/ControlStructures/ProhibitUntilBlocks.pm @@ -0,0 +1,97 @@ +package Perl::Critic::Policy::ControlStructures::ProhibitUntilBlocks; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{"until" block used}; +Readonly::Scalar my $EXPL => [ 97 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core pbp cosmetic) } +sub applies_to { return 'PPI::Statement' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + if ( $elem->first_element() eq 'until' ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ControlStructures::ProhibitUntilBlocks - Write C instead of C. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway discourages using C because it leads to double-negatives +that are hard to understand. Instead, reverse the logic and use +C. + + until($condition) { do_something() } #not ok + until(! $no_flag) { do_something() } #really bad + while( ! $condition) { do_something() } #ok + +This Policy only covers the block-form of C. For the postfix +variety, see C. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ControlStructures/ProhibitYadaOperator.pm b/lib/Perl/Critic/Policy/ControlStructures/ProhibitYadaOperator.pm new file mode 100644 index 0000000..523002b --- /dev/null +++ b/lib/Perl/Critic/Policy/ControlStructures/ProhibitYadaOperator.pm @@ -0,0 +1,101 @@ +package Perl::Critic::Policy::ControlStructures::ProhibitYadaOperator; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :characters :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{yada operator (...) used}; +Readonly::Scalar my $EXPL => q{The yada operator is a placeholder for code you have not yet written.}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core pbp maintenance ) } +sub applies_to { return 'PPI::Token::Operator' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + if ( _is_yada( $elem ) ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +sub _is_yada { + my ( $elem ) = @_; + + return if $elem ne '...'; + #return if not defined $elem->statement; + + # if there is something significant on both sides of the element it's + # probably the three dot range operator + return if ($elem->snext_sibling and $elem->sprevious_sibling); + + return 1; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords yada Berndt + +=head1 NAME + +Perl::Critic::Policy::ControlStructures::ProhibitYadaOperator - Never use C<...> in production code. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +The yada operator C<...> is not something you'd want in production +code because it will throw an exception when executed. However, it is +perfectly useful in less critical environments as a placeholder for code +not yet implemented. + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + +=head1 AUTHOR + +Alan Berndt + +=head1 COPYRIGHT + +Copyright (c) 2015-2017 Alan Berndt. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Documentation/PodSpelling.pm b/lib/Perl/Critic/Policy/Documentation/PodSpelling.pm new file mode 100644 index 0000000..0e13317 --- /dev/null +++ b/lib/Perl/Critic/Policy/Documentation/PodSpelling.pm @@ -0,0 +1,407 @@ +package Perl::Critic::Policy::Documentation::PodSpelling; + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); +use Readonly; + +use File::Spec; +use File::Temp; +use IO::String qw< >; +use List::MoreUtils qw(uniq); +use Pod::Spell qw< >; +use Text::ParseWords qw< >; + +use Perl::Critic::Utils qw{ + :characters + :booleans + :severities + words_from_string +}; +use Perl::Critic::Exception::Fatal::Generic qw{ throw_generic }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $POD_RX => qr{\A = (?: for|begin|end ) }xms; +Readonly::Scalar my $DESC => q{Check the spelling in your POD}; +Readonly::Scalar my $EXPL => [148]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'spell_command', + description => 'The command to invoke to check spelling.', + default_string => 'aspell list', + behavior => 'string', + }, + { + name => 'stop_words', + description => 'The words to not consider as misspelled.', + default_string => $EMPTY, + behavior => 'string list', + }, + { + name => 'stop_words_file', + description => 'A file containing words to not consider as misspelled.', + default_string => $EMPTY, + behavior => 'string', + }, + ); +} + +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw( core cosmetic pbp ) } +sub applies_to { return 'PPI::Document' } + +#----------------------------------------------------------------------------- + +my $got_sigpipe = 0; +sub got_sigpipe { + return $got_sigpipe; +} + +#----------------------------------------------------------------------------- + +sub initialize_if_enabled { + my ( $self, $config ) = @_; + + eval { require File::Which; 1 } or return $FALSE; + + return $FALSE if not $self->_derive_spell_command_line(); + + my $test_code = <<'END_TEST_CODE'; +;pod + +;head1 Test The Spell Command + +;cut +END_TEST_CODE + $test_code =~ s/^;/=/msx; + return $FALSE if not $self->_run_spell_command($test_code); + + $self->_load_stop_words_file(); + + return $TRUE; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + + my $code = $doc->serialize(); + + my $words = $self->_run_spell_command($code); + + return if not $words; # error running spell command + + return if not @{$words}; # no problems found + + return $self->violation( "$DESC: @{$words}", $EXPL, $doc ); +} + +#----------------------------------------------------------------------------- + +sub _derive_spell_command_line { + my ($self) = @_; + + my @words = Text::ParseWords::shellwords($self->_get_spell_command()); + if (!@words) { + return; + } + if (! File::Spec->file_name_is_absolute($words[0])) { + $words[0] = File::Which::which($words[0]); + } + if (! $words[0] || ! -x $words[0]) { + return; + } + $self->_set_spell_command_line(\@words); + + return $self->_get_spell_command_line(); +} + +#----------------------------------------------------------------------------- + +sub _get_spell_command { + my ( $self ) = @_; + + return $self->{_spell_command}; +} + +#----------------------------------------------------------------------------- + +sub _get_spell_command_line { + my ( $self ) = @_; + + return $self->{_spell_command_line}; +} + +sub _set_spell_command_line { + my ( $self, $spell_command_line ) = @_; + + $self->{_spell_command_line} = $spell_command_line; + + return; +} + +#----------------------------------------------------------------------------- + +sub _get_stop_words { + my ( $self ) = @_; + + return $self->{_stop_words}; +} + +sub _set_stop_words { + my ( $self, $stop_words ) = @_; + + $self->{_stop_words} = $stop_words; + + return; +} + +#----------------------------------------------------------------------------- + +sub _get_stop_words_file { + my ( $self ) = @_; + + return $self->{_stop_words_file}; +} + +#----------------------------------------------------------------------------- + +sub _run_spell_command { + my ($self, $code) = @_; + + my $infh = IO::String->new( $code ); + + my $outfh = File::Temp->new(); + + my $outfile = $outfh->filename(); + my @words; + + local $EVAL_ERROR = undef; + + eval { + # temporarily add our special wordlist to this annoying global + local %Pod::Wordlist::Wordlist = ## no critic (ProhibitPackageVars) + %{ $self->_get_stop_words() }; + + Pod::Spell->new()->parse_from_filehandle($infh, $outfh); + close $outfh or throw_generic "Failed to close pod temp file: $OS_ERROR"; + return if not -s $outfile; # Bail out if no words to spellcheck + + # run spell command and fetch output + local $SIG{PIPE} = sub { $got_sigpipe = 1; }; + my $command_line = join $SPACE, @{$self->_get_spell_command_line()}; + open my $aspell_out_fh, q{-|}, "$command_line < $outfile" ## Is this portable?? + or throw_generic "Failed to open handle to spelling program: $OS_ERROR"; + + @words = uniq( <$aspell_out_fh> ); + close $aspell_out_fh + or throw_generic "Failed to close handle to spelling program: $OS_ERROR"; + + chomp @words; + + # Why is this extra step needed??? + @words = grep { not exists $Pod::Wordlist::Wordlist{$_} } @words; ## no critic (ProhibitPackageVars) + 1; + } + or do { + # Eat anything we did ourselves above, propagate anything else. + if ( + $EVAL_ERROR + and not ref Perl::Critic::Exception::Fatal::Generic->caught() + ) { + ref $EVAL_ERROR ? $EVAL_ERROR->rethrow() : die $EVAL_ERROR; ## no critic (ErrorHandling::RequireCarping) + } + + return; + }; + + return [ @words ]; +} + +#----------------------------------------------------------------------------- + +sub _load_stop_words_file { + my ($self) = @_; + + my %stop_words = %{ $self->_get_stop_words() }; + + my $file_name = $self->_get_stop_words_file() or return; + + open my $handle, '<', $file_name + or do { warn qq; return; }; + + while ( my $line = <$handle> ) { + if ( my $word = _word_from_line($line) ) { + $stop_words{$word} = 1; + } + } + + close $handle or warn qq; + + $self->_set_stop_words(\%stop_words); + + return; +} + +sub _word_from_line { + my ($line) = @_; + + $line =~ s< [#] .* \z ><>xms; + $line =~ s< \s+ \z ><>xms; + $line =~ s< \A \s+ ><>xms; + + return $line; +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords foobie foobie-bletch Hmm stopwords + +=head1 NAME + +Perl::Critic::Policy::Documentation::PodSpelling - Check your spelling. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Did you write the documentation? Check. + +Did you document all of the public methods? Check. + +Is your documentation readable? Hmm... + +Ideally, we'd like Perl::Critic to tell you when your documentation is +inadequate. That's hard to code, though. So, inspired by +L, this module checks the spelling of +your POD. It does this by pulling the prose out of the code and +passing it to an external spell checker. It skips over words you +flagged to ignore. If the spell checker returns any misspelled words, +this policy emits a violation. + +If anything else goes wrong -- we can't locate the spell checking program or +(gasp!) your module has no POD -- then this policy passes. + +To add exceptions on a module-by-module basis, add "stopwords" as +described in L. For example: + + =for stopwords gibbles + + =head1 Gibble::Manip -- manipulate your gibbles + + =cut + + +=head1 CONFIGURATION + +This policy can be configured to tell which spell checker to use or to +set a global list of spelling exceptions. To do this, put entries in +a F<.perlcriticrc> file like this: + + [Documentation::PodSpelling] + spell_command = aspell list + stop_words = gibbles foobar + stop_words_file = some/path/with/stop/words.txt + +The default spell command is C and it is interpreted as a +shell command. We parse the individual arguments via +L so feel free to use quotes around +your arguments. If the executable path is an absolute file name, it +is used as-is. If it is a relative file name, we employ +L to convert it to an absolute path via the +C environment variable. As described in Pod::Spell and +Test::Spelling, the spell checker must accept text on STDIN and print +misspelled words one per line on STDOUT. + +You can specify global stop words via the C and +C options. The former is simply split up on +whitespace. The latter is looked at line by line, with anything after +an octothorp ("#") removed and then leading and trailing whitespace +removed. Silly example valid file contents: + + # It's a comment! + + foo + arglbargl # Some other comment. + bar + +The values from C and C are merged +together into a single list of exemptions. + + +=head1 NOTES + +A spell checking program is not included with Perl::Critic. + +The results of failures for this policy can be confusing when F +complains about words containing punctuation such as hyphens and apostrophes. +In this situation F will often only emit part of the word that it +thinks is misspelled. For example, if you ask F to check +"foobie-bletch", the output only complains about "foobie". Unfortunately, +you'll have to look through your POD to figure out what the real word that +F is complaining about is. One thing to try is looking at the output +of C<< perl -MPod::Spell -e 'print +Pod::Spell->new()->parse_from_file("lib/Your/Module.pm")' >> to see what is +actually being checked for spelling. + + +=head1 PREREQUISITES + +This policy will disable itself if L is not +available. + + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Documentation/RequirePackageMatchesPodName.pm b/lib/Perl/Critic/Policy/Documentation/RequirePackageMatchesPodName.pm new file mode 100644 index 0000000..6f3389a --- /dev/null +++ b/lib/Perl/Critic/Policy/Documentation/RequirePackageMatchesPodName.pm @@ -0,0 +1,125 @@ +package Perl::Critic::Policy::Documentation::RequirePackageMatchesPodName; + +use 5.006001; + +use strict; +use warnings; + +use Readonly; +use English qw{ -no_match_vars }; +use Perl::Critic::Utils qw{ :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $PKG_RX => qr{ [[:alpha:]](?:[\w:\']*\w)? }xms; +Readonly::Scalar my $DESC => + q{Pod NAME on line %d does not match the package declaration}; +Readonly::Scalar my $EXPL => q{}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw( core cosmetic ) } +sub applies_to { return 'PPI::Document' } + +#----------------------------------------------------------------------------- + +sub prepare_to_scan_document { + my ( $self, $document ) = @_; + + # idea: force NAME to match the file name in programs? + return $document->is_module(); # mismatch is normal in program entry points +} + +sub violates { + my ( $self, $elem, $doc ) = @_; + + # No POD means no violation + my $pods_ref = $doc->find('PPI::Token::Pod'); + return if !$pods_ref; + + for my $pod (@{$pods_ref}) { + my $content = $pod->content; + + next if $content !~ m{^=head1 [ \t]+ NAME [ \t]*$ \s*}cgxms; + + my $line_number = $pod->line_number() + ( + substr( $content, 0, $LAST_MATCH_START[0] + 1 ) =~ tr/\n/\n/ ); + + my ($pod_pkg) = $content =~ m{\G (\S+) }cgxms; + + if (!$pod_pkg) { + return $self->violation( sprintf( $DESC, $line_number ), + q{Empty name declaration}, $pod ); + } + + # idea: worry about POD escapes? + $pod_pkg =~ s{\A [BCIL]<(.*)>\z}{$1}gxms; # unwrap + $pod_pkg =~ s{\'}{::}gxms; # perl4 -> perl5 + + foreach my $stmt ( @{ $doc->find('PPI::Statement::Package') || [] } ) { + my $pkg = $stmt->namespace(); + $pkg =~ s{\'}{::}gxms; + return if $pkg eq $pod_pkg; + } + + return $self->violation( sprintf( $DESC, $line_number ), + $EXPL, $pod ); + } + + return; # no NAME section found +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Documentation::RequirePackageMatchesPodName - The C<=head1 NAME> section should match the package. + + +=head1 AFFILIATION + +This Policy is part of the core L distribution. + + +=head1 DESCRIPTION + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2008-2011 Chris Dolan + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Documentation/RequirePodAtEnd.pm b/lib/Perl/Critic/Policy/Documentation/RequirePodAtEnd.pm new file mode 100644 index 0000000..4a616d8 --- /dev/null +++ b/lib/Perl/Critic/Policy/Documentation/RequirePodAtEnd.pm @@ -0,0 +1,127 @@ +package Perl::Critic::Policy::Documentation::RequirePodAtEnd; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use List::Util qw(first); + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $POD_RX => qr{\A = (?: for|begin|end ) }xms; +Readonly::Scalar my $DESC => q{POD before __END__}; +Readonly::Scalar my $EXPL => [139, 140]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw( core cosmetic pbp ) } +sub applies_to { return 'PPI::Document' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + + # No POD means no violation + my $pods_ref = $doc->find('PPI::Token::Pod'); + return if !$pods_ref; + + # Look for first POD tag that isn't =for, =begin, or =end + my $pod = first { $_ !~ $POD_RX} @{ $pods_ref }; + return if !$pod; + + my $end = $doc->find_first('PPI::Statement::End'); + if ($end) { # No __END__ means definite violation + my $pod_loc = $pod->location(); + my $end_loc = $end->location(); + if ( $pod_loc->[0] > $end_loc->[0] ) { + # POD is after __END__, or relative position couldn't be determined + return; + } + } + + return $self->violation( $DESC, $EXPL, $pod ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Documentation::RequirePodAtEnd - All POD should be after C<__END__>. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Perl stops processing code when it sees an C<__END__> statement. So, +to save processing time, it's faster to put documentation after the +C<__END__>. Also, writing all the POD in one place usually leads to a +more cohesive document, rather than being forced to follow the layout +of your code. This policy issues violations if any POD is found +before an C<__END__>. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 NOTES + +Some folks like to use C<=for>, and C<=begin>, and C<=end> tags to +create block comments in-line with their code. Since those tags +aren't usually part of the documentation, this Policy does allows them +to appear before the C<__END__> statement. + + =begin comments + + frobulate() + Accepts: A list of things to frobulate + Returns: True if successful + + =end comments + + sub frobulate { ... } + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Documentation/RequirePodSections.pm b/lib/Perl/Critic/Policy/Documentation/RequirePodSections.pm new file mode 100644 index 0000000..3580952 --- /dev/null +++ b/lib/Perl/Critic/Policy/Documentation/RequirePodSections.pm @@ -0,0 +1,494 @@ +package Perl::Critic::Policy::Documentation::RequirePodSections; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :booleans :characters :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => [133, 138]; + +Readonly::Scalar my $BOOK => 'book'; +Readonly::Scalar my $BOOK_FIRST_EDITION => 'book_first_edition'; +Readonly::Scalar my $MODULE_STARTER_PBP => 'module_starter_pbp'; +Readonly::Scalar my $M_S_PBP_0_0_3 => 'module_starter_pbp_0_0_3'; + +Readonly::Scalar my $DEFAULT_SOURCE => $BOOK_FIRST_EDITION; + +Readonly::Hash my %SOURCE_TRANSLATION => ( + $BOOK => $BOOK_FIRST_EDITION, + $BOOK_FIRST_EDITION => $BOOK_FIRST_EDITION, + $MODULE_STARTER_PBP => $M_S_PBP_0_0_3, + $M_S_PBP_0_0_3 => $M_S_PBP_0_0_3, +); + +Readonly::Scalar my $EN_AU => 'en_AU'; +Readonly::Scalar my $EN_US => 'en_US'; +Readonly::Scalar my $ORIGINAL_MODULE_VERSION => 'original'; + +Readonly::Hash my %SOURCE_DEFAULT_LANGUAGE => ( + $BOOK_FIRST_EDITION => $ORIGINAL_MODULE_VERSION, + $M_S_PBP_0_0_3 => $EN_AU, +); + +Readonly::Scalar my $BOOK_FIRST_EDITION_US_LIB_SECTIONS => + [ + 'NAME', + 'VERSION', + 'SYNOPSIS', + 'DESCRIPTION', + 'SUBROUTINES/METHODS', + 'DIAGNOSTICS', + 'CONFIGURATION AND ENVIRONMENT', + 'DEPENDENCIES', + 'INCOMPATIBILITIES', + 'BUGS AND LIMITATIONS', + 'AUTHOR', + 'LICENSE AND COPYRIGHT', + ]; + +Readonly::Hash my %DEFAULT_LIB_SECTIONS => ( + $BOOK_FIRST_EDITION => { + $ORIGINAL_MODULE_VERSION => $BOOK_FIRST_EDITION_US_LIB_SECTIONS, + $EN_AU => [ + 'NAME', + 'VERSION', + 'SYNOPSIS', + 'DESCRIPTION', + 'SUBROUTINES/METHODS', + 'DIAGNOSTICS', + 'CONFIGURATION AND ENVIRONMENT', + 'DEPENDENCIES', + 'INCOMPATIBILITIES', + 'BUGS AND LIMITATIONS', + 'AUTHOR', + 'LICENCE AND COPYRIGHT', + ], + $EN_US => $BOOK_FIRST_EDITION_US_LIB_SECTIONS, + }, + $M_S_PBP_0_0_3 => { + $EN_AU => [ + 'NAME', + 'VERSION', + 'SYNOPSIS', + 'DESCRIPTION', + 'INTERFACE', + 'DIAGNOSTICS', + 'CONFIGURATION AND ENVIRONMENT', + 'DEPENDENCIES', + 'INCOMPATIBILITIES', + 'BUGS AND LIMITATIONS', + 'AUTHOR', + 'LICENCE AND COPYRIGHT', + 'DISCLAIMER OF WARRANTY', + ], + $EN_US => [ + 'NAME', + 'VERSION', + 'SYNOPSIS', + 'DESCRIPTION', + 'INTERFACE', + 'DIAGNOSTICS', + 'CONFIGURATION AND ENVIRONMENT', + 'DEPENDENCIES', + 'INCOMPATIBILITIES', + 'BUGS AND LIMITATIONS', + 'AUTHOR', + 'LICENSE AND COPYRIGHT', + 'DISCLAIMER OF WARRANTY' + ], + }, +); + +Readonly::Hash my %DEFAULT_SCRIPT_SECTIONS => ( + $BOOK_FIRST_EDITION => { + $ORIGINAL_MODULE_VERSION => [ + 'NAME', + 'USAGE', + 'DESCRIPTION', + 'REQUIRED ARGUMENTS', + 'OPTIONS', + 'DIAGNOSTICS', + 'EXIT STATUS', + 'CONFIGURATION', + 'DEPENDENCIES', + 'INCOMPATIBILITIES', + 'BUGS AND LIMITATIONS', + 'AUTHOR', + 'LICENSE AND COPYRIGHT', + ], + $EN_AU => [ + 'NAME', + 'VERSION', + 'USAGE', + 'REQUIRED ARGUMENTS', + 'OPTIONS', + 'DESCRIPTION', + 'DIAGNOSTICS', + 'CONFIGURATION AND ENVIRONMENT', + 'DEPENDENCIES', + 'INCOMPATIBILITIES', + 'BUGS AND LIMITATIONS', + 'AUTHOR', + 'LICENCE AND COPYRIGHT', + ], + $EN_US => [ + 'NAME', + 'VERSION', + 'USAGE', + 'REQUIRED ARGUMENTS', + 'OPTIONS', + 'DESCRIPTION', + 'DIAGNOSTICS', + 'CONFIGURATION AND ENVIRONMENT', + 'DEPENDENCIES', + 'INCOMPATIBILITIES', + 'BUGS AND LIMITATIONS', + 'AUTHOR', + 'LICENSE AND COPYRIGHT', + ], + }, + $M_S_PBP_0_0_3 => { + $EN_AU => [ + 'NAME', + 'VERSION', + 'USAGE', + 'REQUIRED ARGUMENTS', + 'OPTIONS', + 'DESCRIPTION', + 'DIAGNOSTICS', + 'CONFIGURATION AND ENVIRONMENT', + 'DEPENDENCIES', + 'INCOMPATIBILITIES', + 'BUGS AND LIMITATIONS', + 'AUTHOR', + 'LICENCE AND COPYRIGHT', + 'DISCLAIMER OF WARRANTY', + ], + $EN_US => [ + 'NAME', + 'VERSION', + 'USAGE', + 'REQUIRED ARGUMENTS', + 'OPTIONS', + 'DESCRIPTION', + 'DIAGNOSTICS', + 'CONFIGURATION AND ENVIRONMENT', + 'DEPENDENCIES', + 'INCOMPATIBILITIES', + 'BUGS AND LIMITATIONS', + 'AUTHOR', + 'LICENSE AND COPYRIGHT', + 'DISCLAIMER OF WARRANTY', + ], + }, +); + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'lib_sections', + description => 'The sections to require for modules (separated by qr/\s* [|] \s*/xms).', + default_string => $EMPTY, + parser => \&_parse_lib_sections, + }, + { + name => 'script_sections', + description => 'The sections to require for programs (separated by qr/\s* [|] \s*/xms).', + default_string => $EMPTY, + parser => \&_parse_script_sections, + }, + { + name => 'source', + description => 'The origin of sections to use.', + default_string => $DEFAULT_SOURCE, + behavior => 'enumeration', + enumeration_values => [ keys %SOURCE_TRANSLATION ], + }, + { + name => 'language', + description => 'The spelling of sections to use.', + default_string => $EMPTY, + behavior => 'enumeration', + enumeration_values => [ $EN_AU, $EN_US ], + }, + ); +} + +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core pbp maintenance) } +sub applies_to { return 'PPI::Document' } + +#----------------------------------------------------------------------------- + +sub _parse_sections { + my $config_string = shift; + + my @sections = split m{ \s* [|] \s* }xms, $config_string; + + return map { uc } @sections; # Normalize CaSe! +} + +sub _parse_lib_sections { + my ($self, $parameter, $config_string) = @_; + + if ( defined $config_string ) { + $self->{_lib_sections} = [ _parse_sections( $config_string ) ]; + } + + return; +} + +sub _parse_script_sections { + my ($self, $parameter, $config_string) = @_; + + if ( defined $config_string ) { + $self->{_script_sections} = [ _parse_sections( $config_string ) ]; + } + + return; +} + +#----------------------------------------------------------------------------- + +sub initialize_if_enabled { + my ($self, $config) = @_; + + my $source = $self->{_source}; + if ( not defined $source or not defined $DEFAULT_LIB_SECTIONS{$source} ) { + $source = $DEFAULT_SOURCE; + } + + my $language = $self->{_language}; + if ( + not defined $language + or not defined $DEFAULT_LIB_SECTIONS{$source}{$language} + ) { + $language = $SOURCE_DEFAULT_LANGUAGE{$source}; + } + + if ( not $self->_sections_specified('_lib_sections') ) { + $self->{_lib_sections} = $DEFAULT_LIB_SECTIONS{$source}{$language}; + } + if ( not $self->_sections_specified('_script_sections') ) { + $self->{_script_sections} = + $DEFAULT_SCRIPT_SECTIONS{$source}{$language}; + } + + return $TRUE; +} + +sub _sections_specified { + my ( $self, $sections_key ) = @_; + + my $sections = $self->{$sections_key}; + + return 0 if not defined $sections; + + return scalar @{ $sections }; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + + # This policy does not apply unless there is some real code in the + # file. For example, if this file is just pure POD, then + # presumably this file is ancillary documentation and you can use + # whatever headings you want. + return if ! $doc->schild(0); + + my %found_sections = (); + my @violations = (); + + my @required_sections = + $doc->is_program() + ? @{ $self->{_script_sections} } + : @{ $self->{_lib_sections} }; + + my $pods_ref = $doc->find('PPI::Token::Pod'); + return if not $pods_ref; + + # Round up the names of all the =head1 sections + my $pod_of_record; + for my $pod ( @{ $pods_ref } ) { + for my $found ( $pod =~ m{ ^ =head1 \s+ ( .+? ) \s* $ }gxms ) { + # Use first matching POD as POD of record (RT #59268) + $pod_of_record ||= $pod; + #Leading/trailing whitespace is already removed + $found_sections{ uc $found } = 1; + } + } + + # Compare the required sections against those we found + for my $required ( @required_sections ) { + if ( not exists $found_sections{$required} ) { + my $desc = qq{Missing "$required" section in POD}; + # Report any violations against POD of record rather than whole + # document (the point of RT #59268) + # But if there are no =head1 records at all, rat out the + # first pod found, as being better than blowing up. RT #67231 + push @violations, $self->violation( $desc, $EXPL, + $pod_of_record || $pods_ref->[0] ); + } + } + + return @violations; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords licence + +=head1 NAME + +Perl::Critic::Policy::Documentation::RequirePodSections - Organize your POD into the customary sections. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +This Policy requires your POD to contain certain C<=head1> sections. +If the file doesn't contain any POD at all, then this Policy does not +apply. Tools like L make it really +easy to ensure that every module has the same documentation framework, +and they can save you lots of keystrokes. + + +=head1 DEFAULTS + +Different POD sections are required, depending on whether the file is +a library or program (which is determined by the presence or absence +of a perl shebang line). + + Default Required POD Sections + + Perl Libraries Perl Programs + ----------------------------- --------------------- + NAME NAME + VERSION + SYNOPSIS USAGE + DESCRIPTION DESCRIPTION + SUBROUTINES/METHODS REQUIRED ARGUMENTS + OPTIONS + DIAGNOSTICS DIAGNOSTICS + EXIT STATUS + CONFIGURATION AND ENVIRONMENT CONFIGURATION + DEPENDENCIES DEPENDENCIES + INCOMPATIBILITIES INCOMPATIBILITIES + BUGS AND LIMITATIONS BUGS AND LIMITATIONS + AUTHOR AUTHOR + LICENSE AND COPYRIGHT LICENSE AND COPYRIGHT + + +=head1 CONFIGURATION + +The default sections above are derived from Damian Conway's I book. Since the book has been published, Conway has +released L, which has +different names for some of the sections, and adds some more. Also, +the book and module use Australian spelling, while the authors of this +module have previously used American spelling. To sort this all out, +there are a couple of options that can be used: C and +C. + +The C option has two generic values, C and +C, and two version-specific values, +C and C. Currently, the +generic values map to the corresponding version-specific values, but +may change as new versions of the book and module are released, so use +these if you want to keep up with the latest and greatest. If you +want things to remain stable, use the version-specific values. + +The C option has a default, unnamed value but also accepts +values of C and C. The reason the unnamed value exists +is because the default values for programs don't actually match the +book, even taking spelling into account, i.e. C instead +of C, the removal of C, and +the addition of C. To get precisely the sections as +specified in the book, put the following in your F<.perlcriticrc> +file: + + [Documentation::RequirePodSections] + source = book_first_edition + language = en_AU + +If you want to use + + [Documentation::RequirePodSections] + source = module_starter_pbp + language = en_US + +you will need to modify your F<~/.module-starter/PBP/Module.pm> +template because it is generated using Australian spelling. + +Presently, the difference between C and C is in how the +word "licence" is spelled. + +The sections required for modules and programs can be independently +customized, overriding any values for C and C, by +giving values for C and C of a string +of pipe-delimited required POD section names. An example of entries +in a F<.perlcriticrc> file: + + [Documentation::RequirePodSections] + lib_sections = NAME | SYNOPSIS | BUGS AND LIMITATIONS | AUTHOR + script_sections = NAME | USAGE | OPTIONS | EXIT STATUS | AUTHOR + + +=head1 LIMITATIONS + +Currently, this Policy does not look for the required POD sections +below the C<=head1> level. Also, it does not require the sections to +appear in any particular order. + +This Policy applies to the entire document, but can be disabled for a +particular document by a C<## no critic (RequirePodSections)> annotation +anywhere between the beginning of the document and the first POD section +containing a C<=head1>, the C<__END__> (if any), or the C<__DATA__> (if any), +whichever comes first. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ErrorHandling/RequireCarping.pm b/lib/Perl/Critic/Policy/ErrorHandling/RequireCarping.pm new file mode 100644 index 0000000..0178e2e --- /dev/null +++ b/lib/Perl/Critic/Policy/ErrorHandling/RequireCarping.pm @@ -0,0 +1,502 @@ +package Perl::Critic::Policy::ErrorHandling::RequireCarping; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ + :booleans :characters :severities :classification :data_conversion +}; +use Perl::Critic::Utils::PPI qw{ is_ppi_expression_or_generic_statement }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => [ 283 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'allow_messages_ending_with_newlines', + description => q{Don't complain about die or warn if the message ends in a newline.}, + default_string => '1', + behavior => 'boolean', + }, + { + name => 'allow_in_main_unless_in_subroutine', + description => q{Don't complain about die or warn in main::, unless in a subroutine.}, + default_string => '0', + behavior => 'boolean', + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core pbp maintenance certrule ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + my $alternative; + if ( $elem eq 'warn' ) { + $alternative = 'carp'; + } + elsif ( $elem eq 'die' ) { + $alternative = 'croak'; + } + else { + return; + } + + return if ! is_function_call($elem); + + if ($self->{_allow_messages_ending_with_newlines}) { + return if _last_flattened_argument_list_element_ends_in_newline($elem); + } + + return if $self->{_allow_in_main_unless_in_subroutine} + && !$self->_is_element_contained_in_subroutine( $elem ) + && $self->_is_element_in_namespace_main( $elem ); # RT #56619 + + my $desc = qq{"$elem" used instead of "$alternative"}; + return $self->violation( $desc, $EXPL, $elem ); +} + +#----------------------------------------------------------------------------- + +sub _last_flattened_argument_list_element_ends_in_newline { + my $die_or_warn = shift; + + my $last_flattened_argument = + _find_last_flattened_argument_list_element($die_or_warn) + or return $FALSE; + + if ( $last_flattened_argument->isa('PPI::Token::Quote') ) { + my $last_flattened_argument_string = + $last_flattened_argument->string(); + if ( + $last_flattened_argument_string =~ m{ \n \z }xms + or ( + ( + $last_flattened_argument->isa('PPI::Token::Quote::Double') + or $last_flattened_argument->isa('PPI::Token::Quote::Interpolate') + ) + and $last_flattened_argument_string =~ m{ [\\] n \z }xms + ) + ) { + return $TRUE; + } + } + elsif ( $last_flattened_argument->isa('PPI::Token::HereDoc') ) { + return $TRUE; + } + + return $FALSE +} + +#----------------------------------------------------------------------------- +# Here starts the fun. Explanation by example: +# +# Let's say we've got the following (contrived) statement: +# +# die q{Isn't }, ( $this, ( " fun?\n" ) , ) if "It isn't Monday."; +# +# This statement should pass because the last parameter that die is going to +# get is C<" fun?\n">. +# +# The approach is to first find the last non-flattened parameter. If this +# is a simple token, we're done. Else, it's some aggregate thing. We can't +# tell what C is going to do, so we give up on +# anything other than a PPI::Structure::List. +# +# There are three possible scenarios for the children of a List: +# +# * No children of the List, i.e. the list looks like C< ( ) >. +# * One PPI::Statement::Expression element. +# * One PPI::Statement element. That's right, an instance of the base +# statement class and not some subclass. *sigh* +# +# In the first case, we're done. The latter two cases get treated +# identically. We get the last child of the Statement and start the search +# all over again. +# +# Back to our example. The PPI tree for this expression is +# +# PPI::Document +# PPI::Statement +# PPI::Token::Word 'die' +# PPI::Token::Quote::Literal 'q{Isn't }' +# PPI::Token::Operator ',' +# PPI::Structure::List ( ... ) +# PPI::Statement::Expression +# PPI::Token::Symbol '$this' +# PPI::Token::Operator ',' +# PPI::Structure::List ( ... ) +# PPI::Statement::Expression +# PPI::Token::Quote::Double '" fun?\n"' +# PPI::Token::Operator ',' +# PPI::Token::Word 'if' +# PPI::Token::Quote::Double '"It isn't Monday.\n"' +# PPI::Token::Structure ';' +# +# We're starting with the Word containing 'die' (it could just as well be +# 'warn') because the earlier parts of validate() have taken care of any +# other possibility. We're going to scan forward through 'die's siblings +# until we reach what we think the end of its parameters are. So we get +# +# 1. A Literal. A perfectly good argument. +# 2. A comma operator. Looks like we've got more to go. +# 3. A List. Another argument. +# 4. The Word 'if'. Oops. That's a postfix operator. +# +# Thus, the last parameter is the List. So, we've got to scan backwards +# through the components of the List; again, the goal is to find the last +# value in the flattened list. +# +# Before decending into the List, we check that it isn't a subroutine call by +# looking at its prior sibling. In this case, the prior sibling is a comma +# operator, so it's fine. +# +# The List has one Expression element as we expect. We grab the Expression's +# last child and start all over again. +# +# 1. The last child is a comma operator, which Perl will ignore, so we +# skip it. +# 2. The comma's prior sibling is a List. This is the last significant +# part of the outer list. +# 3. The List's prior sibling isn't a Word, so we can continue because the +# List is not a parameter list. +# 4. We go through the child Expression and find that the last child of +# that is a PPI::Token::Quote::Double, which is a simple, non-compound +# token. We return that and we're done. + +sub _find_last_flattened_argument_list_element { + my $die_or_warn = shift; + + # Zoom forward... + my $current_candidate = + _find_last_element_in_subexpression($die_or_warn); + + # ... scan back. + while ( + $current_candidate + and not _is_simple_list_element_token( $current_candidate ) + and not _is_complex_expression_token( $current_candidate ) + ) { + if ( $current_candidate->isa('PPI::Structure::List') ) { + $current_candidate = + _determine_if_list_is_a_plain_list_and_get_last_child( + $current_candidate, + $die_or_warn + ); + } elsif ( not $current_candidate->isa('PPI::Token') ) { + return; + } else { + $current_candidate = $current_candidate->sprevious_sibling(); + } + } + + return if not $current_candidate; + return if _is_complex_expression_token( $current_candidate ); + + my $penultimate_element = $current_candidate->sprevious_sibling(); + if ($penultimate_element) { + # Bail if we've got a Word in front of the Element that isn't + # the original 'die' or 'warn' or anything else that isn't + # a comma or dot operator. + if ( $penultimate_element->isa('PPI::Token::Operator') ) { + if ( + $penultimate_element ne $COMMA + and $penultimate_element ne $PERIOD + ) { + return; + } + } elsif ( $penultimate_element != $die_or_warn ) { + return + } + } + + return $current_candidate; +} + +#----------------------------------------------------------------------------- +# This is the part where we scan forward from the 'die' or 'warn' to find +# the last argument. + +sub _find_last_element_in_subexpression { + my $die_or_warn = shift; + + my $last_following_sibling; + my $next_sibling = $die_or_warn; + while ( + $next_sibling = $next_sibling->snext_sibling() + and not _is_postfix_operator( $next_sibling ) + ) { + $last_following_sibling = $next_sibling; + } + + return $last_following_sibling; +} + +#----------------------------------------------------------------------------- +# Ensure that the list isn't a parameter list. Find the last element of it. + +sub _determine_if_list_is_a_plain_list_and_get_last_child { + my ($list, $die_or_warn) = @_; + + my $prior_sibling = $list->sprevious_sibling(); + + if ( $prior_sibling ) { + # Bail if we've got a Word in front of the List that isn't + # the original 'die' or 'warn' or anything else that isn't + # a comma operator. + if ( $prior_sibling->isa('PPI::Token::Operator') ) { + if ( $prior_sibling ne $COMMA ) { + return; + } + } elsif ( $prior_sibling != $die_or_warn ) { + return + } + } + + my @list_children = $list->schildren(); + + # If zero children, nothing to look for. + # If multiple children, then PPI is not giving us + # anything we understand. + return if scalar (@list_children) != 1; + + my $list_child = $list_children[0]; + + # If the child isn't an Expression or it is some other subclass + # of Statement, we again don't understand PPI's output. + return if not is_ppi_expression_or_generic_statement($list_child); + + my @statement_children = $list_child->schildren(); + return if scalar (@statement_children) < 1; + + return $statement_children[-1]; +} + + +#----------------------------------------------------------------------------- +Readonly::Hash my %POSTFIX_OPERATORS => + hashify qw{ if unless while until for foreach }; + +sub _is_postfix_operator { + my $element = shift; + + if ( + $element->isa('PPI::Token::Word') + and $POSTFIX_OPERATORS{$element} + ) { + return $TRUE; + } + + return $FALSE; +} + + +Readonly::Array my @SIMPLE_LIST_ELEMENT_TOKEN_CLASSES => + qw{ + PPI::Token::Number + PPI::Token::Word + PPI::Token::DashedWord + PPI::Token::Symbol + PPI::Token::Quote + PPI::Token::HereDoc + }; + +sub _is_simple_list_element_token { + my $element = shift; + + return $FALSE if not $element->isa('PPI::Token'); + + foreach my $class (@SIMPLE_LIST_ELEMENT_TOKEN_CLASSES) { + return $TRUE if $element->isa($class); + } + + return $FALSE; +} + + +#----------------------------------------------------------------------------- +# Tokens that can't possibly be part of an expression simple +# enough for us to examine. + +Readonly::Array my @COMPLEX_EXPRESSION_TOKEN_CLASSES => + qw{ + PPI::Token::ArrayIndex + PPI::Token::QuoteLike + PPI::Token::Regexp + PPI::Token::Cast + PPI::Token::Label + PPI::Token::Separator + PPI::Token::Data + PPI::Token::End + PPI::Token::Prototype + PPI::Token::Attribute + PPI::Token::Unknown + }; + +sub _is_complex_expression_token { + my $element = shift; + + return $FALSE if not $element->isa('PPI::Token'); + + foreach my $class (@COMPLEX_EXPRESSION_TOKEN_CLASSES) { + return $TRUE if $element->isa($class); + } + + return $FALSE; +} + +#----------------------------------------------------------------------------- +# Check whether the given element is contained in a subroutine. + +sub _is_element_contained_in_subroutine { + my ( $self, $elem ) = @_; + + my $parent = $elem; + while ( $parent = $parent->parent() ) { + $parent->isa( 'PPI::Statement::Sub' ) and return $TRUE; + $parent->isa( 'PPI::Structure::Block' ) or next; + my $prior_elem = $parent->sprevious_sibling() or next; + $prior_elem->isa( 'PPI::Token::Word' ) + and 'sub' eq $prior_elem->content() + and return $TRUE; + } + + return $FALSE; +} + +#----------------------------------------------------------------------------- +# Check whether the given element is in main:: + +sub _is_element_in_namespace_main { + my ( $self, $elem ) = @_; + my $current_elem = $elem; + my $prior_elem; + + while ( $current_elem ) { + while ( $prior_elem = $current_elem->sprevious_sibling() ) { + if ( $prior_elem->isa( 'PPI::Statement::Package' ) ) { + return 'main' eq $prior_elem->namespace(); + } + } continue { + $current_elem = $prior_elem; + } + $current_elem = $current_elem->parent(); + } + + return $TRUE; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ErrorHandling::RequireCarping - Use functions from L instead of C or C. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +The C and C functions both report the file and line number +where the exception occurred. But if someone else is using your +subroutine, they usually don't care where B code blew up. +Instead, they want to know where B code invoked the subroutine. +The L module provides alternative methods that report the +exception from the caller's file and line number. + +By default, this policy will not complain about C or C, if +it can determine that the message will always result in a terminal +newline. Since perl suppresses file names and line numbers in this +situation, it is assumed that no stack traces are desired either and +none of the L functions are necessary. + + die "oops" if $explosion; #not ok + warn "Where? Where?!" if $tiger; #not ok + + open my $mouth, '<', 'food' + or die 'of starvation'; #not ok + + if (! $dentist_appointment) { + warn "You have bad breath!\n"; #ok + } + + die "$clock not set.\n" if $no_time; #ok + + my $message = "$clock not set.\n"; + die $message if $no_time; #not ok, not obvious + + +=head1 CONFIGURATION + +By default, this policy allows uses of C and C ending in an +explicit newline. If you give this policy an +C option in your F<.perlcriticrc> +with a false value, then this policy will prohibit such uses. + + [ErrorHandling::RequireCarping] + allow_messages_ending_with_newlines = 0 + +If you give this policy an C option +in your F<.perlcriticrc> with a true value, then this policy will allow +C and C in name space main:: unless they appear in a +subroutine, even if they do not end in an explicit newline. + + [ErrorHandling::RequireCarping] + allow_in_main_unless_in_subroutine = 1 + +=head1 BUGS + +Should allow C when it is obvious that the "message" is a reference. + + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ErrorHandling/RequireCheckingReturnValueOfEval.pm b/lib/Perl/Critic/Policy/ErrorHandling/RequireCheckingReturnValueOfEval.pm new file mode 100644 index 0000000..1144d6b --- /dev/null +++ b/lib/Perl/Critic/Policy/ErrorHandling/RequireCheckingReturnValueOfEval.pm @@ -0,0 +1,456 @@ +package Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use Scalar::Util qw< refaddr >; + +use Perl::Critic::Utils qw< :booleans :characters :severities hashify + precedence_of >; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => 'Return value of eval not tested.'; +## no critic (RequireInterpolationOfMetachars) +Readonly::Scalar my $EXPL => + q; +## use critic + +Readonly::Hash my %BOOLEAN_OPERATORS => hashify qw< || && // or and >; +Readonly::Hash my %POSTFIX_OPERATORS => + hashify qw< for foreach if unless while until >; + +Readonly::Scalar my $PRECEDENCE_OF_EQUALS => precedence_of( q{=} ); + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core bugs ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->content() ne 'eval'; + + my $evaluated = $elem->snext_sibling() or return; # Nothing to eval! + my $following = $evaluated->snext_sibling(); + + return if _is_returned( $elem ); # GitHub #324 + return if _is_in_right_hand_side_of_assignment($elem); + return if _is_in_postfix_expression($elem); + return if + _is_in_correct_position_in_a_condition_or_foreach_loop_collection( + $elem, + $following, + ); + + return if _scan_backwards_for_grep( $elem ); # RT 69489 + + if ( $following and $following->isa('PPI::Token::Operator') ) { + return if $BOOLEAN_OPERATORS{ $following->content() }; + return if q{?} eq $following->content; + } + + return $self->violation($DESC, $EXPL, $elem); +} + +#----------------------------------------------------------------------------- + +sub _is_in_right_hand_side_of_assignment { + my ($elem) = @_; + + my $previous = $elem->sprevious_sibling(); + + if (not $previous) { + $previous = + _grandparent_for_is_in_right_hand_side_of_assignment($elem); + } + + while ($previous) { + my $base_previous = $previous; + + EQUALS_SCAN: + while ($previous) { + if ( $previous->isa('PPI::Token::Operator') ) { + return $TRUE if $previous->content() =~ m/= \Z/xms; + last EQUALS_SCAN if _is_effectively_a_comma($previous); + } + $previous = $previous->sprevious_sibling(); + } + + $previous = + _grandparent_for_is_in_right_hand_side_of_assignment($base_previous); + } + + return; +} + +sub _grandparent_for_is_in_right_hand_side_of_assignment { + my ($elem) = @_; + + my $parent = $elem->parent() or return; + $parent->isa('PPI::Statement') or return; + + my $grandparent = $parent->parent() or return; + + if ( + $grandparent->isa('PPI::Structure::Constructor') + or $grandparent->isa('PPI::Structure::List') + ) { + return $grandparent; + } + + return; +} + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $CONDITION_POSITION_IN_C_STYLE_FOR_LOOP => 1; + +sub _is_in_correct_position_in_a_condition_or_foreach_loop_collection { + my ($elem, $following) = @_; + + my $parent = $elem->parent(); + while ($parent) { + if ( $parent->isa('PPI::Structure::Condition') ) { + return + _is_in_correct_position_in_a_structure_condition( + $elem, $parent, $following, + ); + } + + # TECHNICAL DEBT: This code is basically shared with + # ProhibitUnusedCapture. I don't want to put this code + # into Perl::Critic::Utils::*, but I don't have time to sort out + # PPIx::Utilities::Structure::List yet. + if ( + $parent->isa('PPI::Structure::List') + and my $parent_statement = $parent->statement() + ) { + return $TRUE if + $parent_statement->isa('PPI::Statement::Compound') + and $parent_statement->type() eq 'foreach'; + } + + if ( $parent->isa('PPI::Structure::For') ) { + my @for_loop_components = $parent->schildren(); + + my $condition = + $for_loop_components[$CONDITION_POSITION_IN_C_STYLE_FOR_LOOP] + or return; + + return _descendant_of($elem, $condition); + } + + $parent = $parent->parent(); + } + + return; +} + +sub _is_in_correct_position_in_a_structure_condition { + my ($elem, $parent, $following) = @_; + + my $level = $elem; + while ($level and refaddr $level != $parent) { + my $cursor = refaddr $elem == refaddr $level ? $following : $level; + + IS_FINAL_EXPRESSION_AT_DEPTH: + while ($cursor) { + if ( _is_effectively_a_comma($cursor) ) { + $cursor = $cursor->snext_sibling(); + while ( _is_effectively_a_comma($cursor) ) { + $cursor = $cursor->snext_sibling(); + } + + # Semicolon would be a syntax error here. + return if $cursor; + last IS_FINAL_EXPRESSION_AT_DEPTH; + } + + $cursor = $cursor->snext_sibling(); + } + + my $statement = $level->parent(); + return $TRUE if not $statement; # Shouldn't happen. + return $TRUE if not $statement->isa('PPI::Statement'); # Shouldn't happen. + + $level = $statement->parent(); + if ( + not $level + or ( + not $level->isa('PPI::Structure::List') + and not $level->isa('PPI::Structure::Condition') + ) + ) { + # Shouldn't happen. + return $TRUE; + } + } + + return $TRUE; +} + +# Replace with PPI implementation once it is released. +sub _descendant_of { + my ($cursor, $potential_ancestor) = @_; + + return $EMPTY if not $potential_ancestor; + + while ( refaddr $cursor != refaddr $potential_ancestor ) { + $cursor = $cursor->parent() or return $EMPTY; + } + + return 1; +} + +#----------------------------------------------------------------------------- + +sub _is_in_postfix_expression { + my ($elem) = @_; + + my $current_base = $elem; + while ($TRUE) { + my $previous = $current_base->sprevious_sibling(); + while ($previous) { + if ( + $previous->isa('PPI::Token::Word') + and $POSTFIX_OPERATORS{ $previous->content() } + ) { + return $TRUE + } + $previous = $previous->sprevious_sibling(); + } # end while + + my $parent = $current_base->parent() or return; + if ( $parent->isa('PPI::Statement') ) { + return if $parent->specialized(); + + my $grandparent = $parent->parent() or return; + return if not $grandparent->isa('PPI::Structure::List'); + + $current_base = $grandparent; + } else { + $current_base = $parent; + } + + return if not $current_base->isa('PPI::Structure::List'); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _scan_backwards_for_grep { + my ( $elem ) = @_; + + while ( $elem ) { + + my $parent = $elem->parent(); + + while ( $elem = $elem->sprevious_sibling() ) { + $elem->isa( 'PPI::Token::Word' ) + and 'grep' eq $elem->content() + and return $TRUE; + $elem->isa( 'PPI::Token::Operator' ) + and precedence_of( $elem ) >= $PRECEDENCE_OF_EQUALS + and return $FALSE; + } + + $elem = $parent; + } + + return $FALSE; + +} + +#----------------------------------------------------------------------------- + +sub _is_effectively_a_comma { + my ($elem) = @_; + + return if not $elem; + + return + $elem->isa('PPI::Token::Operator') + && ( + $elem->content() eq $COMMA + || $elem->content() eq $FATCOMMA + ); +} + +#----------------------------------------------------------------------------- +# GitHub #324 (https://github.com/Perl-Critic/Perl-Critic/issues/324) +{ + Readonly::Scalar my $RETURN => 'return'; + + sub _is_returned { + my ( $elem ) = @_; + my $prev = $elem->sprevious_sibling(); + return + $prev + && + $prev->isa( 'PPI::Token::Word' ) + && + $RETURN eq $prev->content(); + } +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords destructors + +=head1 NAME + +Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval - You can't depend upon the value of C<$@>/C<$EVAL_ERROR> to tell whether an C failed. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +A common idiom in perl for dealing with possible errors is to use +C followed by a check of C<$@>/C<$EVAL_ERROR>: + + eval { + ... + }; + if ($EVAL_ERROR) { + ... + } + +There's a problem with this: the value of C<$EVAL_ERROR> can change +between the end of the C and the C statement. The issue is +object destructors: + + package Foo; + + ... + + sub DESTROY { + ... + eval { ... }; + ... + } + + package main; + + eval { + my $foo = Foo->new(); + ... + }; + if ($EVAL_ERROR) { + ... + } + +Assuming there are no other references to C<$foo> created, when the +C block in C
is exited, C will be invoked, +regardless of whether the C finished normally or not. If the +C in C
fails, but the C in C +succeeds, then C<$EVAL_ERROR> will be empty by the time that the C +is executed. Additional issues arise if you depend upon the exact +contents of C<$EVAL_ERROR> and both Cs fail, because the +messages from both will be concatenated. + +Even if there isn't an C directly in the C method +code, it may invoke code that does use C or otherwise affects +C<$EVAL_ERROR>. + +The solution is to ensure that, upon normal exit, an C returns a +true value and to test that value: + + # Constructors are no problem. + my $object = eval { Class->new() }; + + # To cover the possibility that an operation may correctly return a + # false value, end the block with "1": + if ( eval { something(); 1 } ) { + ... + } + + eval { + ... + 1; + } + or do { + # Error handling here + }; + +Unfortunately, you can't use the C function to test the +result; C returns an empty string on failure. + +Various modules have been written to take some of the pain out of +properly localizing and checking C<$@>/C<$EVAL_ERROR>. For example: + + use Try::Tiny; + try { + ... + } catch { + # Error handling here; + # The exception is in $_/$ARG, not $@/$EVAL_ERROR. + }; # Note semicolon. + +"But we don't use DESTROY() anywhere in our code!" you say. That may +be the case, but do any of the third-party modules you use have them? +What about any you may use in the future or updated versions of the +ones you already use? + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +See thread on perl5-porters starting here: +L. + +For a nice, easy, non-magical way of properly handling exceptions, see +L. + + +=head1 AUTHOR + +Elliot Shank C<< >> + +=head1 COPYRIGHT + +Copyright (c) 2008-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/InputOutput/ProhibitBacktickOperators.pm b/lib/Perl/Critic/Policy/InputOutput/ProhibitBacktickOperators.pm new file mode 100644 index 0000000..7679c35 --- /dev/null +++ b/lib/Perl/Critic/Policy/InputOutput/ProhibitBacktickOperators.pm @@ -0,0 +1,146 @@ +package Perl::Critic::Policy::InputOutput::ProhibitBacktickOperators; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities is_in_void_context }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => q{Use IPC::Open3 instead}; +Readonly::Scalar my $DESC => q{Backtick operator used}; + +Readonly::Scalar my $VOID_EXPL => q{Assign result to a variable or use system() instead}; +Readonly::Scalar my $VOID_DESC => q{Backtick operator used in void context}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'only_in_void_context', + description => 'Allow backticks everywhere except in void contexts.', + behavior => 'boolean', + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw(core maintenance) } +sub applies_to { return qw(PPI::Token::QuoteLike::Backtick + PPI::Token::QuoteLike::Command ) } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + if ( $self->{_only_in_void_context} ) { + return if not is_in_void_context( $elem ); + + return $self->violation( $VOID_DESC, $VOID_EXPL, $elem ); + } + + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords perlipc + +=head1 NAME + +Perl::Critic::Policy::InputOutput::ProhibitBacktickOperators - Discourage stuff like C<@files = `ls $directory`>. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Backticks are super-convenient, especially for CGI programs, but I +find that they make a lot of noise by filling up STDERR with messages +when they fail. I think its better to use IPC::Open3 to trap all the +output and let the application decide what to do with it. + + use IPC::Open3 'open3'; + $SIG{CHLD} = 'IGNORE'; + + @output = `some_command`; #not ok + + my ($writer, $reader, $err); + open3($writer, $reader, $err, 'some_command'); #ok; + @output = <$reader>; #Output here + @errors = <$err>; #Errors here, instead of the console + + +=head1 CONFIGURATION + +Alternatively, if you do want to use backticks, you can restrict +checks to void contexts by adding the following to your +F<.perlcriticrc> file: + + [InputOutput::ProhibitBacktickOperators] + only_in_void_context = 1 + +The purpose of backticks is to capture the output of an external +command. Use of them in a void context is likely a bug. If the +output isn't actually required, C should be used. Otherwise +assign the result to a variable. + + `some_command`; #not ok + $output = `some_command`; #ok + @output = `some_command`; #ok + + +=head1 NOTES + +This policy also prohibits the generalized form of backticks seen as +C. + +See L for more discussion on using C instead +of C<$SIG{CHLD} = 'IGNORE'>. + +You might consider using the C function from the +L module for a safer way of +doing what backticks do, especially on Windows. The module also has a +safe wrapper around C. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/InputOutput/ProhibitBarewordFileHandles.pm b/lib/Perl/Critic/Policy/InputOutput/ProhibitBarewordFileHandles.pm new file mode 100644 index 0000000..3b03f06 --- /dev/null +++ b/lib/Perl/Critic/Policy/InputOutput/ProhibitBarewordFileHandles.pm @@ -0,0 +1,114 @@ +package Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification :ppi }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Bareword file handle opened}; +Readonly::Scalar my $EXPL => [ 202, 204 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw( core pbp bugs certrec ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, undef) = @_; + + return if $elem->content() ne 'open'; + return if ! is_function_call($elem); + + my $first_arg = ( parse_arg_list($elem) )[0]; + return if !$first_arg; + my $first_token = $first_arg->[0]; + return if !$first_token; + + if ( $first_token->isa('PPI::Token::Word') ) { + if ( ($first_token ne 'my') && ($first_token !~ m/^STD(?:IN|OUT|ERR)$/xms ) ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + } + return; #ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles - Write C instead of C. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Using bareword symbols to refer to file handles is particularly evil +because they are global, and you have no idea if that symbol already +points to some other file handle. You can mitigate some of that risk +by Cizing the symbol first, but that's pretty ugly. Since Perl +5.6, you can use an undefined scalar variable as a lexical reference +to an anonymous filehandle. Alternatively, see the +L or L or +L modules for an object-oriented approach. + + open FH, '<', $some_file; #not ok + open my $fh, '<', $some_file; #ok + my $fh = IO::File->new($some_file); #ok + +There are three exceptions: STDIN, STDOUT and STDERR. These three +standard filehandles are always package variables. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L + +L + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/InputOutput/ProhibitExplicitStdin.pm b/lib/Perl/Critic/Policy/InputOutput/ProhibitExplicitStdin.pm new file mode 100644 index 0000000..590152f --- /dev/null +++ b/lib/Perl/Critic/Policy/InputOutput/ProhibitExplicitStdin.pm @@ -0,0 +1,121 @@ +package Perl::Critic::Policy::InputOutput::ProhibitExplicitStdin; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification &parse_arg_list }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Use "<>" or "" or a prompting module instead of ""}; +Readonly::Scalar my $EXPL => [216,220,221]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core pbp maintenance ) } +sub applies_to { return 'PPI::Token::QuoteLike::Readline' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem ne ''; + return $self->violation( $DESC, $EXPL, $elem ); +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::InputOutput::ProhibitExplicitStdin - Use "<>" or "" or a prompting module instead of "". + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Perl has a useful magic filehandle called C<*ARGV> that checks the +command line and if there are any arguments, opens and reads those as +files. If there are no arguments, C<*ARGV> behaves like C<*STDIN> +instead. This behavior is almost always what you want if you want to +create a program that reads from C. This is often written in +one of the following two equivalent forms: + + while () { + # ... do something with each input line ... + } + # or, equivalently: + while (<>) { + # ... do something with each input line ... + } + +If you want to prompt for user input, try special purpose modules like +L. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 CAVEATS + +Due to a bug in the current version of PPI (v1.119_03) and earlier, +the readline operator is often misinterpreted as less-than and +greater-than operators after a comma. Therefore, this policy misses +important cases like + + my $content = join '', ; + +because it interprets that line as the nonsensical statement: + + my $content = join '', < STDIN >; + +When that PPI bug is fixed, this policy should start catching those +violations automatically. + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + +=head1 AUTHOR + +Chris Dolan + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/InputOutput/ProhibitInteractiveTest.pm b/lib/Perl/Critic/Policy/InputOutput/ProhibitInteractiveTest.pm new file mode 100644 index 0000000..e6d1643 --- /dev/null +++ b/lib/Perl/Critic/Policy/InputOutput/ProhibitInteractiveTest.pm @@ -0,0 +1,83 @@ +package Perl::Critic::Policy::InputOutput::ProhibitInteractiveTest; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Use IO::Interactive::is_interactive() instead of -t}; +Readonly::Scalar my $EXPL => [ 218 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw( core pbp bugs certrule ) } +sub applies_to { return 'PPI::Token::Operator' } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, $doc) = @_; + return if $elem->content() ne '-t'; + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::InputOutput::ProhibitInteractiveTest - Use prompt() instead of -t. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +The C<-t> operator is fragile and complicated. When you are testing +whether C is interactive, It's much more robust to use +well-tested CPAN modules like L. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Chris Dolan + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/InputOutput/ProhibitJoinedReadline.pm b/lib/Perl/Critic/Policy/InputOutput/ProhibitJoinedReadline.pm new file mode 100644 index 0000000..004068e --- /dev/null +++ b/lib/Perl/Critic/Policy/InputOutput/ProhibitJoinedReadline.pm @@ -0,0 +1,126 @@ +package Perl::Critic::Policy::InputOutput::ProhibitJoinedReadline; + +use 5.006001; +use strict; +use warnings; +use Readonly; +use List::MoreUtils qw(any); + +use Perl::Critic::Utils qw{ :severities :classification parse_arg_list }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Use "local $/ = undef" or Path::Tiny instead of joined readline}; ## no critic qw(InterpolationOfMetachars) +Readonly::Scalar my $EXPL => [213]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core pbp performance ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->content() ne 'join'; + return if ! is_function_call($elem); + my @args = parse_arg_list($elem); + shift @args; # ignore separator string + + if (any { any { $_->isa('PPI::Token::QuoteLike::Readline') } @{$_} } @args) { + return $self->violation( $DESC, $EXPL, $elem ); + } + + return; # OK +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::InputOutput::ProhibitJoinedReadline - Use C or L instead of joined readline. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +It's really easy to slurp a whole filehandle in at once with C>, but that's inefficient -- Perl goes to the trouble of +splitting the file into lines only to have that work thrown away. + +To save performance, either slurp the filehandle without splitting +like so: + + do { local $/ = undef; <$fh> } + +or use L, which is even faster. + +B that if the C policy is also in effect, +it will complain about the use of C<$/> in the line above. In that +case, write this instead: + + use English '-no_match_vars'; + + do { local $INPUT_RECORD_SEPARATOR = undef; <$fh> }; + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 CAVEATS + +Due to a bug in the current version of PPI (v1.119_03) and earlier, +the readline operator is often misinterpreted as less-than and +greater-than operators after a comma. Therefore, this policy only +works well on the empty filehandle, C<< <> >>. When PPI is fixed, +this should just start working. + + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/InputOutput/ProhibitOneArgSelect.pm b/lib/Perl/Critic/Policy/InputOutput/ProhibitOneArgSelect.pm new file mode 100644 index 0000000..6e890a4 --- /dev/null +++ b/lib/Perl/Critic/Policy/InputOutput/ProhibitOneArgSelect.pm @@ -0,0 +1,103 @@ +package Perl::Critic::Policy::InputOutput::ProhibitOneArgSelect; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification :ppi }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{One-argument "select" used}; +Readonly::Scalar my $EXPL => [ 224 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core bugs pbp certrule ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, undef) = @_; + + return if $elem->content() ne 'select'; + return if ! is_function_call($elem); + + my @arguments = parse_arg_list($elem); + if( 1 == @arguments ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::InputOutput::ProhibitOneArgSelect - Never write C. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway discourages the use of a raw C when setting +autoflushes. We'll extend that further by simply prohibiting the +one-argument form of C entirely; if you really need it you +should know when/where/why that is. For performing autoflushes, +Conway recommends the use of C instead. + + select((select($fh), $|=1)[0]); # not ok + select $fh; # not ok + + use IO::Handle; + $fh->autoflush(); # ok + *STDOUT->autoflush(); # ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +Graham TerMarsch + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Graham TerMarsch. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/InputOutput/ProhibitReadlineInForLoop.pm b/lib/Perl/Critic/Policy/InputOutput/ProhibitReadlineInForLoop.pm new file mode 100644 index 0000000..edb81f1 --- /dev/null +++ b/lib/Perl/Critic/Policy/InputOutput/ProhibitReadlineInForLoop.pm @@ -0,0 +1,102 @@ +package Perl::Critic::Policy::InputOutput::ProhibitReadlineInForLoop; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use List::Util qw< first >; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Readline inside "for" loop}; +Readonly::Scalar my $EXPL => [ 211 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw< core bugs pbp > } +sub applies_to { return qw< PPI::Statement::Compound > } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->type() ne 'foreach'; + + my $list = first { $_->isa('PPI::Structure::List') } $elem->schildren() + or return; + + if ( + my $readline = $list->find_first('PPI::Token::QuoteLike::Readline') + ) { + return $self->violation( $DESC, $EXPL, $readline ); + } + + return; #ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::InputOutput::ProhibitReadlineInForLoop - Write C<< while( $line = <> ){...} >> instead of C<< for(<>){...} >>. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Using the readline operator in a C or C loop is very +slow. The iteration list of the loop creates a list context, which +causes the readline operator to read the entire input stream before +iteration even starts. Instead, just use a C loop, which only +reads one line at a time. + + for my $line ( <$file_handle> ){ do_something($line) } #not ok + while ( my $line = <$file_handle> ){ do_something($line) } #ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/InputOutput/ProhibitTwoArgOpen.pm b/lib/Perl/Critic/Policy/InputOutput/ProhibitTwoArgOpen.pm new file mode 100644 index 0000000..940218f --- /dev/null +++ b/lib/Perl/Critic/Policy/InputOutput/ProhibitTwoArgOpen.pm @@ -0,0 +1,139 @@ +package Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use version; + +use Perl::Critic::Utils qw{ :severities :classification :ppi }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $STDIO_HANDLES_RX => qr/\b STD (?: IN | OUT | ERR \b)/xms; +Readonly::Scalar my $FORK_HANDLES_RX => qr/\A (?: -[|] | [|]- ) \z/xms; +Readonly::Scalar my $DESC => q{Two-argument "open" used}; +Readonly::Scalar my $EXPL => [ 207 ]; + +Readonly::Scalar my $MINIMUM_VERSION => version->new(5.006); + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw(core pbp bugs security certrule) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, $document) = @_; + + return if $elem->content() ne 'open'; + return if ! is_function_call($elem); + + my $version = $document->highest_explicit_perl_version(); + return if $version and $version < $MINIMUM_VERSION; + + my @args = parse_arg_list($elem); + + if ( scalar @args == 2 ) { + # When opening STDIN, STDOUT, or STDERR, the + # two-arg form is the only option you have. + return if $args[1]->[0] =~ $STDIO_HANDLES_RX; + return if $args[1]->[0]->isa( 'PPI::Token::Quote' ) + && $args[1]->[0]->string() =~ $FORK_HANDLES_RX; + return $self->violation( $DESC, $EXPL, $elem ); + } + + return; # ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords perlipc + +=head1 NAME + +Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen - Write C<< open $fh, q{<}, $filename; >> instead of C<< open $fh, "<$filename"; >>. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +The three-argument form of C (introduced in Perl 5.6) prevents +subtle bugs that occur when the filename starts with funny characters +like '>' or '<'. The L module provides a nice +object-oriented interface to filehandles, which I think is more +elegant anyway. + + open( $fh, '>output.txt' ); # not ok + open( $fh, q{>}, 'output.txt' ); # ok + + use IO::File; + my $fh = IO::File->new( 'output.txt', q{>} ); # even better! + +It's also more explicitly clear to define the input mode of the file, +as in the difference between these two: + + open( $fh, 'foo.txt' ); # BAD: Reader must think what default mode is + open( $fh, '<', 'foo.txt' ); # GOOD: Reader can see open mode + +This policy will not complain if the file explicitly states that it is +compatible with a version of perl prior to 5.6 via an include +statement, e.g. by having C in it. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 NOTES + +There are two cases in which you are forced to use the two-argument form of +open. When re-opening STDIN, STDOUT, or STDERR, and when doing a safe pipe +open, as described in L. + +=head1 SEE ALSO + +L + +L + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/InputOutput/RequireBracedFileHandleWithPrint.pm b/lib/Perl/Critic/Policy/InputOutput/RequireBracedFileHandleWithPrint.pm new file mode 100644 index 0000000..14868ec --- /dev/null +++ b/lib/Perl/Critic/Policy/InputOutput/RequireBracedFileHandleWithPrint.pm @@ -0,0 +1,139 @@ +package Perl::Critic::Policy::InputOutput::RequireBracedFileHandleWithPrint; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification :data_conversion }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Array my @POSTFIX_WORDS => qw( if unless for ); +Readonly::Hash my %POSTFIX_WORDS => hashify( @POSTFIX_WORDS ); +Readonly::Scalar my $PRINT_RX => qr/ \A (?: print f? | say ) \z /xms; + +Readonly::Scalar my $DESC => q{File handle for "print" or "printf" is not braced}; +Readonly::Scalar my $EXPL => [ 217 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw( core pbp cosmetic ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem !~ $PRINT_RX; + return if ! is_function_call($elem); + + my @sib; + + $sib[0] = $elem->snext_sibling(); + return if !$sib[0]; + + # Deal with situations where 'print' is called with parentheses + if ( $sib[0]->isa('PPI::Structure::List') ) { + my $expr = $sib[0]->schild(0); + return if !$expr; + $sib[0] = $expr->schild(0); + return if !$sib[0]; + } + + $sib[1] = $sib[0]->next_sibling(); + return if !$sib[1]; + $sib[2] = $sib[1]->next_sibling(); + return if !$sib[2]; + + # First token must be a scalar symbol or bareword; + return if !( ($sib[0]->isa('PPI::Token::Symbol') && $sib[0] =~ m/\A \$/xms) + || $sib[0]->isa('PPI::Token::Word') ); + + # First token must not be a builtin function or control + return if is_perl_builtin($sib[0]); + return if exists $POSTFIX_WORDS{ $sib[0] }; + + # Second token must be white space + return if !$sib[1]->isa('PPI::Token::Whitespace'); + + # Third token must not be an operator + return if $sib[2]->isa('PPI::Token::Operator'); + + # Special case for postfix controls + return if exists $POSTFIX_WORDS{ $sib[2] }; + + return if $sib[0]->isa('PPI::Structure::Block'); + + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::InputOutput::RequireBracedFileHandleWithPrint - Write C instead of C. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +The C and C functions have a unique syntax that +supports an optional file handle argument. Conway suggests wrapping +this argument in braces to make it visually stand out from the other +arguments. When you put braces around any of the special +package-level file handles like C, C, and C, you +must the C<'*'> sigil or else it won't compile under C. + + print $FH "Mary had a little lamb\n"; #not ok + print {$FH} "Mary had a little lamb\n"; #ok + + print STDERR $foo, $bar, $baz; #not ok + print {STDERR} $foo, $bar, $baz; #won't compile under 'strict' + print {*STDERR} $foo, $bar, $baz; #perfect! + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm b/lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm new file mode 100644 index 0000000..d4b86c7 --- /dev/null +++ b/lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm @@ -0,0 +1,364 @@ +package Perl::Critic::Policy::InputOutput::RequireBriefOpen; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use List::MoreUtils qw(any); + +use Perl::Critic::Utils qw{ :severities :classification :booleans + hashify parse_arg_list +}; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q; +Readonly::Scalar my $EXPL => [209]; + +Readonly::Scalar my $SCALAR_SIGIL => q<$>; +Readonly::Scalar my $GLOB_SIGIL => q<*>; + +# Identify the builtins that are equivalent to 'open' and 'close'. Note that +# 'return' is considered equivalent to 'close'. +Readonly::Hash my %CLOSE_BUILTIN => hashify( qw{ + close + CORE::close + CORE::GLOBAL::close + return +} ); +Readonly::Hash my %OPEN_BUILTIN => hashify( qw{ + open + CORE::open + CORE::GLOBAL::open +} ); + +# Possible values for $is_lexical +Readonly::Scalar my $NOT_LEXICAL => 0; # Guaranteed only false value +Readonly::Scalar my $LOCAL_LEXICAL => 1; +Readonly::Scalar my $NON_LOCAL_LEXICAL => 2; + +Readonly::Scalar my $LAST_ELEMENT => -1; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'lines', + description => 'The maximum number of lines between an open() and a close().', + default_string => '9', + behavior => 'integer', + integer_minimum => 1, + }, + ); +} + +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw< core pbp maintenance > } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + # Is it a call to open? + $OPEN_BUILTIN{$elem->content()} or return; + return if ! is_function_call($elem); + my @open_args = parse_arg_list($elem); + return if 2 > @open_args; # not a valid call to open() + + my ($is_lexical, $fh) = _get_opened_fh($open_args[0]); + return if not $fh; + return if $fh =~ m< \A [*]? STD (?: IN|OUT|ERR ) \z >xms; + + for my $close_token ( $self->_find_close_invocations_or_return( + $elem, $is_lexical ) ) { + # The $close_token might be a close() or a return() + # It doesn't matter which -- both satisfy this policy + if (is_function_call($close_token)) { + my @close_args = parse_arg_list($close_token); + + my $close_parameter = $close_args[0]; + if ('ARRAY' eq ref $close_parameter) { + $close_parameter = ${$close_parameter}[0]; + } + if ( $close_parameter ) { + $close_parameter = "$close_parameter"; + return if $fh eq $close_parameter; + + if ( any { m< \A [*] >xms } ($fh, $close_parameter) ) { + (my $stripped_fh = $fh) =~ s< \A [*] ><>xms; + (my $stripped_parameter = $close_parameter) =~ + s< \A [*] ><>xms; + + return if $stripped_fh eq $stripped_parameter; + } + } + } + elsif ($is_lexical && is_method_call($close_token)) { + my $tok = $close_token->sprevious_sibling->sprevious_sibling; + return if $fh eq $tok; + } + } + + return $self->violation( $DESC, $EXPL, $elem ); +} + +sub _find_close_invocations_or_return { + my ($self, $elem, $is_lexical) = @_; + + my $parent = $self->_get_scope( $elem, $is_lexical ); + return if !$parent; # I can't think of a scenario where this would happen + + my $open_loc = $elem->location; + # we don't actually allow _lines to be zero or undef, but maybe we will + my $end_line = $self->{_lines} ? $open_loc->[0] + $self->{_lines} : undef; + + my $closes = $parent->find(sub { + ##no critic (ProhibitExplicitReturnUndef) + my ($parent, $candidate) = @_; ## no critic(Variables::ProhibitReusedNames) + return undef if $candidate->isa('PPI::Statement::Sub'); + my $candidate_loc = $candidate->location; + return undef if !defined $candidate_loc->[0]; + return 0 if $candidate_loc->[0] < $open_loc->[0]; + return 0 if $candidate_loc->[0] == $open_loc->[0] && $candidate_loc->[1] <= $open_loc->[1]; + return undef if defined $end_line && $candidate_loc->[0] > $end_line; + return 0 if !$candidate->isa('PPI::Token::Word'); + return $CLOSE_BUILTIN{ $candidate->content() } || 0; + }); + return @{$closes || []}; +} + +sub _get_scope { + my ( $self, $elem, $is_lexical ) = @_; + + my $open_loc = $elem->location; + my $end_line = ( $self->{_lines} && defined $open_loc->[0] ) ? + $open_loc->[0] + $self->{_lines} : + undef; + + while ( my $dad = $elem->parent) { + $elem = $dad; + next if not $elem->scope; + + # If we are analyzing something like 'open my $fh ...', the + # most-local scope suffices. RT #64437 + return $elem if $LOCAL_LEXICAL == $is_lexical; + next if not defined $end_line; # Presume search everywhere + + # If we are analyzing something like 'open $fh ...', 'open FH + # ...', or 'open *FH ...' we need to use a scope that includes + # the end of the legal range. We just give up and return the + # current scope if we can not determine any of the locations + # involved. RT #64437 + return $elem if not $open_loc; + my $elem_loc = $elem->location + or return $elem; + my $last_kid = $elem->child( $LAST_ELEMENT ) + or return $elem; # What? no children? + my $last_kid_loc = $last_kid->location + or return $elem; + # At this point, the scope we have, even if it is not the + # correct scope for the file handle, is big enough that if the + # corresponding close() is outside it, it must be a violation. + # RT #64437 + return $elem if $last_kid_loc->[0] > $end_line; + } + return $elem; # Whatever the top-level PPI::Node was. +} + +sub _get_opened_fh { + my ($tokens) = shift; + + my $is_lexical; + my $fh; + + if ( 2 == @{$tokens} ) { + if ('my' eq $tokens->[0] && + $tokens->[1]->isa('PPI::Token::Symbol') && + $SCALAR_SIGIL eq $tokens->[1]->raw_type) { + + $is_lexical = $LOCAL_LEXICAL; + $fh = $tokens->[1]; + } + } + elsif (1 == @{$tokens}) { + my $argument = _unwrap_block( $tokens->[0] ); + if ( $argument->isa('PPI::Token::Symbol') ) { + my $sigil = $argument->raw_type(); + if ($SCALAR_SIGIL eq $sigil) { + $is_lexical = $NON_LOCAL_LEXICAL; # We need to + # distinguish between + # 'open my $fh ...' and + # 'open $fh ...'. RT #64437 + $fh = $argument; + } + elsif ($GLOB_SIGIL eq $sigil) { + $is_lexical = $NOT_LEXICAL; + $fh = $argument; + } + } + elsif ($argument->isa('PPI::Token::Word') && $argument eq uc $argument) { + $is_lexical = $NOT_LEXICAL; + $fh = $argument; + } + } + + return ($is_lexical, $fh); +} + +sub _unwrap_block { + my ($element) = @_; + + return $element if not $element->isa('PPI::Structure::Block'); + + my @children = $element->schildren(); + return $element if 1 != @children; + my $child = $children[0]; + + return $child if not $child->isa('PPI::Statement'); + + my @grandchildren = $child->schildren(); + return $element if 1 != @grandchildren; + + return $grandchildren[0]; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords redeclared + +=head1 NAME + +Perl::Critic::Policy::InputOutput::RequireBriefOpen - Close filehandles as soon as possible after opening them. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +One way that production systems fail unexpectedly is by running out of +filehandles. Filehandles are a finite resource on every operating +system that I'm aware of, and running out of them is virtually +impossible to recover from. The solution is to not run out in the +first place. What causes programs to run out of filehandles? +Usually, it's leaks: you open a filehandle and forget to close it, or +just wait a really long time before closing it. + +This problem is rarely exposed by test systems, because the tests +rarely run long enough or have enough load to hit the filehandle +limit. So, the best way to avoid the problem is 1) always close all +filehandles that you open and 2) close them as soon as is practical. + +This policy takes note of calls to C where there is no +matching C call within C lines of code. If you really +need to do a lot of processing on an open filehandle, then you can +move that processing to another method like this: + + sub process_data_file { + my ($self, $filename) = @_; + open my $fh, '<', $filename + or croak 'Failed to read datafile ' . $filename . '; ' . $OS_ERROR; + $self->_parse_input_data($fh); + close $fh; + return; + } + sub _parse_input_data { + my ($self, $fh) = @_; + while (my $line = <$fh>) { + ... + } + return; + } + +As a special case, this policy also allows code to return the +filehandle after the C instead of closing it. Just like the +close, however, that C has to be within the right number of +lines. From there, you're on your own to figure out whether the code +is promptly closing the filehandle. + +The STDIN, STDOUT, and STDERR handles are exempt from this policy. + + +=head1 CONFIGURATION + +This policy allows C invocations to be up to C lines after +their corresponding C calls, where C defaults to 9. You +can override this to set it to a different number with the C +setting. To do this, put entries in a F<.perlcriticrc> file like +this: + + [InputOutput::RequireBriefOpen] + lines = 5 + + +=head1 CAVEATS + +=head2 Cnew> + +This policy only looks for explicit C calls. It does not detect +calls to C or Cnew> or the like. + + +=head2 Is it the right lexical? + +We don't currently check for redeclared filehandles. So the following +code is false negative, for example, because the outer scoped +filehandle is not closed: + + open my $fh, '<', $file1 or croak; + if (open my $fh, '<', $file2) { + print <$fh>; + close $fh; + } + +This is a contrived example, but it isn't uncommon for people to use +C<$fh> for the name of the filehandle every time. Perhaps it's time +to think of better variable names... + + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/InputOutput/RequireCheckedClose.pm b/lib/Perl/Critic/Policy/InputOutput/RequireCheckedClose.pm new file mode 100644 index 0000000..2f7528c --- /dev/null +++ b/lib/Perl/Critic/Policy/InputOutput/RequireCheckedClose.pm @@ -0,0 +1,124 @@ +package Perl::Critic::Policy::InputOutput::RequireCheckedClose; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Return value of "close" ignored}; +Readonly::Scalar my $EXPL => q{Check the return value of "close" for success}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'autodie_modules', + description => 'Modules which export autodie.', + default_string => 'autodie', + behavior => 'string list', + }, + ); +} + +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw( core maintenance certrule ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->content() ne 'close'; + return if ! is_unchecked_call( $elem, [ keys %{ $self->{_autodie_modules} } ] ); + + return $self->violation( $DESC, $EXPL, $elem ); + +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords autodie + +=head1 NAME + +Perl::Critic::Policy::InputOutput::RequireCheckedClose - Write C<< my $error = close $fh; >> instead of C<< close $fh; >>. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +The perl builtin I/O function C returns a false value on +failure. That value should be checked to ensure that the close was +successful. + + + my $error = close $filehandle; # ok + close $filehandle or die "unable to close: $!"; # ok + close $filehandle; # not ok + + use autodie qw< :io >; + close $filehandle; # ok + +You can use L, L, or +L to get around +this. Currently, L is not properly treated as a pragma; its +lexical effects aren't taken into account. + + +=head1 CONFIGURATION + +If you create a module that exports C you can tell this policy about +it with the C setting: + + [InputOutput::RequireCheckedSyscalls] + autodie_modules = My::Thing + + +=head1 AUTHOR + +Andrew Moore + +=head1 ACKNOWLEDGMENTS + +This policy module is based heavily on policies written by Jeffrey +Ryan Thalhammer . + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Andrew Moore. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/InputOutput/RequireCheckedOpen.pm b/lib/Perl/Critic/Policy/InputOutput/RequireCheckedOpen.pm new file mode 100644 index 0000000..066b62c --- /dev/null +++ b/lib/Perl/Critic/Policy/InputOutput/RequireCheckedOpen.pm @@ -0,0 +1,124 @@ +package Perl::Critic::Policy::InputOutput::RequireCheckedOpen; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Return value of "open" ignored}; +Readonly::Scalar my $EXPL => q{Check the return value of "open" for success}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'autodie_modules', + description => 'Modules which export autodie.', + default_string => 'autodie', + behavior => 'string list', + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core maintenance certrule ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->content() ne 'open'; + return if ! is_unchecked_call( $elem, [ keys %{ $self->{_autodie_modules} } ] ); + + return $self->violation( $DESC, $EXPL, $elem ); + +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords autodie + +=head1 NAME + +Perl::Critic::Policy::InputOutput::RequireCheckedOpen - Write C<< my $error = open $fh, $mode, $filename; >> instead of C<< open $fh, $mode, $filename; >>. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +The perl builtin I/O function C returns a false value on +failure. That value should always be checked to ensure that the open +was successful. + + + my $error = open( $filehandle, $mode, $filename ); # ok + open( $filehandle, $mode, $filename ) or die "unable to open: $!"; # ok + open( $filehandle, $mode, $filename ); # not ok + + use autodie; + open $filehandle, $mode, $filename; # ok + +You can use L, L, or +L to get around +this. Currently, L is not properly treated as a pragma; its +lexical effects aren't taken into account. + + +=head1 CONFIGURATION + +If you create a module that exports C you can tell this policy about +it with the C setting: + + [InputOutput::RequireCheckedSyscalls] + autodie_modules = My::Thing + + +=head1 AUTHOR + +Andrew Moore + +=head1 ACKNOWLEDGMENTS + +This policy module is based heavily on policies written by Jeffrey +Ryan Thalhammer . + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Andrew Moore. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/InputOutput/RequireCheckedSyscalls.pm b/lib/Perl/Critic/Policy/InputOutput/RequireCheckedSyscalls.pm new file mode 100644 index 0000000..ef325bd --- /dev/null +++ b/lib/Perl/Critic/Policy/InputOutput/RequireCheckedSyscalls.pm @@ -0,0 +1,235 @@ +package Perl::Critic::Policy::InputOutput::RequireCheckedSyscalls; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :booleans :characters :severities :classification + hashify is_perl_bareword }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Return value of flagged function ignored}; +Readonly::Scalar my $EXPL => [208, 278]; + +Readonly::Array my @DEFAULT_FUNCTIONS => qw( + open close print say +); +# I created this list by searching for "return" in perlfunc +Readonly::Array my @BUILTIN_FUNCTIONS => qw( + accept bind binmode chdir chmod chown close closedir connect + dbmclose dbmopen exec fcntl flock fork ioctl kill link listen + mkdir msgctl msgget msgrcv msgsnd open opendir pipe print read + readdir readline readlink readpipe recv rename rmdir say seek seekdir + semctl semget semop send setpgrp setpriority setsockopt shmctl + shmget shmread shutdown sleep socket socketpair symlink syscall + sysopen sysread sysseek system syswrite tell telldir truncate + umask unlink utime wait waitpid +); + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'functions', + description => + 'The set of functions to require checking the return value of.', + default_string => join( $SPACE, @DEFAULT_FUNCTIONS ), + behavior => 'string list', + }, + { + name => 'exclude_functions', + description => + 'The set of functions to not require checking the return value of.', + default_string => $EMPTY, + behavior => 'string list', + }, + { + name => 'autodie_modules', + description => 'Modules which export autodie.', + default_string => 'autodie', + behavior => 'string list', + }, + ); +} + +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw( core maintenance certrule ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub initialize_if_enabled { + my ($self, $config) = @_; + + my @specified_functions = keys %{ $self->{_functions} }; + my @resulting_functions; + + foreach my $function (@specified_functions) { + if ( $function eq ':defaults' ) { + push @resulting_functions, @DEFAULT_FUNCTIONS; + } + elsif ( $function eq ':builtins' ) { + push @resulting_functions, @BUILTIN_FUNCTIONS; + } + else { + push @resulting_functions, $function; + } + } + + my %functions = hashify(@resulting_functions); + + foreach my $function ( keys %{ $self->{_exclude_functions} } ) { + delete $functions{$function}; + } + + $self->{_functions} = \%functions; + + return $TRUE; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + if ( $self->{_functions}->{':all'} ) { + return if is_perl_bareword($elem); + return if $self->{_exclude_functions}->{ $elem->content() }; + } + elsif ( not $self->{_functions}->{ $elem->content() } ) { + return; + } + + return if ! is_unchecked_call( $elem, [ keys %{ $self->{_autodie_modules} } ] ); + + return $self->violation( "$DESC - " . $elem->content(), $EXPL, $elem ); +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords nyah autodie builtins + +=head1 NAME + +Perl::Critic::Policy::InputOutput::RequireCheckedSyscalls - Return value of flagged function ignored. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +This performs identically to InputOutput::RequireCheckedOpen/Close +except that this is configurable to apply to any function, whether +core or user-defined. + +If your module uses L, +L, or L then any functions +wrapped by those modules will not trigger this policy. For example: + + use Fatal qw(open); + open my $fh, $filename; # no violation + close $fh; # yes violation + + use autodie; + open $filehandle, $mode, $filename; # no violation + +Currently, L is not properly treated as a pragma; its +lexical effects aren't taken into account. + + +=head1 CONFIGURATION + +This policy watches for a configurable list of function names. By +default, it applies to C, C, C and C. You can +override this to set it to a different list of functions with the +C and C settings. To do this, put +entries in a F<.perlcriticrc> file like this: + + [InputOutput::RequireCheckedSyscalls] + functions = open opendir read readline readdir close closedir + +We have defined a few shortcuts for creating this list + + [InputOutput::RequireCheckedSyscalls] + functions = :defaults opendir readdir closedir + + [InputOutput::RequireCheckedSyscalls] + functions = :builtins + + [InputOutput::RequireCheckedSyscalls] + functions = :all + +The C<:builtins> shortcut above represents all of the builtin +functions that have error conditions (about 65 of them, many of them +rather obscure). + +You can require checking all builtins except C by combining +the C and C: + + [InputOutput::RequireCheckedSyscalls] + functions = :builtins + exclude_functions = print + +This is a lot easier to read than the alternative. + +The C<:all> is the insane case: you must check the return value of +EVERY function call, even C and C. Yes, this "feature" +is overkill and is wasting CPU cycles on your computer by just +existing. Nyah nyah. I shouldn't code after midnight. + +If you create a module that exports C you can tell this policy about +it with the C setting: + + [InputOutput::RequireCheckedSyscalls] + autodie_modules = My::Thing + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + +This policy module is based heavily on policies written by Andrew +Moore . + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/InputOutput/RequireEncodingWithUTF8Layer.pm b/lib/Perl/Critic/Policy/InputOutput/RequireEncodingWithUTF8Layer.pm new file mode 100644 index 0000000..bf01770 --- /dev/null +++ b/lib/Perl/Critic/Policy/InputOutput/RequireEncodingWithUTF8Layer.pm @@ -0,0 +1,189 @@ +package Perl::Critic::Policy::InputOutput::RequireEncodingWithUTF8Layer; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use version; + +use Perl::Critic::Utils qw{ :severities :ppi }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{I/O layer ":utf8" used}; +Readonly::Scalar my $EXPL => q{Use ":encoding(UTF-8)" to get strict validation}; + +Readonly::Scalar my $THREE_ARGUMENT_OPEN => 3; +Readonly::Hash my %RECOVER_ENCODING => ( + binmode => \&_recover_binmode_encoding, + open => \&_recover_open_encoding, +); + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw(core bugs security) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, $document) = @_; + + my $handler = $RECOVER_ENCODING{ $elem->content() } + or return; # If we don't have a handler, we're not interested. + my $encoding = $handler->( parse_arg_list( $elem ) ) + or return; # If we can't recover an encoding, we give up. + return if $encoding !~ m/ (?: \A | : ) utf8 \b /smxi; # OK + + return $self->violation( $DESC, $EXPL, $elem ); +} + +#----------------------------------------------------------------------------- + +# my $string = _get_argument_string( $arg[1] ); +# +# This subroutine returns the string from the given argument (which must +# be a reference to an array of PPI objects), _PROVIDED_ the array +# contains a single PPI::Token::Quote object. Otherwise it simply +# returns, since we're too stupid to analyze anything else. + +sub _get_argument_string { + my ( $arg ) = @_; + ref $arg eq 'ARRAY' or return; + return if @{ $arg } == 0 || @{ $arg } > 1; + return $arg->[0]->string() if $arg->[0]->isa( 'PPI::Token::Quote' ); + return; +} + +#----------------------------------------------------------------------------- + +# my $encoding = _recover_binmode_encoding( _parse_arg_list( $elem ) ); +# +# This subroutine returns the encoding specified by the given $elem, +# which _MUST_ be the 'binmode' of a binmode() call. + +sub _recover_binmode_encoding { + my ( @args ) = @_; + return _get_argument_string( $args[1] ); +} + +#----------------------------------------------------------------------------- + +# my $encoding = _recover_open_encoding( _parse_arg_list( $elem ) ); +# +# This subroutine returns the encoding specified by the given $elem, +# which _MUST_ be the 'open' of a open() call. + +sub _recover_open_encoding { + my ( @args ) = @_; + @args < $THREE_ARGUMENT_OPEN + and return; + defined( my $string = _get_argument_string( $args[1] ) ) + or return; + $string =~ s/ [+]? (?: < | >{1,2} ) //smx; + return $string; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords PerlIO PerlMonks Wiki + +=head1 NAME + +Perl::Critic::Policy::InputOutput::RequireEncodingWithUTF8Layer - Write C<< open $fh, q{<:encoding(UTF-8)}, $filename; >> instead of C<< open $fh, q{<:utf8}, $filename; >>. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Use of the C<:utf8> I/O layer (as opposed to C<:encoding(UTF8)> or +C<:encoding(UTF-8)>) was suggested in the Perl documentation up to +version 5.8.8. This may be OK for output, but on input C<:utf8> does not +validate the input, leading to unexpected results. + +An exploit based on this behavior of C<:utf8> is exhibited on PerlMonks +at L. The exploit involves a +string read from an external file and sanitized with C, +where C<$1> nonetheless ends up containing shell meta-characters. + +To summarize: + + open $fh, '<:utf8', 'foo.txt'; # BAD + open $fh, '<:encoding(UTF8)', 'foo.txt'; # GOOD + open $fh, '<:encoding(UTF-8)', 'foo.txt'; # BETTER + +See the L documentation for the difference between +C and C. The short version is that C implements the +Unicode standard, and C is liberalized. + +For consistency's sake, this policy checks files opened for output as +well as input. For complete coverage it also checks C calls, +where the direction of operation can not be determined. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 NOTES + +Because C does a static analysis, this policy can not +detect cases like + + my $encoding = ':utf8'; + binmode $fh, $encoding; + +where the encoding is computed. + + +=head1 SEE ALSO + +L + +L + +C + +L + +L + +=head1 AUTHOR + +Thomas R. Wyant, III F + +=head1 COPYRIGHT + +Copyright (c) 2010-2011 Thomas R. Wyant, III + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Miscellanea/ProhibitFormats.pm b/lib/Perl/Critic/Policy/Miscellanea/ProhibitFormats.pm new file mode 100644 index 0000000..41520b1 --- /dev/null +++ b/lib/Perl/Critic/Policy/Miscellanea/ProhibitFormats.pm @@ -0,0 +1,92 @@ +package Perl::Critic::Policy::Miscellanea::ProhibitFormats; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Format used}; +Readonly::Scalar my $EXPL => [ 449 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core maintenance pbp certrule ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + return if $elem->content() ne 'format'; + return if ! is_function_call( $elem ); + return $self->violation( $DESC, $EXPL, $elem ); +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Miscellanea::ProhibitFormats - Do not use C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Formats are one of the oldest features of Perl. Unfortunately, they +suffer from several limitations. Formats are static and cannot be +easily defined at run time. Also, formats depend on several obscure +global variables. + +For more modern reporting tools, consider using one of the template +frameworks like L or try the +L module. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Miscellanea/ProhibitTies.pm b/lib/Perl/Critic/Policy/Miscellanea/ProhibitTies.pm new file mode 100644 index 0000000..f4e8514 --- /dev/null +++ b/lib/Perl/Critic/Policy/Miscellanea/ProhibitTies.pm @@ -0,0 +1,90 @@ +package Perl::Critic::Policy::Miscellanea::ProhibitTies; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Tied variable used}; +Readonly::Scalar my $EXPL => [ 451 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core pbp maintenance) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + return if $elem->content() ne 'tie'; + return if ! is_function_call( $elem ); + return $self->violation( $DESC, $EXPL, $elem ); +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Miscellanea::ProhibitTies - Do not use C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway discourages using C to bind Perl primitive variables to +user-defined objects. Unless the tie is done close to where the +object is used, other developers probably won't know that the variable +has special behavior. If you want to encapsulate complex behavior, +just use a proper object or subroutine. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Miscellanea/ProhibitUnrestrictedNoCritic.pm b/lib/Perl/Critic/Policy/Miscellanea/ProhibitUnrestrictedNoCritic.pm new file mode 100644 index 0000000..95bd88d --- /dev/null +++ b/lib/Perl/Critic/Policy/Miscellanea/ProhibitUnrestrictedNoCritic.pm @@ -0,0 +1,137 @@ +package Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw<:severities :booleans>; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Unrestricted '## no critic' annotation}; +Readonly::Scalar my $EXPL => q{Only disable the Policies you really need to disable}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core maintenance ) } +sub applies_to { return 'PPI::Document' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $doc, undef ) = @_; + + # If for some reason $doc is not a P::C::Document, then all bets are off + return if not $doc->isa('Perl::Critic::Document'); + + my @violations = (); + for my $annotation ($doc->annotations()) { + if ($annotation->disables_all_policies()) { + my $elem = $annotation->element(); + push @violations, $self->violation($DESC, $EXPL, $elem); + } + } + + return @violations; +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords syntaxes + +=head1 NAME + +Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic - Forbid a bare C<## no critic> + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +A bare C<## no critic> annotation will disable B the active Policies. This +creates holes for other, unintended violations to appear in your code. It is +better to disable B the particular Policies that you need to get around. +By putting Policy names in a comma-separated list after the C<## no critic> +annotation, then it will only disable the named Policies. Policy names are +matched as regular expressions, so you can use shortened Policy names, or +patterns that match several Policies. This Policy generates a violation any +time that an unrestricted C<## no critic> annotation appears. + + ## no critic # not ok + ## no critic '' # not ok + ## no critic () # not ok + ## no critic qw() # not ok + + ## no critic (Policy1, Policy2) # ok + ## no critic (Policy1 Policy2) # ok (can use spaces to separate) + ## no critic qw(Policy1 Policy2) # ok (the preferred style) + + +=head1 NOTE + +Unfortunately, L is very sloppy about +parsing the Policy names that appear after a C<##no critic> +annotation. For example, you might be using one of these +broken syntaxes... + + ## no critic Policy1 Policy2 + ## no critic 'Policy1, Policy2' + ## no critic "Policy1, Policy2" + ## no critic "Policy1", "Policy2" + +In all of these cases, Perl::Critic will silently disable B Policies, +rather than just the ones you requested. But if you use the +C Policy, all of these will generate +violations. That way, you can track them down and correct them to use +the correct syntax, as shown above in the L<"DESCRIPTION">. If you've +been using the syntax that is shown throughout the Perl::Critic +documentation for the last few years, then you should be fine. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2008-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################### +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Miscellanea/ProhibitUselessNoCritic.pm b/lib/Perl/Critic/Policy/Miscellanea/ProhibitUselessNoCritic.pm new file mode 100644 index 0000000..2061da2 --- /dev/null +++ b/lib/Perl/Critic/Policy/Miscellanea/ProhibitUselessNoCritic.pm @@ -0,0 +1,160 @@ +package Perl::Critic::Policy::Miscellanea::ProhibitUselessNoCritic; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use List::MoreUtils qw< none >; + +use Perl::Critic::Utils qw{ :severities :classification hashify }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Useless '## no critic' annotation}; +Readonly::Scalar my $EXPL => q{This annotation can be removed}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core maintenance) } +sub applies_to { return 'PPI::Document' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, undef, $doc ) = @_; + + # If for some reason $doc is not a P::C::Document, then all bets are off + return if not $doc->isa('Perl::Critic::Document'); + + my @violations = (); + my @suppressed_viols = $doc->suppressed_violations(); + + for my $ann ( $doc->annotations() ) { + if ( none { _annotation_suppresses_violation($ann, $_) } @suppressed_viols ) { + push @violations, $self->violation($DESC, $EXPL, $ann->element()); + } + } + + return @violations; +} + +#----------------------------------------------------------------------------- + +sub _annotation_suppresses_violation { + my ($annotation, $violation) = @_; + + my $policy_name = $violation->policy(); + my $line = $violation->location()->[0]; + + return $annotation->disables_line($line) + && $annotation->disables_policy($policy_name); +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::Miscellanea::ProhibitUselessNoCritic - Remove ineffective "## no critic" annotations. + + +=head1 AFFILIATION + +This Policy is part of the core L distribution. + + +=head1 DESCRIPTION + +Sometimes, you may need to use a C<"## no critic"> annotation to work around +a false-positive bug in L. But eventually, that bug might get +fixed, leaving your code with extra C<"## no critic"> annotations lying about. +Or you may use them to locally disable a Policy, but then later decide to +permanently remove that Policy entirely from your profile, making some of +those C<"## no critic"> annotations pointless. Or, you may accidentally +disable too many Policies at once, creating an opportunity for new +violations to slip in unnoticed. + +This Policy will emit violations if you have a C<"## no critic"> annotation in +your source code that does not actually suppress any violations given your +current profile. To resolve this, you should either remove the annotation +entirely, or adjust the Policy name patterns in the annotation to match only +the Policies that are actually being violated in your code. + + +=head1 EXAMPLE + +For example, let's say I have a regex, but I don't want to use the C flag, +which violates the C policy. +In the following code, the C<"## no critic"> annotation will suppress +violations of that Policy and ALL Policies that match +C + + my $re = qr/foo bar baz/ms; ## no critic (RegularExpressions) + +However, this creates a potential loop-hole for someone to introduce +additional violations in the future, without explicitly acknowledging them. +This Policy is designed to catch these situations by warning you that you've +disabled more Policies than the situation really requires. The above code +should be remedied like this: + + my $re = qr/foo bar baz/ms; ## no critic (RequireExtendedFormatting) + +Notice how the C pattern more precisely matches +the name of the Policy that I'm trying to suppress. + + +=head1 NOTE + +Changing your F<.perlcriticrc> file and disabling policies globally or running +at a higher (i.e. less restrictive) severity level may cause this Policy to +emit additional violations. So you might want to defer using this Policy +until you have a fairly stable profile. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 ACKNOWLEDGMENT + +This Policy was inspired by Adam Kennedy's article at +L. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Modules/ProhibitAutomaticExportation.pm b/lib/Perl/Critic/Policy/Modules/ProhibitAutomaticExportation.pm new file mode 100644 index 0000000..24eea30 --- /dev/null +++ b/lib/Perl/Critic/Policy/Modules/ProhibitAutomaticExportation.pm @@ -0,0 +1,158 @@ +package Perl::Critic::Policy::Modules::ProhibitAutomaticExportation; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use List::MoreUtils qw(any); +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Symbols are exported by default}; +Readonly::Scalar my $EXPL => q{Use '@EXPORT_OK' or '%EXPORT_TAGS' instead}; ## no critic (RequireInterpolation) + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core bugs ) } +sub applies_to { return 'PPI::Document' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + + if ( _uses_exporter($doc) ) { + if ( my $exp = _has_exports($doc) ) { + return $self->violation( $DESC, $EXPL, $exp ); + } + } + return; #ok +} + +#----------------------------------------------------------------------------- + +sub _uses_exporter { + my ($doc) = @_; + + my $includes_ref = $doc->find('PPI::Statement::Include'); + return if not $includes_ref; + + # This covers both C and C + return scalar grep { m/ \b Exporter \b/xms } @{ $includes_ref }; +} + +#------------------ + +sub _has_exports { + my ($doc) = @_; + + my $wanted = + sub { _our_export(@_) or _vars_export(@_) or _package_export(@_) }; + + return $doc->find_first( $wanted ); +} + +#------------------ + +sub _our_export { + my (undef, $elem) = @_; + + $elem->isa('PPI::Statement::Variable') or return 0; + $elem->type() eq 'our' or return 0; + + return any { $_ eq '@EXPORT' } $elem->variables(); ## no critic(RequireInterpolationOfMetachars) +} + +#------------------ + +sub _vars_export { + my (undef, $elem) = @_; + + $elem->isa('PPI::Statement::Include') or return 0; + $elem->pragma() eq 'vars' or return 0; + + return $elem =~ m{ \@EXPORT \b }xms; #Crude, but usually works +} + +#------------------ + +sub _package_export { + my (undef, $elem) = @_; + + $elem->isa('PPI::Token::Symbol') or return 0; + + return $elem =~ m{ \A \@ \S+ ::EXPORT \z }xms; + #TODO: ensure that it is in _this_ package! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Modules::ProhibitAutomaticExportation - Export symbols via C<@EXPORT_OK> or C<%EXPORT_TAGS> instead of C<@EXPORT>. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +When using L, symbols placed in the C<@EXPORT> +variable are automatically exported into the caller's namespace. +Although convenient, this practice is not polite, and may cause +serious problems if the caller declares the same symbols. The best +practice is to place your symbols in C<@EXPORT_OK> or C<%EXPORT_TAGS> +and let the caller choose exactly which symbols to export. + + package Foo; + + use Exporter 'import'; + our @EXPORT = qw(foo $bar @baz); # not ok + our @EXPORT_OK = qw(foo $bar @baz); # ok + our %EXPORT_TAGS = ( all => [ qw(foo $bar @baz) ] ); # ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Modules/ProhibitConditionalUseStatements.pm b/lib/Perl/Critic/Policy/Modules/ProhibitConditionalUseStatements.pm new file mode 100644 index 0000000..281c3f6 --- /dev/null +++ b/lib/Perl/Critic/Policy/Modules/ProhibitConditionalUseStatements.pm @@ -0,0 +1,203 @@ +package Perl::Critic::Policy::Modules::ProhibitConditionalUseStatements; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :booleans :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Conditional "use" statement}; +Readonly::Scalar my $EXPL => q{Use "require" to conditionally include a module.}; + +# operators + +Readonly::Hash my %OPS => map { $_ => 1 } qw( || && or and ); + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core bugs ) } +sub applies_to { return 'PPI::Statement::Include' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + return $self->violation( $DESC, $EXPL, $elem ) if $elem->type() eq 'use' + && !$elem->pragma() + && $elem->module() + && $self->_is_in_conditional_logic($elem); + return; +} + +#----------------------------------------------------------------------------- + +# is this a non-string eval statement + +sub _is_eval { + my ( $self, $elem ) = @_; + $elem->isa('PPI::Statement') or return; + my $first_elem = $elem->first_element(); + return $TRUE if $first_elem->isa('PPI::Token::Word') + && $first_elem eq 'eval'; + return; +} + +#----------------------------------------------------------------------------- + +# is this in a conditional do block + +sub _is_in_do_conditional_block { + my ( $self, $elem ) = @_; + return if !$elem->isa('PPI::Structure::Block'); + my $prev_sibling = $elem->sprevious_sibling() or return; + if ($prev_sibling->isa('PPI::Token::Word') && $prev_sibling eq 'do') { + my $next_sibling = $elem->snext_sibling(); + return $TRUE if $next_sibling + && $next_sibling->isa('PPI::Token::Word'); + $prev_sibling = $prev_sibling->sprevious_sibling() or return; + return $TRUE if $prev_sibling->isa('PPI::Token::Operator') + && $OPS{$prev_sibling->content()}; + } + return; +} + +#----------------------------------------------------------------------------- + +# is this a compound statement + +sub _is_compound_statement { + my ( $self, $elem ) = @_; + return if !$elem->isa('PPI::Statement::Compound'); + return $TRUE if $elem->type() ne 'continue'; # exclude bare blocks + return; +} + +#----------------------------------------------------------------------------- + +# is this contained in conditional logic + +sub _is_in_conditional_logic { + my ( $self, $elem ) = @_; + while ($elem = $elem->parent()) { + last if $elem->isa('PPI::Document'); + return $TRUE if $self->_is_compound_statement($elem) + || $self->_is_eval($elem) + || $self->_is_in_do_conditional_block($elem); + } + return; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords evals + +=head1 NAME + +Perl::Critic::Policy::Modules::ProhibitConditionalUseStatements - Avoid putting conditional logic around compile-time includes. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Modules included via "use" are loaded at compile-time. Placing conditional +logic around the "use" statement has no effect on whether the module will be +loaded. Doing so can also serve to confuse the reader as to the author's +original intent. + +If you need to conditionally load a module you should be using "require" +instead. + +This policy will catch the following forms of conditional "use" statements: + + # if-elsif-else + if ($a == 1) { use Module; } + if ($a == 1) { } elsif ($a == 2) { use Module; } + if ($a == 1) { } else { use Module; } + + # for/foreach + for (1..$a) { use Module; } + foreach (@a) { use Module; } + + # while + while ($a == 1) { use Module; } + + # unless + unless ($a == 1) { use Module; } + + # until + until ($a == 1) { use Module; } + + # do-condition + do { use Module; } if $a == 1; + do { use Module; } while $a == 1; + do { use Module; } unless $a == 1; + do { use Module; } until $a == 1; + + # operator-do + $a == 1 || do { use Module; }; + $a == 1 && do { use Module; }; + $a == 1 or do { use Module; }; + $a == 1 and do { use Module; }; + + # non-string eval + eval { use Module; }; + +Including a module via "use" in bare blocks, standalone do blocks, or +string evals is allowed. + + # bare block + { use Module; } + + # do + do { use Module; } + + # string eval + eval "use Module"; + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Peter Guzis + + +=head1 COPYRIGHT + +Copyright (c) 2010-2011 Peter Guzis. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Modules/ProhibitEvilModules.pm b/lib/Perl/Critic/Policy/Modules/ProhibitEvilModules.pm new file mode 100644 index 0000000..4e22a82 --- /dev/null +++ b/lib/Perl/Critic/Policy/Modules/ProhibitEvilModules.pm @@ -0,0 +1,371 @@ +package Perl::Critic::Policy::Modules::ProhibitEvilModules; + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); +use Readonly; + +use Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue + qw{ throw_policy_value }; +use Perl::Critic::Utils qw{ + :booleans :characters :severities :data_conversion +}; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => q{Find an alternative module}; + +Readonly::Scalar my $MODULE_NAME_REGEX => + qr< + \b + [[:alpha:]_] + (?: + (?: \w | :: )* + \w + )? + \b + >xms; +Readonly::Scalar my $REGULAR_EXPRESSION_REGEX => qr< [/] ( [^/]+ ) [/] >xms; +Readonly::Scalar my $DESCRIPTION_REGEX => qr< [{] ( [^}]+ ) [}] >xms; + +# It's kind of unfortunate that I had to put capturing parentheses in the +# component regexes above, because they're not visible here and so make +# figuring out the positions of captures hard. Too bad we can't make the +# minimum perl version 5.10. :] +Readonly::Scalar my $MODULES_REGEX => + qr< + \A + \s* + (?: + ( $MODULE_NAME_REGEX ) + | $REGULAR_EXPRESSION_REGEX + ) + (?: \s* $DESCRIPTION_REGEX )? + \s* + >xms; + +Readonly::Scalar my $MODULES_FILE_LINE_REGEX => + qr< + \A + \s* + (?: + ( $MODULE_NAME_REGEX ) + | $REGULAR_EXPRESSION_REGEX + ) + \s* + ( \S (?: .* \S )? )? + \s* + \z + >xms; + +Readonly::Scalar my $DEFAULT_MODULES => + join + $SPACE, + map { "$_ {Found use of $_. This module is deprecated by the Perl 5 Porters.}" } + qw< Class::ISA Pod::Plainer Shell Switch >; + +# Indexes in the arrays of regexes for the "modules" option. +Readonly::Scalar my $INDEX_REGEX => 0; +Readonly::Scalar my $INDEX_DESCRIPTION => 1; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'modules', + description => 'The names of or patterns for modules to forbid.', + default_string => $DEFAULT_MODULES, + parser => \&_parse_modules, + }, + { + name => 'modules_file', + description => 'A file containing names of or patterns for modules to forbid.', + default_string => $EMPTY, + parser => \&_parse_modules_file, + }, + ); +} + +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw( core bugs certrule ) } +sub applies_to { return 'PPI::Statement::Include' } + +#----------------------------------------------------------------------------- + +sub _parse_modules { + my ($self, $parameter, $config_string) = @_; + + my $module_specifications = + defined $config_string + ? $config_string + : $parameter->get_default_string(); + + return if not $module_specifications; + return if $module_specifications =~ m< \A \s* \z >xms; + + while ( $module_specifications =~ s< $MODULES_REGEX ><>xms ) { + my ($module, $regex_string, $description) = ($1, $2, $3); + + $self->_handle_module_specification( + module => $module, + regex_string => $regex_string, + description => $description, + option_name => 'modules', + option_value => $config_string, + ); + } + + if ($module_specifications) { + throw_policy_value + policy => $self->get_short_name(), + option_name => 'modules', + option_value => $config_string, + message_suffix => + qq{contains unparseable data: "$module_specifications"}; + } + + return; +} + +sub _parse_modules_file { + my ($self, $parameter, $config_string) = @_; + + return if not $config_string; + return if $config_string =~ m< \A \s* \z >xms; + + open my $handle, '<', $config_string + or throw_policy_value + policy => $self->get_short_name(), + option_name => 'modules_file', + option_value => $config_string, + message_suffix => + qq; + while ( my $line = <$handle> ) { + $self->_handle_module_specification_on_line($line, $config_string); + } + close $handle or warn qq; + + return; +} + +sub _handle_module_specification_on_line { + my ($self, $line, $config_string) = @_; + + $line =~ s< [#] .* \z ><>xms; + $line =~ s< \s+ \z ><>xms; + $line =~ s< \A \s+ ><>xms; + + return if not $line; + + if ( $line =~ s< $MODULES_FILE_LINE_REGEX ><>xms ) { + my ($module, $regex_string, $description) = ($1, $2, $3); + + $self->_handle_module_specification( + module => $module, + regex_string => $regex_string, + description => $description, + option_name => 'modules_file', + option_value => $config_string, + ); + } + else { + throw_policy_value + policy => $self->get_short_name(), + option_name => 'modules_file', + option_value => $config_string, + message_suffix => + qq{contains unparseable data: "$line"}; + } + + return; +} + +sub _handle_module_specification { + my ($self, %arguments) = @_; + + my $description = $arguments{description} || $EMPTY; + + if ( my $regex_string = $arguments{regex_string} ) { + # These are module name patterns (e.g. /Acme/) + my $actual_regex; + + eval { $actual_regex = qr/$regex_string/; 1 } ## no critic (ExtendedFormatting, LineBoundaryMatching, DotMatchAnything) + or throw_policy_value + policy => $self->get_short_name(), + option_name => $arguments{option_name}, + option_value => $arguments{option_value}, + message_suffix => + qq{contains an invalid regular expression: "$regex_string"}; + + # Can't use a hash due to stringification, so this is an AoA. + $self->{_evil_modules_regexes} ||= []; + + push + @{ $self->{_evil_modules_regexes} }, + [ $actual_regex, $description ]; + } + else { + # These are literal module names (e.g. Acme::Foo) + $self->{_evil_modules} ||= {}; + $self->{_evil_modules}{ $arguments{module} } = $description; + } + + return; +} + +#----------------------------------------------------------------------------- + +sub initialize_if_enabled { + my ($self, $config) = @_; + + # Disable if no modules are specified; there's no point in running if + # there aren't any. + return + exists $self->{_evil_modules} + || exists $self->{_evil_modules_regexes}; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + my $module = $elem->module(); + return if not $module; + + my $evil_modules = $self->{_evil_modules}; + my $evil_modules_regexes = $self->{_evil_modules_regexes}; + my $description; + + if ( exists $evil_modules->{$module} ) { + $description = $evil_modules->{ $module }; + } + else { + REGEX: + foreach my $regex ( @{$evil_modules_regexes} ) { + if ( $module =~ $regex->[$INDEX_REGEX] ) { + $description = $regex->[$INDEX_DESCRIPTION]; + last REGEX; + } + } + } + + if (defined $description) { + $description ||= qq; + + return $self->violation( $description, $EXPL, $elem ); + } + + return; # ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Modules::ProhibitEvilModules - Ban modules that aren't blessed by your shop. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Use this policy if you wish to prohibit the use of specific modules. +These may be modules that you feel are deprecated, buggy, unsupported, +insecure, or just don't like. + + +=head1 CONFIGURATION + +The set of prohibited modules is configurable via the C and +C options. + +The value of C should be a string of space-delimited, fully +qualified module names and/or regular expressions. An example of +prohibiting two specific modules in a F<.perlcriticrc> file: + + [Modules::ProhibitEvilModules] + modules = Getopt::Std Autoload + +Regular expressions are identified by values beginning and ending with +slashes. Any module with a name that matches C will be +forbidden. For example: + + [Modules::ProhibitEvilModules] + modules = /Acme::/ + +would cause all modules that match C to be forbidden. + +In addition, you can override the default message ("Prohibited module +"I" used") with your own, in order to give suggestions for +alternative action. To do so, put your message in curly braces after +the module name or regular expression. Like this: + + [Modules::ProhibitEvilModules] + modules = Fatal {Found use of Fatal. Use autodie instead} /Acme::/ {We don't use joke modules} + +Similarly, the C option gives the name of a file +containing specifications for prohibited modules. Only one module +specification is allowed per line and comments start with an octothorp +and run to end of line; no curly braces are necessary for delimiting +messages: + + Evil # Prohibit the "Evil" module and use the default message. + + # Prohibit the "Fatal" module and give a replacement message. + Fatal Found use of Fatal. Use autodie instead. + + # Use a regular expression. + /Acme::/ We don't use joke modules. + +By default, the modules that have been deprecated by the Perl 5 Porters are +reported; at the time of writing these are L, +L, L, and L. +Specifying a value for the C option will override this. + + +=head1 NOTES + +Note that this policy doesn't apply to pragmas. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Modules/ProhibitExcessMainComplexity.pm b/lib/Perl/Critic/Policy/Modules/ProhibitExcessMainComplexity.pm new file mode 100644 index 0000000..21c882d --- /dev/null +++ b/lib/Perl/Critic/Policy/Modules/ProhibitExcessMainComplexity.pm @@ -0,0 +1,153 @@ +package Perl::Critic::Policy::Modules::ProhibitExcessMainComplexity; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use Perl::Critic::Utils::McCabe qw{ calculate_mccabe_of_main }; + +use base 'Perl::Critic::Policy'; + +#----------------------------------------------------------------------------- + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => q{Consider refactoring}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'max_mccabe', + description => 'The maximum complexity score allowed.', + default_string => '20', + behavior => 'integer', + integer_minimum => 1, + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw(core complexity maintenance) } +sub applies_to { return 'PPI::Document' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $doc, undef ) = @_; + + my $score = calculate_mccabe_of_main( $doc ); + + # Is it too complex? + return if $score <= $self->{_max_mccabe}; + + my $desc = qq{Main code has high complexity score ($score)}; + return $self->violation( $desc, $EXPL, $doc ); +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords McCabe + +=head1 NAME + +Perl::Critic::Policy::Modules::ProhibitExcessMainComplexity - Minimize complexity in code that is B of subroutines. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +All else being equal, complicated code is more error-prone and more +expensive to maintain than simpler code. The first step towards +managing complexity is to establish formal complexity metrics. One +such metric is the McCabe score, which describes the number of +possible paths through a block of code. This Policy approximates the +McCabe score by summing the number of conditional statements and +operators within a block of code. Research has shown that a McCabe +score higher than 20 is a sign of high-risk, potentially untestable +code. See L for +some discussion about the McCabe number and other complexity metrics. + +Whereas +L +scores the complexity of each subroutine, this Policy scores the total +complexity of all the code that is B of any subroutine +declaration. + +The usual prescription for reducing complexity is to refactor code +into smaller subroutines. Mark Dominus book "Higher Order Perl" also +describes callbacks, recursion, memoization, iterators, and other +techniques that help create simple and extensible Perl code. + + +=head1 CONFIGURATION + +The maximum acceptable McCabe score can be set with the C + +configuration item. If the sum of all code B any subroutine has a +McCabe score higher than this number, it will generate a Policy violation. +The default is 20. An example section for a F<.perlcriticrc>: + + [Modules::ProhibitExcessMainComplexity] + max_mccabe = 30 + + +=head1 NOTES + + + "Everything should be made as simple as possible, but no simpler." + + -- Albert Einstein + + +Complexity is subjective, but formal complexity metrics are still +incredibly valuable. Every problem has an inherent level of +complexity, so it is not necessarily optimal to minimize the McCabe +number. So don't get offended if your code triggers this Policy. +Just consider if there B be a simpler way to get the job done. + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Modules/ProhibitMultiplePackages.pm b/lib/Perl/Critic/Policy/Modules/ProhibitMultiplePackages.pm new file mode 100644 index 0000000..5783186 --- /dev/null +++ b/lib/Perl/Critic/Policy/Modules/ProhibitMultiplePackages.pm @@ -0,0 +1,91 @@ +package Perl::Critic::Policy::Modules::ProhibitMultiplePackages; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Multiple "package" declarations}; +Readonly::Scalar my $EXPL => q{Limit to one per file}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core bugs ) } +sub applies_to { return 'PPI::Document' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + my $nodes_ref = $doc->find('PPI::Statement::Package'); + return if !$nodes_ref; + my @matches = @{$nodes_ref} > 1 ? @{$nodes_ref}[ 1 .. $#{$nodes_ref} ] :(); + + return map {$self->violation($DESC, $EXPL, $_)} @matches; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Modules::ProhibitMultiplePackages - Put packages (especially subclasses) in separate files. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway doesn't specifically mention this, but I find it annoying when +there are multiple packages in the same file. When searching for +methods or keywords in your editor, it makes it hard to find the right +chunk of code, especially if each package is a subclass of the same +base. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Modules/RequireBarewordIncludes.pm b/lib/Perl/Critic/Policy/Modules/RequireBarewordIncludes.pm new file mode 100644 index 0000000..d570f20 --- /dev/null +++ b/lib/Perl/Critic/Policy/Modules/RequireBarewordIncludes.pm @@ -0,0 +1,125 @@ +package Perl::Critic::Policy::Modules::RequireBarewordIncludes; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => q{Use a bareword instead}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw(core portability) } +sub applies_to { return 'PPI::Statement::Include' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + my $child = $elem->schild(1); + return if !$child; + + if ( $child->isa('PPI::Token::Quote') ) { + my $type = $elem->type; + my $desc = qq{"$type" statement with library name as string}; + return $self->violation( $desc, $EXPL, $elem ); + } + return; #ok! +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Modules::RequireBarewordIncludes - Write C instead of C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +When including another module (or library) via the C or +C statements, it is best to identify the module (or library) +using a bareword rather than an explicit path. This is because paths +are usually not portable from one machine to another. Also, Perl +automatically assumes that the filename ends in '.pm' when the library +is expressed as a bareword. So as a side-effect, this Policy +encourages people to write '*.pm' modules instead of the old-school +'*.pl' libraries. + + use 'My/Perl/Module.pm'; #not ok + use My::Perl::Module; #ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 NOTES + +This Policy is a replacement for C, which +completely banned the use of C for the sake of eliminating +the old '*.pl' libraries from Perl4. Upon further consideration, I +realized that C is quite useful and necessary to enable +run-time loading. Thus, C does allow you to +use C, but still encourages you to write '*.pm' modules. + +Sometimes, you may want to load modules at run-time, but you don't +know at design-time exactly which module you will need to load +(L is an example of this). In that case, +just attach the C<'## no critic'> annotation like so: + + require $module_name; ## no critic + + +=head1 CREDITS + +Chris Dolan was instrumental in identifying the +correct motivation for and behavior of this Policy. Thanks Chris. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Modules/RequireEndWithOne.pm b/lib/Perl/Critic/Policy/Modules/RequireEndWithOne.pm new file mode 100644 index 0000000..d7ac3de --- /dev/null +++ b/lib/Perl/Critic/Policy/Modules/RequireEndWithOne.pm @@ -0,0 +1,113 @@ +package Perl::Critic::Policy::Modules::RequireEndWithOne; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => q{Must end with a recognizable true value}; +Readonly::Scalar my $DESC => q{Module does not end with "1;"}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core bugs pbp certrule ) } +sub applies_to { return 'PPI::Document' } + +#----------------------------------------------------------------------------- + +sub prepare_to_scan_document { + my ( $self, $document ) = @_; + + return $document->is_module(); # Must be a library or module. +} + +sub violates { + my ( $self, $elem, $doc ) = @_; + + # Last statement should be just "1;" + my @significant = grep { _is_code($_) } $doc->schildren(); + my $match = $significant[-1]; + return if !$match; + return if ((ref $match) eq 'PPI::Statement' && + $match =~ m{\A 1 \s* ; \z}xms ); + + # Must be a violation... + return $self->violation( $DESC, $EXPL, $match ); +} + +sub _is_code { + my $elem = shift; + return ! ( $elem->isa('PPI::Statement::End') + || $elem->isa('PPI::Statement::Data')); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Modules::RequireEndWithOne - End each module with an explicitly C<1;> instead of some funky expression. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +All files included via C or C must end with a true value +to indicate to the caller that the include was successful. The +standard practice is to conclude your .pm files with C<1;>, but some +authors like to get clever and return some other true value like +C. We cannot tolerate such frivolity! OK, +we can, but we don't recommend it since it confuses the newcomers. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Chris Dolan C + +Some portions cribbed from +L. + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Chris Dolan and Imaginative Software Systems. All +rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Modules/RequireExplicitPackage.pm b/lib/Perl/Critic/Policy/Modules/RequireExplicitPackage.pm new file mode 100644 index 0000000..46dde12 --- /dev/null +++ b/lib/Perl/Critic/Policy/Modules/RequireExplicitPackage.pm @@ -0,0 +1,189 @@ +package Perl::Critic::Policy::Modules::RequireExplicitPackage; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :booleans :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => q{Violates encapsulation}; +Readonly::Scalar my $DESC => q{Code not contained in explicit package}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'exempt_scripts', + description => q{Don't require programs to contain a package statement.}, + default_string => '1', + behavior => 'boolean', + }, + { + name => 'allow_import_of', + description => q{Allow the specified modules to be imported outside a package}, + behavior => 'string list', + }, + ); +} + +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core bugs ) } +sub applies_to { return 'PPI::Document' } + +sub default_maximum_violations_per_document { return 1; } + +#----------------------------------------------------------------------------- + +sub prepare_to_scan_document { + my ( $self, $document ) = @_; + + return ! $self->{_exempt_scripts} || $document->is_module(); +} + +sub violates { + my ( $self, $elem, $doc ) = @_; + + # Find the first 'package' statement + my $package_stmnt = $doc->find_first( 'PPI::Statement::Package' ); + my $package_line = $package_stmnt ? $package_stmnt->location()->[0] : undef; + + # Find all statements that aren't 'package' statements + my $stmnts_ref = $doc->find( 'PPI::Statement' ); + return if !$stmnts_ref; + my @non_packages = grep { + $self->_is_statement_of_interest( $_ ) + } @{$stmnts_ref}; + return if !@non_packages; + + # If the 'package' statement is not defined, or the other + # statements appear before the 'package', then it violates. + + my @viols = (); + for my $stmnt ( @non_packages ) { + my $stmnt_line = $stmnt->location()->[0]; + if ( (! defined $package_line) || ($stmnt_line < $package_line) ) { + push @viols, $self->violation( $DESC, $EXPL, $stmnt ); + } + } + + return @viols; +} + +sub _is_statement_of_interest { + my ( $self, $elem ) = @_; + + $elem + or return $FALSE; + + $elem->isa( 'PPI::Statement::Package' ) + and return $FALSE; + + if ( $elem->isa( 'PPI::Statement::Include' ) ) { + if ( my $module = $elem->module() ) { + $self->{_allow_import_of}{$module} + and return $FALSE; + } + } + + return $TRUE; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Modules::RequireExplicitPackage - Always make the C explicit. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +In general, the first statement of any Perl module or library should +be a C statement. Otherwise, all the code that comes before +the C statement is getting executed in the caller's package, +and you have no idea who that is. Good encapsulation and common +decency require your module to keep its innards to itself. + +There are some valid reasons for not having a C statement at +all. But make sure you understand them before assuming that you +should do it too. + +The maximum number of violations per document for this policy defaults +to 1. + + + +=head1 CONFIGURATION + +As for programs, most people understand that the default package is +C
, so this Policy doesn't apply to files that begin with a perl +shebang. If you want to require an explicit C declaration in +all files, including programs, then add the following to your +F<.perlcriticrc> file + + [Modules::RequireExplicitPackage] + exempt_scripts = 0 + +Some users may find it desirable to exempt the load of specific modules +from this policy. For example, Perl does not support Unicode module +names because of portability problems. Users who are not concerned about +this and intend to use C module names will need to specify +C before the package declaration. To do this, add the +following to your F<.perlcriticrc> file + + [Modules::RequireExplicitPackage] + allow_import_of = utf8 + +The C configuration option takes multiple module names, +separated by spaces. + + +=head1 IMPORTANT CHANGES + +This policy was formerly called C which +sounded a bit odd. If you get lots of "Cannot load policy module" +errors, then you probably need to change C to +C in your F<.perlcriticrc> file. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Modules/RequireFilenameMatchesPackage.pm b/lib/Perl/Critic/Policy/Modules/RequireFilenameMatchesPackage.pm new file mode 100644 index 0000000..3da17d3 --- /dev/null +++ b/lib/Perl/Critic/Policy/Modules/RequireFilenameMatchesPackage.pm @@ -0,0 +1,156 @@ +package Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use File::Spec; + +use Perl::Critic::Utils qw{ :characters :severities }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Package declaration must match filename}; +Readonly::Scalar my $EXPL => q{Correct the filename or package statement}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw(core bugs) } +sub applies_to { return 'PPI::Document' } + +#----------------------------------------------------------------------------- + +sub prepare_to_scan_document { + my ( $self, $document ) = @_; + return $document->is_module(); # Must be a library or module. +} + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, $doc) = @_; + + # 'Foo::Bar' -> ('Foo', 'Bar') + my $pkg_node = $doc->find_first('PPI::Statement::Package'); + return if not $pkg_node; + my $pkg = $pkg_node->namespace(); + return if $pkg eq 'main'; + my @pkg_parts = split m/(?:\'|::)/xms, $pkg; + + + # 'lib/Foo/Bar.pm' -> ('lib', 'Foo', 'Bar') + my $filename = $pkg_node->logical_filename() || $doc->filename(); + return if not $filename; + + my @path = File::Spec->splitpath($filename); + $filename = $path[2]; + $filename =~ s/ [.] \w+ \z //xms; + my @path_parts = + grep {$_ ne $EMPTY} File::Spec->splitdir($path[1]), $filename; + + + # To succeed, at least the lastmost must match + # Beyond that, the search terminates if a dirname is an impossible package name + my $matched_any; + while (@pkg_parts && @path_parts) { + my $pkg_part = pop @pkg_parts; + my $path_part = pop @path_parts; + if ($pkg_part eq $path_part) { + $matched_any = 1; + next; + } + + # if it's a path that's not a possible package (like 'Foo-Bar-1.00'), that's OK + last if ($path_part =~ m/\W/xms); + + # Mismatched name + return $self->violation( $DESC, $EXPL, $pkg_node ); + } + + return if $matched_any; + return $self->violation( $DESC, $EXPL, $pkg_node ); +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage - Package declaration must match filename. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +The package declaration should always match the name of the file that contains +it. For example, C should be in a file called C. +This makes it easier for developers to figure out which file a symbol comes +from when they see it in your code. For instance, when you see C<< +Foo::Bar->new() >>, you should be able to find the class definition for a +C in a file called F + +Therefore, this Policy requires the last component of the first package name +declared in the file to match the physical filename. Or if C<#line> +directives are used, then it must match the logical filename defined by the +prevailing C<#line> directive at the point of the package declaration. Here +are some examples: + + # Any of the following in file "Foo/Bar/Baz.pm": + package Foo::Bar::Baz; # ok + package Baz; # ok + package Nuts; # not ok (doesn't match physical filename) + + # using #line directives in file "Foo/Bar/Baz.pm": + #line 1 Nuts.pm + package Nuts; # ok + package Baz; # not ok (contradicts #line directive) + +If the file is not deemed to be a module, then this Policy does not apply. +Also, if the first package namespace found in the file is "main" then this +Policy does not apply. + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Modules/RequireNoMatchVarsWithUseEnglish.pm b/lib/Perl/Critic/Policy/Modules/RequireNoMatchVarsWithUseEnglish.pm new file mode 100644 index 0000000..0e75944 --- /dev/null +++ b/lib/Perl/Critic/Policy/Modules/RequireNoMatchVarsWithUseEnglish.pm @@ -0,0 +1,197 @@ +package Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use Perl::Critic::Utils qw< :characters :severities >; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => + q{"use English" without the '-no_match_vars' argument degrades performance.'}; +Readonly::Scalar my $DESC => q{"use English" without '-no_match_vars' argument}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw( core performance ) } +sub applies_to { return 'PPI::Statement::Include' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + + # "require"ing English is kind of useless. + return if $elem->type() ne 'use'; + return if $elem->module() ne 'English'; + + my @elements = $elem->schildren(); + shift @elements; # dump "use" + shift @elements; # dump "English" + + if (not @elements) { + return $self->violation($DESC, $EXPL, $elem); + } + + _skip_version_number( \@elements ); + + @elements = _descend_into_parenthesized_list_if_present(@elements); + + if (not @elements) { + return $self->violation($DESC, $EXPL, $elem); + } + + my $current_element = $elements[0]; + + while ( $current_element ) { + if ( $current_element->isa('PPI::Token::Quote') ) { + return if $current_element->string() eq '-no_match_vars'; + } + elsif ( $current_element->isa('PPI::Token::QuoteLike::Words') ) { + return if $current_element->content() =~ m/-no_match_vars \b/xms; + } + elsif ( + not $current_element->isa('PPI::Token::Operator') + or $current_element->content() ne $COMMA + and $current_element->content() ne $FATCOMMA + ) { + return $self->violation($DESC, $EXPL, $elem); + } + + shift @elements; + $current_element = $elements[0]; + } + + return $self->violation($DESC, $EXPL, $elem); +} + + +sub _skip_version_number { + my ($elements_ref) = @_; + + my $current_element = $elements_ref->[0]; + + if ( $current_element->isa('PPI::Token::Number') ) { + shift @{$elements_ref}; + } + elsif ( + @{$elements_ref} >= 2 + and $current_element->isa('PPI::Token::Word') + and $current_element->content() =~ m/\A v \d+ \z/xms + and $elements_ref->[1]->isa('PPI::Token::Number') + ) { + # The above messy conditional necessary due to PPI not handling + # v-strings. + shift @{$elements_ref}; + shift @{$elements_ref}; + } + + return; +} + +sub _descend_into_parenthesized_list_if_present { + my @elements = @_; + + return if not @elements; + + my $current_element = $elements[0]; + + if ( $current_element->isa('PPI::Structure::List') ) { + my @grand_children = $current_element->schildren(); + if (not @grand_children) { + return; + } + + my $grand_child = $grand_children[0]; + + if ( $grand_child->isa('PPI::Statement::Expression') ) { + my @great_grand_children = $grand_child->schildren(); + + if (not @great_grand_children) { + return; + } + + return @great_grand_children; + } + else { + return @grand_children; + } + } + + return @elements; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish - C must be passed a C<-no_match_vars> argument. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Due to unfortunate history, if you use the L module +but don't pass in a C<-no_match_vars> argument, all regular +expressions in the entire program, not merely the module in question, +suffer a significant performance penalty, even if you only import a +subset of the variables. + + use English; # not ok + use English '-no_match_vars'; # ok + use English qw< $ERRNO -no_match_vars >; # ok + use English qw($OS_ERROR); # not ok + +In the last example above, while the match variables aren't loaded +into your namespace, they are still created in the C +namespace and you still pay the cost. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Elliot Shank C<< >> + + +=head1 COPYRIGHT + +Copyright (c) 2008-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Modules/RequireVersionVar.pm b/lib/Perl/Critic/Policy/Modules/RequireVersionVar.pm new file mode 100644 index 0000000..19d23d4 --- /dev/null +++ b/lib/Perl/Critic/Policy/Modules/RequireVersionVar.pm @@ -0,0 +1,207 @@ +package Perl::Critic::Policy::Modules::RequireVersionVar; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use List::MoreUtils qw(any); + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{No package-scoped "$VERSION" variable found}; ## no critic (RequireInterpolation) +Readonly::Scalar my $EXPL => [ 404 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core pbp readability) } +sub applies_to { return 'PPI::Document' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + + return if $doc->find_first( \&_is_version_declaration ); + + #If we get here, then no $VERSION was found + return $self->violation( $DESC, $EXPL, $doc ); +} + +#----------------------------------------------------------------------------- + +sub _is_version_declaration { ## no critic (ArgUnpacking) + return 1 if _is_our_version(@_); + return 1 if _is_vars_version(@_); + return 1 if _is_package_version(@_); + return 1 if _is_readonly_version(@_); + return 1 if _is_package_argument_version(@_); + return 0; +} + +#----------------------------------------------------------------------------- + +sub _is_our_version { + my (undef, $elem) = @_; + $elem->isa('PPI::Statement::Variable') || return 0; + $elem->type() eq 'our' || return 0; + return any { $_ eq '$VERSION' } $elem->variables(); ## no critic (RequireInterpolation) +} + +#----------------------------------------------------------------------------- + +sub _is_vars_version { + my (undef, $elem) = @_; + $elem->isa('PPI::Statement::Include') || return 0; + $elem->pragma() eq 'vars' || return 0; + return $elem =~ m{ \$VERSION }xms; #Crude, but usually works +} + +#----------------------------------------------------------------------------- + +sub _is_package_version { + my (undef, $elem) = @_; + $elem->isa('PPI::Token::Symbol') || return 0; + return $elem =~ m{ \A \$ \S+ ::VERSION \z }xms; + #TODO: ensure that it is in _this_ package! +} + +#----------------------------------------------------------------------------- + +sub _is_readonly_version { + + #--------------------------------------------------------------- + # Readonly VERSION statements usually come in one of two forms: + # + # Readonly our $VERSION = 1.0; + # Readonly::Scalar our $VERSION = 1.0; + #--------------------------------------------------------------- + + my (undef, $elem) = @_; + $elem->isa('PPI::Token::Symbol') || return 0; + return 0 if $elem !~ m{ \A \$VERSION \z }xms; + + my $psib = $elem->sprevious_sibling() || return 0; + return 0 if $psib ne 'our'; + + my $ppsib = $psib->sprevious_sibling() || return 0; + return $ppsib eq 'Readonly' || $ppsib eq 'Readonly::Scalar'; +} + +#----------------------------------------------------------------------------- + +sub _is_package_argument_version { + my (undef, $elem) = @_; + $elem->isa( 'PPI::Statement::Package' ) or return 0; + # Perldoc for 5.12.3 documents the statement as + # package NAMESPACE VERSION + # with no comma, and the compiler in fact does not accept one. + my $ver = $elem->schild( 2 ) + or return 0; + return $ver->isa( 'PPI::Token::Number' ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Modules::RequireVersionVar - Give every module a C<$VERSION> number. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Every Perl file (modules, libraries, and programs) should have a +package-scoped C<$VERSION> variable. The C<$VERSION> allows clients to +insist on a particular revision of your file like this: + + use SomeModule 2.4; #Only loads version 2.4 + +This Policy scans your file for any package variable named +C<$VERSION>. I'm assuming that you are using C, so you'll +have to declare it like one of these: + + our $VERSION = 1.0611; + $MyPackage::VERSION = 1.061; + use vars qw($VERSION); + use version; our $VERSION = qv(1.0611); + +Perl's version system does not recognize lexical variables such as + + my $VERSION = 1.0611; + +so they are not accepted by this policy. + +A common practice is to use the C<$Revision$> keyword to +automatically define the C<$VERSION> variable like this: + + our ($VERSION) = '$Revision$' =~ m{ \$Revision: \s+ (\S+) }x; + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 NOTES + +Conway recommends using the C pragma instead of raw numbers +or 'v-strings.' However, this Policy only insists that the +C<$VERSION> be defined somehow. I may try to extend this in the +future. + + +=head1 TO DO + +Add check that C<$VERSION> is independently evaluatable. In +particular, prohibit this: + + our $VERSION = $Other::Module::VERSION; + +This doesn't work because PAUSE and other tools literally copy your +version declaration out of your module and evaluates it in isolation, +at which point there's nothing in C, and so the +C<$VERSION> is undefined. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/NamingConventions/Capitalization.pm b/lib/Perl/Critic/Policy/NamingConventions/Capitalization.pm new file mode 100644 index 0000000..5984afe --- /dev/null +++ b/lib/Perl/Critic/Policy/NamingConventions/Capitalization.pm @@ -0,0 +1,782 @@ +package Perl::Critic::Policy::NamingConventions::Capitalization; + +use 5.006001; +use strict; +use warnings; + +use English qw< -no_match_vars >; +use Readonly; + +use Perl::Critic::Exception::AggregateConfiguration; +use Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue; +use Perl::Critic::Utils qw< + :booleans :characters :severities + hashify is_perl_global +>; +use Perl::Critic::Utils::Perl qw< symbol_without_sigil >; +use Perl::Critic::Utils::PPI qw< + is_in_subroutine +>; +use PPIx::Utilities::Statement qw< + get_constant_name_elements_from_declaring_statement +>; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +# Don't worry about leading digits-- let perl/PPI do that. +Readonly::Scalar my $ALL_ONE_CASE_REGEX => + qr< \A [@%\$]? (?: [[:lower:]_\d]+ | [[:upper:]_\d]+ ) \z >xms; +Readonly::Scalar my $ALL_LOWER_REGEX => qr< \A [[:lower:]_\d]+ \z >xms; +Readonly::Scalar my $ALL_UPPER_REGEX => qr< \A [[:upper:]_\d]+ \z >xms; +Readonly::Scalar my $STARTS_WITH_LOWER_REGEX => qr< \A _* [[:lower:]\d] >xms; +Readonly::Scalar my $STARTS_WITH_UPPER_REGEX => qr< \A _* [[:upper:]\d] >xms; +Readonly::Scalar my $NO_RESTRICTION_REGEX => qr< . >xms; + +Readonly::Hash my %CAPITALIZATION_SCHEME_TAGS => ( + ':single_case' => { + regex => $ALL_ONE_CASE_REGEX, + regex_violation => 'is not all lower case or all upper case', + }, + ':all_lower' => { + regex => $ALL_LOWER_REGEX, + regex_violation => 'is not all lower case', + }, + ':all_upper' => { + regex => $ALL_UPPER_REGEX, + regex_violation => 'is not all upper case', + }, + ':starts_with_lower' => { + regex => $STARTS_WITH_LOWER_REGEX, + regex_violation => 'does not start with a lower case letter', + }, + ':starts_with_upper' => { + regex => $STARTS_WITH_UPPER_REGEX, + regex_violation => 'does not start with a upper case letter', + }, + ':no_restriction' => { + regex => $NO_RESTRICTION_REGEX, + regex_violation => 'there is a bug in Perl::Critic if you are reading this', + }, +); + +Readonly::Scalar my $PACKAGE_REGEX => qr/ :: | ' /xms; + +Readonly::Hash my %NAME_FOR_TYPE => ( + package => 'Package', + subroutine => 'Subroutine', + local_lexical_variable => 'Local lexical variable', + scoped_lexical_variable => 'Scoped lexical variable', + file_lexical_variable => 'File lexical variable', + global_variable => 'Global variable', + constant => 'Constant', + label => 'Label', +); + +Readonly::Hash my %IS_COMMA => hashify( $COMMA, $FATCOMMA ); + +Readonly::Scalar my $EXPL => [ 45, 46 ]; + +#----------------------------------------------------------------------------- + +# Can't handle named parameters yet. +sub supported_parameters { + return ( + { + name => 'packages', + description => 'How package name components should be capitalized. Valid values are :single_case, :all_lower, :all_upper:, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex.', + default_string => ':starts_with_upper', + behavior => 'string', + }, + { + name => 'package_exemptions', + description => 'Package names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z.', + default_string => 'main', + behavior => 'string list', + }, + { + name => 'subroutines', + description => 'How subroutine names should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex.', + default_string => ':single_case', # Matches ProhibitMixedCaseSubs + behavior => 'string', + }, + { + name => 'subroutine_exemptions', + description => 'Subroutine names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z.', + default_string => + join ( + $SPACE, + qw< + + AUTOLOAD BUILD BUILDARGS CLEAR CLOSE + DELETE DEMOLISH DESTROY EXISTS EXTEND + FETCH FETCHSIZE FIRSTKEY GETC NEXTKEY + POP PRINT PRINTF PUSH READ + READLINE SCALAR SHIFT SPLICE STORE + STORESIZE TIEARRAY TIEHANDLE TIEHASH TIESCALAR + UNSHIFT UNTIE WRITE + + >, + ), + behavior => 'string list', + }, + { + name => 'local_lexical_variables', + description => 'How local lexical variables names should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex.', + default_string => ':single_case', # Matches ProhibitMixedCaseVars + behavior => 'string', + }, + { + name => 'local_lexical_variable_exemptions', + description => 'Local lexical variable names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z.', + default_string => $EMPTY, + behavior => 'string list', + }, + { + name => 'scoped_lexical_variables', + description => 'How lexical variables that are scoped to a subset of subroutines, should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex.', + default_string => ':single_case', # Matches ProhibitMixedCaseVars + behavior => 'string', + }, + { + name => 'scoped_lexical_variable_exemptions', + description => 'Names for variables in anonymous blocks that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z.', + default_string => $EMPTY, + behavior => 'string list', + }, + { + name => 'file_lexical_variables', + description => 'How lexical variables at the file level should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex.', + default_string => ':single_case', # Matches ProhibitMixedCaseVars + behavior => 'string', + }, + { + name => 'file_lexical_variable_exemptions', + description => 'File-scope lexical variable names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z.', + default_string => $EMPTY, + behavior => 'string list', + }, + { + name => 'global_variables', + description => 'How global (package) variables should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex.', + default_string => ':single_case', # Matches ProhibitMixedCaseVars + behavior => 'string', + }, + { + name => 'global_variable_exemptions', + description => 'Global variable names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z.', + default_string => '\$VERSION @ISA @EXPORT(?:_OK)? %EXPORT_TAGS \$AUTOLOAD %ENV %SIG \$TODO', ## no critic (RequireInterpolation) + behavior => 'string list', + }, + { + name => 'constants', + description => 'How constant names should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex.', + default_string => ':all_upper', + behavior => 'string', + }, + { + name => 'constant_exemptions', + description => 'Constant names that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z.', + default_string => $EMPTY, + behavior => 'string list', + }, + { + name => 'labels', + description => 'How labels should be capitalized. Valid values are :single_case, :all_lower, :all_upper, :starts_with_lower, :starts_with_upper, :no_restriction, or a regex.', + default_string => ':all_upper', + behavior => 'string', + }, + { + name => 'label_exemptions', + description => 'Labels that are exempt from capitalization rules. The values here are regexes that will be surrounded by \A and \z.', + default_string => $EMPTY, + behavior => 'string list', + }, + ); +} + +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw< core pbp cosmetic > } +sub applies_to { return qw< PPI::Statement PPI::Token::Label > } + +#----------------------------------------------------------------------------- + +sub initialize_if_enabled { + my ($self, $config) = @_; + + my $configuration_exceptions = + Perl::Critic::Exception::AggregateConfiguration->new(); + + KIND: + foreach my $kind_of_name ( qw< + package subroutine + local_lexical_variable scoped_lexical_variable + file_lexical_variable global_variable + constant label + > ) { + my ($capitalization_regex, $message) = + $self->_derive_capitalization_test_regex_and_message( + $kind_of_name, $configuration_exceptions, + ); + my $exemption_regexes = + $self->_derive_capitalization_exemption_test_regexes( + $kind_of_name, $configuration_exceptions, + ); + + # Keep going, despite problems, so that all problems can be reported + # at one go, rather than the user fixing one problem, receiving a new + # error, etc.. + next KIND if $configuration_exceptions->has_exceptions(); + + $self->{"_${kind_of_name}_test"} = sub { + my ($name) = @_; + + return if _name_is_exempt($name, $exemption_regexes); + + return $message if $name !~ m/$capitalization_regex/xms; + return; + } + } + + if ( $configuration_exceptions->has_exceptions() ) { + $configuration_exceptions->throw(); + } + + return $TRUE; +} + +sub _derive_capitalization_test_regex_and_message { + my ($self, $kind_of_name, $configuration_exceptions) = @_; + + my $capitalization_option = "${kind_of_name}s"; + my $capitalization = $self->{"_$capitalization_option"}; + + if ( my $tag_properties = $CAPITALIZATION_SCHEME_TAGS{$capitalization} ) { + return @{$tag_properties}{ qw< regex regex_violation > }; + } + elsif ($capitalization =~ m< \A : >xms) { + $configuration_exceptions->add_exception( + Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue->new( + policy => $self, + option_name => $capitalization_option, + option_value => $capitalization, + message_suffix => + 'is not a known capitalization scheme tag. Valid tags are: ' + . (join q<, >, sort keys %CAPITALIZATION_SCHEME_TAGS) + . $PERIOD, + ) + ); + return; + } + + my $regex; + eval { $regex = qr< \A $capitalization \z >xms; } + or do { + $configuration_exceptions->add_exception( + Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue->new( + policy => $self, + option_name => $capitalization_option, + option_value => $capitalization, + message_suffix => + "is not a valid regular expression: $EVAL_ERROR", + ) + ); + return; + }; + + return $regex, qq; +} + +sub _derive_capitalization_exemption_test_regexes { + my ($self, $kind_of_name, $configuration_exceptions) = @_; + + my $exemptions_option = "${kind_of_name}_exemptions"; + my $exemptions = $self->{"_$exemptions_option"}; + + my @regexes; + + PATTERN: + foreach my $pattern ( keys %{$exemptions} ) { + my $regex; + eval { $regex = qr< \A $pattern \z >xms; } + or do { + $configuration_exceptions->add_exception( + Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue->new( + policy => $self, + option_name => $exemptions_option, + option_value => $pattern, + message_suffix => + "is not a valid regular expression: $EVAL_ERROR", + ) + ); + next PATTERN; + }; + + push @regexes, $regex; + } + + return \@regexes; +} + +sub _name_is_exempt { + my ($name, $exemption_regexes) = @_; + + foreach my $regex ( @{$exemption_regexes} ) { + return $TRUE if $name =~ m/$regex/xms; + } + + return $FALSE; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + # Want given. Want 5.10. Gimme gimme gimme. :] + if ( $elem->isa('PPI::Statement::Variable') ) { + return $self->_variable_capitalization($elem); + } + + if ( $elem->isa('PPI::Statement::Sub') ) { + return $self->_subroutine_capitalization($elem); + } + + if ( + my @names = get_constant_name_elements_from_declaring_statement($elem) + ) { + return ( grep { $_ } + map { $self->_constant_capitalization( $elem, $_ ) } @names ) + } + + if ( $elem->isa('PPI::Statement::Package') ) { + return $self->_package_capitalization($elem); + } + + if ( + $elem->isa('PPI::Statement::Compound') and $elem->type() eq 'foreach' + ) { + return $self->_foreach_variable_capitalization($elem); + } + + if ( $elem->isa('PPI::Token::Label') ) { + return $self->_label_capitalization($elem); + } + + return; +} + +sub _variable_capitalization { + my ($self, $elem) = @_; + + my @violations; + + NAME: + for my $name ( map { $_->symbol() } $elem->symbols() ) { + if ($elem->type() eq 'local') { + # Fully qualified names are exempt because we can't be responsible + # for other people's symbols. + next NAME if $name =~ m/$PACKAGE_REGEX/xms; + next NAME if is_perl_global($name); + + push + @violations, + $self->_check_capitalization( + symbol_without_sigil($name), + $name, + 'global_variable', + $elem, + ); + } + elsif ($elem->type() eq 'our') { + push + @violations, + $self->_check_capitalization( + symbol_without_sigil($name), + $name, + 'global_variable', + $elem, + ); + } + else { + # Got my or state + my $parent = $elem->parent(); + if ( not $parent or $parent->isa('PPI::Document') ) { + push + @violations, + $self->_check_capitalization( + symbol_without_sigil($name), + $name, + 'file_lexical_variable', + $elem, + ); + } + else { + if ( _is_directly_in_scope_block($elem) ) { + push + @violations, + $self->_check_capitalization( + symbol_without_sigil($name), + $name, + 'scoped_lexical_variable', + $elem, + ); + } + else { + push + @violations, + $self->_check_capitalization( + symbol_without_sigil($name), + $name, + 'local_lexical_variable', + $elem, + ); + } + } + } + } + + return @violations; +} + +sub _subroutine_capitalization { + my ($self, $elem) = @_; + + # These names are fixed and you've got no choice what to call them. + return if $elem->isa('PPI::Statement::Scheduled'); + + my $name = $elem->name(); + $name =~ s{ .* :: }{}smx; # Allow for "sub Some::Package::foo {}" + + return $self->_check_capitalization($name, $name, 'subroutine', $elem); +} + +sub _constant_capitalization { + my ($self, $elem, $name) = @_; + + return $self->_check_capitalization( + symbol_without_sigil($name), $name, 'constant', $elem, + ); +} + +sub _package_capitalization { + my ($self, $elem) = @_; + + my $namespace = $elem->namespace(); + my @components = split m/::/xms, $namespace; + + foreach my $component (@components) { + my $violation = + $self->_check_capitalization( + $component, $namespace, 'package', $elem, + ); + return $violation if $violation; + } + + return; +} + +sub _foreach_variable_capitalization { + my ($self, $elem) = @_; + + my $type; + my $symbol; + my $second_element = $elem->schild(1); + return if not $second_element; + + if ($second_element->isa('PPI::Token::Word')) { + $type = $second_element->content(); + $symbol = $second_element->snext_sibling(); + } else { + $type = 'my'; + $symbol = $second_element; + } + + return if not $symbol; + return if not $symbol->isa('PPI::Token::Symbol'); + + my $name = $symbol->symbol(); + + if ($type eq 'local') { + # Fully qualified names are exempt because we can't be responsible + # for other people's symbols. + return if $name =~ m/$PACKAGE_REGEX/xms; + return if is_perl_global($name); + + return $self->_check_capitalization( + symbol_without_sigil($name), $name, 'global_variable', $elem, + ); + } + elsif ($type eq 'our') { + return $self->_check_capitalization( + symbol_without_sigil($name), $name, 'global_variable', $elem, + ); + } + + # Got my or state: treat as local lexical variable + return $self->_check_capitalization( + symbol_without_sigil($name), $name, 'local_lexical_variable', $elem, + ); +} + +sub _label_capitalization { + my ($self, $elem, $name) = @_; + + return if _is_not_real_label($elem); + ( my $label = $elem->content() ) =~ s< \s* : \z ><>xms; + return $self->_check_capitalization($label, $label, 'label', $elem); +} + +sub _check_capitalization { + my ($self, $to_match, $full_name, $name_type, $elem) = @_; + + my $test = $self->{"_${name_type}_test"}; + if ( my $message = $test->($to_match) ) { + return $self->violation( + qq<$NAME_FOR_TYPE{$name_type} "$full_name" $message>, + $EXPL, + $elem, + ); + } + + return; +} + + +# { my $x } parses as +# PPI::Document +# PPI::Statement::Compound +# PPI::Structure::Block { ... } +# PPI::Statement::Variable +# PPI::Token::Word 'my' +# PPI::Token::Symbol '$x' +# PPI::Token::Structure ';' +# +# Also, type() on the PPI::Statement::Compound returns "continue". *sigh* +# +# The parameter is expected to be the PPI::Statement::Variable. +sub _is_directly_in_scope_block { + my ($elem) = @_; + + + return if is_in_subroutine($elem); + + my $parent = $elem->parent(); + return if not $parent->isa('PPI::Structure::Block'); + + my $grand_parent = $parent->parent(); + return $TRUE if not $grand_parent; + return $TRUE if $grand_parent->isa('PPI::Document'); + + return if not $grand_parent->isa('PPI::Statement::Compound'); + + my $type = $grand_parent->type(); + return if not $type; + return if $type ne 'continue'; + + my $great_grand_parent = $grand_parent->parent(); + return if + $great_grand_parent and not $great_grand_parent->isa('PPI::Document'); + + # Make sure we aren't really in a continue block. + my $prior_to_grand_parent = $grand_parent->sprevious_sibling(); + return $TRUE if not $prior_to_grand_parent; + return $TRUE if not $prior_to_grand_parent->isa('PPI::Token::Word'); + return $prior_to_grand_parent->content() ne 'continue'; +} + +sub _is_not_real_label { + my $elem = shift; + + # PPI misparses part of a ternary expression as a label + # when the token to the left of the ":" is a bareword. + # See http://rt.cpan.org/Ticket/Display.html?id=41170 + # For example... + # + # $foo = $condition ? undef : 1; + # + # PPI thinks that "undef" is a label. To workaround this, + # I'm going to check that whatever PPI thinks is the label, + # actually is the first token in the statement. I believe + # this should be true for all real labels. + + my $stmnt = $elem->statement() || return; + my $first_child = $stmnt->schild(0) || return; + return $first_child ne $elem; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords pbp perlstyle Schwern THINGY + +=head1 NAME + +Perl::Critic::Policy::NamingConventions::Capitalization - Distinguish different program components by case. + + +=head1 AFFILIATION + +This Policy is part of the core L distribution. + + +=head1 DESCRIPTION + +Conway recommends to distinguish different program components by case. + +Normal subroutines, methods and variables are all in lower case. + + my $foo; # ok + my $foo_bar; # ok + sub foo {} # ok + sub foo_bar {} # ok + + my $Foo; # not ok + my $foo_Bar; # not ok + sub Foo {} # not ok + sub foo_Bar {} # not ok + +Package and class names are capitalized. + + package IO::Thing; # ok + package Web::FooBar # ok + + package foo; # not ok + package foo::Bar; # not ok + +Constants are in all-caps. + + Readonly::Scalar my $FOO = 42; # ok + + Readonly::Scalar my $foo = 42; # not ok + +There are other opinions on the specifics, for example, in +L. This +policy can be configured to match almost any style that you can think of. + + +=head1 CONFIGURATION + +You can specify capitalization rules for the following things: +C, C, C, +C, C, +C, C, and C. + +C are things declared via L or +L. + + use constant FOO => 193; + Readonly::Array my @BAR => qw< a b c >; + +C are anything declared using C, C, or +L. C are variables declared at the +file scope. + +C are variables declared inside bare blocks +that are outside of any subroutines or other control structures; these +are usually created to limit scope of variables to a given subset of +subroutines. E.g. + + sub foo { ... } + + { + my $thingy; + + sub bar { ... $thingy ... } + sub baz { ... $thingy ... } + } + +All other variable declarations are considered +C. + +Each of the C, C, C, +C, C, +C, C, and C options can be +specified as one of C<:single_case>, C<:all_lower>, C<:all_upper:>, +C<:starts_with_lower>, C<:starts_with_upper>, or C<:no_restriction> or +a regular expression; any value that does not start with a colon, +C<:>, is considered to be a regular expression. The C<:single_case> +tag means a name can be all lower case or all upper case. If a +regular expression is specified, it is surrounded by C<\A> and C<\z>. + +C defaults to C<:starts_with_upper>. C, +C, C, +C, and C default to +C<:single_case>. And C and C default to +C<:all_upper>. + +There are corresponding C, +C, C, +C, +C, C, +C, and C options that are lists +of regular expressions to exempt from the corresponding capitalization +rule. These values also end up being surrounded by C<\A> and C<\z>. + +C defaults to C
. C +defaults to +C<\$VERSION @ISA @EXPORT(?:_OK)? %EXPORT_TAGS \$AUTOLOAD %ENV %SIG \$TODO>. +C defaults to +C +which should cover all the standard Perl subroutines plus those from +L. + +For example, if you want all local variables to be in all lower-case +and global variables to start with "G_" and otherwise not contain +underscores, but exempt any variable with a name that contains +"THINGY", you could put the following in your F<.perlcriticrc>: + + [NamingConventions::Capitalization] + local_lexical_variables = :all_lower + global_variables = G_(?:(?!_)\w)+ + global_variable_exemptions = .*THINGY.* + + +=head1 TODO + +Handle C. Treat constant subroutines like constant +variables. Handle bareword file handles. There needs to be "schemes" +or ways of specifying "perlstyle" or "pbp". Differentiate lexical +L constants in scopes. + + +=head1 BUGS + +This policy won't catch problems with the declaration of C<$y> below: + + for (my $x = 3, my $y = 5; $x < 57; $x += 3) { + ... + } + + +=head1 AUTHOR + +Multiple people + + +=head1 COPYRIGHT + +Copyright (c) 2008-2011 Michael G Schwern. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/NamingConventions/ProhibitAmbiguousNames.pm b/lib/Perl/Critic/Policy/NamingConventions/ProhibitAmbiguousNames.pm new file mode 100644 index 0000000..aa97441 --- /dev/null +++ b/lib/Perl/Critic/Policy/NamingConventions/ProhibitAmbiguousNames.pm @@ -0,0 +1,180 @@ +package Perl::Critic::Policy::NamingConventions::ProhibitAmbiguousNames; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :data_conversion }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => [ 48 ]; + +Readonly::Scalar my $DEFAULT_FORBID => + 'abstract bases close contract last left no record right second set'; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'forbid', + description => 'The variable names that are not to be allowed.', + default_string => $DEFAULT_FORBID, + behavior => 'string list', + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw(core pbp maintenance) } +sub applies_to { return qw(PPI::Statement::Sub + PPI::Statement::Variable) } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + if ( $elem->isa('PPI::Statement::Sub') ) { + my @words = grep { $_->isa('PPI::Token::Word') } $elem->schildren(); + for my $word (@words) { + + # strip off any leading "Package::" + my ($name) = $word =~ m/ (\w+) \z /xms; + next if not defined $name; # should never happen, right? + + if ( exists $self->{_forbid}->{$name} ) { + return $self->violation( + qq, + $EXPL, + $elem, + ); + } + } + return; # ok + } + + # PPI::Statement::Variable + + # Accumulate them since there can be more than one violation + # per variable statement + my @violations; + + # TODO: false positive bug - this can erroneously catch the + # assignment half of a variable statement + + my $symbols = $elem->find('PPI::Token::Symbol'); + if ($symbols) { # this should always be true, right? + for my $symbol ( @{$symbols} ) { + + # Strip off sigil and any leading "Package::" + # Beware that punctuation vars may have no + # alphanumeric characters. + + my ($name) = $symbol =~ m/ (\w+) \z /xms; + next if ! defined $name; + + if ( exists $self->{_forbid}->{$name} ) { + push + @violations, + $self->violation( + qq, + $EXPL, + $elem, + ); + } + } + } + + return @violations; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords bioinformatics + +=head1 NAME + +Perl::Critic::Policy::NamingConventions::ProhibitAmbiguousNames - Don't use vague variable or subroutine names like 'last' or 'record'. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway lists a collection of English words which are highly ambiguous +as variable or subroutine names. For example, C<$last> can mean +previous or final. + +This policy tests against a list of ambiguous words for variable +names. + + +=head1 CONFIGURATION + +The default list of forbidden words is: + + abstract bases close contract last left no record right second set + +This list can be changed by giving a value for C of a series +of forbidden words separated by spaces. + +For example, if you decide that C is an OK name for variables +(e.g. in bioinformatics), then put something like the following in +C<$HOME/.perlcriticrc>: + + [NamingConventions::ProhibitAmbiguousNames] + forbid = last set left right no abstract contract record second close + + +=head1 BUGS + +Currently this policy checks the entire variable and subroutine name, +not parts of the name. For example, it catches C<$last> but not +C<$last_record>. Hopefully future versions will catch both cases. + +Some variable statements will be false positives if they have +assignments where the right hand side uses forbidden names. For +example, in this case the C incorrectly triggers a violation. + + my $previous_record = $Foo::last; + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Objects/ProhibitIndirectSyntax.pm b/lib/Perl/Critic/Policy/Objects/ProhibitIndirectSyntax.pm new file mode 100644 index 0000000..e543165 --- /dev/null +++ b/lib/Perl/Critic/Policy/Objects/ProhibitIndirectSyntax.pm @@ -0,0 +1,164 @@ +package Perl::Critic::Policy::Objects::ProhibitIndirectSyntax; + +use 5.006001; +use strict; +use warnings; + +use Carp; +use English qw(-no_match_vars); +use Perl::Critic::Utils qw{ :severities :classification }; +use Readonly; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Hash my %COMMA => { + q<,> => 1, + q{=>} => 1, +}; +Readonly::Scalar my $DOLLAR => q<$>; + +Readonly::Scalar my $DESC => 'Subroutine "%s" called using indirect syntax'; +Readonly::Scalar my $EXPL => [ 349 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'forbid', + description => 'Indirect method syntax is forbidden for these methods.', + behavior => 'string list', + list_always_present_values => [ qw{ new } ], + } + ) +} + +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core pbp maintenance certrule ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + + # We are only interested in the functions we have been told to check. + # Do this before calling is_function_call() because we want to weed + # out as many candidate tokens as possible before calling it. + return if not $self->{_forbid}->{$elem->content()}; + + # Make sure it really is a function call. + return if not is_function_call($elem); + + # Per perlobj, it is only an indirect object call if the next sibling + # is a word, a scalar symbol, or a block. + my $object = $elem->snext_sibling() or return; + return if not ( + $object->isa( 'PPI::Token::Word' ) + or $object->isa( 'PPI::Token::Symbol' ) + and $DOLLAR eq $object->raw_type() + or $object->isa( 'PPI::Structure::Block' ) + ); + + # Per perlobj, it is not an indirect object call if the operator after + # the possible indirect object is a comma. + if ( my $operator = $object->snext_sibling() ) { + return if + $operator->isa( 'PPI::Token::Operator' ) + and $COMMA{ $operator->content() }; + } + + my $message = sprintf $DESC, $elem->content(); + + return $self->violation( $message, $EXPL, $elem ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Objects::ProhibitIndirectSyntax - Prohibit indirect object call syntax. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Indirect object syntax is commonly used in other object-oriented languages for +instantiating objects. Perl allows this, but to say that it supports it may be +going too far. Instead of writing + + my $foo = new Foo; + +it is preferable to write + + my $foo = Foo->new; + +The problem is that Perl needs to make a number of assumptions at compile time +to disambiguate the first form, so it tends to be fragile and to produce +hard-to-track-down bugs. + + +=head1 CONFIGURATION + +Indirect object syntax is also hard for Perl::Critic to disambiguate, so this +policy only checks certain subroutine calls. The names of the subroutines can +be configured using the C configuration option: + + [Objects::ProhibitIndirectSyntax] + forbid = create destroy + +The C subroutine is configured by default; any additional C +values are in addition to C. + + +=head1 CAVEATS + +The general situation can not be handled via static analysis. + + +=head1 SEE ALSO + +L +and L both do a better job with this, but they require that you +compile/execute your code. + + +=head1 AUTHOR + +Thomas R. Wyant, III F + + +=head1 COPYRIGHT + +Copyright (c) 2009-2011 Tom Wyant. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : + diff --git a/lib/Perl/Critic/Policy/References/ProhibitDoubleSigils.pm b/lib/Perl/Critic/Policy/References/ProhibitDoubleSigils.pm new file mode 100644 index 0000000..b6d94c5 --- /dev/null +++ b/lib/Perl/Critic/Policy/References/ProhibitDoubleSigils.pm @@ -0,0 +1,96 @@ +package Perl::Critic::Policy::References::ProhibitDoubleSigils; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Double-sigil dereference}; +Readonly::Scalar my $EXPL => [ 228 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core pbp cosmetic) } +sub applies_to { return 'PPI::Token::Cast' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + return if $elem eq q{\\}; + + my $sib = $elem->snext_sibling; + return if !$sib; + if ( ! $sib->isa('PPI::Structure::Block') ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::References::ProhibitDoubleSigils - Write C<@{ $array_ref }> instead of C<@$array_ref>. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +When dereferencing a reference, put braces around the reference to +separate the sigils. Especially for newbies, the braces eliminate any +potential confusion about the relative precedence of the sigils. + + push @$array_ref, 'foo', 'bar', 'baz'; #not ok + push @{ $array_ref }, 'foo', 'bar', 'baz'; #ok + + foreach ( keys %$hash_ref ){} #not ok + foreach ( keys %{ $hash_ref } ){} #ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/RegularExpressions/ProhibitCaptureWithoutTest.pm b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitCaptureWithoutTest.pm new file mode 100644 index 0000000..8dc0493 --- /dev/null +++ b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitCaptureWithoutTest.pm @@ -0,0 +1,407 @@ +package Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :booleans :data_conversion :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Hash my %CONDITIONAL_OPERATOR => hashify( qw{ && || ? and or xor } ); +Readonly::Hash my %UNAMBIGUOUS_CONTROL_TRANSFER => hashify( + qw< next last redo return > ); + +Readonly::Scalar my $DESC => q{Capture variable used outside conditional}; +Readonly::Scalar my $EXPL => [ 253 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return ( + { + name => 'exception_source', + description => 'Names of ways to generate exceptions', + behavior => 'string list', + list_always_present_values => [ qw{ die croak confess } ], + } + ); +} +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw(core pbp maintenance certrule ) } +sub applies_to { return 'PPI::Token::Magic' } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, $doc) = @_; + # TODO named capture variables + return if $elem !~ m/\A \$[1-9] \z/xms; + return if _is_in_conditional_expression($elem); + return if $self->_is_in_conditional_structure($elem); + return $self->violation( $DESC, $EXPL, $elem ); +} + +sub _is_in_conditional_expression { + my $elem = shift; + + # simplistic check: is there a conditional operator between a match and + # the capture var? + my $psib = $elem->sprevious_sibling; + while ($psib) { + if ($psib->isa('PPI::Token::Operator')) { + my $op = $psib->content; + if ( $CONDITIONAL_OPERATOR{ $op } ) { + $psib = $psib->sprevious_sibling; + while ($psib) { + return 1 if ($psib->isa('PPI::Token::Regexp::Match')); + return 1 if ($psib->isa('PPI::Token::Regexp::Substitute')); + $psib = $psib->sprevious_sibling; + } + return; # false + } + } + $psib = $psib->sprevious_sibling; + } + + return; # false +} + +sub _is_in_conditional_structure { + my ( $self, $elem ) = @_; + + my $stmt = $elem->statement(); + while ($stmt && $elem->isa('PPI::Statement::Expression')) { + #return if _is_in_conditional_expression($stmt); + $stmt = $stmt->statement(); + } + return if !$stmt; + + # Check if any previous statements in the same scope have regexp matches + my $psib = $stmt->sprevious_sibling; + while ($psib) { + if ( $psib->isa( 'PPI::Node' ) and + my $match = _find_exposed_match_or_substitute( $psib ) ) { + return _is_control_transfer_to_left( $self, $match, $elem ) || + _is_control_transfer_to_right( $self, $match, $elem ); + } + $psib = $psib->sprevious_sibling; + } + + # Check for an enclosing 'if', 'unless', 'elsif', 'else', or 'when' + my $parent = $stmt->parent; + while ($parent) { # never false as long as we're inside a PPI::Document + if ($parent->isa('PPI::Statement::Compound') || + $parent->isa('PPI::Statement::When' ) + ) { + return 1; + } + elsif ($parent->isa('PPI::Structure')) { + return 1 if _is_in_conditional_expression($parent); + return 1 if $self->_is_in_conditional_structure($parent); + $parent = $parent->parent; + } + else { + last; + } + } + + return; # fail +} + +# This subroutine returns true if there is a control transfer to the left of +# the match operation which would bypass the capture variable. The arguments +# are the match operation and the capture variable. +sub _is_control_transfer_to_left { + my ( $self, $match, $elem ) = @_; + # If a regexp match is found, we succeed if a match failure + # appears to throw an exception, and fail otherwise. RT 36081 + my $prev = $match->sprevious_sibling() or return; + while ( not ( $prev->isa( 'PPI::Token::Word' ) && + q eq $prev->content() ) ) { + $prev = $prev->sprevious_sibling() or return; + } + # In this case we analyze the first thing to appear in the parent of the + # 'unless'. This is the simplest case, and it will not be hard to dream up + # cases where this is insufficient (e.g. do {something(); die} unless ...) + my $parent = $prev->parent() or return; + my $first = $parent->schild( 0 ) or return; + if ( my $method = _get_method_name( $first ) ) { + # Methods can also be exception sources. + return $self->{_exception_source}{ $method->content() }; + } + return $self->{_exception_source}{ $first->content() } || + _unambiguous_control_transfer( $first, $elem ); +} + +# This subroutine returns true if there is a control transfer to the right of +# the match operation which would bypass the capture variable. The arguments +# are the match operation and the capture variable. +sub _is_control_transfer_to_right { + my ( $self, $match, $elem ) = @_; + # If a regexp match is found, we succeed if a match failure + # appears to throw an exception, and fail otherwise. RT 36081 + my $oper = $match->snext_sibling() or return; # fail + my $oper_content = $oper->content(); + # We do not check 'dor' or '//' because a match failure does not + # return an undefined value. + q{or} eq $oper_content + or q{||} eq $oper_content + or return; # fail + my $next = $oper->snext_sibling() or return; # fail + if ( my $method = _get_method_name( $next ) ) { + # Methods can also be exception sources. + return $self->{_exception_source}{ $method->content() }; + } + return $self->{_exception_source}{ $next->content() } || + _unambiguous_control_transfer( $next, $elem ); +} + +# Given a PPI::Node, find the last regexp match or substitution that is +# in-scope to the node's next sibling. +sub _find_exposed_match_or_substitute { # RT 36081 + my $elem = shift; +FIND_REGEXP_NOT_IN_BLOCK: + foreach my $regexp ( reverse @{ $elem->find( + sub { + return $_[1]->isa( 'PPI::Token::Regexp::Substitute' ) + || $_[1]->isa( 'PPI::Token::Regexp::Match' ); + } + ) || [] } ) { + my $parent = $regexp->parent(); + while ( $parent != $elem ) { + $parent->isa( 'PPI::Structure::Block' ) + and next FIND_REGEXP_NOT_IN_BLOCK; + $parent = $parent->parent() + or next FIND_REGEXP_NOT_IN_BLOCK; + } + return $regexp; + } + return; +} + +# If the argument introduces a method call, return the method name; +# otherwise just return. +sub _get_method_name { + my ( $elem ) = @_; + # We fail unless the element we were given looks like it might be an + # object or a class name. + $elem or return; + ( + $elem->isa( 'PPI::Token::Symbol' ) && + q<$> eq $elem->raw_type() || + $elem->isa( 'PPI::Token::Word' ) && + $elem->content() =~ m/ \A [\w:]+ \z /smx + ) or return; + # We skip over all the subscripts and '->' operators to the right of + # the original element, failing if we run out of objects. + my $prior; + my $next = $elem->snext_sibling() or return; + while ( $next->isa( 'PPI::Token::Subscript' ) || + $next->isa( 'PPI::Token::Operator' ) && + q{->} eq $next->content() ) { + $prior = $next; + $next = $next->snext_sibling or return; # fail + } + # A method call must have a '->' operator before it. + ( $prior && + $prior->isa( 'PPI::Token::Operator' ) && + q{->} eq $prior->content() + ) or return; + # Anything other than a PPI::Token::Word can not be statically + # recognized as a method name. + $next->isa( 'PPI::Token::Word' ) or return; + # Whatever we have left at this point looks very like a method name. + return $next; +} + +# Determine whether the given element represents an unambiguous transfer of +# control around anything that follows it in the same block. The arguments are +# the element to check, and the capture variable that is the subject of this +# call to the policy. +sub _unambiguous_control_transfer { # RT 36081. + my ( $xfer, $elem ) = @_; + + my $content = $xfer->content(); + + # Anything in the hash is always a transfer of control. + return $TRUE if $UNAMBIGUOUS_CONTROL_TRANSFER{ $content }; + + # A goto is not unambiguous on the face of it, but at least some forms of + # it can be accepted. + q eq $content + and return _unambiguous_goto( $xfer, $elem ); + + # Anything left at this point is _not_ an unambiguous transfer of control + # around whatever follows it. + return; +} + +# Determine whether the given goto represents an unambiguous transfer of +# control around anything that follows it in the same block. The arguments are +# the element to check, and the capture variable that is the subject of this +# call to the policy. +sub _unambiguous_goto { + my ( $xfer, $elem ) = @_; + + # A goto without a target? + my $target = $xfer->snext_sibling() or return; + + # The co-routine form of goto is an unambiguous transfer of control. + $target->isa( 'PPI::Token::Symbol' ) + and q<&> eq $target->raw_type() + and return $TRUE; + + # The label form of goto is an unambiguous transfer of control, + # provided the label does not occur between the goto and the capture + # variable. + if ( $target->isa( 'PPI::Token::Word' ) ) { + + # We need to search in our most-local block, or the document if + # there is no enclosing block. + my $container = $target; + while ( my $parent = $container->parent() ) { + $container = $parent; + $container->isa( 'PPI::Structure::Block' ) and last; + } + + # We search the container for our label. If we find it, we return + # true if it occurs before the goto or after the capture variable, + # otherwise we return false. If we do not find it we return true. + # Note that perl does not seem to consider duplicate labels an + # error, but also seems to take the first one in the relevant + # scope when this happens. + my $looking_for = qr/ \A @{[ $target->content() ]} \s* : \z /smx; + my ($start_line, $start_char) = @{ $xfer->location() || [] }; + defined $start_line or return; # document not indexed. + my ($end_line, $end_char) = @{ $elem->location() || [] }; + foreach my $label ( + @{ $container->find( 'PPI::Token::Label' ) || [] } ) + { + $label->content() =~ m/$looking_for/smx or next; + my ( $line, $char ) = @{ $label->location() || [] }; + return $TRUE + if $line < $start_line || + $line == $start_line && $char < $start_char; + return $TRUE + if $line > $end_line || + $line == $end_line && $char > $end_char; + return; + } + return $TRUE; + } + + # Any other form of goto can not be statically analyzed, and so is not + # an unambiguous transfer of control around the capture variable. + return; +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest - Capture variable used outside conditional. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + +=head1 DESCRIPTION + +If a regexp match fails, then any capture variables (C<$1>, C<$2>, +...) will be unaffected. They will retain whatever old values they may +have had. Therefore it's important to check the return value of a match +before using those variables. + + '12312123' =~ /(2)/; + print $1; # Prints 2 + '123123123' =~ /(X)/; + print $1; # Prints 2, because $1 has not changed. + +Note that because the values of C<$1> etc will be unaffected, you cannot +determine if a match succeeded by checking to see if the capture variables +have values. + + # WRONG + $str =~ /foo(.+)/; + if ( $1 ) { + print "I found $1 after 'foo'"; + } + +This policy checks that the previous regexp for which the capture +variable is in-scope is either in a conditional or causes an exception +or other control transfer (i.e. C, C, C, C, or +sometimes C) if the match fails. + +A C is only accepted by this policy if it is a co-routine call +(i.e. C) or a C where the label does not fall +between the C and the capture variable in the scope of the +C. A computed C (i.e. something like C) is not accepted by this policy because its target can not be +statically determined. + +This policy does not check whether that conditional is actually +testing a regexp result, nor does it check whether a regexp actually +has a capture in it. Those checks are too hard. + +This policy also does not check arbitrarily complex conditionals guarding +regexp results, for pretty much the same reason. Simple things like + + m/(foo)/ or die "No foo!"; + die "No foo!" unless m/(foo)/; + +will be handled, but something like + + m/(foo)/ or do { + ... lots of complicated calculations here ... + die "No foo!"; + }; + +are beyond its scope. + + +=head1 CONFIGURATION + +By default, this policy considers C, C, and C to +throw exceptions. If you have additional subroutines or methods that may +be used in lieu of one of these, you can configure them in your +perlcriticrc as follows: + + [RegularExpressions::ProhibitCaptureWithoutTest] + exception_source = my_exception_generator + +=head1 BUGS + +This policy does not recognize named capture variables. Yet. + +=head1 AUTHOR + +Chris Dolan + +=head1 COPYRIGHT + +Copyright (c) 2006-2017 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/RegularExpressions/ProhibitComplexRegexes.pm b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitComplexRegexes.pm new file mode 100644 index 0000000..647ffb4 --- /dev/null +++ b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitComplexRegexes.pm @@ -0,0 +1,221 @@ +package Perl::Critic::Policy::RegularExpressions::ProhibitComplexRegexes; + +use 5.006001; +use strict; +use warnings; + +use Carp; +use English qw(-no_match_vars); +use List::Util qw{ min }; +use Readonly; + +use Perl::Critic::Utils qw{ :booleans :severities }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Split long regexps into smaller qr// chunks}; +Readonly::Scalar my $EXPL => [261]; + +Readonly::Scalar my $MAX_LITERAL_LENGTH => 7; +Readonly::Scalar my $MAX_VARIABLE_LENGTH => 4; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'max_characters', + description => + 'The maximum number of characters to allow in a regular expression.', + default_string => '60', + behavior => 'integer', + integer_minimum => 1, + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core pbp maintenance ) } +sub applies_to { return qw(PPI::Token::Regexp::Match + PPI::Token::Regexp::Substitute + PPI::Token::QuoteLike::Regexp) } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $document ) = @_; + + # Optimization: if its short enough now, parsing won't make it longer + return if $self->{_max_characters} >= length $elem->get_match_string(); + + my $re = $document->ppix_regexp_from_element( $elem ) + or return; # Abort on syntax error. + $re->failures() + and return; # Abort if parse errors found. + my $qr = $re->regular_expression() + or return; # Abort if no regular expression. + + my $length = 0; + # We use map { $_->tokens() } qr->children() rather than just + # $qr->tokens() because we are not interested in the delimiters. + foreach my $token ( map { $_->tokens() } $qr->children() ) { + + # Do not count whitespace or comments + $token->significant() or next; + + if ( $token->isa( 'PPIx::Regexp::Token::Interpolation' ) ) { + + # Do not penalize long variable names + $length += min( $MAX_VARIABLE_LENGTH, length $token->content() ); + + } elsif ( $token->isa( 'PPIx::Regexp::Token::Literal' ) ) { + + # Do not penalize long literals like \p{...} + $length += min( $MAX_LITERAL_LENGTH, length $token->content() ); + + } else { + + # Take everything else at face value + $length += length $token->content(); + + } + + } + + return if $self->{_max_characters} >= $length; + + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords BNF Tatsuhiko Miyagawa + +=head1 NAME + +Perl::Critic::Policy::RegularExpressions::ProhibitComplexRegexes - Split long regexps into smaller C chunks. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Big regexps are hard to read, perhaps even the hardest part of Perl. +A good practice to write digestible chunks of regexp and put them +together. This policy flags any regexp that is longer than C +characters, where C is a configurable value that defaults to 60. +If the regexp uses the C flag, then the length is computed after +parsing out any comments or whitespace. + +Unfortunately the use of descriptive (and therefore longish) variable +names can cause regexps to be in violation of this policy, so +interpolated variables are counted as 4 characters no matter how long +their names actually are. + + +=head1 CASE STUDY + +As an example, look at the regexp used to match email addresses in +L (tweaked lightly to wrap +for POD) + + (?x-ism:(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\] + \000-\037\x80-\xff])|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n\015 + "]*)*")(?:(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[ + \]\000-\037\x80-\xff])|"[^\\\x80-\xff\n\015"]*(?:\\[^\x80-\xff][^\\\x80-\xff\n + \015"]*)*")|\.)*\@(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@, + ;:".\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\] + )(?:\.(?:[^(\040)<>@,;:".\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\[\]\000 + -\037\x80-\xff])|\[(?:[^\\\x80-\xff\n\015\[\]]|\\[^\x80-\xff])*\]))*) + +which is constructed from the following code: + + my $esc = '\\\\'; + my $period = '\.'; + my $space = '\040'; + my $open_br = '\['; + my $close_br = '\]'; + my $nonASCII = '\x80-\xff'; + my $ctrl = '\000-\037'; + my $cr_list = '\n\015'; + my $qtext = qq/[^$esc$nonASCII$cr_list\"]/; # " + my $dtext = qq/[^$esc$nonASCII$cr_list$open_br$close_br]/; + my $quoted_pair = qq<$esc>.qq<[^$nonASCII]>; + my $atom_char = qq/[^($space)<>\@,;:\".$esc$open_br$close_br$ctrl$nonASCII]/;# " + my $atom = qq<$atom_char+(?!$atom_char)>; + my $quoted_str = qq<\"$qtext*(?:$quoted_pair$qtext*)*\">; # " + my $word = qq<(?:$atom|$quoted_str)>; + my $domain_ref = $atom; + my $domain_lit = qq<$open_br(?:$dtext|$quoted_pair)*$close_br>; + my $sub_domain = qq<(?:$domain_ref|$domain_lit)>; + my $domain = qq<$sub_domain(?:$period$sub_domain)*>; + my $local_part = qq<$word(?:$word|$period)*>; # This part is modified + $Addr_spec_re = qr<$local_part\@$domain>; + +If you read the code from bottom to top, it is quite readable. And, +you can even see the one violation of RFC822 that Tatsuhiko Miyagawa +deliberately put into Email::Valid::Loose to allow periods. Look for +the C<|\.> in the upper regexp to see that same deviation. + +One could certainly argue that the top regexp could be re-written more +legibly with C and comments. But the bottom version is +self-documenting and, for example, doesn't repeat C<\x80-\xff> 18 +times. Furthermore, it's much easier to compare the second version +against the source BNF grammar in RFC 822 to judge whether the +implementation is sound even before running tests. + + +=head1 CONFIGURATION + +This policy allows regexps up to C characters long, where C +defaults to 60. You can override this to set it to a different number +with the C setting. To do this, put entries in a +F<.perlcriticrc> file like this: + + [RegularExpressions::ProhibitComplexRegexes] + max_characters = 40 + + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/RegularExpressions/ProhibitEnumeratedClasses.pm b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitEnumeratedClasses.pm new file mode 100644 index 0000000..276d590 --- /dev/null +++ b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitEnumeratedClasses.pm @@ -0,0 +1,197 @@ +package Perl::Critic::Policy::RegularExpressions::ProhibitEnumeratedClasses; + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); +use List::MoreUtils qw(all); +use Readonly; + +use Perl::Critic::Utils qw{ :booleans :severities hashify }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Use named character classes}; +Readonly::Scalar my $EXPL => [248]; + +Readonly::Array my @PATTERNS => ( # order matters: most to least specific + [q{ },'\\t','\\r','\\n'] => ['\\s', '\\S'], + ['A-Z','a-z','0-9','_'] => ['\\w', '\\W'], # RT 69322 + ['A-Z','a-z'] => ['[[:alpha:]]','[[:^alpha:]]'], + ['A-Z'] => ['[[:upper:]]','[[:^upper:]]'], + ['a-z'] => ['[[:lower:]]','[[:^lower:]]'], + ['0-9'] => ['\\d','\\D'], + ['\w'] => [undef, '\\W'], + ['\s'] => [undef, '\\S'], +); + +#----------------------------------------------------------------------------- + +sub supported_parameters { return qw() } +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw( core pbp cosmetic unicode ) } +sub applies_to { return qw(PPI::Token::Regexp::Match + PPI::Token::Regexp::Substitute + PPI::Token::QuoteLike::Regexp) } + +#----------------------------------------------------------------------------- + + +sub violates { + my ( $self, $elem, $document ) = @_; + + # optimization: don't bother parsing the regexp if there are no character classes + return if $elem !~ m/\[/xms; + + my $re = $document->ppix_regexp_from_element( $elem ) or return; + $re->failures() and return; + + my $anyofs = $re->find( 'PPIx::Regexp::Structure::CharClass' ) + or return; + foreach my $anyof ( @{ $anyofs } ) { + my $violation; + $violation = $self->_get_character_class_violations( $elem, $anyof ) + and return $violation; + } + + return; # OK +} + +sub _get_character_class_violations { + my ($self, $elem, $anyof) = @_; + + my %elements; + foreach my $element ( $anyof->children() ) { + $elements{ _fixup( $element ) } = 1; + } + + for (my $i = 0; $i < @PATTERNS; $i += 2) { ##no critic (CStyleForLoop) + if (all { exists $elements{$_} } @{$PATTERNS[$i]}) { + my $neg = $anyof->negated(); + my $improvement = $PATTERNS[$i + 1]->[$neg ? 1 : 0]; + next if !defined $improvement; + + if ($neg && ! defined $PATTERNS[$i + 1]->[0]) { + # the [^\w] => \W rule only applies if \w is the only token. + # that is it does not apply to [^\w\s] + next if 1 != scalar keys %elements; + } + + my $orig = join q{}, '[', ($neg ? q{^} : ()), @{$PATTERNS[$i]}, ']'; + return $self->violation( $DESC . " ($orig vs. $improvement)", $EXPL, $elem ); + } + } + + return; # OK +} + +Readonly::Hash my %ORDINALS => ( + ord "\n" => '\\n', + ord "\f" => '\\f', + ord "\r" => '\\r', + ord q< > => q< >, +); + +sub _fixup { + my ( $element ) = @_; + if ( $element->isa( 'PPIx::Regexp::Token::Literal' ) ) { + my $ord = $element->ordinal(); + exists $ORDINALS{$ord} and return $ORDINALS{$ord}; + return $element->content(); + } elsif ( $element->isa( 'PPIx::Regexp::Node' ) ) { + return join q{}, map{ _fixup( $_ ) } $element->elements(); + } else { + return $element->content(); + } +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::RegularExpressions::ProhibitEnumeratedClasses - Use named character classes instead of explicit character lists. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +This policy is not for everyone! If you are working in pure ASCII, +then disable it now or you may see some false violations. + +On the other hand many of us are working in a multilingual world with +an extended character set, probably Unicode. In that world, patterns +like C can be a source of bugs when you really meant +C. This policy catches a selection of possible +incorrect character class usage. + +Specifically, the patterns are: + +B> vs. B> + +B> vs. B> (because many people forget C<\f>) + +B> vs. B> + +B> vs. B> + +B> vs. B> + +B> vs. B> + +B> vs. B> + +B> vs. B> + +B> vs. B> + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/RegularExpressions/ProhibitEscapedMetacharacters.pm b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitEscapedMetacharacters.pm new file mode 100644 index 0000000..6aa0bb9 --- /dev/null +++ b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitEscapedMetacharacters.pm @@ -0,0 +1,169 @@ +package Perl::Critic::Policy::RegularExpressions::ProhibitEscapedMetacharacters; + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); +use Readonly; + +use Perl::Critic::Utils qw{ :booleans :severities hashify }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Use character classes for literal metachars instead of escapes}; +Readonly::Scalar my $EXPL => [247]; + +Readonly::Hash my %REGEXP_METACHARS => hashify(split / /xms, '{ } ( ) . * + ? |'); + +#----------------------------------------------------------------------------- + +sub supported_parameters { return qw() } +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw( core pbp cosmetic ) } +sub applies_to { return qw(PPI::Token::Regexp::Match + PPI::Token::Regexp::Substitute + PPI::Token::QuoteLike::Regexp) } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $document ) = @_; + + # optimization: don't bother parsing the regexp if there are no escapes + return if $elem !~ m/\\/xms; + + my $re = $document->ppix_regexp_from_element( $elem ) or return; + $re->failures() and return; + my $qr = $re->regular_expression() or return; + + my $exacts = $qr->find( 'PPIx::Regexp::Token::Literal' ) or return; + foreach my $exact( @{ $exacts } ) { + $exact->content() =~ m/ \\ ( . ) /xms or next; + return $self->violation( $DESC, $EXPL, $elem ) if $REGEXP_METACHARS{$1}; + } + + return; # OK +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords IPv4 + +=head1 NAME + +Perl::Critic::Policy::RegularExpressions::ProhibitEscapedMetacharacters - Use character classes for literal meta-characters instead of escapes. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Ever heard of leaning toothpick syndrome? That comes from writing +regular expressions that match on characters that are significant in +regular expressions. For example, the expression to match four +forward slashes looks like: + + m/\/\/\/\//; + +Well, this policy doesn't solve that problem (write it as C +instead!) but solves a related one. As seen above, the escapes make +the expression hard to parse visually. One solution is to use +character classes. You see, inside of character classes, the only +characters that are special are C<\>, C<]>, C<^> and C<->, so you +don't need to escape the others. So instead of the following loose +IPv4 address matcher: + + m/ \d+ \. \d+ \. \d+ \. \d+ /x; + +You could write: + + m/ \d+ [.] \d+ [.] \d+ [.] \d+ /x; + +which is certainly more readable, if less recognizable prior the +publication of Perl Best Practices. (Of course, you should really use +L to match IPv4 addresses!) + +Specifically, this policy forbids backslashes immediately prior to the +following characters: + + { } ( ) . * + ? | # + +We make special exception for C<$> because C turns into +C for Perl 5.8.6. We also make an exception for C<^> +because it has special meaning (negation) in a character class. +Finally, C<[> and C<]> are exempt, of course, because they are awkward +to represent in character classes. + +Note that this policy does not forbid unnecessary escaping. So go +ahead and (pointlessly) escape C characters. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 BUGS + +Perl treats C in unexpected ways. +I think it's a bug in Perl itself, but am not 100% sure that I have +not simply misunderstood... + +This part makes sense: + + "#f" =~ m/[#]f/x; # match + "#f" =~ m/[#]a/x; # no match + +This doesn't: + + $qr = qr/f/; + "#f" =~ m/[#]$qr/x; # no match + +Neither does this: + + print qr/[#]$qr/x; # yields '(?x-ism:[#]$qr + )' + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/RegularExpressions/ProhibitFixedStringMatches.pm b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitFixedStringMatches.pm new file mode 100644 index 0000000..63704ba --- /dev/null +++ b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitFixedStringMatches.pm @@ -0,0 +1,180 @@ +package Perl::Critic::Policy::RegularExpressions::ProhibitFixedStringMatches; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use English qw(-no_match_vars); +use Carp; + +use Perl::Critic::Utils qw{ :booleans :severities }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Use 'eq' or hash instead of fixed-pattern regexps}; +Readonly::Scalar my $EXPL => [271,272]; + +Readonly::Scalar my $RE_METACHAR => qr/[\\#\$()*+.?\@\[\]^{|}]/xms; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return qw() } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw( core pbp performance ) } +sub applies_to { return qw(PPI::Token::Regexp::Match + PPI::Token::Regexp::Substitute + PPI::Token::QuoteLike::Regexp) } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + + my $re = $elem->get_match_string(); + + # only flag regexps that are anchored front and back + if ($re =~ m{\A \s* + (\\A|\^) # front anchor == $1 + (.*?) + (\\z|\$) # end anchor == $2 + \s* \z}xms) { + + my ($front_anchor, $words, $end_anchor) = ($1, $2, $3); + + # If it's a multiline match, then end-of-line anchors don't represent the whole string + if ($front_anchor eq q{^} || $end_anchor eq q{$}) { + my $regexp = $doc->ppix_regexp_from_element( $elem ) + or return; + return if $regexp->modifier_asserted( 'm' ); + } + + # check for grouping and optional alternation. Grouping may or may not capture + if ($words =~ m{\A \s* + [(] # start group + (?:[?]:)? # optional non-capturing indicator + \s* (.*?) \s* # interior of group + [)] # end of group + \s* \z}xms) { + $words = $1; + $words =~ s/[|]//gxms; # ignore alternation inside of parens -- just look at words + } + + # Regexps that contain metachars are not fixed strings + return if $words =~ m/$RE_METACHAR/oxms; + + return $self->violation( $DESC, $EXPL, $elem ); + + } else { + return; # OK + } +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::RegularExpressions::ProhibitFixedStringMatches - Use C or hash instead of fixed-pattern regexps. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +A regular expression that matches just a fixed set of constant strings +is wasteful of performance and is hard on maintainers. It is much +more readable and often faster to use C or a hash to match such +strings. + + # Bad + my $is_file_function = $token =~ m/\A (?: open | close | read ) \z/xms; + + # Faster and more readable + my $is_file_function = $token eq 'open' || + $token eq 'close' || + $token eq 'read'; + +For larger numbers of strings, a hash is superior: + + # Bad + my $is_perl_keyword = + $token =~ m/\A (?: chomp | chop | chr | crypt | hex | index + lc | lcfirst | length | oct | ord | ... ) \z/xms; + + # Better + Readonly::Hash my %PERL_KEYWORDS => map {$_ => 1} qw( + chomp chop chr crypt hex index lc lcfirst length oct ord ... + ); + my $is_perl_keyword = $PERL_KEYWORD{$token}; + +Conway also suggests using C instead of a case-insensitive match. + + +=head2 VARIANTS + +This policy detects both grouped and non-grouped strings. The +grouping may or may not be capturing. The grouped body may or may not +be alternating. C<\A> and C<\z> are always considered anchoring which +C<^> and C<$> are considered anchoring is the C regexp option is +not in use. Thus, all of these are violations: + + m/^foo$/; + m/\A foo \z/x; + m/\A foo \z/xm; + m/\A(foo)\z/; + m/\A(?:foo)\z/; + m/\A(foo|bar)\z/; + m/\A(?:foo|bar)\z/; + +Furthermore, this policy detects violations in C, C and +C constructs, as you would expect. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/RegularExpressions/ProhibitSingleCharAlternation.pm b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitSingleCharAlternation.pm new file mode 100644 index 0000000..e1d8ee5 --- /dev/null +++ b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitSingleCharAlternation.pm @@ -0,0 +1,143 @@ +package Perl::Critic::Policy::RegularExpressions::ProhibitSingleCharAlternation; + +use 5.006001; +use strict; +use warnings; + +use Carp; +use English qw(-no_match_vars); +use Readonly; + +use Perl::Critic::Utils qw{ :booleans :characters :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => [265]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return qw() } +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw( core pbp performance ) } +sub applies_to { return qw(PPI::Token::Regexp::Match + PPI::Token::Regexp::Substitute + PPI::Token::QuoteLike::Regexp) } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $document ) = @_; + + # optimization: don't bother parsing the regexp if there are no pipes + return if $elem !~ m/[|]/xms; + + my $re = $document->ppix_regexp_from_element( $elem ) or return; + $re->failures() and return; + + my @violations; + foreach my $node ( @{ $re->find_parents( sub { + return $_[1]->isa( 'PPIx::Regexp::Token::Operator' ) + && $_[1]->content() eq q<|>; + } ) || [] } ) { + + my @singles; + my @alternative; + foreach my $kid ( $node->children() ) { + if ( $kid->isa( 'PPIx::Regexp::Token::Operator' ) + && $kid->content() eq q<|> + ) { + @alternative == 1 + and $alternative[0]->isa( 'PPIx::Regexp::Token::Literal' ) + and push @singles, map { $_->content() } @alternative; + @alternative = (); + } elsif ( $kid->significant() ) { + push @alternative, $kid; + } + } + @alternative == 1 + and $alternative[0]->isa( 'PPIx::Regexp::Token::Literal' ) + and push @singles, map { $_->content() } @alternative; + + if ( 1 < @singles ) { + my $description = + 'Use [' + . join( $EMPTY, @singles ) + . '] instead of ' + . join q<|>, @singles; + push @violations, $self->violation( $description, $EXPL, $elem ); + } + } + + return @violations; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::RegularExpressions::ProhibitSingleCharAlternation - Use C<[abc]> instead of C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Character classes (like C<[abc]>) are significantly faster than single +character alternations (like C<(?:a|b|c)>). This policy complains if +you have more than one instance of a single character in an +alternation. So C<(?:a|the)> is allowed, but C<(?:a|e|i|o|u)> is not. + +NOTE: Perl 5.10 (not released as of this writing) has major regexp +optimizations which may mitigate the performance penalty of +alternations, which will be rewritten behind the scenes as something +like character classes. Consequently, if you are deploying +exclusively on 5.10, yo might consider ignoring this policy. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusedCapture.pm b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusedCapture.pm new file mode 100644 index 0000000..5cecad6 --- /dev/null +++ b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusedCapture.pm @@ -0,0 +1,810 @@ +package Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture; + +use 5.006001; +use strict; +use warnings; + +use Carp; +use English qw(-no_match_vars); +use List::MoreUtils qw(none); +use Readonly; +use Scalar::Util qw(refaddr); + +use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal }; +use Perl::Critic::Utils qw{ + :booleans :characters :severities hashify precedence_of + split_nodes_on_comma +}; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $WHILE => q{while}; + +Readonly::Hash my %CAPTURE_REFERENCE => hashify( qw{ $+ $- } ); +Readonly::Hash my %CAPTURE_REFERENCE_ENGLISH => ( + hashify( qw{ $LAST_PAREN_MATCH $LAST_MATCH_START $LAST_MATCH_END } ), + %CAPTURE_REFERENCE ); + +Readonly::Scalar my $DESC => q{Only use a capturing group if you plan to use the captured value}; +Readonly::Scalar my $EXPL => [252]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return qw() } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core pbp maintenance ) } +sub applies_to { + return qw< PPI::Token::Regexp::Match PPI::Token::Regexp::Substitute > +} + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $NUM_CAPTURES_FOR_GLOBAL => 100; # arbitrarily large number + +sub violates { + my ( $self, $elem, $doc ) = @_; + + # optimization: don't bother parsing the regexp if there are no parens + return if 0 > index $elem->content(), '('; + + my $re = $doc->ppix_regexp_from_element( $elem ) or return; + $re->failures() and return; + + my $ncaptures = $re->max_capture_number() or return; + + my @captures; # List of expected captures + $#captures = $ncaptures - 1; + + my %named_captures; # List of expected named captures. + # Unlike the numbered capture logic, %named_captures + # entries are made undefined when a use of the name is + # found. Otherwise two hashes would be needed, one to + # become defined when a use is found, and one to hold + # the mapping of name to number. + foreach my $struct ( @{ $re->find( 'PPIx::Regexp::Structure::NamedCapture' + ) || [] } ) { + # There can be more than one capture with the same name, so we need to + # record all of them. There will be duplications if the 'branch reset' + # "(?| ... )" pattern is used, but this is benign given how numbered + # captures are recorded. + push @{ $named_captures{ $struct->name() } ||= [] }, $struct->number(); + } + + # Look for references to the capture in the regex itself + return if _enough_uses_in_regexp( $re, \@captures, \%named_captures, $doc ); + + if ( $re->modifier_asserted( 'g' ) + and not _check_if_in_while_condition_or_block( $elem ) ) { + $ncaptures = $NUM_CAPTURES_FOR_GLOBAL; + $#captures = $ncaptures - 1; + } + + return if _enough_assignments($elem, \@captures) && !%named_captures; + return if _is_in_slurpy_array_context($elem) && !%named_captures; + return if _enough_magic($elem, $re, \@captures, \%named_captures, $doc); + + return $self->violation( $DESC, $EXPL, $elem ); +} + +# Find uses of both numbered and named capture variables in the regexp itself. +# Return true if all are used. +sub _enough_uses_in_regexp { + my ( $re, $captures, $named_captures, $doc ) = @_; + + # Look for references to the capture in the regex itself. Note that this + # will also find backreferences in the replacement string of s///. + foreach my $token ( @{ $re->find( 'PPIx::Regexp::Token::Reference' ) + || [] } ) { + if ( $token->is_named() ) { + _record_named_capture( $token->name(), $captures, $named_captures ); + } else { + _record_numbered_capture( $token->absolute(), $captures ); + } + } + + foreach my $token ( @{ $re->find( + 'PPIx::Regexp::Token::Code' ) || [] } ) { + my $ppi = $token->ppi() or next; + _check_node_children( $ppi, { + regexp => $re, + numbered_captures => $captures, + named_captures => $named_captures, + document => $doc, + }, _make_regexp_checker() ); + } + + return ( none {not defined} @{$captures} ) + && ( !%{$named_captures} || + none {defined} values %{$named_captures} ); +} + +sub _enough_assignments { + my ($elem, $captures) = @_; + + # look backward for the assignment operator + my $psib = $elem->sprevious_sibling; + SIBLING: + while (1) { + return if !$psib; + if ($psib->isa('PPI::Token::Operator')) { + last SIBLING if q{=} eq $psib->content; + return if q{!~} eq $psib->content; + } + $psib = $psib->sprevious_sibling; + } + + $psib = $psib->sprevious_sibling; + return if !$psib; # syntax error: '=' at the beginning of a statement??? + + if ($psib->isa('PPI::Token::Symbol')) { + # @foo = m/(foo)/ + # @$foo = m/(foo)/ + # %foo = m/(foo)/ + # %$foo = m/(foo)/ + return $TRUE if _symbol_is_slurpy($psib); + + } elsif ($psib->isa('PPI::Structure::Block')) { + # @{$foo} = m/(foo)/ + # %{$foo} = m/(foo)/ + return $TRUE if _block_is_slurpy($psib); + + } elsif ($psib->isa('PPI::Structure::List')) { + # () = m/(foo)/ + # ($foo) = m/(foo)/ + # ($foo,$bar) = m/(foo)(bar)/ + # (@foo) = m/(foo)(bar)/ + # ($foo,@foo) = m/(foo)(bar)/ + # ($foo,@$foo) = m/(foo)(bar)/ + # ($foo,@{$foo}) = m/(foo)(bar)/ + + my @args = $psib->schildren; + return $TRUE if not @args; # empty list (perhaps the "goatse" operator) is slurpy + + # Forward looking: PPI might change in v1.200 so schild(0) is a + # PPI::Statement::Expression. + if ( 1 == @args && $args[0]->isa('PPI::Statement::Expression') ) { + @args = $args[0]->schildren; + } + + my @parts = split_nodes_on_comma(@args); + PART: + for my $i (0 .. $#parts) { + if (1 == @{$parts[$i]}) { + my $var = $parts[$i]->[0]; + if ($var->isa('PPI::Token::Symbol') || $var->isa('PPI::Token::Cast')) { + return $TRUE if _has_array_sigil($var); + } + } + _record_numbered_capture( $i + 1, $captures ); + # ith variable capture + } + } + + return none {not defined} @{$captures}; +} + +sub _symbol_is_slurpy { + my ($symbol) = @_; + + return $TRUE if _has_array_sigil($symbol); + return $TRUE if _has_hash_sigil($symbol); + return $TRUE if _is_preceded_by_array_or_hash_cast($symbol); + return; +} + +sub _has_array_sigil { + my ($elem) = @_; # Works on PPI::Token::Symbol and ::Cast + + return q{@} eq substr $elem->content, 0, 1; +} + +sub _has_hash_sigil { + my ($elem) = @_; # Works on PPI::Token::Symbol and ::Cast + + return q{%} eq substr $elem->content, 0, 1; +} + +sub _block_is_slurpy { + my ($block) = @_; + + return $TRUE if _is_preceded_by_array_or_hash_cast($block); + return; +} + +sub _is_preceded_by_array_or_hash_cast { + my ($elem) = @_; + my $psib = $elem->sprevious_sibling; + my $cast; + while ($psib && $psib->isa('PPI::Token::Cast')) { + $cast = $psib; + $psib = $psib->sprevious_sibling; + } + return if !$cast; + my $sigil = substr $cast->content, 0, 1; + return q{@} eq $sigil || q{%} eq $sigil; +} + +sub _is_in_slurpy_array_context { + my ($elem) = @_; + + # return true is the result of the regexp is passed to a subroutine. + # doesn't check for array context due to assignment. + + # look backward for explicit regex operator + my $psib = $elem->sprevious_sibling; + if ($psib && $psib->content eq q{=~}) { + # Track back through value + $psib = _skip_lhs($psib); + } + + if (!$psib) { + my $parent = $elem->parent; + return if !$parent; + if ($parent->isa('PPI::Statement')) { + $parent = $parent->parent; + return if !$parent; + } + + # Return true if we have a list that isn't part of a foreach loop. + # TECHNICAL DEBT: This code is basically shared with + # RequireCheckingReturnValueOfEval. I don't want to put this code + # into Perl::Critic::Utils::*, but I don't have time to sort out + # PPIx::Utilities::Structure::List yet. + if ( $parent->isa('PPI::Structure::List') ) { + my $parent_statement = $parent->statement() or return $TRUE; + return $TRUE if not + $parent_statement->isa('PPI::Statement::Compound'); + return $TRUE if $parent_statement->type() ne 'foreach'; + } + + return $TRUE if $parent->isa('PPI::Structure::Constructor'); + if ($parent->isa('PPI::Structure::Block')) { + return $TRUE + if + refaddr($elem->statement) + eq refaddr([$parent->schildren]->[-1]); + } + return; + } + if ($psib->isa('PPI::Token::Operator')) { + # most operators kill slurpiness (except assignment, which is handled elsewhere) + return $TRUE if q{,} eq $psib->content; + return; + } + return $TRUE; +} + +sub _skip_lhs { + my ($elem) = @_; + + # TODO: better implementation to handle casts, expressions, subcalls, etc. + $elem = $elem->sprevious_sibling(); + + return $elem; +} + +sub _enough_magic { + my ($elem, $re, $captures, $named_captures, $doc) = @_; + + _check_for_magic($elem, $re, $captures, $named_captures, $doc); + + return ( none {not defined} @{$captures} ) + && ( !%{$named_captures} || + none {defined} values %{$named_captures} ); +} + +# void return +sub _check_for_magic { + my ($elem, $re, $captures, $named_captures, $doc) = @_; + + # Search for $1..$9 in : + # * the rest of this statement + # * subsequent sibling statements + # * if this is in a conditional boolean, the if/else bodies of the conditional + # * if this is in a while/for condition, the loop body + # But NO intervening regexps! + + # Package up the usual arguments for _check_rest_of_statement(). + my $arg = { + regexp => $re, + numbered_captures => $captures, + named_captures => $named_captures, + document => $doc, + }; + + # Capture whether or not the regular expression is negated -- that + # is, whether it is preceded by the '!~' binding operator. + if ( my $prior_token = $elem->sprevious_sibling() ) { + $arg->{negated} = $prior_token->isa( 'PPI::Token::Operator' ) && + q eq $prior_token->content(); + } + + return if ! _check_rest_of_statement( $elem, $arg ); + + my $parent = $elem->parent(); + while ($parent && ! $parent->isa('PPI::Statement::Sub')) { + return if ! _check_rest_of_statement( $parent, $arg ); + $parent = $parent->parent(); + } + + return; +} + +# Check if we are in the condition or block of a 'while' +sub _check_if_in_while_condition_or_block { + my ( $elem ) = @_; + $elem or return; + + my $parent = $elem->parent() or return; + $parent->isa( 'PPI::Statement' ) or return; + + my $item = $parent = $parent->parent() or return; + if ( $item->isa( 'PPI::Structure::Block' ) ) { + $item = $item->sprevious_sibling() or return; + } + $item->isa( 'PPI::Structure::Condition' ) or return; + + $item = $item->sprevious_sibling() or return; + $item->isa( 'PPI::Token::Word' ) or return; + + return $WHILE eq $item->content(); +} + +{ + # Shortcut operators '||', '//', and 'or' can cause everything after + # them to be skipped. 'and' trumps '||' and '//', and causes things + # to be evaluated again. The value is true to skip, false to cancel + # skipping. + Readonly::Hash my %SHORTCUT_OPERATOR => ( + q<||> => $FALSE, + q => $FALSE, + and => $TRUE, + or => $FALSE, + ); + + # RT #38942 + # The issue in the ticket is that in something like + # if ( /(a)/ || /(b) ) { + # say $1 + # } + # the capture variable can come from either /(a)/ or /(b)/. If we + # don't take into account the short-cutting nature of the '||' we + # erroneously conclude that the capture in /(a)/ is not used. So we + # need to skip every regular expression after an alternation. + # + # The trick is that we want to still mark magic variables, because + # of code like + # my $foo = $1 || $2; + # so we can't just ignore everything after an alternation. + # + # To do all this correctly, we have to track precedence, and start + # paying attention again if an 'and' is found after a '||'. + + # Subroutine _make_regexp_checker() manufactures a snippet of code + # which is used to track regular expressions. It takes one optional + # argument, which is the snippet used to track the parent object's + # regular expressions. + # + # The snippet is passed each token encountered, and returns true if + # the scan for capture variables is to be stopped. This will happen + # if the token is a regular expression which is _not_ to the right + # of an alternation operator ('||', '//', or 'or'), or it _is_ to + # the right of an 'and', without an intervening alternation + # operator. + # + # If _make_regexp_checker() was passed a snippet which + # returns false on encountering a regular expression, the returned + # snippet always returns false, for the benefit of code like + # /(a)/ || ( /(b)/ || /(c)/ ). + + sub _make_regexp_checker { + my ( $parent ) = @_; + + $parent + and not $parent->() + and return sub { return $FALSE }; + + my $check = $TRUE; + my $precedence = 0; + + return sub { + my ( $elem ) = @_; + + $elem or return $check; + + $elem->isa( 'PPI::Token::Regexp' ) + and return $check; + + if ( $elem->isa( 'PPI::Token::Structure' ) + && q<;> eq $elem->content() ) { + $check = $TRUE; + $precedence = 0; + return $FALSE; + } + + $elem->isa( 'PPI::Token::Operator' ) + or return $FALSE; + + my $content = $elem->content(); + defined( my $oper_check = $SHORTCUT_OPERATOR{$content} ) + or return $FALSE; + + my $oper_precedence = precedence_of( $content ); + $oper_precedence >= $precedence + or return $FALSE; + + $precedence = $oper_precedence; + $check = $oper_check; + + return $FALSE; + }; + } +} + +# false if we hit another regexp +# The arguments are: +# $elem - The PPI::Element whose siblings are to be checked; +# $arg - A hash reference containing the following keys: +# regexp => the relevant PPIx::Regexp object; +# numbered_captures => a reference to the array used to track the +# use of numbered captures; +# named_captures => a reference to the hash used to track the +# use of named captures; +# negated => true if the regexp was bound to its target with the +# '!~' operator; +# document => a reference to the Perl::Critic::Document; +# Converted to passing the arguments everyone gets in a hash because of +# the need to add the 'negated' argument, which would put us at six +# arguments. +sub _check_rest_of_statement { + my ( $elem, $arg ) = @_; + + my $checker = _make_regexp_checker(); + my $nsib = $elem->snext_sibling; + + # If we are an if (or elsif) and the result of the regexp is + # negated, we skip the first block found. RT #69867 + if ( $arg->{negated} && _is_condition_of_if_statement( $elem ) ) { + while ( $nsib && ! $nsib->isa( 'PPI::Structure::Block' ) ) { + $nsib = $nsib->snext_sibling(); + } + $nsib and $nsib = $nsib->snext_sibling(); + } + + while ($nsib) { + return if $checker->($nsib); + if ($nsib->isa('PPI::Node')) { + return if ! _check_node_children($nsib, $arg, $checker ); + } else { + _mark_magic( $nsib, $arg->{regexp}, $arg->{numbered_captures}, + $arg->{named_captures}, $arg->{document} ); + } + $nsib = $nsib->snext_sibling; + } + return $TRUE; +} + +{ + + Readonly::Hash my %IS_IF_STATEMENT => hashify( qw{ if elsif } ); + + # Return true if the argument is the condition of an if or elsif + # statement, otherwise return false. + sub _is_condition_of_if_statement { + my ( $elem ) = @_; + $elem + and $elem->isa( 'PPI::Structure::Condition' ) + or return $FALSE; + my $psib = $elem->sprevious_sibling() + or return $FALSE; + $psib->isa( 'PPI::Token::Word' ) + or return $FALSE; + return $IS_IF_STATEMENT{ $psib->content() }; + + } +} + +# false if we hit another regexp +# The arguments are: +# $elem - The PPI::Node whose children are to be checked; +# $arg - A hash reference containing the following keys: +# regexp => the relevant PPIx::Regexp object; +# numbered_captures => a reference to the array used to track the +# use of numbered captures; +# named_captures => a reference to the hash used to track the +# use of named captures; +# document => a reference to the Perl::Critic::Document; +# $parent_checker - The parent's regexp checking code snippet, +# manufactured by _make_regexp_checker(). This argument is not in +# the $arg hash because that hash is shared among levels of the +# parse tree, whereas the regexp checker is not. +# TODO the things in the $arg hash are widely shared among the various +# pieces/parts of this policy; maybe more subroutines should use this +# hash rather than passing all this stuff around as individual +# arguments. This particular subroutine got the hash-reference treatment +# because Subroutines::ProhibitManyArgs started complaining when the +# checker argument was added. +sub _check_node_children { + my ($elem, $arg, $parent_checker) = @_; + + # caveat: this will descend into subroutine definitions... + + my $checker = _make_regexp_checker($parent_checker); + for my $child ($elem->schildren) { + return if $checker->($child); + if ($child->isa('PPI::Node')) { + return if ! _check_node_children($child, $arg, $checker); + } else { + _mark_magic($child, $arg->{regexp}, + $arg->{numbered_captures}, $arg->{named_captures}, + $arg->{document}); + } + } + return $TRUE; +} + +sub _mark_magic { + my ($elem, $re, $captures, $named_captures, $doc) = @_; + + # If we're a double-quotish element, we need to grub through its + # content. RT #38942 + if ( _is_double_quotish_element( $elem ) ) { + _mark_magic_in_content( + $elem->content(), $re, $captures, $named_captures, $doc ); + return; + } + + # Ditto a here document, though the logic is different. RT #38942 + if ( $elem->isa( 'PPI::Token::HereDoc' ) ) { + $elem->content() =~ m/ \A << ~? \s* ' /sxm + or _mark_magic_in_content( + join( $EMPTY, $elem->heredoc() ), $re, $captures, + $named_captures, $doc ); + return; + } + + # Only interested in magic, or known English equivalent. + my $content = $elem->content(); + my $capture_ref = $doc->uses_module( 'English' ) ? + \%CAPTURE_REFERENCE_ENGLISH : + \%CAPTURE_REFERENCE; + $elem->isa( 'PPI::Token::Magic' ) + or $capture_ref->{$content} + or return; + + if ( $content =~ m/ \A \$ ( \d+ ) /xms ) { + + # Record if we see $1, $2, $3, ... + my $num = $1; + if (0 < $num) { # don't mark $0 + # Only mark the captures we really need -- don't mark superfluous magic vars + if ($num <= @{$captures}) { + _record_numbered_capture( $num, $captures ); + } + } + } elsif ( $capture_ref->{$content} ) { + _mark_magic_subscripted_code( $elem, $re, $captures, $named_captures ); + } + return; +} + +# Record a named capture referenced by a hash or array found in code. +# The arguments are: +# $elem - The element that represents a subscripted capture variable; +# $re - The PPIx::Regexp object; +# $captures - A reference to the numbered capture array; +# $named_captures - A reference to the named capture hash. +sub _mark_magic_subscripted_code { + my ( $elem, $re, $captures, $named_captures ) = @_; + my $subscr = $elem->snext_sibling() or return; + $subscr->isa( 'PPI::Structure::Subscript' ) or return; + my $subval = $subscr->content(); + _record_subscripted_capture( + $elem->content(), $subval, $re, $captures, $named_captures ); + return; +} + +# Find capture variables in the content of a double-quotish thing, and +# record their use. RT #38942. The arguments are: +# $content - The content() ( or heredoc() in the case of a here +# document) to be analyzed; +# $re - The PPIx::Regexp object; +# $captures - A reference to the numbered capture array; +# $named_captures - A reference to the named capture hash. +sub _mark_magic_in_content { + my ( $content, $re, $captures, $named_captures, $doc ) = @_; + + my $capture_ref = $doc->uses_module( 'English' ) ? + \%CAPTURE_REFERENCE_ENGLISH : + \%CAPTURE_REFERENCE; + + while ( $content =~ m< ( \$ (?: + [{] (?: \w+ | . ) [}] | \w+ | . ) ) >sxmg ) { + my $name = $1; + $name =~ s/ \A \$ [{] /\$/sxm; + $name =~ s/ [}] \z //sxm; + + if ( $name =~ m/ \A \$ ( \d+ ) \z /sxm ) { + + my $num = $1; + 0 < $num + and $num <= @{ $captures } + and _record_numbered_capture( $num, $captures ); + + } elsif ( $capture_ref->{$name} && + $content =~ m/ \G ( [{] [^}]+ [}] | [[] [^]] []] ) /smxgc ) + { + _record_subscripted_capture( + $name, $1, $re, $captures, $named_captures ); + + } + } + return; +} + +# Return true if the given element is double-quotish. Always returns +# false for a PPI::Token::HereDoc, since they're a different beast. +# RT #38942. +sub _is_double_quotish_element { + my ( $elem ) = @_; + + $elem or return; + + my $content = $elem->content(); + + if ( $elem->isa( 'PPI::Token::QuoteLike::Command' ) ) { + return $content !~ m/ \A qx \s* ' /sxm; + } + + foreach my $class ( qw{ + PPI::Token::Quote::Double + PPI::Token::Quote::Interpolate + PPI::Token::QuoteLike::Backtick + PPI::Token::QuoteLike::Readline + } ) { + $elem->isa( $class ) and return $TRUE; + } + + return $FALSE; +} + +# Record a subscripted capture, either hash dereference or array +# dereference. We assume that an array represents a numbered capture and +# a hash represents a named capture, since we have to handle (e.g.) both +# @+ and %+. +sub _record_subscripted_capture { + my ( $variable_name, $suffix, $re, $captures, $named_captures ) = @_; + if ( $suffix =~ m/ \A [{] ( .*? ) [}] /smx ) { + ( my $name = $1 ) =~ s/ \A ( ["'] ) ( .*? ) \1 \z /$2/smx; + _record_named_capture( $name, $captures, $named_captures ); + } elsif ( $suffix =~ m/ \A [[] \s* ( [-+]? \d+ ) \s* []] /smx ) { + _record_numbered_capture( $1 . q{}, $captures, $re ); + } + return; +} + +# Because a named capture is also one or more numbered captures, the recording +# of the use of a named capture seemed complex enough to wrap in a subroutine. +sub _record_named_capture { + my ( $name, $captures, $named_captures ) = @_; + defined ( my $numbers = $named_captures->{$name} ) or return; + foreach my $capnum ( @{ $numbers } ) { + _record_numbered_capture( $capnum, $captures ); + } + $named_captures->{$name} = undef; + return; +} + +sub _record_numbered_capture { + my ( $number, $captures, $re ) = @_; + $re and $number < 0 + and $number = $re->max_capture_number() + $number + 1; + return if $number <= 0; + $captures->[ $number - 1 ] = 1; + return; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords refactored + +=head1 NAME + +Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture - Only use a capturing group if you plan to use the captured value. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Perl regular expressions have multiple types of grouping syntax. The +basic parentheses (e.g. C) captures into the magic variable +C<$1>. Non-capturing groups (e.g. C are useful because +they have better runtime performance and do not copy strings to the +magic global capture variables. + +It's also easier on the maintenance programmer if you consistently use +capturing vs. non-capturing groups, because that programmer can tell +more easily which regexps can be refactored without breaking +surrounding code which may use the captured values. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 CAVEATS + +=head2 C interpolation + +This policy can be confused by interpolation of C elements, but +those are always false negatives. For example: + + my $foo_re = qr/(foo)/; + my ($foo) = m/$foo_re (bar)/x; + +A human can tell that this should be a violation because there are two +captures but only the first capture is used, not the second. The +policy only notices that there is one capture in the regexp and +remains happy. + +=head2 C<@->, C<@+>, C<$LAST_MATCH_START> and C<$LAST_MATCH_END> + +This policy will only recognize capture groups referred to by these +variables if the use is subscripted by a literal integer. + +=head2 C<$^N> and C<$LAST_SUBMATCH_RESULT> + +This policy will not recognize capture groups referred to only by these +variables, because there is in general no way by static analysis to +determine which capture group is referred to. For example, + + m/ (?: (A[[:alpha:]]+) | (N\d+) ) (?{$foo=$^N}) /smx + +makes use of the first capture group if it matches, or the second +capture group if the first does not match but the second does. + + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusualDelimiters.pm b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusualDelimiters.pm new file mode 100644 index 0000000..cfdce6b --- /dev/null +++ b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusualDelimiters.pm @@ -0,0 +1,138 @@ +package Perl::Critic::Policy::RegularExpressions::ProhibitUnusualDelimiters; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use English qw(-no_match_vars); +use Carp; + +use Perl::Critic::Utils qw{ :booleans :severities hashify }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q; +Readonly::Scalar my $EXPL => [246]; + +Readonly::Array my @EXTRA_BRACKETS => qw{ () [] <> }; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'allow_all_brackets', + description => + q[In addition to allowing '{}', allow '()', '[]', and '{}'.], + behavior => 'boolean', + }, + ); +} + +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw( core pbp cosmetic ) } +sub applies_to { return qw(PPI::Token::Regexp::Match + PPI::Token::Regexp::Substitute + PPI::Token::QuoteLike::Regexp) } + +#----------------------------------------------------------------------------- + +sub initialize_if_enabled { + my ( $self, $config ) = @_; + + my %delimiters = hashify( qw< // {} > ); + if ( $self->{_allow_all_brackets} ) { + @delimiters{ @EXTRA_BRACKETS } = (1) x @EXTRA_BRACKETS; + } + + $self->{_allowed_delimiters} = \%delimiters; + + return $TRUE; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + my $allowed_delimiters = $self->{_allowed_delimiters}; + foreach my $delimiter ($elem->get_delimiters()) { + next if $allowed_delimiters->{$delimiter}; + return $self->violation( $DESC, $EXPL, $elem ); + } + + return; # OK +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::RegularExpressions::ProhibitUnusualDelimiters - Use only C or C<{}> to delimit regexps. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Perl lets you delimit regular expressions with almost any character, +but most choices are illegible. Compare these equivalent expressions: + + s/foo/bar/; # good + s{foo}{bar}; # good + s#foo#bar#; # bad + s;foo;bar;; # worse + s|\|\||\||; # eye-gouging bad + + +=head1 CONFIGURATION + +There is one option for this policy, C. If this +is true, then, in addition to allowing C and C<{}>, the other +matched pairs of C<()>, C<[]>, and C<< <> >> are allowed. + + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/RegularExpressions/ProhibitUselessTopic.pm b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitUselessTopic.pm new file mode 100644 index 0000000..7f3046a --- /dev/null +++ b/lib/Perl/Critic/Policy/RegularExpressions/ProhibitUselessTopic.pm @@ -0,0 +1,116 @@ +package Perl::Critic::Policy::RegularExpressions::ProhibitUselessTopic; + +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification :ppi }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +## no critic ( ValuesAndExpressions::RequireInterpolationOfMetachars ) +## The numerous $_ variables make false positives. +Readonly::Scalar my $DESC => q{Useless use of $_}; +Readonly::Scalar my $EXPL => q{$_ should be omitted when matching a regular expression}; + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw( core ) } +sub applies_to { return 'PPI::Token::Magic' } + +sub violates { + my ( $self, $elem, undef ) = @_; + + my $content = $elem->content; + if ( $content eq q{$_} ) { + # Is there an op following the $_ ? + my $op_node = $elem->snext_sibling; + if ( $op_node && $op_node->isa('PPI::Token::Operator') ) { + # If the op is a regex match, then we have an unnecessary $_ . + my $op = $op_node->content; + if ( $op eq q{=~} || $op eq q{!~} ) { + my $target_node = $op_node->snext_sibling; + if ( $target_node && ($target_node->isa('PPI::Token::Regexp') || $target_node->isa('PPI::Token::QuoteLike::Regexp')) ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + } + } + } + + return; +} + +1; + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::RegularExpressions::ProhibitUselessTopic - Don't use $_ to match against regexes. + +=head1 AFFILIATION + +This Policy is part of the L distribution. + +=head1 DESCRIPTION + +It is not necessary to specify the topic variable C<$_> when matching +against a regular expression. + +Match or substitution operations are performed against variables, such as: + + $x =~ /foo/; + $x =~ s/foo/bar/; + $x =~ tr/a-mn-z/n-za-m/; + +If a variable is not specified, the match is against C<$_>. + + # These are identical. + /foo/; + $_ =~ /foo/; + + # These are identical. + s/foo/bar/; + $_ =~ s/foo/bar/; + + # These are identical. + tr/a-mn-z/n-za-m/; + $_ =~ tr/a-mn-z/n-za-m/; + +This applies to negative matching as well. + + # These are identical + if ( $_ !~ /DEBUG/ ) { ... + if ( !/DEBUG ) { ... + +Including the C<$_ =~> or C<$_ !~> is unnecessary, adds complexity, +and is not idiomatic Perl. + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + +=head1 AUTHOR + +Andy Lester + +=head1 COPYRIGHT + +Copyright (c) 2013 Andy Lester + +This library is free software; you can redistribute it and/or modify it +under the terms of the Artistic License 2.0. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/RegularExpressions/RequireBracesForMultiline.pm b/lib/Perl/Critic/Policy/RegularExpressions/RequireBracesForMultiline.pm new file mode 100644 index 0000000..c3a063c --- /dev/null +++ b/lib/Perl/Critic/Policy/RegularExpressions/RequireBracesForMultiline.pm @@ -0,0 +1,156 @@ +package Perl::Critic::Policy::RegularExpressions::RequireBracesForMultiline; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use English qw(-no_match_vars); +use Carp; + +use Perl::Critic::Utils qw{ :booleans :severities }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q; +Readonly::Scalar my $EXPL => [242]; + +Readonly::Array my @EXTRA_BRACKETS => qw{ () [] <> }; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'allow_all_brackets', + description => + q[In addition to allowing '{}', allow '()', '[]', and '{}'.], + behavior => 'boolean', + }, + ); +} + +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw( core pbp cosmetic ) } +sub applies_to { return qw(PPI::Token::Regexp::Match + PPI::Token::Regexp::Substitute + PPI::Token::QuoteLike::Regexp) } + +#----------------------------------------------------------------------------- + +sub initialize_if_enabled { + my ( $self, $config ) = @_; + + my %delimiters = ( q<{}> => 1 ); + if ( $self->{_allow_all_brackets} ) { + @delimiters{ @EXTRA_BRACKETS } = (1) x @EXTRA_BRACKETS; + } + + $self->{_allowed_delimiters} = \%delimiters; + + return $TRUE; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + my $re = $elem->get_match_string(); + return if $re !~ m/\n/xms; + + my ($match_delim) = $elem->get_delimiters(); + return if $self->{_allowed_delimiters}{$match_delim}; + + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::RegularExpressions::RequireBracesForMultiline - Use C<{> and C<}> to delimit multi-line regexps. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Long regular expressions are hard to read. A good practice is to use +the C modifier and break the regex into multiple lines with +comments explaining the parts. But, with the usual C delimiters, +the beginning and end can be hard to match, especially in a C +regexp. Instead, try using C<{}> characters to delimit your +expressions. + +Compare these: + + s/ + + (.*?) + + /link=$1, text=$2/xms; + +vs. + + s{ + + (.*?) + + } + {link=$1, text=$2}xms; + +Is that an improvement? Marginally, but yes. The curly braces lead +the eye better. + + +=head1 CONFIGURATION + +There is one option for this policy, C. If this +is true, then, in addition to allowing C<{}>, the other matched pairs +of C<()>, C<[]>, and C<< <> >> are allowed. + + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/RegularExpressions/RequireDotMatchAnything.pm b/lib/Perl/Critic/Policy/RegularExpressions/RequireDotMatchAnything.pm new file mode 100644 index 0000000..c1f6a38 --- /dev/null +++ b/lib/Perl/Critic/Policy/RegularExpressions/RequireDotMatchAnything.pm @@ -0,0 +1,108 @@ +package Perl::Critic::Policy::RegularExpressions::RequireDotMatchAnything; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Regular expression without "/s" flag}; +Readonly::Scalar my $EXPL => [ 240, 241 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw } +sub applies_to { return qw } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + + my $re = $doc->ppix_regexp_from_element( $elem ) + or return; + $re->modifier_asserted( 's' ) + or return $self->violation( $DESC, $EXPL, $elem ); + + return; #ok!; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::RegularExpressions::RequireDotMatchAnything - Always use the C modifier with regular expressions. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +When asked what C<.> in a regular expression means, most people will +say that it matches any character, which isn't true. It's actually +shorthand for C<[^\n]>. Using the C modifier makes C<.> act like +people expect it to. + + my $match = m< foo.bar >xm; # not ok + my $match = m< foo.bar >xms; # ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 NOTES + +Be cautious about slapping modifier flags onto existing regular +expressions, as they can drastically alter their meaning. See +L for an interesting +discussion on the effects of blindly modifying regular expression +flags. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/RegularExpressions/RequireExtendedFormatting.pm b/lib/Perl/Critic/Policy/RegularExpressions/RequireExtendedFormatting.pm new file mode 100644 index 0000000..48aa7b9 --- /dev/null +++ b/lib/Perl/Critic/Policy/RegularExpressions/RequireExtendedFormatting.pm @@ -0,0 +1,178 @@ +package Perl::Critic::Policy::RegularExpressions::RequireExtendedFormatting; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Regular expression without "/x" flag}; +Readonly::Scalar my $EXPL => [ 236 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'minimum_regex_length_to_complain_about', + description => + q, + behavior => 'integer', + default_string => '0', + integer_minimum => 0, + }, + { + name => 'strict', + description => + q, + behavior => 'boolean', + default_string => '0', + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw< core pbp maintenance > } +sub applies_to { + return qw< + PPI::Token::Regexp::Match + PPI::Token::Regexp::Substitute + PPI::Token::QuoteLike::Regexp + >; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + + my $match = $elem->get_match_string(); + return if length $match <= $self->{_minimum_regex_length_to_complain_about}; + return if not $self->{_strict} and $match =~ m< \A [\s\w]* \z >xms; + + my $re = $doc->ppix_regexp_from_element( $elem ) + or return; + $re->modifier_asserted( 'x' ) + or return $self->violation( $DESC, $EXPL, $elem ); + + return; # ok!; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::RegularExpressions::RequireExtendedFormatting - Always use the C modifier with regular expressions. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Extended regular expression formatting allows you mix whitespace and +comments into the pattern, thus making them much more readable. + + # Match a single-quoted string efficiently... + + m{'[^\\']*(?:\\.[^\\']*)*'}; #Huh? + + # Same thing with extended format... + + m{ + ' # an opening single quote + [^\\'] # any non-special chars (i.e. not backslash or single quote) + (?: # then all of... + \\ . # any explicitly backslashed char + [^\\']* # followed by an non-special chars + )* # ...repeated zero or more times + ' # a closing single quote + }x; + + +=head1 CONFIGURATION + +You might find that putting a C on short regular expressions to be +excessive. An exception can be made for them by setting +C to the minimum match length +you'll allow without a C. The length only counts the regular +expression, not the braces or operators. + + [RegularExpressions::RequireExtendedFormatting] + minimum_regex_length_to_complain_about = 5 + + $num =~ m<(\d+)>; # ok, only 5 characters + $num =~ m<\d\.(\d+)>; # not ok, 9 characters + +This option defaults to 0. + +Because using C on a regex which has whitespace in it can make it +harder to read (you have to escape all that innocent whitespace), by +default, you can have a regular expression that only contains +whitespace and word characters without the modifier. If you want to +restrict this, turn on the C option. + + [RegularExpressions::RequireExtendedFormatting] + strict = 1 + + $string =~ m/Basset hounds got long ears/; # no longer ok + +This option defaults to false. + + +=head1 NOTES + +For common regular expressions like e-mail addresses, phone numbers, +dates, etc., have a look at the L module. +Also, be cautions about slapping modifier flags onto existing regular +expressions, as they can drastically alter their meaning. See +L for an interesting +discussion on the effects of blindly modifying regular expression +flags. + + +=head1 TO DO + +Add an exemption for regular expressions that contain C<\Q> at the +front and don't use C<\E> until the very end, if at all. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/RegularExpressions/RequireLineBoundaryMatching.pm b/lib/Perl/Critic/Policy/RegularExpressions/RequireLineBoundaryMatching.pm new file mode 100644 index 0000000..e5f26f7 --- /dev/null +++ b/lib/Perl/Critic/Policy/RegularExpressions/RequireLineBoundaryMatching.pm @@ -0,0 +1,109 @@ +package Perl::Critic::Policy::RegularExpressions::RequireLineBoundaryMatching; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Regular expression without "/m" flag}; +Readonly::Scalar my $EXPL => [ 237 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core pbp cosmetic) } +sub applies_to { return qw(PPI::Token::Regexp::Match + PPI::Token::Regexp::Substitute + PPI::Token::QuoteLike::Regexp) } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + + my $re = $doc->ppix_regexp_from_element( $elem ) + or return; + $re->modifier_asserted( 'm' ) + or return $self->violation( $DESC, $EXPL, $elem ); + + return; #ok!; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::RegularExpressions::RequireLineBoundaryMatching - Always use the C modifier with regular expressions. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Folks coming from a C or C background tend to assume that +C<'$'> and C<'^'> match the beginning and end of the line, rather than +then beginning and end of the string. Adding the '/m' flag to your +regex makes it behave as most people expect it should. + + my $match = m{ ^ $pattern $ }x; #not ok + my $match = m{ ^ $pattern $ }xm; #ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 NOTES + +For common regular expressions like e-mail addresses, phone numbers, +dates, etc., have a look at the L module. +Also, be cautions about slapping modifier flags onto existing regular +expressions, as they can drastically alter their meaning. See +L for an interesting +discussion on the effects of blindly modifying regular expression +flags. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Subroutines/ProhibitAmpersandSigils.pm b/lib/Perl/Critic/Policy/Subroutines/ProhibitAmpersandSigils.pm new file mode 100644 index 0000000..484015d --- /dev/null +++ b/lib/Perl/Critic/Policy/Subroutines/ProhibitAmpersandSigils.pm @@ -0,0 +1,138 @@ +package Perl::Critic::Policy::Subroutines::ProhibitAmpersandSigils; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use Perl::Critic::Utils qw{ :severities hashify }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Subroutine called with "&" sigil}; +Readonly::Scalar my $EXPL => [ 175 ]; + +Readonly::Hash my %EXEMPTIONS => + hashify( qw< defined exists goto sort > ); + +Readonly::Hash my %IS_COMMA => + hashify( q{,}, q{=>} ); + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core pbp maintenance) } +sub applies_to { return 'PPI::Token::Symbol' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + my $previous = $elem->sprevious_sibling(); + if ( $previous ) { + #Sigil is allowed if taking a reference, e.g. "\&my_sub" + return if $previous->isa('PPI::Token::Cast') && $previous eq q{\\}; + } + + return if ( $elem !~ m{\A [&] }xms ); # ok + + # look up past parens to get say the "defined" in "defined(&foo)" or + # "defined((&foo))" etc + if (not $previous or + $previous->isa( 'PPI::Token::Operator' ) and + $IS_COMMA{ $previous->content() } ) { + my $up = $elem; + + PARENT: + while ( + ($up = $up->parent) + and ( + $up->isa('PPI::Statement::Expression') + or $up->isa('PPI::Structure::List') + or $up->isa('PPI::Statement') + ) + ) { + if (my $word = $up->sprevious_sibling) { + # Since backslashes distribute over lists (per perlref), if + # we have a list and the previous is a backslash, we're cool. + return if + $up->isa('PPI::Structure::List') + && $word->isa('PPI::Token::Cast') + && $word->content() eq q{\\}; + + # For a word set $previous to have it checked against %EXEMPTIONS + # below. For a non-word it's a violation, leave $previous false + # to get there. + if ($word->isa('PPI::Token::Word')) { + $previous = $word; + } + last PARENT; + } + } + } + return if $previous and $EXEMPTIONS{$previous}; + + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Subroutines::ProhibitAmpersandSigils - Don't call functions with a leading ampersand sigil. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Since Perl 5, the ampersand sigil is completely optional when invoking +subroutines. It also turns off checking of subroutine prototypes. +It's easily confused with the bitwise 'and' operator. + + @result = &some_function(); # not ok + @result = some_function(); # ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Subroutines/ProhibitBuiltinHomonyms.pm b/lib/Perl/Critic/Policy/Subroutines/ProhibitBuiltinHomonyms.pm new file mode 100644 index 0000000..0693276 --- /dev/null +++ b/lib/Perl/Critic/Policy/Subroutines/ProhibitBuiltinHomonyms.pm @@ -0,0 +1,123 @@ +package Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :data_conversion + :classification :characters }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Array my @ALLOW => qw( import AUTOLOAD DESTROY ); +Readonly::Hash my %ALLOW => hashify( @ALLOW ); +Readonly::Scalar my $DESC => q{Subroutine name is a homonym for builtin %s %s}; +Readonly::Scalar my $EXPL => [177]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core bugs pbp certrule ) } +sub applies_to { return 'PPI::Statement::Sub' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + return if $elem->isa('PPI::Statement::Scheduled'); #e.g. BEGIN, INIT, END + return if exists $ALLOW{ $elem->name() }; + + my $homonym_type = $EMPTY; + if ( is_perl_builtin( $elem ) ) { + $homonym_type = 'function'; + } + elsif ( is_perl_bareword( $elem ) ) { + $homonym_type = 'keyword'; + } + else { + return; #ok! + } + + my $desc = sprintf $DESC, $homonym_type, $elem->name(); + return $self->violation($desc, $EXPL, $elem); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords perlfunc perlsyn + +=head1 NAME + +Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms - Don't declare your own C function. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Common sense dictates that you shouldn't declare subroutines with the same +name as one of Perl's built-in functions or keywords. See +L for a list of built-in functions; see L +for keywords. + + sub open {} #not ok + sub exit {} #not ok + sub print {} #not ok + sub foreach {} #not ok + sub if {} #not ok + + #You get the idea... + +Exceptions are made for C, C, C and C blocks, +as well as C, C, and C subroutines. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 CAVEATS + +It is reasonable to declare an B method with the same name as +a Perl built-in function, since they are easily distinguished from +each other. However, at this time, Perl::Critic cannot tell whether a +subroutine is static or an object method. + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Subroutines/ProhibitExcessComplexity.pm b/lib/Perl/Critic/Policy/Subroutines/ProhibitExcessComplexity.pm new file mode 100644 index 0000000..a4ada32 --- /dev/null +++ b/lib/Perl/Critic/Policy/Subroutines/ProhibitExcessComplexity.pm @@ -0,0 +1,144 @@ +package Perl::Critic::Policy::Subroutines::ProhibitExcessComplexity; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :data_conversion :classification }; +use Perl::Critic::Utils::McCabe qw{ calculate_mccabe_of_sub }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => q{Consider refactoring}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'max_mccabe', + description => 'The maximum complexity score allowed.', + default_string => '20', + behavior => 'integer', + integer_minimum => 1, + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw(core complexity maintenance) } +sub applies_to { return 'PPI::Statement::Sub' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + my $score = calculate_mccabe_of_sub( $elem ); + + # Is it too complex? + return if $score <= $self->{_max_mccabe}; + + my $desc; + if ( my $name = $elem->name() ) { + $desc = qq; + } + else { + $desc = qq; + } + + return $self->violation( $desc, $EXPL, $elem ); +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords McCabe + +=head1 NAME + +Perl::Critic::Policy::Subroutines::ProhibitExcessComplexity - Minimize complexity by factoring code into smaller subroutines. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +All else being equal, complicated code is more error-prone and more +expensive to maintain than simpler code. The first step towards +managing complexity is to establish formal complexity metrics. One +such metric is the McCabe score, which describes the number of +possible paths through a subroutine. This Policy approximates the +McCabe score by summing the number of conditional statements and +operators within a subroutine. Research has shown that a McCabe score +higher than 20 is a sign of high-risk, potentially untestable code. +See L +for some discussion about the McCabe number and other complexity +metrics. + +The usual prescription for reducing complexity is to refactor code +into smaller subroutines. Mark Dominus book "Higher Order Perl" also +describes callbacks, recursion, memoization, iterators, and other +techniques that help create simple and extensible Perl code. + +=head1 CONFIGURATION + +The maximum acceptable McCabe can be set with the C +configuration item. Any subroutine with a McCabe score higher than +this number will generate a policy violation. The default is 20. An +example section for a F<.perlcriticrc>: + + [Subroutines::ProhibitExcessComplexity] + max_mccabe = 30 + +=head1 NOTES + + + "Everything should be made as simple as possible, but no simpler." + + -- Albert Einstein + + +Complexity is subjective, but formal complexity metrics are still +incredibly valuable. Every problem has an inherent level of +complexity, so it is not necessarily optimal to minimize the McCabe +number. So don't get offended if your code triggers this Policy. +Just consider if there B be a simpler way to get the job done. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Subroutines/ProhibitExplicitReturnUndef.pm b/lib/Perl/Critic/Policy/Subroutines/ProhibitExplicitReturnUndef.pm new file mode 100644 index 0000000..5d6231d --- /dev/null +++ b/lib/Perl/Critic/Policy/Subroutines/ProhibitExplicitReturnUndef.pm @@ -0,0 +1,149 @@ +package Perl::Critic::Policy::Subroutines::ProhibitExplicitReturnUndef; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{"return" statement with explicit "undef"}; +Readonly::Scalar my $EXPL => [ 199 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw(core pbp bugs certrec ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + return if $elem->content() ne 'return'; + return if is_hash_key($elem); + + my $sib = $elem->snext_sibling(); + return if !$sib; + return if !$sib->isa('PPI::Token::Word'); + return if $sib->content() ne 'undef'; + + # Must be 'return undef' + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Subroutines::ProhibitExplicitReturnUndef - Return failure with bare C instead of C. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Returning C upon failure from a subroutine is pretty common. +But if the subroutine is called in list context, an explicit C statement will return a one-element list containing +C<(undef)>. Now if that list is subsequently put in a boolean context +to test for failure, then it evaluates to true. But you probably +wanted it to be false. + + sub read_file { + my $file = shift; + -f $file || return undef; #file doesn't exist! + + #Continue reading file... + } + + #and later... + + if ( my @data = read_file($filename) ){ + + # if $filename doesn't exist, + # @data will be (undef), + # but I'll still be in here! + + process(@data); + } + else{ + + # This is my error handling code. + # I probably want to be in here + # if $filname doesn't exist. + + die "$filename not found"; + } + +The solution is to just use a bare C statement whenever you +want to return failure. In list context, Perl will then give you an +empty list (which is false), and C in scalar context (which is +also false). + + sub read_file { + my $file = shift; + -f $file || return; #DWIM! + + #Continue reading file... + } + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 NOTES + +You can fool this policy pretty easily by hiding C in a boolean +expression. But don't bother trying. In fact, using return values to +indicate failure is pretty poor technique anyway. Consider using +C or C with C, or the L module for a +much more robust exception-handling model. Conway has a real nice +discussion on error handling in chapter 13 of PBP. + + +=head1 SEE ALSO + +There's a discussion of the appropriateness of this policy at +L. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Subroutines/ProhibitManyArgs.pm b/lib/Perl/Critic/Policy/Subroutines/ProhibitManyArgs.pm new file mode 100644 index 0000000..8be7dee --- /dev/null +++ b/lib/Perl/Critic/Policy/Subroutines/ProhibitManyArgs.pm @@ -0,0 +1,217 @@ +package Perl::Critic::Policy::Subroutines::ProhibitManyArgs; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use File::Spec; +use English qw(-no_match_vars); +use Carp; + +use Perl::Critic::Utils qw{ :booleans :severities split_nodes_on_comma }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $AT => q{@}; +Readonly::Scalar my $AT_ARG => q{@_}; ## no critic (InterpolationOfMetachars) +Readonly::Scalar my $CLASS => q{$class}; ## no critic (InterpolationOfMetachars) +Readonly::Scalar my $SELF => q{$self}; ## no critic (InterpolationOfMetachars) + +Readonly::Scalar my $DESC => q{Too many arguments}; +Readonly::Scalar my $EXPL => [182]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'max_arguments', + description => + 'The maximum number of arguments to allow a subroutine to have.', + default_string => '5', + behavior => 'integer', + integer_minimum => 1, + }, + { + name => 'skip_object', + description => q[Don't count $self or $class first argument], ## no critic (InterpolationOfMetachars) + default_string => '0', + behavior => 'boolean', + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core pbp maintenance ) } +sub applies_to { return 'PPI::Statement::Sub' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + # forward declaration? + return if !$elem->block; + + my $num_args; + if ($elem->prototype) { + my $prototype = $elem->prototype(); + $prototype =~ s/ \\ [[] .*? []] /*/smxg; # Allow for grouping + $num_args = $prototype =~ tr/$@%&*_+/$@%&*_+/; # RT 56627 + } else { + $num_args = _count_args($self->{_skip_object}, $elem->block->schildren); + } + + if ($self->{_max_arguments} < $num_args) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; # OK +} + +sub _count_args { + my ($skip_object, @statements) = @_; + + # look for these patterns: + # " ... = @_;" => then examine previous variable list + # " ... = shift;" => counts as one arg, then look for more + + return 0 if !@statements; # no statements + + my $statement = shift @statements; + my @elements = $statement->schildren(); + my $operand = pop @elements; + while ($operand && $operand->isa('PPI::Token::Structure') && q{;} eq $operand->content()) { + $operand = pop @elements; + } + return 0 if !$operand; + + #print "pulled off last, remaining: '@elements'\n"; + my $operator = pop @elements; + return 0 if !$operator; + return 0 if !$operator->isa('PPI::Token::Operator'); + return 0 if q{=} ne $operator->content(); + + if ($operand->isa('PPI::Token::Magic') && $AT_ARG eq $operand->content()) { + return _count_list_elements($skip_object, @elements); + } elsif ($operand->isa('PPI::Token::Word') && 'shift' eq $operand->content()) { + my $count_first = $skip_object ? !_is_object_arg(pop @elements) : 1; + return $count_first + _count_args(0, @statements); # only check for object on first argument + } + + return 0; +} + +sub _count_list_elements { + my ($skip_object, @elements) = @_; + + my $list = pop @elements; + return 0 if !$list; + return 0 if !$list->isa('PPI::Structure::List'); + my @inner = $list->schildren; + if (1 == @inner && $inner[0]->isa('PPI::Statement::Expression')) { + @inner = $inner[0]->schildren; + } + my @args = split_nodes_on_comma(@inner); + return scalar @args if !$skip_object || !@args;; + + # Check if first argument is $self/$class + my $first_ref = $args[0]; + return scalar @args if scalar @{ $first_ref } != 1; # more complex than simple scalar + return scalar @args - !!_is_object_arg($first_ref->[0]); +} + +sub _is_object_arg { + my ($symbol) = @_; + return 0 if !$symbol; + return 0 if !$symbol->isa('PPI::Token::Symbol'); + return $SELF eq $symbol->content() || $CLASS eq $symbol->content(); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords refactored + +=head1 NAME + +Perl::Critic::Policy::Subroutines::ProhibitManyArgs - Too many arguments. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Subroutines that expect large numbers of arguments are hard to use +because programmers routinely have to look at documentation to +remember the order of those arguments. Many arguments is often a sign +that a subroutine should be refactored or that an object should be +passed to the routine. + + +=head1 CONFIGURATION + +By default, this policy allows up to 5 arguments without warning. To +change this threshold, put entries in a F<.perlcriticrc> file like +this: + + [Subroutines::ProhibitManyArgs] + max_arguments = 6 + +To ignore C<$self> or C<$class> in your argument count, as long as they're +the first argument, use: + + [Subroutines::ProhibitManyArgs] + skip_object = 1 + + +=head1 CAVEATS + +PPI doesn't currently detect anonymous subroutines, so we don't check +those. This should just work when PPI gains that feature. + +We don't check for C<@ARG>, the alias for C<@_> from English.pm. +That's deprecated anyway. + + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2007-2019 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Subroutines/ProhibitNestedSubs.pm b/lib/Perl/Critic/Policy/Subroutines/ProhibitNestedSubs.pm new file mode 100644 index 0000000..0c77f71 --- /dev/null +++ b/lib/Perl/Critic/Policy/Subroutines/ProhibitNestedSubs.pm @@ -0,0 +1,116 @@ +package Perl::Critic::Policy::Subroutines::ProhibitNestedSubs; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Nested named subroutine}; +Readonly::Scalar my $EXPL => + q{Declaring a named sub inside another named sub does not prevent the } + . q{inner sub from being global}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw(core bugs) } +sub applies_to { return 'PPI::Statement::Sub' } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, $doc) = @_; + + return if $elem->isa('PPI::Statement::Scheduled'); + + my $inner = $elem->find_first( + sub { + return + $_[1]->isa('PPI::Statement::Sub') + && ! $_[1]->isa('PPI::Statement::Scheduled'); + } + ); + return if not $inner; + + # Must be a violation... + return $self->violation($DESC, $EXPL, $inner); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords RJBS SIGNES + +=head1 NAME + +Perl::Critic::Policy::Subroutines::ProhibitNestedSubs - C. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +B + +This does not do what you think: + + sub do_something { + ... + sub do_subprocess { + ... + } + ... + } + +C is global, despite where it is declared. Either +write your subs without nesting or use anonymous code references. + + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 NOTE + +Originally part of L. + + +=head1 AUTHOR + +Ricardo SIGNES + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Ricardo SIGNES. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Subroutines/ProhibitReturnSort.pm b/lib/Perl/Critic/Policy/Subroutines/ProhibitReturnSort.pm new file mode 100644 index 0000000..1835d6a --- /dev/null +++ b/lib/Perl/Critic/Policy/Subroutines/ProhibitReturnSort.pm @@ -0,0 +1,124 @@ +package Perl::Critic::Policy::Subroutines::ProhibitReturnSort; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{"return" statement followed by "sort"}; +Readonly::Scalar my $EXPL => q{Behavior is undefined if called in scalar context}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw(core bugs certrule ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + return if $elem->content() ne 'return'; + return if is_hash_key($elem); + + my $sib = $elem->snext_sibling(); + return if !$sib; + return if !$sib->isa('PPI::Token::Word'); + return if $sib->content() ne 'sort'; + + # Must be 'return sort' + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords Ulrich Wisser + +=head1 NAME + +Perl::Critic::Policy::Subroutines::ProhibitReturnSort - Behavior of C is not defined if called in scalar context. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + +=head1 DESCRIPTION + +The behavior of the builtin C function is not defined if called +in scalar context. So if you write a subroutine that directly +Cs the result of a C operation, then your code will +behave unpredictably if someone calls your subroutine in a scalar +context. This Policy emits a violation if the C keyword +is directly followed by the C function. To safely return a +sorted list of values from a subroutine, you should assign the +sorted values to a temporary variable first. For example: + + sub frobulate { + + return sort @list; # not ok! + + my @sorted_list = sort @list; + return @sorted_list # OK + } + +=head1 KNOWN BUGS + +This Policy is not sensitive to the C function. So the +following code would generate a false violation: + + sub frobulate { + + if (wantarray) { + return sort @list; + } + else{ + return join @list; + } + } + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + +=head1 CREDITS + +This Policy was suggested by Ulrich Wisser and the L team. + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2017 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Subroutines/ProhibitSubroutinePrototypes.pm b/lib/Perl/Critic/Policy/Subroutines/ProhibitSubroutinePrototypes.pm new file mode 100644 index 0000000..976cfa7 --- /dev/null +++ b/lib/Perl/Critic/Policy/Subroutines/ProhibitSubroutinePrototypes.pm @@ -0,0 +1,85 @@ +package Perl::Critic::Policy::Subroutines::ProhibitSubroutinePrototypes; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Subroutine prototypes used}; +Readonly::Scalar my $EXPL => [ 194 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw(core pbp bugs certrec ) } +sub applies_to { return 'PPI::Statement::Sub' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + if ( $elem->prototype() ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Subroutines::ProhibitSubroutinePrototypes - Don't write C. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Contrary to common belief, subroutine prototypes do not enable +compile-time checks for proper arguments. Don't use them. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Subroutines/ProhibitUnusedPrivateSubroutines.pm b/lib/Perl/Critic/Policy/Subroutines/ProhibitUnusedPrivateSubroutines.pm new file mode 100644 index 0000000..1843570 --- /dev/null +++ b/lib/Perl/Critic/Policy/Subroutines/ProhibitUnusedPrivateSubroutines.pm @@ -0,0 +1,440 @@ +package Perl::Critic::Policy::Subroutines::ProhibitUnusedPrivateSubroutines; + +use 5.006001; + +use strict; +use warnings; + +use English qw< $EVAL_ERROR -no_match_vars >; +use List::MoreUtils qw(any); +use Readonly; + +use Perl::Critic::Utils qw{ + :characters hashify is_function_call is_method_call :severities + $EMPTY $TRUE +}; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => + q{Private subroutine/method '%s' declared but not used}; +Readonly::Scalar my $EXPL => q{Eliminate dead code}; + +Readonly::Hash my %IS_COMMA => hashify( $COMMA, $FATCOMMA ); + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'private_name_regex', + description => 'Pattern that determines what a private subroutine is.', + default_string => '\b_\w+\b', ## no critic (RequireInterpolationOfMetachars) + behavior => 'string', + parser => \&_parse_regex_parameter, + }, + { + name => 'allow', + description => + q, + default_string => $EMPTY, + behavior => 'string list', + }, + { + name => 'skip_when_using', + description => + q, + default_string => $EMPTY, + behavior => 'string list', + }, + { + name => 'allow_name_regex', + description => + q, + default_string => $EMPTY, + behavior => 'string', + parser => \&_parse_regex_parameter, + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core maintenance certrec ) } +sub applies_to { return 'PPI::Statement::Sub' } + +#----------------------------------------------------------------------------- + +sub _parse_regex_parameter { + my ($self, $parameter, $config_string) = @_; + defined $config_string + or $config_string = $parameter->get_default_string(); + + my $regex; + eval { $regex = qr/$config_string/; 1 } ## no critic (RegularExpressions) + or $self->throw_parameter_value_exception( + $parameter, + $config_string, + undef, + "is not a valid regular expression: $EVAL_ERROR", + ); + + $self->__set_parameter_value($parameter, $regex); + + return; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $document ) = @_; + + my @skip_modules = keys %{ $self->{_skip_when_using} }; + return if any { $document->uses_module($_) } @skip_modules; + + # Not interested in forward declarations, only the real thing. + $elem->forward() and return; + + # Not interested in subs without names. + my $name = $elem->name() or return; + + # If the sub is shoved into someone else's name space, we wimp out. + $name =~ m/ :: /smx and return; + + # If the name is explicitly allowed, we just return (OK). + $self->{_allow}{$name} and return; + + # Allow names that match the 'allow_name_regex' pattern. + if ($self->{_allow_name_regex}) { + $name =~ m/ \A $self->{_allow_name_regex} \z /smx and return; + } + + # If the name is not an anonymous subroutine according to our definition, + # we just return (OK). + $name =~ m/ \A $self->{_private_name_regex} \z /smx or return; + + # If the subroutine is called in the document, just return (OK). + $self->_find_sub_call_in_document( $elem, $document ) and return; + + # If the subroutine is referred to in the document, just return (OK). + $self->_find_sub_reference_in_document( $elem, $document ) and return; + + # If the subroutine is used in an overload, just return (OK). + $self->_find_sub_overload_in_document( $elem, $document ) and return; + + # No uses of subroutine found. Return a violation. + return $self->violation( sprintf( $DESC, $name ), $EXPL, $elem ); +} + + +# Basically the spaceship operator for token locations. The arguments are the +# two tokens to compare. If either location is unavailable we return undef. +sub _compare_token_locations { + my ( $left_token, $right_token ) = @_; + my $left_loc = $left_token->location() or return; + my $right_loc = $right_token->location() or return; + return $left_loc->[0] <=> $right_loc->[0] || + $left_loc->[1] <=> $right_loc->[1]; +} + +# Find out if the subroutine defined in $elem is called in $document. Calls +# inside the subroutine itself do not count. +sub _find_sub_call_in_document { + my ( $self, $elem, $document ) = @_; + + my $start_token = $elem->first_token(); + my $finish_token = $elem->last_token(); + my $name = $elem->name(); + + if ( my $found = $document->find( 'PPI::Token::Word' ) ) { + foreach my $usage ( @{ $found } ) { + $name eq $usage->content() or next; + is_function_call( $usage ) + or is_method_call( $usage ) + or next; + _compare_token_locations( $usage, $start_token ) < 0 + and return $TRUE; + _compare_token_locations( $finish_token, $usage ) < 0 + and return $TRUE; + } + } + + foreach my $regexp ( _find_regular_expressions( $document ) ) { + + _compare_token_locations( $regexp, $start_token ) >= 0 + and _compare_token_locations( $finish_token, $regexp ) >= 0 + and next; + _find_sub_usage_in_regexp( $name, $regexp, $document ) + and return $TRUE; + + } + + return; +} + +# Find analyzable regular expressions in the given document. This means +# matches, substitutions, and the qr{} operator. +sub _find_regular_expressions { + my ( $document ) = @_; + + return ( map { @{ $document->find( $_ ) || [] } } qw{ + PPI::Token::Regexp::Match + PPI::Token::Regexp::Substitute + PPI::Token::QuoteLike::Regexp + } ); +} + +# Find out if the subroutine named in $name is called in the given $regexp. +# This could happen either by an explicit s/.../.../e, or by interpolation +# (i.e. @{[...]} ). +sub _find_sub_usage_in_regexp { + my ( $name, $regexp, $document ) = @_; + + my $ppix = $document->ppix_regexp_from_element( $regexp ) or return; + $ppix->failures() and return; + + foreach my $code ( @{ $ppix->find( 'PPIx::Regexp::Token::Code' ) || [] } ) { + my $doc = $code->ppi() or next; + + foreach my $word ( @{ $doc->find( 'PPI::Token::Word' ) || [] } ) { + $name eq $word->content() or next; + is_function_call( $word ) + or is_method_call( $word ) + or next; + return $TRUE; + } + + } + + return; +} + +# Find out if the subroutine defined in $elem handles an overloaded operator. +# We recognize both string literals (the usual form) and words (in case +# someone perversely followed the subroutine name by a fat comma). We ignore +# the '\&_foo' construction, since _find_sub_reference_in_document() should +# find this. +sub _find_sub_overload_in_document { + my ( $self, $elem, $document ) = @_; + + my $name = $elem->name(); + + if ( my $found = $document->find( 'PPI::Statement::Include' ) ) { + foreach my $usage ( @{ $found } ) { + 'overload' eq $usage->module() or next; + my $inx; + foreach my $arg ( _get_include_arguments( $usage ) ) { + $inx++ % 2 or next; + @{ $arg } == 1 or next; + my $element = $arg->[0]; + + if ( $element->isa( 'PPI::Token::Quote' ) ) { + $element->string() eq $name and return $TRUE; + } elsif ( $element->isa( 'PPI::Token::Word' ) ) { + $element->content() eq $name and return $TRUE; + } + } + } + } + + return; +} + +# Find things of the form '&_foo'. This includes both references proper (i.e. +# '\&foo'), calls using the sigil, and gotos. The latter two do not count if +# inside the subroutine itself. +sub _find_sub_reference_in_document { + my ( $self, $elem, $document ) = @_; + + my $start_token = $elem->first_token(); + my $finish_token = $elem->last_token(); + my $symbol = q<&> . $elem->name(); + + if ( my $found = $document->find( 'PPI::Token::Symbol' ) ) { + foreach my $usage ( @{ $found } ) { + $symbol eq $usage->content() or next; + + my $prior = $usage->sprevious_sibling(); + $prior + and $prior->isa( 'PPI::Token::Cast' ) + and q<\\> eq $prior->content() + and return $TRUE; + + is_function_call( $usage ) + or $prior + and $prior->isa( 'PPI::Token::Word' ) + and 'goto' eq $prior->content() + or next; + + _compare_token_locations( $usage, $start_token ) < 0 + and return $TRUE; + _compare_token_locations( $finish_token, $usage ) < 0 + and return $TRUE; + } + } + + return; +} + +# Expand the given element, losing any brackets along the way. This is +# intended to be used to flatten the argument list of 'use overload'. +sub _expand_element { + my ( $element ) = @_; + $element->isa( 'PPI::Node' ) + and return ( map { _expand_element( $_ ) } $_->children() ); + $element->significant() and return $element; + return; +} + +# Given an include statement, return its arguments. The return is a flattened +# list of lists of tokens, each list of tokens representing an argument. +sub _get_include_arguments { + my ($include) = @_; + + # If there are no arguments, just return. We flatten the list because + # someone might use parens to define it. + my @arguments = map { _expand_element( $_ ) } $include->arguments() + or return; + + my @elements; + my $inx = 0; + foreach my $element ( @arguments ) { + if ( $element->isa( 'PPI::Token::Operator' ) && + $IS_COMMA{$element->content()} ) { + $inx++; + } else { + push @{ $elements[$inx] ||= [] }, $element; + } + } + + return @elements; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Subroutines::ProhibitUnusedPrivateSubroutines - Prevent unused private subroutines. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +By convention Perl authors (like authors in many other languages) +indicate private methods and variables by inserting a leading +underscore before the identifier. This policy catches such subroutines +which are not used in the file which declares them. + +This module defines a 'use' of a subroutine as a subroutine or method call to +it (other than from inside the subroutine itself), a reference to it (i.e. +C<< my $foo = \&_foo >>), a C to it outside the subroutine itself (i.e. +C), or the use of the subroutine's name as an even-numbered +argument to C<< use overload >>. + + +=head1 CONFIGURATION + +You can define what a private subroutine name looks like by specifying +a regular expression for the C option in your +F<.perlcriticrc>: + + [Subroutines::ProhibitUnusedPrivateSubroutines] + private_name_regex = _(?!_)\w+ + +The above example is a way of saying that subroutines that start with +a double underscore are not considered to be private. (Perl::Critic, +in its implementation, uses leading double underscores to indicate a +distribution-private subroutine -- one that is allowed to be invoked by +other Perl::Critic modules, but not by anything outside of +Perl::Critic.) + +You can configure additional subroutines to accept by specifying them +in a space-delimited list to the C option: + + [Subroutines::ProhibitUnusedPrivateSubroutines] + allow = _bar _baz + +These are added to the default list of exemptions from this policy. So the +above allows C<< sub _bar {} >> and C<< sub _baz {} >>, even if they are not +referred to in the module that defines them. + +You can allow a whole class or subroutine names by defining a a regular +expression that matches allowed names. + + [Subroutines::ProhibitUnusedPrivateSubroutines] + allow_name_regex = _build_\w+ + +You can configure this policy not to check private subroutines declared in a +file that uses one or more particular named modules. This allows you to, for +example, exclude unused private subroutine checking in classes that are roles. + + [Subroutines::ProhibitUnusedPrivateSubroutines] + skip_when_using = Moose::Role Moo::Role Role::Tiny + + +=head1 HISTORY + +This policy is derived from +L, +which looks at the other side of the problem. + + +=head1 BUGS + +Does not forbid C<< sub Foo::_foo{} >> because it does not know (and can not +assume) what is in the C package. + +Does not respect the scope caused by multiple packages in the same file. For +example a file: + + package Foo; + sub _is_private { print "A private sub!"; } + + package Bar; + _is_private(); + +Will not trigger a violation even though C is not called. +Similarly, C currently works on a I level, not on a +I level. + + +=head1 SEE ALSO + +L. + + +=head1 AUTHOR + +Chris Dolan + +=head1 COPYRIGHT + +Copyright (c) 2009-2011 Thomas R. Wyant, III. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Subroutines/ProtectPrivateSubs.pm b/lib/Perl/Critic/Policy/Subroutines/ProtectPrivateSubs.pm new file mode 100644 index 0000000..1ea8468 --- /dev/null +++ b/lib/Perl/Critic/Policy/Subroutines/ProtectPrivateSubs.pm @@ -0,0 +1,269 @@ +package Perl::Critic::Policy::Subroutines::ProtectPrivateSubs; + +use 5.006001; + +use strict; +use warnings; + +use English qw< $EVAL_ERROR -no_match_vars >; +use Readonly; + +use Perl::Critic::Utils qw< + :severities $EMPTY is_function_call is_method_call +>; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q; +Readonly::Scalar my $EXPL => q; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'private_name_regex', + description => 'Pattern that determines what a private subroutine is.', + default_string => '\b_\w+\b', ## no critic (RequireInterpolationOfMetachars) + behavior => 'string', + parser => \&_parse_private_name_regex, + }, + { + name => 'allow', + description => + q, + default_string => $EMPTY, + behavior => 'string list', + list_always_present_values => [ qw< + POSIX::_PC_CHOWN_RESTRICTED + POSIX::_PC_LINK_MAX + POSIX::_PC_MAX_CANON + POSIX::_PC_MAX_INPUT + POSIX::_PC_NAME_MAX + POSIX::_PC_NO_TRUNC + POSIX::_PC_PATH_MAX + POSIX::_PC_PIPE_BUF + POSIX::_PC_VDISABLE + POSIX::_POSIX_ARG_MAX + POSIX::_POSIX_CHILD_MAX + POSIX::_POSIX_CHOWN_RESTRICTED + POSIX::_POSIX_JOB_CONTROL + POSIX::_POSIX_LINK_MAX + POSIX::_POSIX_MAX_CANON + POSIX::_POSIX_MAX_INPUT + POSIX::_POSIX_NAME_MAX + POSIX::_POSIX_NGROUPS_MAX + POSIX::_POSIX_NO_TRUNC + POSIX::_POSIX_OPEN_MAX + POSIX::_POSIX_PATH_MAX + POSIX::_POSIX_PIPE_BUF + POSIX::_POSIX_SAVED_IDS + POSIX::_POSIX_SSIZE_MAX + POSIX::_POSIX_STREAM_MAX + POSIX::_POSIX_TZNAME_MAX + POSIX::_POSIX_VDISABLE + POSIX::_POSIX_VERSION + POSIX::_SC_ARG_MAX + POSIX::_SC_CHILD_MAX + POSIX::_SC_CLK_TCK + POSIX::_SC_JOB_CONTROL + POSIX::_SC_NGROUPS_MAX + POSIX::_SC_OPEN_MAX + POSIX::_SC_PAGESIZE + POSIX::_SC_SAVED_IDS + POSIX::_SC_STREAM_MAX + POSIX::_SC_TZNAME_MAX + POSIX::_SC_VERSION + POSIX::_exit + > ], + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core maintenance certrule ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub _parse_private_name_regex { + my ($self, $parameter, $config_string) = @_; + + defined $config_string + or $config_string = $parameter->get_default_string(); + + my $regex; + eval { $regex = qr/$config_string/; 1 } ## no critic (RegularExpressions) + or $self->throw_parameter_value_exception( + 'private_name_regex', + $config_string, + undef, + "is not a valid regular expression: $EVAL_ERROR", + ); + + $self->__set_parameter_value($parameter, $regex); + + return; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + if ( my $prior = $elem->sprevious_sibling() ) { + my $prior_name = $prior->content(); + return if $prior_name eq 'package'; + return if $prior_name eq 'require'; + return if $prior_name eq 'use'; + } + + if ( + $self->_is_other_pkg_private_function($elem) + or $self->_is_other_pkg_private_method($elem) + ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + + return; # ok! +} + +sub _is_other_pkg_private_function { + my ( $self, $elem ) = @_; + + return if ! is_method_call($elem) && ! is_function_call($elem); + + my $private_name_regex = $self->{_private_name_regex}; + my $content = $elem->content(); + return + $content =~ m< \w+::$private_name_regex \z >xms + && $content !~ m< \A SUPER::$private_name_regex \z >xms + && ! $self->{_allow}{$content}; +} + +sub _is_other_pkg_private_method { + my ( $self, $elem ) = @_; + + my $private_name_regex = $self->{_private_name_regex}; + my $content = $elem->content(); + + # look for structures like "Some::Package->_foo()" + return if $content !~ m< \A $private_name_regex \z >xms; + my $operator = $elem->sprevious_sibling() or return; + return if $operator->content() ne q[->]; + + my $package = $operator->sprevious_sibling() or return; + return if not $package->isa('PPI::Token::Word'); + + # sometimes the previous sib is a keyword, as in: + # shift->_private_method(); This is typically used as + # shorthand for "my $self=shift; $self->_private_method()" + return if $package->content() eq 'shift' + or $package->content() eq '__PACKAGE__'; + + # Maybe the user wanted to exempt this explicitly. + return if $self->{_allow}{"${package}::$content"}; + + return 1; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Subroutines::ProtectPrivateSubs - Prevent access to private subs in other packages. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +By convention Perl authors (like authors in many other languages) +indicate private methods and variables by inserting a leading +underscore before the identifier. This policy catches attempts to +access private variables from outside the package itself. + +The subroutines in the L package which begin with an underscore +(e.g. C) are not flagged as errors by this +policy. + + +=head1 CONFIGURATION + +You can define what a private subroutine name looks like by specifying +a regular expression for the C option in your +F<.perlcriticrc>: + + [Subroutines::ProtectPrivateSubs] + private_name_regex = _(?!_)\w+ + +The above example is a way of saying that subroutines that start with +a double underscore are not considered to be private. (Perl::Critic, +in its implementation, uses leading double underscores to indicate a +distribution-private subroutine-- one that is allowed to be invoked by +other Perl::Critic modules, but not by anything outside of +Perl::Critic.) + +You can configure additional subroutines to accept by specifying them +in a space-delimited list to the C option: + + [Subroutines::ProtectPrivateSubs] + allow = FOO::_bar FOO::_baz + +These are added to the default list of exemptions from this policy. +Allowing a subroutine also allows the corresponding method call. So +C<< FOO::_bar >> in the above example allows both C<< FOO::_bar() >> +and C<< FOO->_bar() >>. + + +=head1 HISTORY + +This policy is inspired by a similar test in L. + + +=head1 BUGS + +Doesn't forbid C<< $pkg->_foo() >> because it can't tell the +difference between that and C<< $self->_foo() >>. + + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Chris Dolan + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Subroutines/RequireArgUnpacking.pm b/lib/Perl/Critic/Policy/Subroutines/RequireArgUnpacking.pm new file mode 100644 index 0000000..35c0de5 --- /dev/null +++ b/lib/Perl/Critic/Policy/Subroutines/RequireArgUnpacking.pm @@ -0,0 +1,448 @@ +package Perl::Critic::Policy::Subroutines::RequireArgUnpacking; + +use 5.006001; +use strict; +use warnings; + +use Carp; +use English qw(-no_match_vars); +use Readonly; + +use File::Spec; + +use Perl::Critic::Utils qw< + :booleans :characters :classification hashify :severities words_from_string +>; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $AT => q{@}; +Readonly::Scalar my $AT_ARG => q{@_}; ## no critic (InterpolationOfMetachars) +Readonly::Scalar my $DOLLAR => q{$}; +Readonly::Scalar my $DOLLAR_ARG => q{$_}; ## no critic (InterpolationOfMetaChars) + +Readonly::Scalar my $DESC => qq{Always unpack $AT_ARG first}; +Readonly::Scalar my $EXPL => [178]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'short_subroutine_statements', + description => + 'The number of statements to allow without unpacking.', + default_string => '0', + behavior => 'integer', + integer_minimum => 0, + }, + { + name => 'allow_subscripts', + description => + 'Should unpacking from array slices and elements be allowed?', + default_string => $FALSE, + behavior => 'boolean', + }, + { + name => 'allow_delegation_to', + description => + 'Allow the usual delegation idiom to these namespaces/subroutines', + behavior => 'string list', + list_always_present_values => [ qw< SUPER:: NEXT:: > ], + } + ); +} + +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core pbp maintenance ) } +sub applies_to { return 'PPI::Statement::Sub' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + # forward declaration? + return if not $elem->block; + + my @statements = $elem->block->schildren; + + # empty sub? + return if not @statements; + + # Don't apply policy to short subroutines + + # Should we instead be doing a find() for PPI::Statement + # instances? That is, should we count all statements instead of + # just top-level statements? + return if $self->{_short_subroutine_statements} >= @statements; + + # look for explicit dereferences of @_, including '$_[0]' + # You may use "... = @_;" in the first paragraph of the sub + # Don't descend into nested or anonymous subs + my $state = 'unpacking'; # still in unpacking paragraph + for my $statement (@statements) { + + my @magic = _get_arg_symbols($statement); + + my $saw_unpack = $FALSE; + + MAGIC: + for my $magic (@magic) { + # allow conditional checks on the size of @_ + next MAGIC if _is_size_check($magic); + + if ('unpacking' eq $state) { + if ($self->_is_unpack($magic)) { + $saw_unpack = $TRUE; + next MAGIC; + } + } + + # allow @$_[] construct in "... for ();" + # Check for "print @$_[] for ()" construct (rt39601) + next MAGIC + if _is_cast_of_array($magic) and _is_postfix_foreach($magic); + + # allow $$_[], which is equivalent to $_->[] and not a use + # of @_ at all. + next MAGIC + if _is_cast_of_scalar( $magic ); + + # allow delegation of the form "$self->SUPER::foo( @_ );" + next MAGIC + if $self->_is_delegation( $magic ); + + # If we make it this far, it is a violation + return $self->violation( $DESC, $EXPL, $elem ); + } + if (not $saw_unpack) { + $state = 'post_unpacking'; + } + } + return; # OK +} + +sub _is_unpack { + my ($self, $magic) = @_; + + my $prev = $magic->sprevious_sibling(); + my $next = $magic->snext_sibling(); + + # If we have a subscript, we're dealing with an array slice on @_ + # or an array element of @_. See RT #34009. + if ( $next and $next->isa('PPI::Structure::Subscript') ) { + $self->{_allow_subscripts} or return; + $next = $next->snext_sibling; + } + + return $TRUE if + $prev + and $prev->isa('PPI::Token::Operator') + and is_assignment_operator($prev->content()) + and ( + not $next + or $next->isa('PPI::Token::Structure') + and $SCOLON eq $next->content() + ); + return; +} + +sub _is_size_check { + my ($magic) = @_; + + # No size check on $_[0]. RT #34009. + $AT eq $magic->raw_type or return; + + my $prev = $magic->sprevious_sibling; + my $next = $magic->snext_sibling; + + if ( $prev || $next ) { + + return $TRUE + if _legal_before_size_check( $prev ) + and _legal_after_size_check( $next ); + } + + my $parent = $magic; + { + $parent = $parent->parent() + or return; + $prev = $parent->sprevious_sibling(); + $next = $parent->snext_sibling(); + $prev + or $next + or redo; + } # until ( $prev || $next ); + + return $TRUE + if $parent->isa( 'PPI::Structure::Condition' ); + + return; +} + +{ + + Readonly::Hash my %LEGAL_NEXT_OPER => hashify( + qw{ && || == != > >= < <= and or } ); + + Readonly::Hash my %LEGAL_NEXT_STRUCT => hashify( qw{ ; } ); + + sub _legal_after_size_check { + my ( $next ) = @_; + + $next + or return $TRUE; + + $next->isa( 'PPI::Token::Operator' ) + and return $LEGAL_NEXT_OPER{ $next->content() }; + + $next->isa( 'PPI::Token::Structure' ) + and return $LEGAL_NEXT_STRUCT{ $next->content() }; + + return; + } +} + +{ + + Readonly::Hash my %LEGAL_PREV_OPER => hashify( + qw{ && || ! == != > >= < <= and or not } ); + + Readonly::Hash my %LEGAL_PREV_WORD => hashify( + qw{ if unless } ); + + sub _legal_before_size_check { + my ( $prev ) = @_; + + $prev + or return $TRUE; + + $prev->isa( 'PPI::Token::Operator' ) + and return $LEGAL_PREV_OPER{ $prev->content() }; + + $prev->isa( 'PPI::Token::Word' ) + and return $LEGAL_PREV_WORD{ $prev->content() }; + + return; + } + +} + +sub _is_postfix_foreach { + my ($magic) = @_; + + my $sibling = $magic; + while ( $sibling = $sibling->snext_sibling ) { + return $TRUE + if + $sibling->isa('PPI::Token::Word') + and $sibling =~ m< \A for (?:each)? \z >xms; + } + return; +} + +sub _is_cast_of_array { + my ($magic) = @_; + + my $prev = $magic->sprevious_sibling; + + return $TRUE + if ( $prev && $prev->content() eq $AT ) + and $prev->isa('PPI::Token::Cast'); + return; +} + +# This subroutine recognizes (e.g.) $$_[0]. This is a use of $_ (equivalent to +# $_->[0]), not @_. + +sub _is_cast_of_scalar { + my ($magic) = @_; + + my $prev = $magic->sprevious_sibling; + my $next = $magic->snext_sibling; + + return $DOLLAR_ARG eq $magic->content() && + $prev && $prev->isa('PPI::Token::Cast') && + $DOLLAR eq $prev->content() && + $next && $next->isa('PPI::Structure::Subscript'); +} + +# A literal @_ is allowed as the argument for a delegation. +# An example of the idiom we are looking for is $self->SUPER::foo(@_). +# The argument list of (@_) is required; no other use of @_ is allowed. + +sub _is_delegation { + my ($self, $magic) = @_; + + $AT_ARG eq $magic->content() or return; # Not a literal '@_'. + my $parent = $magic->parent() # Don't know what to do with + or return; # orphans. + $parent->isa( 'PPI::Statement::Expression' ) + or return; # Parent must be expression. + 1 == $parent->schildren() # '@_' must stand alone in + or return; # its expression. + $parent = $parent->parent() # Still don't know what to do + or return; # with orphans. + $parent->isa ( 'PPI::Structure::List' ) + or return; # Parent must be a list. + 1 == $parent->schildren() # '@_' must stand alone in + or return; # the argument list. + my $subroutine_name = $parent->sprevious_sibling() + or return; # Missing sub name. + $subroutine_name->isa( 'PPI::Token::Word' ) + or return; + $self->{_allow_delegation_to}{$subroutine_name} + and return 1; + my ($subroutine_namespace) = $subroutine_name =~ m/ \A ( .* ::) \w+ \z /smx + or return; + return $self->{_allow_delegation_to}{$subroutine_namespace}; +} + + +sub _get_arg_symbols { + my ($statement) = @_; + + return grep {$AT_ARG eq $_->symbol} @{$statement->find(\&_magic_finder) || []}; +} + +sub _magic_finder { + # Find all @_ and $_[\d+] not inside of nested subs + my (undef, $elem) = @_; + return $TRUE if $elem->isa('PPI::Token::Magic'); # match + + if ($elem->isa('PPI::Structure::Block')) { + # don't descend into a nested named sub + return if $elem->statement->isa('PPI::Statement::Sub'); + + my $prev = $elem->sprevious_sibling; + # don't descend into a nested anon sub block + return if $prev + and $prev->isa('PPI::Token::Word') + and 'sub' eq $prev->content(); + } + + return $FALSE; # no match, descend +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Subroutines::RequireArgUnpacking - Always unpack C<@_> first. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Subroutines that use C<@_> directly instead of unpacking the arguments +to local variables first have two major problems. First, they are +very hard to read. If you're going to refer to your variables by +number instead of by name, you may as well be writing assembler code! +Second, C<@_> contains aliases to the original variables! If you +modify the contents of a C<@_> entry, then you are modifying the +variable outside of your subroutine. For example: + + sub print_local_var_plus_one { + my ($var) = @_; + print ++$var; + } + sub print_var_plus_one { + print ++$_[0]; + } + + my $x = 2; + print_local_var_plus_one($x); # prints "3", $x is still 2 + print_var_plus_one($x); # prints "3", $x is now 3 ! + print $x; # prints "3" + +This is spooky action-at-a-distance and is very hard to debug if it's +not intentional and well-documented (like C or C). + +An exception is made for the usual delegation idiom C<< +$object->SUPER::something( @_ ) >>. Only C and C are +recognized (though this is configurable) and the argument list for the +delegate must consist only of C<< ( @_ ) >>. + +=head1 CONFIGURATION + +This policy is lenient for subroutines which have C or fewer +top-level statements, where C defaults to ZERO. You can override +this to set it to a higher number with the +C setting. This is very much not +recommended but perhaps you REALLY need high performance. To do this, +put entries in a F<.perlcriticrc> file like this: + + [Subroutines::RequireArgUnpacking] + short_subroutine_statements = 2 + +By default this policy does not allow you to specify array subscripts +when you unpack arguments (i.e. by an array slice or by referencing +individual elements). Should you wish to permit this, you can do so +using the C setting. This defaults to false. You can +set it true like this: + + [Subroutines::RequireArgUnpacking] + allow_subscripts = 1 + +The delegation logic can be configured to allow delegation other than to +C or C. The configuration item is +C, and it takes a space-delimited list of allowed +delegates. If a given delegate ends in a double colon, anything in the +given namespace is allowed. If it does not, only that subroutine is +allowed. For example, to allow C from C and +_delegate from the current namespace in addition to SUPER and NEXT, the +following configuration could be used: + + [Subroutines::RequireArgUnpacking] + allow_delegation_to = next::method _delegate + +=head1 CAVEATS + +PPI doesn't currently detect anonymous subroutines, so we don't check +those. This should just work when PPI gains that feature. + +We don't check for C<@ARG>, the alias for C<@_> from English.pm. That's +deprecated anyway. + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + +=head1 AUTHOR + +Chris Dolan + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Subroutines/RequireFinalReturn.pm b/lib/Perl/Critic/Policy/Subroutines/RequireFinalReturn.pm new file mode 100644 index 0000000..f96d3d8 --- /dev/null +++ b/lib/Perl/Critic/Policy/Subroutines/RequireFinalReturn.pm @@ -0,0 +1,386 @@ +package Perl::Critic::Policy::Subroutines::RequireFinalReturn; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal }; +use Perl::Critic::Utils qw{ :characters :severities :data_conversion }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => [ 197 ]; + +Readonly::Hash my %CONDITIONALS => hashify( qw(if unless for foreach) ); + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'terminal_funcs', + description => 'The additional subroutines to treat as terminal.', + default_string => $EMPTY, + behavior => 'string list', + list_always_present_values => + [ qw< croak confess die exec exit throw Carp::confess Carp::croak ...> ], + }, + { + name => 'terminal_methods', + description => 'The additional methods to treat as terminal.', + default_string => $EMPTY, + behavior => 'string list', + list_always_present_values => [], + }, + ); +} + +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core bugs pbp certrec ) } +sub applies_to { return 'PPI::Statement::Sub' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + # skip BEGIN{} and INIT{} and END{} etc + return if $elem->isa('PPI::Statement::Scheduled'); + + my @blocks = grep {$_->isa('PPI::Structure::Block')} $elem->schildren(); + if (@blocks > 1) { + # sanity check + throw_internal 'Subroutine should have no more than one block'; + } + elsif (@blocks == 0) { + #Technically, subroutines don't have to have a block at all. In + # that case, its just a declaration so this policy doesn't really apply + return; # ok! + } + + + my ($block) = @blocks; + if ($self->_block_is_empty($block) || $self->_block_has_return($block)) { + return; # OK + } + + # Must be a violation + my $desc; + if ( my $name = $elem->name() ) { + $desc = qq; + } + else { + $desc = q; + } + + return $self->violation( $desc, $EXPL, $elem ); +} + +#----------------------------------------------------------------------------- + +sub _block_is_empty { + my ( $self, $block ) = @_; + return $block->schildren() == 0; +} + +#----------------------------------------------------------------------------- + +sub _block_has_return { + my ( $self, $block ) = @_; + my @blockparts = $block->schildren(); + my $final = $blockparts[-1]; # always defined because we call _block_is_empty first + return if !$final; + return $self->_is_explicit_return($final) + || $self->_is_given_when_return($final) + || $self->_is_compound_return($final); +} + +#----------------------------------------------------------------------------- + +sub _is_explicit_return { + my ( $self, $final ) = @_; + + return if $self->_is_conditional_stmnt( $final ); + return $self->_is_return_or_goto_stmnt( $final ) + || $self->_is_terminal_stmnt( $final ); +} + +#----------------------------------------------------------------------------- + +sub _is_compound_return { + my ( $self, $final ) = @_; + + if (!$final->isa('PPI::Statement::Compound')) { + return; #fail + } + + my $begin = $final->schild(0); + return if !$begin; #fail + if (!($begin->isa('PPI::Token::Word') && + ($begin->content() eq 'if' || $begin->content() eq 'unless'))) { + return; #fail + } + + my @blocks = grep {!$_->isa('PPI::Structure::Condition') && + !$_->isa('PPI::Token')} $final->schildren(); + # Sanity check: + if (scalar grep {!$_->isa('PPI::Structure::Block')} @blocks) { + throw_internal + 'Expected only conditions, blocks and tokens in the if statement'; + } + + for my $block (@blocks) { + if (! $self->_block_has_return($block)) { + return; #fail + } + } + + return 1; +} + +#----------------------------------------------------------------------------- + +sub _is_given_when_return { + my ( $self, $final ) = @_; + + if ( ! $final->isa( 'PPI::Statement::Given' ) ) { + return; #fail + } + + my $begin = $final->schild(0); + return if !$begin; #fail + if ( ! ( $begin->isa( 'PPI::Token::Word' ) && + $begin->content() eq 'given' ) ) { + return; #fail + } + + my @blocks = grep {!$_->isa( 'PPI::Structure::Given' ) && + !$_->isa( 'PPI::Token' )} $final->schildren(); + # Sanity check: + if (scalar grep {!$_->isa('PPI::Structure::Block')} @blocks) { + throw_internal + 'Expected only givens, blocks and tokens in the given statement'; + } + if (@blocks > 1) { + # sanity check + throw_internal 'Given statement should have no more than one block'; + } + @blocks or return; #fail + + my $have_default; # We have to fail unless a default block is present + + foreach my $stmnt ( $blocks[0]->schildren() ) { + + if ( $stmnt->isa( 'PPI::Statement::When' ) ) { + + # Check for the default block. + my $first_token; + $first_token = $stmnt->schild( 0 ) + and 'default' eq $first_token->content() + and $have_default = 1; + + $self->_is_when_stmnt_with_return( $stmnt ) + or return; #fail + + } else { + + $self->_is_suffix_when_with_return( $stmnt ) + or return; #fail + + } + + } + + return $have_default; +} + +#----------------------------------------------------------------------------- + +sub _is_return_or_goto_stmnt { + my ( $self, $stmnt ) = @_; + return if not $stmnt->isa('PPI::Statement::Break'); + my $first_token = $stmnt->schild(0) || return; + return $first_token->content() eq 'return' + || $first_token->content() eq 'goto'; +} + +#----------------------------------------------------------------------------- + +sub _is_terminal_stmnt { + my ( $self, $stmnt ) = @_; + + return if not $stmnt->isa('PPI::Statement'); + + my $first_token = $stmnt->schild(0) || return; + return 1 if exists $self->{_terminal_funcs}->{$first_token}; + + my $second_token = $stmnt->schild(1) || return; + return if not ( $second_token->isa('PPI::Token::Operator') && ($second_token eq q{->}) ); + + my $third_token = $stmnt->schild(2) || return; + return exists $self->{_terminal_methods}->{$third_token}; +} + +#----------------------------------------------------------------------------- + +sub _is_conditional_stmnt { + my ( $self, $stmnt ) = @_; + return if not $stmnt->isa('PPI::Statement'); + for my $elem ( $stmnt->schildren() ) { + return 1 if $elem->isa('PPI::Token::Word') + && exists $CONDITIONALS{$elem}; + } + return; +} + +#----------------------------------------------------------------------------- + +sub _is_when_stmnt_with_return { + my ( $self, $stmnt ) = @_; + + my @inner = grep { ! $_->isa( 'PPI::Token' ) && + ! $_->isa( 'PPI::Structure::When' ) } + $stmnt->schildren(); + if ( scalar grep { ! $_->isa( 'PPI::Structure::Block' ) } @inner ) { + throw_internal 'When statement should contain only tokens, conditions, and blocks'; + } + @inner > 1 + and throw_internal 'When statement should have no more than one block'; + @inner or return; #fail + + foreach my $block ( @inner ) { + if ( ! $self->_block_has_return( $block ) ) { + return; #fail + } + } + + return 1; #succeed +} + +#----------------------------------------------------------------------------- + +sub _is_suffix_when_with_return { + my ( $self, $stmnt ) = @_; + return if not $stmnt->isa('PPI::Statement'); + foreach my $elem ( $stmnt->schildren() ) { + return ( $self->_is_return_or_goto_stmnt( $stmnt ) || + $self->_is_terminal_stmnt( $stmnt ) ) + if $elem->isa( 'PPI::Token::Word' ) + && 'when' eq $elem->content(); + } + return; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Subroutines::RequireFinalReturn - End every path through a subroutine with an explicit C statement. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Require all subroutines to terminate explicitly with one of the +following: C, C, C, C, C, C, +C, or C. + +Subroutines without explicit return statements at their ends can be +confusing. It can be challenging to deduce what the return value will +be. + +Furthermore, if the programmer did not mean for there to be a +significant return value, and omits a return statement, some of the +subroutine's inner data can leak to the outside. Consider this case: + + package Password; + # every time the user guesses the password wrong, its value + # is rotated by one character + my $password; + sub set_password { + $password = shift; + } + sub check_password { + my $guess = shift; + if ($guess eq $password) { + unlock_secrets(); + } else { + $password = (substr $password, 1).(substr $password, 0, 1); + } + } + 1; + +In this case, the last statement in check_password() is the +assignment. The result of that assignment is the implicit return +value, so a wrong guess returns the right password! Adding a +C at the end of that subroutine solves the problem. + +The only exception allowed is an empty subroutine. + +Be careful when fixing problems identified by this Policy; don't +blindly put a C statement at the end of every subroutine. + +=head1 CONFIGURATION + +If you've created your own terminal functions that behave like C +or C, then you can configure Perl::Critic to recognize those +functions as well. Just put something like this in your +F<.perlcriticrc>: + + [Subroutines::RequireFinalReturn] + terminal_funcs = quit abort bailout + +If you've created your own terminal methods, then you can configure +Perl::Critic to recognize those methods as well, but the class won't +be considered. For example if you define throw_exception as terminal, +then any method of that name will be terminal, regardless of class. +Just put something like this in your +F<.perlcriticrc>: + + [Subroutines::RequireFinalReturn] + terminal_methods = throw_exception + +=head1 BUGS + +We do not look for returns inside ternary operators. That +construction is too complicated to analyze right now. Besides, a +better form is the return outside of the ternary like this: C + +=head1 AUTHOR + +Chris Dolan + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoStrict.pm b/lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoStrict.pm new file mode 100644 index 0000000..4d3b215 --- /dev/null +++ b/lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoStrict.pm @@ -0,0 +1,150 @@ +package Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use List::MoreUtils qw(all); + +use Perl::Critic::Utils qw{ :characters :severities :data_conversion }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Stricture disabled}; +Readonly::Scalar my $EXPL => [ 429 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'allow', + description => 'Allow vars, subs, and/or refs.', + default_string => $EMPTY, + parser => \&_parse_allow, + }, + ); +} + +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw( core pbp bugs certrec ) } +sub applies_to { return 'PPI::Statement::Include' } + +#----------------------------------------------------------------------------- + +sub _parse_allow { + my ($self, $parameter, $config_string) = @_; + + $self->{_allow} = {}; + + if( defined $config_string ) { + my $allowed = lc $config_string; #String of words + my %allowed = hashify( $allowed =~ m/ (\w+) /gxms ); + $self->{_allow} = \%allowed; + } + + return; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->type() ne 'no'; + return if $elem->pragma() ne 'strict'; + + #Arguments to 'no strict' are usually a list of literals or a qw() + #list. Rather than trying to parse the various PPI elements, I + #just use a regex to split the statement into words. This is + #kinda lame, but it does the trick for now. + + # TODO consider: a possible alternate implementation: + # my $re = join q{|}, keys %{$self->{allow}}; + # return if $re && $stmnt =~ m/\b(?:$re)\b/mx; + # May need to detaint for that to work... Not sure. + + my $stmnt = $elem->statement(); + return if !$stmnt; + my @words = $stmnt =~ m/ ([[:lower:]]+) /gxms; + @words = grep { $_ ne 'qw' && $_ ne 'no' && $_ ne 'strict' } @words; + return if @words && all { exists $self->{_allow}->{$_} } @words; + + #If we get here, then it must be a violation + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict - Prohibit various flavors of C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +There are good reasons for disabling certain kinds of strictures, But +if you were wise enough to C in the first place, then it +doesn't make sense to disable it completely. By default, any C statement will violate this policy. However, you can +configure this Policy to allow certain types of strictures to be +disabled (See L). A bare C statement will +always raise a violation. + + +=head1 CONFIGURATION + +The permitted strictures can be configured via the C option. +The value is a list of whitespace-delimited stricture types that you +want to permit. These can be C, C and/or C. An +example of this customization: + + [TestingAndDebugging::ProhibitNoStrict] + allow = vars subs refs + + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoWarnings.pm b/lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoWarnings.pm new file mode 100644 index 0000000..96ecb77 --- /dev/null +++ b/lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoWarnings.pm @@ -0,0 +1,202 @@ +package Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use List::MoreUtils qw(all); + +use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal }; +use Perl::Critic::Utils qw{ :characters :severities :data_conversion }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Warnings disabled}; +Readonly::Scalar my $EXPL => [ 431 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'allow', + description => 'Permitted warning categories.', + default_string => $EMPTY, + parser => \&_parse_allow, + }, + { + name => 'allow_with_category_restriction', + description => + 'Allow "no warnings" if it restricts the kinds of warnings that are turned off.', + default_string => '0', + behavior => 'boolean', + }, + ); +} + +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core bugs pbp certrec ) } +sub applies_to { return 'PPI::Statement::Include' } + +#----------------------------------------------------------------------------- + +sub _parse_allow { + my ($self, $parameter, $config_string) = @_; + + $self->{_allow} = {}; + + if( defined $config_string ) { + my $allowed = lc $config_string; #String of words + my %allowed = hashify( $allowed =~ m/ (experimental::\w+|\w+) /gxms ); + + $self->{_allow} = \%allowed; + } + + return; +} + +#----------------------------------------------------------------------------- + +sub violates { + + my ( $self, $elem, undef ) = @_; + + return if $elem->type() ne 'no'; + return if $elem->pragma() ne 'warnings'; + + my @words = _extract_potential_categories( $elem ); + @words >= 2 + and 'no' eq $words[0] + and 'warnings' eq $words[1] + or throw_internal + q<'no warnings' word list did not begin with qw{ no warnings }>; + splice @words, 0, 2; + + return if $self->{_allow_with_category_restriction} and @words; + return if @words && all { exists $self->{_allow}->{$_} } @words; + + #If we get here, then it must be a violation + return $self->violation( $DESC, $EXPL, $elem ); +} + +#----------------------------------------------------------------------------- + +# Traverse the element, accumulating and ultimately returning things +# that might be warnings categories. These are: +# * Words (because of the 'foo' in 'no warnings foo => "bar"'); +# * Quotes (because of 'no warnings "foo"'); +# * qw{} strings (obviously); +# * Nodes (because of 'no warnings ( "foo", "bar" )'). +# We don't lop off the 'no' and 'warnings' because we recurse. +# RT #74647. + +{ + + Readonly::Array my @HANDLER => ( + [ 'PPI::Token::Word' => sub { return $_[0]->content() } ], + [ 'PPI::Token::QuoteLike::Words' => + sub { return $_[0]->literal() }, ], + [ 'PPI::Token::Quote' => sub { return $_[0]->string() } ], + [ 'PPI::Node' => sub { _extract_potential_categories( $_[0] ) } ], + ); + + sub _extract_potential_categories { + my ( $elem ) = @_; + + my @words; + foreach my $child ( $elem->schildren() ) { + foreach my $hdlr ( @HANDLER ) { + $child->isa( $hdlr->[0] ) + or next; + push @words, $hdlr->[1]->( $child ); + last; + } + } + + return @words; + } + +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords perllexwarn + +=head1 NAME + +Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings - Prohibit various flavors of C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +There are good reasons for disabling certain kinds of warnings. But +if you were wise enough to C in the first place, then it +doesn't make sense to disable them completely. By default, any +C statement will violate this policy. However, you can +configure this Policy to allow certain types of warnings to be +disabled (See L<"CONFIGURATION">). A bare C +statement will always raise a violation. + + +=head1 CONFIGURATION + +The permitted warning types can be configured via the C option. +The value is a list of whitespace-delimited warning types that you +want to be able to disable. See L for a list +of possible warning types. An example of this customization: + + [TestingAndDebugging::ProhibitNoWarnings] + allow = uninitialized once + +If a true value is specified for the +C option, then any C +that restricts the set of warnings that are turned off will pass. + + [TestingAndDebugging::ProhibitNoWarnings] + allow_with_category_restriction = 1 + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. The full text of this license can be found in +the LICENSE file included with this module + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitProlongedStrictureOverride.pm b/lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitProlongedStrictureOverride.pm new file mode 100644 index 0000000..24df0af --- /dev/null +++ b/lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitProlongedStrictureOverride.pm @@ -0,0 +1,117 @@ +package Perl::Critic::Policy::TestingAndDebugging::ProhibitProlongedStrictureOverride; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Don't turn off strict for large blocks of code}; +Readonly::Scalar my $EXPL => [ 433 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'statements', + description => 'The maximum number of statements in a no strict block.', + default_string => '3', + behavior => 'integer', + integer_minimum => 1, + }, + ); +} + +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core pbp bugs certrec ) } +sub applies_to { return 'PPI::Statement::Include' } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, $doc) = @_; + + return if $elem->type ne 'no'; + return if $elem->module ne 'strict'; + + my $sib = $elem->snext_sibling; + my $nstatements = 0; + while ($nstatements++ <= $self->{_statements}) { + return if !$sib; + return if $sib->isa('PPI::Statement::Include') && + $sib->type eq 'use' && + $sib->module eq 'strict'; + $sib = $sib->snext_sibling; + } + + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::TestingAndDebugging::ProhibitProlongedStrictureOverride - Don't turn off strict for large blocks of code. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Every agrees that C is the first step to writing +maintainable code in Perl. However, sometimes C is a little +too strict. In those cases, you can turn it off briefly with a C directive. + +This policy checks that C is only in effect for a small +number of statements. + + +=head1 CONFIGURATION + +The default number of statements allowed per C is three. +To override this number, put the following in your F<.perlcriticrc>: + + [TestingAndDebugging::ProhibitProlongedStrictureOverride] + statements = 5 + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/TestingAndDebugging/RequireTestLabels.pm b/lib/Perl/Critic/Policy/TestingAndDebugging/RequireTestLabels.pm new file mode 100644 index 0000000..35d10c2 --- /dev/null +++ b/lib/Perl/Critic/Policy/TestingAndDebugging/RequireTestLabels.pm @@ -0,0 +1,156 @@ +package Perl::Critic::Policy::TestingAndDebugging::RequireTestLabels; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use List::MoreUtils qw(any); +use Perl::Critic::Utils qw{ + :characters :severities :data_conversion :classification :ppi +}; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +Readonly::Hash my %LABEL_ARG_POS => ( + ok => 1, + is => 2, + isnt => 2, + like => 2, + unlike => 2, + cmp_ok => 3, + is_deeply => 2, + pass => 0, + fail => 0, +); + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Test without a label}; +Readonly::Scalar my $EXPL => q{Add a label argument to all Test::More functions}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'modules', + description => 'The additional modules to require labels for.', + default_string => $EMPTY, + behavior => 'string list', + list_always_present_values => [ qw( Test::More ) ], + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core maintenance tests ) } +sub applies_to { return 'PPI::Token::Word' } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, $doc) = @_; + + my $arg_index = $LABEL_ARG_POS{$elem}; + return if not defined $arg_index; + return if not is_function_call($elem); + return if not $self->_has_test_more($doc); + + # Does the function call have enough arguments? + my @args = parse_arg_list($elem); + return if ( @args > $arg_index ); + + return $self->violation( $DESC, $EXPL, $elem ); +} + +#----------------------------------------------------------------------------- + +sub _has_test_more { + my ( $self, $doc ) = @_; + + # TODO: This method gets called every time violates() is invoked, + # but it only needs to happen once per document. Perhaps this + # policy should just apply to PPI::Document, and then do its own + # search for method calls. Since Perl::Critic::Document is + # optimized, this should be pretty fast. + + my $includes = $doc->find('PPI::Statement::Include'); + return if not $includes; + return any { exists $self->{_modules}->{$_->module()} } + @{ $includes }; +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Policy::TestingAndDebugging::RequireTestLabels - Tests should all have labels. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Most Perl modules with regression tests use L +as infrastructure for writing and running those tests. It has an +easy, procedural syntax for writing comparisons of results to +expectations. + +Most of the Test::More functions allow the programmer to add an +optional label that describes what each test is trying to judge. When +a test goes wrong, these labels are very useful for quickly +determining where the problem originated. + +This policy enforces that all Test::More functions have labels where +applicable. This only applies to code that has a C or +C declaration (see below to add more test modules +to the list). + + +=head1 CONFIGURATION + +A list of additional modules to require label parameters be passed to +their methods can be specified with the C option. The list +must consist of whitespace-delimited, fully-qualified module names. +For example: + + [TestingAndDebugging::RequireTestLabels] + modules = My::Test::SubClass Some::Other::Module + +The module list always implicitly includes L. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseStrict.pm b/lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseStrict.pm new file mode 100644 index 0000000..89503c8 --- /dev/null +++ b/lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseStrict.pm @@ -0,0 +1,210 @@ +package Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict; + +use 5.006001; +use strict; +use warnings; + +use version 0.77; +use Readonly; +use Scalar::Util qw{ blessed }; + +use Perl::Critic::Utils qw{ :severities $EMPTY }; +use Perl::Critic::Utils::Constants qw{ :equivalent_modules }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Code before strictures are enabled}; +Readonly::Scalar my $EXPL => [ 429 ]; + +Readonly::Scalar my $PERL_VERSION_WHICH_IMPLIES_STRICTURE => qv('v5.11.0'); + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'equivalent_modules', + description => + q, + default_string => $EMPTY, + behavior => 'string list', + list_always_present_values => ['strict', @STRICT_EQUIVALENT_MODULES], + }, + ); +} + +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw( core pbp bugs certrule certrec ) } +sub applies_to { return 'PPI::Document' } + +sub default_maximum_violations_per_document { return 1; } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, undef, $doc ) = @_; + + # Find the first 'use strict' statement + my $strict_stmnt = $doc->find_first( $self->_generate_is_use_strict() ); + my $strict_line = $strict_stmnt ? $strict_stmnt->location()->[0] : undef; + + # Find all statements that aren't 'use', 'require', or 'package' + my $stmnts_ref = $self->_find_isnt_include_or_package($doc); + return if not $stmnts_ref; + + # If the 'use strict' statement is not defined, or the other + # statement appears before the 'use strict', then it violates. + + my @viols = (); + for my $stmnt ( @{ $stmnts_ref } ) { + last if $stmnt->isa('PPI::Statement::End'); + last if $stmnt->isa('PPI::Statement::Data'); + + my $stmnt_line = $stmnt->location()->[0]; + if ( (! defined $strict_line) || ($stmnt_line < $strict_line) ) { + push @viols, $self->violation( $DESC, $EXPL, $stmnt ); + } + } + return @viols; +} + +#----------------------------------------------------------------------------- + +sub _generate_is_use_strict { + my ($self) = @_; + + return sub { + my (undef, $elem) = @_; + + return 0 if !$elem->isa('PPI::Statement::Include'); + return 0 if $elem->type() ne 'use'; + + # We only want file-scoped pragmas + my $parent = $elem->parent(); + return 0 if !$parent->isa('PPI::Document'); + + if ( my $pragma = $elem->pragma() ) { + return 1 if $self->{_equivalent_modules}{$pragma}; + } + elsif ( my $module = $elem->module() ) { + return 1 if $self->{_equivalent_modules}{$module}; + } + elsif ( my $version = $elem->version() ) { + # Currently Adam returns a string here. He has said he may return + # a version object in the future, so best be prepared. + if ( not blessed( $version ) or not $version->isa( 'version' ) ) { + if ( 'v' ne substr $version, 0, 1 + and ( $version =~ tr/././ ) > 1 ) { + $version = 'v' . $version; + } + $version = version->parse( $version ); + } + return 1 if $PERL_VERSION_WHICH_IMPLIES_STRICTURE <= $version; + } + + return 0; + }; +} + +#----------------------------------------------------------------------------- +# Here, we're using the fact that Perl::Critic::Document::find() is optimized +# to search for elements based on their type. This is faster than using the +# native PPI::Node::find() method with a custom callback function. + +sub _find_isnt_include_or_package { + my ($self, $doc) = @_; + my $all_statements = $doc->find('PPI::Statement') or return; + my @wanted_statements = grep { _statement_isnt_include_or_package($_) } @{$all_statements}; + return @wanted_statements ? \@wanted_statements : (); +} + +#----------------------------------------------------------------------------- + +sub _statement_isnt_include_or_package { + my ($elem) = @_; + return 0 if $elem->isa('PPI::Statement::Package'); + return 0 if $elem->isa('PPI::Statement::Include'); + return 1; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict - Always C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Using strictures is probably the single most effective way to improve +the quality of your code. This policy requires that the C<'use +strict'> statement must come before any other statements except +C, C, and other C statements. Thus, all the +code in the entire package will be affected. + +There are special exemptions for L, +L, and +L because +they enforces strictness; e.g. C<'use Moose'> is treated as +equivalent to C<'use strict'>. + +The maximum number of violations per document for this policy defaults +to 1. + + +=head1 CONFIGURATION + +If you make use of things like +L, you can create your own modules +that import the L pragma into the code that is +Cing them. There is an option to add to the default set of +pragmata and modules in your F<.perlcriticrc>: C. + + [TestingAndDebugging::RequireUseStrict] + equivalent_modules = MooseX::My::Sugar + + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. The full text of this license can be found in +the LICENSE file included with this module + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseWarnings.pm b/lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseWarnings.pm new file mode 100644 index 0000000..76246bd --- /dev/null +++ b/lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseWarnings.pm @@ -0,0 +1,210 @@ +package Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use version (); + +use Perl::Critic::Utils qw{ :severities $EMPTY }; +use Perl::Critic::Utils::Constants qw{ :equivalent_modules }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Code before warnings are enabled}; +Readonly::Scalar my $EXPL => [431]; + +Readonly::Scalar my $MINIMUM_VERSION => version->new(5.006); + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'equivalent_modules', + description => + q, + default_string => $EMPTY, + behavior => 'string list', + list_always_present_values => ['warnings', @WARNINGS_EQUIVALENT_MODULES], + }, + ); +} + +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core pbp bugs certrule ) } +sub applies_to { return 'PPI::Document' } + +sub default_maximum_violations_per_document { return 1; } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, undef, $document ) = @_; + + my $version = $document->highest_explicit_perl_version(); + return if $version and $version < $MINIMUM_VERSION; + + # Find the first 'use warnings' statement + my $warn_stmnt = $document->find_first( $self->_generate_is_use_warnings() ); + my $warn_line = $warn_stmnt ? $warn_stmnt->location()->[0] : undef; + + # Find all statements that aren't 'use', 'require', or 'package' + my $stmnts_ref = $self->_find_isnt_include_or_package($document); + return if !$stmnts_ref; + + # If the 'use warnings' statement is not defined, or the other + # statement appears before the 'use warnings', then it violates. + + my @viols = (); + for my $stmnt ( @{ $stmnts_ref } ) { + last if $stmnt->isa('PPI::Statement::End'); + last if $stmnt->isa('PPI::Statement::Data'); + + my $stmnt_line = $stmnt->location()->[0]; + if ( (! defined $warn_line) || ($stmnt_line < $warn_line) ) { + push @viols, $self->violation( $DESC, $EXPL, $stmnt ); + } + } + return @viols; +} + +#----------------------------------------------------------------------------- + +sub _generate_is_use_warnings { + my ($self) = @_; + + return sub { + my (undef, $elem) = @_; + + return 0 if !$elem->isa('PPI::Statement::Include'); + return 0 if $elem->type() ne 'use'; + + # We only want file-scoped pragmas + my $parent = $elem->parent(); + return 0 if !$parent->isa('PPI::Document'); + + if ( my $pragma = $elem->pragma() ) { + return 1 if $self->{_equivalent_modules}{$pragma}; + } + elsif ( my $module = $elem->module() ) { + return 1 if $self->{_equivalent_modules}{$module}; + } + + return 0; + }; +} + +#----------------------------------------------------------------------------- +# Here, we're using the fact that Perl::Critic::Document::find() is optimized +# to search for elements based on their type. This is faster than using the +# native PPI::Node::find() method with a custom callback function. + +sub _find_isnt_include_or_package { + my ($self, $doc) = @_; + my $all_statements = $doc->find('PPI::Statement') or return; + my @wanted_statements = grep { _statement_isnt_include_or_package($_) } @{$all_statements}; + return @wanted_statements ? \@wanted_statements : (); +} + +#----------------------------------------------------------------------------- + +sub _statement_isnt_include_or_package { + my ($elem) = @_; + return 0 if $elem->isa('PPI::Statement::Package'); + return 0 if $elem->isa('PPI::Statement::Include'); + return 1; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings - Always C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Using warnings, and paying attention to what they say, is probably the +single most effective way to improve the quality of your code. This +policy requires that the C<'use warnings'> statement must come before +any other statements except C, C, and other C +statements. Thus, all the code in the entire package will be +affected. + +There are special exemptions for L, +L, and +L because +they enforces warnings; e.g. C<'use Moose'> is treated as +equivalent to C<'use warnings'>. + +This policy will not complain if the file explicitly states that it is +compatible with a version of perl prior to 5.6 via an include +statement, e.g. by having C in it. + +The maximum number of violations per document for this policy defaults +to 1. + + +=head1 CONFIGURATION + +If you make use of things like +L, you can create your own modules +that import the L pragma into the code that is +Cing them. There is an option to add to the default set of +pragmata and modules in your F<.perlcriticrc>: C. + + [TestingAndDebugging::RequireUseWarnings] + equivalent_modules = MooseX::My::Sugar + + +=head1 BUGS + +Needs to check for -w on the shebang line. + + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitCommaSeparatedStatements.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitCommaSeparatedStatements.pm new file mode 100644 index 0000000..2459cf3 --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitCommaSeparatedStatements.pm @@ -0,0 +1,253 @@ +package Perl::Critic::Policy::ValuesAndExpressions::ProhibitCommaSeparatedStatements; + +use 5.006001; +use strict; +use warnings; +use Readonly; + + +use Perl::Critic::Utils qw{ :booleans :characters :severities :classification }; +use Perl::Critic::Utils::PPI qw{ is_ppi_statement_subclass }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Comma used to separate statements}; +Readonly::Scalar my $EXPL => [ 68, 71 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'allow_last_statement_to_be_comma_separated_in_map_and_grep', + description => 'Allow map and grep blocks to return lists.', + default_string => $FALSE, + behavior => 'boolean', + }, + ); +} + +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core bugs pbp certrule ) } +sub applies_to { return 'PPI::Statement' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + # Grrr... PPI instantiates non-leaf nodes in its class hierarchy... + return if is_ppi_statement_subclass($elem); + + # Now, if PPI hasn't introduced any new PPI::Statement subclasses, we've + # got an element who's class really is PPI::Statement. + + return if _is_parent_a_constructor_or_list($elem); + return if _is_parent_a_for_loop($elem); + + if ( + $self->{_allow_last_statement_to_be_comma_separated_in_map_and_grep} + ) { + return if not _is_direct_part_of_map_or_grep_block($elem); + } + + foreach my $child ( $elem->schildren() ) { + if ( + not $self->{_allow_last_statement_to_be_comma_separated_in_map_and_grep} + and not _is_last_statement_in_a_block($child) + ) { + if ( $child->isa('PPI::Token::Word') ) { + return if _succeeding_commas_are_list_element_separators($child); + } + elsif ( $child->isa('PPI::Token::Operator') ) { + if ( $child->content() eq $COMMA ) { + return $self->violation($DESC, $EXPL, $elem); + } + } + } + } + + return; +} + +sub _is_parent_a_constructor_or_list { + my ($elem) = @_; + + my $parent = $elem->parent(); + + return if not $parent; + + return ( + $parent->isa('PPI::Structure::Constructor') + or $parent->isa('PPI::Structure::List') + ); +} + +sub _is_parent_a_for_loop { + my ($elem) = @_; + + my $parent = $elem->parent(); + + return if not $parent; + + return if not $parent->isa('PPI::Structure::For'); + + return 1 == scalar $parent->schildren(); # Multiple means C-style loop. +} + +sub _is_direct_part_of_map_or_grep_block { + my ($elem) = @_; + + my $parent = $elem->parent(); + return if not $parent; + return if not $parent->isa('PPI::Structure::Block'); + + my $block_prior_sibling = $parent->sprevious_sibling(); + return if not $block_prior_sibling; + return if not $block_prior_sibling->isa('PPI::Token::Word'); + + return $block_prior_sibling eq 'map' || $block_prior_sibling eq 'grep'; +} + +sub _is_last_statement_in_a_block { + my ($elem) = @_; + + my $parent = $elem->parent(); + return if not $parent; + return if not $parent->isa('PPI::Structure::Block'); + + my $next_sibling = $elem->snext_sibling(); + return if not $next_sibling; + + return 1; +} + +sub _succeeding_commas_are_list_element_separators { + my ($elem) = @_; + + if ( + is_perl_builtin_with_zero_and_or_one_arguments($elem) + and not is_perl_builtin_with_multiple_arguments($elem) + ) { + return; + } + + my $sibling = $elem->snext_sibling(); + + return 1 if not $sibling; # There won't be any succeeding commas. + + return not $sibling->isa('PPI::Structure::List'); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::ProhibitCommaSeparatedStatements - Don't use the comma operator as a statement separator. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Perl's comma statement separator has really low precedence, which +leads to code that looks like it's using the comma list element +separator not actually doing so. Conway suggests that the statement +separator not be used in order to prevent this situation. + +The confusion that the statement separator causes is primarily due to +the assignment operators having higher precedence. + +For example, trying to combine two arrays into another like this won't +work: + + @x = @y, @z; + +because it is equivalent to + + @x = @y; + @z; + +Conversely, there are the built-in functions, like C, that +normally force the rest of the statement into list context, but don't +when called like a subroutine. + +This is not likely to produce what is intended: + + print join q{, }, 2, 3, 5, 7, ": the single-digit primes.\n"; + +The obvious fix is to add parentheses. Placing them like + + print join( q{, }, 2, 3, 5, 7 ), ": the single-digit primes.\n"; + +will work, but + + print ( join q{, }, 2, 3, 5, 7 ), ": the single-digit primes.\n"; + +will not, because it is equivalent to + + print( join q{, }, 2, 3, 5, 7 ); + ": the single-digit primes.\n"; + + +=head1 CONFIGURATION + +This policy can be configured to allow the last statement in a C +or C block to be comma separated. This is done via the +C option +like so: + + [ValuesAndExpressions::ProhibitCommaSeparatedStatements] + allow_last_statement_to_be_comma_separated_in_map_and_grep = 1 + +With this option off (the default), the following code violates this +policy. + + %hash = map {$_, 1} @list; + +With this option on, this statement is allowed. Even if this option +is off, using a fat comma C<< => >> works, but that forces +stringification on the first value, which may not be what you want. + + +=head1 BUGS + +Needs to check for C. + + +=head1 AUTHOR + +Elliot Shank C<< >> + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitComplexVersion.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitComplexVersion.pm new file mode 100644 index 0000000..707c5eb --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitComplexVersion.pm @@ -0,0 +1,273 @@ +package Perl::Critic::Policy::ValuesAndExpressions::ProhibitComplexVersion; + +use 5.006001; +use strict; +use warnings; + +use Carp; +use English qw(-no_match_vars); +use Perl::Critic::Utils qw{ :booleans :characters :severities }; +use Perl::Critic::Utils::PPI qw{ + get_next_element_in_same_simple_statement + get_previous_module_used_on_same_line + is_ppi_simple_statement +}; +use Readonly; +use Scalar::Util qw{ blessed }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DOLLAR => q<$>; +# All uses of the $DOLLAR variable below are to prevent false failures in +# xt/93_version.t. +Readonly::Scalar my $VERSION_MODULE => q; +Readonly::Scalar my $VERSION_VARIABLE => $DOLLAR . q; + +Readonly::Scalar my $DESC => + $DOLLAR . q; +Readonly::Scalar my $EXPL => + q; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return ( + { + name => 'forbid_use_version', + description => + qq, + default_string => $FALSE, + behavior => 'boolean', + }, + ); +} +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core maintenance ) } +sub applies_to { return 'PPI::Token::Symbol' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + + # Any variable other than $VERSION is ignored. + return if $VERSION_VARIABLE ne $elem->content(); + + # We are only interested in assignments to $VERSION, but it might be a + # list assignment, so if we do not find an assignment, we move up the + # parse tree. If we hit a statement (or no parent at all) we do not + # understand the code to be an assignment statement, and we simply return. + my $operator; + return if + not $operator = get_next_element_in_same_simple_statement( $elem ) + or $EQUAL ne $operator; + + # Find the simple statement we are in. If we can not find it, abandon the + # attempt to analyze the code. + my $statement = $self->_get_simple_statement( $elem ) + or return; + + # Check all symbols in the statement for violation. + my $exception; + return $exception if + $exception = + $self->_validate_fully_qualified_symbols($elem, $statement, $doc); + + # At this point we have found no data that is explicitly from outside the + # file. If the author wants to use a $VERSION from another module, _and_ + # wants MM->parse_version to understand it, the other module must be used + # on the same line. So we assume no violation unless this has been done. + my $module = get_previous_module_used_on_same_line( $elem ) + or return; + + # We make an exception for 'use version' unless configured otherwise; so + # let it be written, so let it be done. + return if $module eq $VERSION_MODULE and not $self->{_forbid_use_version}; + + # We assume nefarious intent if we have any other module used on the same + # line as the $VERSION assignment. + return $self->violation( $DESC, $EXPL, $elem ); +} + +#----------------------------------------------------------------------------- + +# Return the simple statement that contains our element. The classification +# done by is_ppi_simple_statement is not quite good enough in this case -- if +# our parent is a PPI::Structure::List, we want to keep looking. + +sub _get_simple_statement { + my ( $self, $elem ) = @_; + + my $statement = $elem; + + while ( $statement) { + my $parent; + if ( is_ppi_simple_statement( $statement ) ) { + return $statement if + not $parent = $statement->parent() + or not $parent->isa( 'PPI::Structure::List' ); + $statement = $parent; + } else { + $statement = $statement->parent(); + } + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _validate_fully_qualified_symbols { + my ( $self, $elem, $statement, $doc ) = @_; + + # Find the package(s) in this file. + my %local_package = + map { $_->schild( 1 ) => 1 } + @{ $doc->find( 'PPI::Statement::Package' ) || [] }; + $local_package{main} = 1; # For completeness. + + # Check all symbols in the statement for violation. + foreach my $symbol ( + @{ $statement->find( 'PPI::Token::Symbol' ) || [] } + ) { + if ( $symbol->canonical() =~ m< \A [@\$%&] ([\w:]*) :: >smx ) { + $local_package{ $1 } + or return $self->violation( $DESC, $EXPL, $elem ); + } + } + + # Check all interpolatable strings in the statement for violation. + # TODO this does not correctly handle "@{[some_expression()]}". + foreach my $string ( + @{ + $statement->find( + sub { + return + $_[1]->isa('PPI::Token::Quote::Double') + || $_[1]->isa('PPI::Token::Quote::Interpolate'); + } + ) + or [] + } + ) { + my $unquoted = $string->string(); + while ( + $unquoted =~ + m< + (?: \A | [^\\] ) + (?: \\{2} )* + [@\$] + [{]? + ([\w:]*) + :: + >gsmx + ) { + next if $local_package{ $1 }; + + return $self->violation( $DESC, $EXPL, $elem ); + } + } + + # Check all words in the statement for violation. + foreach my $symbol ( @{ $statement->find( 'PPI::Token::Word' ) || [] } ) { + if ( $symbol->content() =~ m/ \A ([\w:]*) :: /smx ) { + return $self->violation( $DESC, $EXPL, $elem ) + if not $local_package{ $1 }; + } + } + + return; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::ProhibitComplexVersion - Prohibit version values from outside the module. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +One tempting way to keep a group of related modules at the same version number +is to have all of them import the version number from a designated module. For +example, module C could be the version master for the C +package, and all other modules could use its C<$VERSION> by + + use Foo::Master; our $VERSION = $Foo::Master::VERSION; + +This turns out not to be a good idea, because all sorts of unintended things +can happen - anything from unintended version number changes to +denial-of-service attacks (since C is executed by the 'use'). + +This policy examines statements that assign to C<$VERSION>, and declares a +violation under two circumstances: first, if that statement uses a +fully-qualified symbol that did not originate in a package declared in the +file; second if there is a C statement on the same line that makes the +assignment. + +By default, an exception is made for C because of its +recommendation by Perl Best Practices. See the C +configuration variable if you do not want an exception made for C. + + +=head1 CONFIGURATION + +The construction + + use version; our $VERSION = qv('1.2.3'); + +is exempt from this policy by default, because it is recommended by Perl Best +Practices. Should you wish to identify C as a violation, add the +following to your perlcriticrc file: + + [ValuesAndExpressions::ProhibitComplexVersion] + forbid_use_version = 1 + + +=head1 CAVEATS + +This code assumes that the hallmark of a violation is a 'use' on the same line +as the C<$VERSION> assignment, because that is the way to have it seen by +L->parse_version(). Other ways to get +a version value from outside the module can be imagined, and this policy is +currently oblivious to them. + + +=head1 AUTHOR + +Thomas R. Wyant, III F + + +=head1 COPYRIGHT + +Copyright (c) 2009-2011 Tom Wyant. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitConstantPragma.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitConstantPragma.pm new file mode 100644 index 0000000..41aeb45 --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitConstantPragma.pm @@ -0,0 +1,91 @@ +package Perl::Critic::Policy::ValuesAndExpressions::ProhibitConstantPragma; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Pragma "constant" used}; +Readonly::Scalar my $EXPL => [ 55 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core bugs pbp ) } +sub applies_to { return 'PPI::Statement::Include' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + if ( $elem->type() eq 'use' && $elem->pragma() eq 'constant' ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::ProhibitConstantPragma - Don't C<< use constant FOO => 15 >>. + +=head1 AFFILIATION + +This Policy is part of the core L distribution. + + +=head1 DESCRIPTION + +Named constants are a good thing. But don't use the C +pragma because barewords don't interpolate. Instead use the +L module. + + use constant FOOBAR => 42; #not ok + + use Readonly; + Readonly my $FOOBAR => 42; #ok + Readonly::Scalar my $FOOBAR => 42; #ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEmptyQuotes.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEmptyQuotes.pm new file mode 100644 index 0000000..701d752 --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEmptyQuotes.pm @@ -0,0 +1,105 @@ +package Perl::Critic::Policy::ValuesAndExpressions::ProhibitEmptyQuotes; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EMPTY_RX => qr{\A ["'] \s* ['"] \z}xms; +Readonly::Scalar my $DESC => q; +Readonly::Scalar my $EXPL => [ 53 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core pbp cosmetic) } +sub applies_to { return 'PPI::Token::Quote' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + if ( $elem =~ $EMPTY_RX ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::ProhibitEmptyQuotes - Write C instead of C<''>. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Don't use quotes for an empty string or any string that is pure +whitespace. Instead, use C to improve legibility. Better still, +created named values like this. Use the C operator to repeat +characters. + + $message = ''; #not ok + $message = ""; #not ok + $message = " "; #not ok + + $message = q{}; #better + $message = q{ } #better + + $EMPTY = q{}; + $message = $EMPTY; #best + + $SPACE = q{ }; + $message = $SPACE x 5; #best + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEscapedCharacters.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEscapedCharacters.pm new file mode 100644 index 0000000..f2fbde6 --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEscapedCharacters.pm @@ -0,0 +1,96 @@ +package Perl::Critic::Policy::ValuesAndExpressions::ProhibitEscapedCharacters; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Numeric escapes in interpolated string}; +Readonly::Scalar my $EXPL => [ 54..55 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core pbp cosmetic) } +sub applies_to { return qw(PPI::Token::Quote::Double + PPI::Token::Quote::Interpolate) } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + my $not_escaped = qr/(?content =~ m/$not_escaped (?:$hex|$widehex|$oct)/xmso) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::ProhibitEscapedCharacters - Write C<"\N{DELETE}"> instead of C<"\x7F">, etc. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Escaped numeric values are hard to read and debug. Instead, use named +values. The syntax is less compact, but dramatically more readable. + + $str = "\x7F\x06\x22Z"; # not ok + + use charnames ':full'; + $str = "\N{DELETE}\N{ACKNOWLEDGE}\N{CANCEL}Z"; # ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Chris Dolan + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitImplicitNewlines.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitImplicitNewlines.pm new file mode 100644 index 0000000..1bf3f2c --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitImplicitNewlines.pm @@ -0,0 +1,107 @@ +package Perl::Critic::Policy::ValuesAndExpressions::ProhibitImplicitNewlines; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Literal line breaks in a string}; +Readonly::Scalar my $EXPL => [60,61]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core pbp cosmetic ) } +sub applies_to { return 'PPI::Token::Quote' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->string !~ m/\n/xms; + + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::ProhibitImplicitNewlines - Use concatenation or HEREDOCs instead of literal line breaks in strings. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Strings with embedded line breaks are hard to read. Use concatenation +or HEREDOCs instead. + + my $foo = "Line one is quite long + Line two"; # Bad + + my $foo = "Line one is quite long\nLine two"; # Better, but still hard to read + + my $foo = "Line one is quite long\n" + . "Line two"; # Better still + + my $foo = <<'EOF'; # Use heredoc for longer passages + Line one is quite long + Line two + Line three breaks the camel's back + EOF + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + + +=head1 COPYRIGHT + + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitInterpolationOfLiterals.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitInterpolationOfLiterals.pm new file mode 100644 index 0000000..5adc870 --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitInterpolationOfLiterals.pm @@ -0,0 +1,197 @@ +package Perl::Critic::Policy::ValuesAndExpressions::ProhibitInterpolationOfLiterals; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use List::MoreUtils qw(any); + +use Perl::Critic::Utils qw{ :characters :severities :data_conversion }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Useless interpolation of literal string}; +Readonly::Scalar my $EXPL => [51]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'allow', + description => + 'Kinds of delimiters to permit, e.g. "qq{", "qq(", "qq[", "qq/".', + default_string => $EMPTY, + parser => \&_parse_allow, + }, + { + name => 'allow_if_string_contains_single_quote', + description => + q, + default_string => '0', + behavior => 'boolean', + }, + ); +} + +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw( core pbp cosmetic ) } +sub applies_to { return qw(PPI::Token::Quote::Double + PPI::Token::Quote::Interpolate) } + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $MAX_SPECIFICATION_LENGTH => 3; + +sub _parse_allow { + my ($self, $parameter, $config_string) = @_; + + my @allow; + + if (defined $config_string) { + @allow = words_from_string( $config_string ); + #Try to be forgiving with the configuration... + for (@allow) { + m{ \A qq }xms || ($_ = 'qq' . $_) + } #Add 'qq' + for (@allow) { + (length $_ <= $MAX_SPECIFICATION_LENGTH) || chop + } #Chop closing char + } + + $self->{_allow} = \@allow; + + return; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + # Skip if this string needs interpolation + return if _has_interpolation($elem); + + # Overlook allowed quote styles + return if any { $elem =~ m{ \A \Q$_\E }xms } @{ $self->{_allow} }; + + # If the flag is set, allow "I'm here". + if ( $self->{_allow_if_string_contains_single_quote} ) { + return if index ($elem, $QUOTE) >= 0; + } + + # Must be a violation + return $self->violation( $DESC, $EXPL, $elem ); +} + +#----------------------------------------------------------------------------- + +sub _has_interpolation { + my $elem = shift; + return $elem =~ m< + (?: \A | [^\\] ) + (?: \\{2} )* + (?: [\$\@] \S+ | \\[tnrfbae0xcNLuLUEQ] ) + >xmso; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::ProhibitInterpolationOfLiterals - Always use single quotes for literal strings. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Don't use double-quotes or C if your string doesn't require +interpolation. This saves the interpreter a bit of work and it lets +the reader know that you really did intend the string to be literal. + + print "foobar"; #not ok + print 'foobar'; #ok + print qq/foobar/; #not ok + print q/foobar/; #ok + + print "$foobar"; #ok + print "foobar\n"; #ok + print qq/$foobar/; #ok + print qq/foobar\n/; #ok + + print qq{$foobar}; #preferred + print qq{foobar\n}; #preferred + +Use of double-quotes might be reasonable if the string contains single +quote (') characters: + + print "it's me"; # ok, if configuration flag set + + +=head1 CONFIGURATION + +The types of quoting styles to exempt from this policy can be +configured via the C option. This must be a +whitespace-delimited combination of some or all of the following +styles: C, C, C, and C. + +This is useful because some folks have configured their editor to +apply special syntax highlighting within certain styles of quotes. +For example, you can tweak C to use SQL highlighting for +everything that appears within C or C quotes. But if +those strings are literal, Perl::Critic will complain. To prevent +this, put the following in your F<.perlcriticrc> file: + + [ValuesAndExpressions::ProhibitInterpolationOfLiterals] + allow = qq{} qq[] + +The flag C permits +double-quoted strings if the string contains a single quote (') +character. It defaults to off; to turn it on put the following in +your F<.perlcriticrc> file: + + [ValuesAndExpressions::ProhibitInterpolationOfLiterals] + allow_if_string_contains_single_quote = 1 + + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLeadingZeros.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLeadingZeros.pm new file mode 100644 index 0000000..df42c82 --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLeadingZeros.pm @@ -0,0 +1,270 @@ +package Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use Perl::Critic::Utils qw{ :characters :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $LEADING_RX => qr<\A [+-]? (?: 0+ _* )+ [1-9]>xms; +Readonly::Scalar my $EXPL => [ 58 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'strict', + description => + q, + default_string => '0', + behavior => 'boolean', + }, + ); +} + +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw< core pbp bugs certrec > } +sub applies_to { return 'PPI::Token::Number::Octal' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem !~ $LEADING_RX; + return $self->_create_violation($elem) if $self->{_strict}; + return if $self->_is_first_argument_of_chmod_or_umask($elem); + return if $self->_is_second_argument_of_mkdir($elem); + return if $self->_is_second_argument_of_mkfifo($elem); + return if $self->_is_third_argument_of_dbmopen($elem); + return if $self->_is_fourth_argument_of_sysopen($elem); + return $self->_create_violation($elem); +} + +sub _create_violation { + my ($self, $elem) = @_; + + return $self->violation( + qq, + $EXPL, + $elem + ); +} + +sub _is_first_argument_of_chmod_or_umask { + my ($self, $elem) = @_; + + my $previous_token = _previous_token_that_isnt_a_parenthesis($elem); + return if not $previous_token; + + my $content = $previous_token->content(); + return $content eq 'chmod' || $content eq 'umask'; +} + +sub _is_second_argument_of_mkdir { + my ($self, $elem) = @_; + + # Preceding comma. + my $previous_token = _previous_token_that_isnt_a_parenthesis($elem); + return if not $previous_token; + return if $previous_token->content() ne $COMMA; # Don't know what it is. + + # Directory name. + $previous_token = + _previous_token_that_isnt_a_parenthesis($previous_token); + return if not $previous_token; + + $previous_token = + _previous_token_that_isnt_a_parenthesis($previous_token); + return if not $previous_token; + + return $previous_token->content() eq 'mkdir'; +} + +sub _is_second_argument_of_mkfifo { + my ($self, $elem) = @_; + + # Preceding comma. + my $previous_token = _previous_token_that_isnt_a_parenthesis($elem); + return if not $previous_token; + return if $previous_token->content() ne $COMMA; # Don't know what it is. + + # FIFO name. + $previous_token = + _previous_token_that_isnt_a_parenthesis($previous_token); + return if not $previous_token; + + $previous_token = + _previous_token_that_isnt_a_parenthesis($previous_token); + return if not $previous_token; + + return $previous_token->content() eq 'mkfifo' + || $previous_token->content() eq 'POSIX::mkfifo'; +} + +sub _is_third_argument_of_dbmopen { + my ($self, $elem) = @_; + + # Preceding comma. + my $previous_token = _previous_token_that_isnt_a_parenthesis($elem); + return if not $previous_token; + return if $previous_token->content() ne $COMMA; # Don't know what it is. + + # File path. + $previous_token = + _previous_token_that_isnt_a_parenthesis($previous_token); + return if not $previous_token; + + # Another comma. + $previous_token = + _previous_token_that_isnt_a_parenthesis($previous_token); + return if not $previous_token; + return if $previous_token->content() ne $COMMA; # Don't know what it is. + + # Variable name. + $previous_token = + _previous_token_that_isnt_a_parenthesis($previous_token); + return if not $previous_token; + + $previous_token = + _previous_token_that_isnt_a_parenthesis($previous_token); + return if not $previous_token; + + return $previous_token->content() eq 'dbmopen'; +} + +sub _is_fourth_argument_of_sysopen { + my ($self, $elem) = @_; + + # Preceding comma. + my $previous_token = _previous_token_that_isnt_a_parenthesis($elem); + return if not $previous_token; + return if $previous_token->content() ne $COMMA; # Don't know what it is. + + # Mode. + $previous_token = + _previous_token_that_isnt_a_parenthesis($previous_token); + while ($previous_token and $previous_token->content() ne $COMMA) { + $previous_token = + _previous_token_that_isnt_a_parenthesis($previous_token); + } + return if not $previous_token; + return if $previous_token->content() ne $COMMA; # Don't know what it is. + + # File name. + $previous_token = + _previous_token_that_isnt_a_parenthesis($previous_token); + return if not $previous_token; + + # Yet another comma. + $previous_token = + _previous_token_that_isnt_a_parenthesis($previous_token); + return if not $previous_token; + return if $previous_token->content() ne $COMMA; # Don't know what it is. + + # File handle. + $previous_token = + _previous_token_that_isnt_a_parenthesis($previous_token); + return if not $previous_token; + + $previous_token = + _previous_token_that_isnt_a_parenthesis($previous_token); + return if not $previous_token; + + return $previous_token->content() eq 'sysopen'; +} + +sub _previous_token_that_isnt_a_parenthesis { + my ($elem) = @_; + + my $previous_token = $elem->previous_token(); + while ( + $previous_token + and ( + not $previous_token->significant() + or $previous_token->content() eq $LEFT_PAREN + or $previous_token->content() eq $RIGHT_PAREN + ) + ) { + $previous_token = $previous_token->previous_token(); + } + + return $previous_token; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros - Write C instead of C<0755>. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Perl interprets numbers with leading zeros as octal. If that's what +you really want, its better to use C and make it obvious. + + $var = 041; # not ok, actually 33 + $var = oct(41); # ok + + chmod 0644, $file; # ok by default + dbmopen %database, 'foo.db', 0600; # ok by default + mkdir $directory, 0755; # ok by default + sysopen $filehandle, $filename, O_RDWR, 0666; # ok by default + umask 0002; # ok by default + + use POSIX 'mkfifo'; + mkfifo $fifo, 0600; # ok by default + POSIX::mkfifo $fifo, 0600; # ok by default + +=head1 CONFIGURATION + +If you want to ban all leading zeros, set C to a true value in +a F<.perlcriticrc> file. + + [ValuesAndExpressions::ProhibitLeadingZeros] + strict = 1 + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLongChainsOfMethodCalls.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLongChainsOfMethodCalls.pm new file mode 100644 index 0000000..9ad459b --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLongChainsOfMethodCalls.pm @@ -0,0 +1,191 @@ +package Perl::Critic::Policy::ValuesAndExpressions::ProhibitLongChainsOfMethodCalls; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :characters :severities }; +use Perl::Critic::Utils::PPI qw{ is_ppi_expression_or_generic_statement }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => + q{Long chains of method calls indicate code that is too tightly coupled}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'max_chain_length', + description => 'The number of chained calls to allow.', + default_string => '3', + behavior => 'integer', + integer_minimum => 1, + }, + ); +} + +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw( core maintenance ) } +sub applies_to { return qw{ PPI::Statement }; } + +#----------------------------------------------------------------------------- + +sub _max_chain_length { + my ( $self ) = @_; + + return $self->{_max_chain_length}; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if not is_ppi_expression_or_generic_statement($elem); + + my $chain_length = 0; + my $max_chain_length = $self->_max_chain_length(); + my @children = $elem->schildren(); + my $child = shift @children; + + while ($child) { + # if it looks like we've got a subroutine call, drop the parameter + # list. + if ( + $child->isa('PPI::Token::Word') + and @children + and $children[0]->isa('PPI::Structure::List') + ) { + shift @children; + } + + if ( + $child->isa('PPI::Token::Word') + or $child->isa('PPI::Token::Symbol') + ) { + if ( @children ) { + if ( $children[0]->isa('PPI::Token::Operator') ) { + if ( q{->} eq $children[0]->content() ) { + $chain_length++; + shift @children; + } + } + elsif ( not $children[0]->isa('PPI::Token::Structure') ) { + $chain_length = 0; + } + } + } + else { + if ($chain_length > $max_chain_length) { + return + $self->violation( + "Found method-call chain of length $chain_length.", + $EXPL, + $elem, + ); + } + + $chain_length = 0; + } + + $child = shift @children; + } + + if ($chain_length > $max_chain_length) { + return + $self->violation( + "Found method-call chain of length $chain_length.", + $EXPL, + $elem, + ); + } + + return; +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords MSCHWERN + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::ProhibitLongChainsOfMethodCalls - Long chains of method calls indicate tightly coupled code. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +A long chain of method calls usually indicates that the code knows too +much about the interrelationships between objects. If the code is +able to directly navigate far down a network of objects, then when the +network changes structure in the future, the code will need to be +modified to deal with the change. The code is too tightly coupled and +is brittle. + + + $x = $y->a; #ok + $x = $y->a->b; #ok + $x = $y->a->b->c; #questionable, but allowed by default + $x = $y->a->b->c->d; #not ok + + +=head1 CONFIGURATION + +This policy has one option: C which controls how far +the code is allowed to navigate. The default value is 3. + + +=head1 TO DO + +Add a C option to allow for things like + + File::Find::Rule + ->name('*.blah') + ->not_name('thingy') + ->readable() + ->directory() + ->in(@roots); + + +=head1 AUTHOR + +Elliot Shank C<< >> + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMagicNumbers.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMagicNumbers.pm new file mode 100644 index 0000000..5fb3e0b --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMagicNumbers.pm @@ -0,0 +1,679 @@ +package Perl::Critic::Policy::ValuesAndExpressions::ProhibitMagicNumbers; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use Perl::Critic::Utils qw{ :booleans :characters :severities :data_conversion }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#---------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => + q{Unnamed numeric literals make code less maintainable}; +Readonly::Scalar my $USE_READONLY_OR_CONSTANT => + ' Use the Readonly or Const::Fast module or the "constant" pragma instead'; +Readonly::Scalar my $TYPE_NOT_ALLOWED_SUFFIX => + ") are not allowed.$USE_READONLY_OR_CONSTANT"; + +Readonly::Scalar my $UNSIGNED_NUMBER => + qr{ + \d+ (?: [$PERIOD] \d+ )? # 1, 1.5, etc. + | [$PERIOD] \d+ # .3, .7, etc. + }xms; +Readonly::Scalar my $SIGNED_NUMBER => qr/ [-+]? $UNSIGNED_NUMBER /xms; + +Readonly::Scalar my $RANGE => + qr{ + \A + ($SIGNED_NUMBER) + [$PERIOD] [$PERIOD] + ($SIGNED_NUMBER) + (?: + [$COLON] by [$LEFT_PAREN] + ($UNSIGNED_NUMBER) + [$RIGHT_PAREN] + )? + \z + }xms; + +Readonly::Scalar my $SPECIAL_ARRAY_SUBSCRIPT_EXEMPTION => -1; + +#---------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'allowed_values', + description => 'Individual and ranges of values to allow, and/or "all_integers".', + default_string => '0 1 2', + parser => \&_parse_allowed_values, + }, + { + name => 'allowed_types', + description => 'Kind of literals to allow.', + default_string => 'Float', + behavior => 'enumeration', + enumeration_values => [ qw{ Binary Exp Float Hex Octal } ], + enumeration_allow_multiple_values => 1, + }, + { + name => 'allow_to_the_right_of_a_fat_comma', + description => + q[Should anything to the right of a "=>" be allowed?], + default_string => '1', + behavior => 'boolean', + }, + { + name => 'constant_creator_subroutines', + description => q{Names of subroutines that create constants}, + behavior => 'string list', + list_always_present_values => [ + qw< + Readonly Readonly::Scalar Readonly::Array Readonly::Hash + const + >, + ], + }, + ); +} + +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw( core maintenance certrec ) } +sub applies_to { return 'PPI::Token::Number' } + +sub default_maximum_violations_per_document { return 10; } + +#---------------------------------------------------------------------------- + +sub initialize_if_enabled { + my ($self, $config) = @_; + + $self->_determine_checked_types(); + + return $TRUE; +} + +sub _parse_allowed_values { + my ($self, $parameter, $config_string) = @_; + + my ( $all_integers_allowed, $allowed_values ) + = _determine_allowed_values($config_string); + + my $allowed_string = ' is not one of the allowed literal values ('; + if ($all_integers_allowed) { + $allowed_string .= 'all integers'; + + if ( %{$allowed_values} ) { + $allowed_string .= ', '; + } + } + $allowed_string + .= ( join ', ', sort { $a <=> $b } keys %{$allowed_values} ) . ').' + . $USE_READONLY_OR_CONSTANT; + + $self->{_allowed_values} = $allowed_values; + $self->{_all_integers_allowed} = $all_integers_allowed; + $self->{_allowed_string} = $allowed_string; + + return; +} + +sub _determine_allowed_values { + my ($config_string) = @_; + + my @allowed_values; + my @potential_allowed_values; + my $all_integers_allowed = 0; + + if ( defined $config_string ) { + my @allowed_values_strings = + grep {$_} split m/\s+/xms, $config_string; + + foreach my $value_string (@allowed_values_strings) { + if ($value_string eq 'all_integers') { + $all_integers_allowed = 1; + } elsif ( $value_string =~ m/ \A $SIGNED_NUMBER \z /xms ) { + push @potential_allowed_values, $value_string + 0; + } elsif ( $value_string =~ m/$RANGE/xms ) { + my ( $minimum, $maximum, $increment ) = ($1, $2, $3); + $increment ||= 1; + + $minimum += 0; + $maximum += 0; + $increment += 0; + + for ( ## no critic (ProhibitCStyleForLoops) + my $value = $minimum; + $value <= $maximum; + $value += $increment + ) { + push @potential_allowed_values, $value; + } + } else { + die q{Invalid value for allowed_values: }, $value_string, + q{. Must be a number, a number range, or}, + qq{ "all_integers".\n}; + } + } + + if ($all_integers_allowed) { + @allowed_values = grep { $_ != int $_ } @potential_allowed_values; ## no critic ( BuiltinFunctions::ProhibitUselessTopic ) + } else { + @allowed_values = @potential_allowed_values; + } + } else { + @allowed_values = (2); + } + + if ( not $all_integers_allowed ) { + push @allowed_values, 0, 1; + } + my %allowed_values = hashify(@allowed_values); + + return ( $all_integers_allowed, \%allowed_values ); +} + +sub _determine_checked_types { + my ($self) = @_; + + my %checked_types = ( + 'PPI::Token::Number::Binary' => 'Binary literals (', + 'PPI::Token::Number::Float' => 'Floating-point literals (', + 'PPI::Token::Number::Exp' => 'Exponential literals (', + 'PPI::Token::Number::Hex' => 'Hexadecimal literals (', + 'PPI::Token::Number::Octal' => 'Octal literals (', + 'PPI::Token::Number::Version' => 'Version literals (', + ); + + # This will be set by the enumeration behavior specified in + # supported_parameters() above. + my $allowed_types = $self->{_allowed_types}; + + foreach my $allowed_type ( keys %{$allowed_types} ) { + delete $checked_types{"PPI::Token::Number::$allowed_type"}; + + if ( $allowed_type eq 'Exp' ) { + + # because an Exp isa(Float). + delete $checked_types{'PPI::Token::Number::Float'}; + } + } + + $self->{_checked_types} = \%checked_types; + + return; +} + + +sub violates { + my ( $self, $elem, undef ) = @_; + + if ( $self->{_allow_to_the_right_of_a_fat_comma} ) { + return if _element_is_to_the_right_of_a_fat_comma($elem); + } + + return if _element_is_in_an_include_readonly_or_version_statement( + $self, $elem, + ); + return if _element_is_in_a_plan_statement($elem); + return if _element_is_in_a_constant_subroutine($elem); + return if _element_is_a_package_statement_version_number($elem); + + my $literal = $elem->literal(); + if ( + defined $literal + and not ( + $self->{_all_integers_allowed} + and int $literal == $literal + ) + and not defined $self->{_allowed_values}{$literal} + and not ( + _element_is_sole_component_of_a_subscript($elem) + and $literal == $SPECIAL_ARRAY_SUBSCRIPT_EXEMPTION + ) + ) { + return + $self->violation( + $elem->content() . $self->{_allowed_string}, + $EXPL, + $elem, + ); + } + + + my ( $number_type, $type_string ); + + while ( + ( $number_type, $type_string ) = ( each %{ $self->{_checked_types} } ) + ) { + if ( $elem->isa($number_type) ) { + return + $self->violation( + $type_string . $elem->content() . $TYPE_NOT_ALLOWED_SUFFIX, + $EXPL, + $elem, + ); + } + } + + return; +} + +sub _element_is_to_the_right_of_a_fat_comma { + my ($elem) = @_; + + my $previous = $elem->sprevious_sibling() or return; + + $previous->isa('PPI::Token::Operator') or return; + + return $previous->content() eq q[=>]; +} + +sub _element_is_sole_component_of_a_subscript { + my ($elem) = @_; + + my $parent = $elem->parent(); + if ( $parent and $parent->isa('PPI::Statement::Expression') ) { + if ( $parent->schildren() > 1 ) { + return 0; + } + + my $grandparent = $parent->parent(); + if ( + $grandparent + and $grandparent->isa('PPI::Structure::Subscript') + ) { + return 1; + } + } + + return 0; +} + +sub _element_is_in_an_include_readonly_or_version_statement { + my ($self, $elem) = @_; + + my $parent = $elem->parent(); + while ($parent) { + if ( $parent->isa('PPI::Statement') ) { + return 1 if $parent->isa('PPI::Statement::Include'); + + if ( $parent->isa('PPI::Statement::Variable') ) { + if ( $parent->type() eq 'our' ) { + my @variables = $parent->variables(); + if ( + scalar @variables == 1 + and $variables[0] eq '$VERSION' ## no critic (RequireInterpolationOfMetachars) + ) { + return 1; + } + } + + return 0; + } + + my $first_token = $parent->first_token(); + if ( $first_token->isa('PPI::Token::Word') ) { + if ( $self->{_constant_creator_subroutines}{ + $first_token->content() } ) { + return 1; + } + } elsif ($parent->isa('PPI::Structure::Block')) { + return 0; + } + } + + $parent = $parent->parent(); + } + + return 0; +} + +# Allow "plan tests => 39;". + +Readonly::Scalar my $PLAN_STATEMENT_MINIMUM_TOKENS => 4; + +sub _element_is_in_a_plan_statement { + my ($elem) = @_; + + my $parent = $elem->parent(); + return 0 if not $parent; + + return 0 if not $parent->isa('PPI::Statement'); + + my @children = $parent->schildren(); + return 0 if @children < $PLAN_STATEMENT_MINIMUM_TOKENS; + + return 0 if not $children[0]->isa('PPI::Token::Word'); + return 0 if $children[0]->content() ne 'plan'; + + return 0 if not $children[1]->isa('PPI::Token::Word'); + return 0 if $children[1]->content() ne 'tests'; + + return 0 if not $children[2]->isa('PPI::Token::Operator'); + return 0 if $children[2]->content() ne '=>'; + + return 1; +} + +sub _element_is_in_a_constant_subroutine { + my ($elem) = @_; + + my $parent = $elem->parent(); + return 0 if not $parent; + + return 0 if not $parent->isa('PPI::Statement'); + + my $following = $elem->snext_sibling(); + if ($following) { + return 0 if not $following->isa('PPI::Token::Structure'); + return 0 if $following->content() ne $SCOLON; + return 0 if $following->snext_sibling(); + } + + my $preceding = $elem->sprevious_sibling(); + if ($preceding) { + return 0 if not $preceding->isa('PPI::Token::Word'); + return 0 if $preceding->content() ne 'return'; + return 0 if $preceding->sprevious_sibling(); + } + + return 0 if $parent->snext_sibling(); + return 0 if $parent->sprevious_sibling(); + + my $grandparent = $parent->parent(); + return 0 if not $grandparent; + + return 0 if not $grandparent->isa('PPI::Structure::Block'); + + my $greatgrandparent = $grandparent->parent(); + return 0 if not $greatgrandparent; + return 0 if not $greatgrandparent->isa('PPI::Statement::Sub'); + + return 1; +} + +sub _element_is_a_package_statement_version_number { + my ($elem) = @_; + + my $parent = $elem->statement() + or return 0; + + $parent->isa( 'PPI::Statement::Package' ) + or return 0; + + my $version = $parent->schild( 2 ) + or return 0; + + return $version == $elem; +} + +1; + +__END__ + +#---------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::ProhibitMagicNumbers - Don't use values that don't explain themselves. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +What is a "magic number"? A magic number is a number that appears in +code without any explanation; e.g. C<$bank_account_balance *= +57.492;>. You look at that number and have to wonder where that +number came from. Since you don't understand the significance of the +number, you don't understand the code. + +In general, numeric literals other than C<0> or C<1> in should not be used. +Use the L pragma or the L or +L modules to give a descriptive name to the number. + +There are, of course, exceptions to when this rule should be applied. +One good example is positioning of objects in some container like +shapes on a blueprint or widgets in a user interface. In these cases, +the significance of a number can readily be determined by context. + +The maximum number of violations per document for this policy defaults +to 10. + + +=head2 Ways in which this module applies this rule. + +By default, this rule is relaxed in that C<2> is permitted to allow +for common things like alternation, the STDERR file handle, etc.. + +Numeric literals are allowed in C and C statements to +allow for things like Perl version restrictions and +L plans. Declarations of C<$VERSION> package +variables are permitted. Use of C, C, +C, and C from the +L module are obviously valid, but use of +C, C, and C are +specifically not supported. + +Use of binary, exponential, hexadecimal, octal, and version numbers, +even for C<0> and C<1>, outside of C/C/C +statements aren't permitted (but you can change this). + +There is a special exemption for accessing the last element of an +array, i.e. C<$x[-1]>. + + + $x = 0; # ok + $x = 0.0; # ok + $x = 1; # ok + $x = 1.0; # ok + $x = 1.5; # not ok + $x = 0b0 # not ok + $x = 0b1 # not ok + $x = 0x00 # not ok + $x = 0x01 # not ok + $x = 000 # not ok + $x = 001 # not ok + $x = 0e1 # not ok + $x = 1e1 # not ok + + $frobnication_factor = 42; # not ok + use constant FROBNICATION_FACTOR => 42; # ok + + + use 5.6.1; # ok + use Test::More plan => 57; # ok + plan tests => 39; # ok + our $VERSION = 0.22; # ok + + + $x = $y[-1] # ok + $x = $y[-2] # not ok + + + + foreach my $solid (1..5) { # not ok + ... + } + + + use Readonly; + + Readonly my $REGULAR_GEOMETRIC_SOLIDS => 5; + + foreach my $solid (1..$REGULAR_GEOMETRIC_SOLIDS) { #ok + ... + } + + +=head1 CONFIGURATION + +This policy has four options: C, C, +C, and C. + + +=head2 C + +The C parameter is a whitespace delimited set of +permitted number I; this does not affect the permitted formats +for numbers. The defaults are equivalent to having the following in +your F<.perlcriticrc>: + + [ValuesAndExpressions::ProhibitMagicNumbers] + allowed_values = 0 1 2 + +Note that this policy forces the values C<0> and C<1> into the +permitted values. Thus, specifying no values, + + allowed_values = + +is the same as simply listing C<0> and C<1>: + + allowed_values = 0 1 + +The special C value, not surprisingly, allows all +integral values to pass, subject to the restrictions on number types. + +Ranges can be specified as two (possibly fractional) numbers separated +by two periods, optionally suffixed with an increment using the Perl 6 +C<:by()> syntax. E.g. + + allowed_values = 7..10 + +will allow 0, 1, 7, 8, 9, and 10 as literal values. Using fractional +values like so + + allowed_values = -3.5..-0.5:by(0.5) + +will permit -3.5, -3, -2.5, -2, -2.5, -1, -0.5, 0, and 1. +Unsurprisingly, the increment defaults to 1, which means that + + allowed_values = -3.5..-0.5 + +will make -3.5, -2.5, -2.5, -0.5, 0, and 1 valid. + +Ranges are not lazy, i.e. you'd better have a lot of memory available +if you use a range of C<1..1000:by(0.01)>. Also remember that all of +this is done using floating-point math, which means that +C<1..10:by(0.3333)> is probably not going to be very useful. + +Specifying an upper limit that is less than the lower limit will +result in no values being produced by that range. Negative increments +are not permitted. + +Multiple ranges are permitted. + +To put this all together, the following is a valid, though not likely +to be used, F<.perlcriticrc> entry: + + [ValuesAndExpressions::ProhibitMagicNumbers] + allowed_values = 3.1415269 82..103 -507.4..57.8:by(0.2) all_integers + + +=head2 C + +The C parameter is a whitespace delimited set of +subclasses of L. + +Decimal integers are always allowed. By default, floating-point +numbers are also allowed. + +For example, to allow hexadecimal literals, you could configure this +policy like + + [ValuesAndExpressions::ProhibitMagicNumbers] + allowed_types = Hex + +but without specifying anything for C, the allowed +hexadecimal literals will be C<0x00>, C<0x01>, and C<0x02>. Note, +also, as soon as you specify a value for this parameter, you must +include C in the list to continue to be able to use floating +point literals. This effect can be used to restrict literals to only +decimal integers: + + [ValuesAndExpressions::ProhibitMagicNumbers] + allowed_types = + +If you permit exponential notation, you automatically also allow +floating point values because an exponential is a subclass of +floating-point in L. + + +=head2 C + +If this is set, you can put any number to the right of a fat comma. + + my %hash = ( a => 4512, b => 293 ); # ok + my $hash_ref = { a => 4512, b => 293 }; # ok + some_subroutine( a => 4512, b => 293 ); # ok + +Currently, this only means I to the right of the fat comma. By +default, this value is I. + + +=head2 C + +This parameter allows you to specify the names of subroutines that create +constants, in addition to C, C, and friends. For +example, if you use a custom C-like module that supports a +C subroutine to create constants, you could add something +like the following to your F<.perlcriticrc>: + + [ValuesAndExpressions::ProhibitMagicNumbers] + constant_creator_subroutines = create_constant + +If you have more than one name to add, separate them by whitespace. + +The subroutine name should appear exactly as it is in your code. For example, +if your code does not import the creating subroutine +subroutine, you would need to configure this policy as something like + + [ValuesAndExpressions::ProhibitMagicNumbers] + constant_creator_subroutines = create_constant Constant::Create::create_constant + + +=head1 BUGS + +There is currently no way to permit version numbers in regular code, +even if you include them in the C. Some may actually +consider this a feature. + + +=head1 AUTHOR + +Elliot Shank C<< >> + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMismatchedOperators.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMismatchedOperators.pm new file mode 100644 index 0000000..070a18e --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMismatchedOperators.pm @@ -0,0 +1,219 @@ +package Perl::Critic::Policy::ValuesAndExpressions::ProhibitMismatchedOperators; +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :booleans :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q; +Readonly::Scalar my $EXPL => q; + +# token compatibility [ numeric, string ] +Readonly::Hash my %TOKEN_COMPATIBILITY => ( + 'PPI::Token::Number' => [$TRUE, $FALSE], + 'PPI::Token::Symbol' => [$TRUE, $TRUE ], + 'PPI::Token::Quote' => [$FALSE, $TRUE ], +); + +Readonly::Hash my %FILE_OPERATOR_COMPATIBILITY => + map {; "-$_" => [$TRUE, $FALSE] } + qw< r w x o R W X O e z s f d l p S b c t u g k T B M A >; + +Readonly::Scalar my $TOKEN_COMPATIBILITY_INDEX_NUMERIC => 0; +Readonly::Scalar my $TOKEN_COMPATIBILITY_INDEX_STRING => 1; + +Readonly::Hash my %OPERATOR_TYPES => ( + # numeric + ( + map { $_ => $TOKEN_COMPATIBILITY_INDEX_NUMERIC } + qw[ == != > >= < <= + - * / += -= *= /= ] + ), + # string + map { $_ => $TOKEN_COMPATIBILITY_INDEX_STRING } + qw< eq ne lt gt le ge . .= >, +); + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw< core bugs certrule > } +sub applies_to { return 'PPI::Token::Operator' } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem) = @_; + + my $elem_text = $elem->content(); + + return if not exists $OPERATOR_TYPES{$elem_text}; + + my $leading_operator = $self->_get_potential_leading_operator($elem) + or return; + + my $next_elem = $elem->snext_sibling() or return; + + if ( $next_elem->isa('PPI::Token::Operator') ) { + $elem_text .= $next_elem->content(); + $next_elem = $next_elem->snext_sibling(); + } + + return if not exists $OPERATOR_TYPES{$elem_text}; + my $operator_type = $OPERATOR_TYPES{$elem_text}; + + my $leading_operator_compatibility = + $self->_get_token_compatibility($leading_operator); + my $next_compatibility = $self->_get_token_compatibility($next_elem); + + return if + ( + ! defined $leading_operator_compatibility + || $leading_operator_compatibility->[$operator_type] + ) + && ( + ! defined $next_compatibility + || $next_compatibility->[$operator_type] + ); + + return if + $operator_type + && defined $leading_operator_compatibility + && ! $leading_operator_compatibility->[$operator_type] + && $self->_have_stringy_x($leading_operator); # RT 54524 + + return $self->violation($DESC, $EXPL, $elem); +} + +#----------------------------------------------------------------------------- + +sub _get_token_compatibility { + my ($self, $elem) = @_; + + return $FILE_OPERATOR_COMPATIBILITY{ $elem->content() } + if $self->_is_file_operator($elem); + + for my $class (keys %TOKEN_COMPATIBILITY) { + return $TOKEN_COMPATIBILITY{$class} if $elem->isa($class); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _have_stringy_x { + my ($self, $elem) = @_; + + return if not $elem; + + my $prev_oper = $elem->sprevious_sibling() or return; + + return if not $prev_oper->isa('PPI::Token::Operator'); + return if 'x' ne $prev_oper->content(); + + return !! $prev_oper->sprevious_sibling(); +} + +#----------------------------------------------------------------------------- + +sub _get_potential_leading_operator { + my ($self, $elem) = @_; + + my $previous_element = $elem->sprevious_sibling() or return; + + if ( $self->_get_token_compatibility($previous_element) ) { + my $previous_sibling = $previous_element->sprevious_sibling(); + if ( + $previous_sibling and $self->_is_file_operator($previous_sibling) + ) { + $previous_element = $previous_sibling; + } + } + + return $previous_element; +} + +#----------------------------------------------------------------------------- + +sub _is_file_operator { + my ($self, $elem) = @_; + + return if not $elem; + return if not $elem->isa('PPI::Token::Operator'); + return !! $FILE_OPERATOR_COMPATIBILITY{ $elem->content() } +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::ProhibitMismatchedOperators - Don't mix numeric operators with string operands, or vice-versa. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Using the wrong operator type for a value can obscure coding intent +and possibly lead to subtle errors. An example of this is mixing a +string equality operator with a numeric value, or vice-versa. + + if ($foo == 'bar') {} #not ok + if ($foo eq 'bar') {} #ok + if ($foo eq 123) {} #not ok + if ($foo == 123) {} #ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 NOTES + +If L are enabled, the Perl interpreter usually +warns you about using mismatched operators at run-time. This Policy +does essentially the same thing, but at author-time. That way, you +can find out about them sooner. + + +=head1 AUTHOR + +Peter Guzis + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Peter Guzis. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMixedBooleanOperators.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMixedBooleanOperators.pm new file mode 100644 index 0000000..bf79ec4 --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMixedBooleanOperators.pm @@ -0,0 +1,145 @@ +package Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :data_conversion }; +use base 'Perl::Critic::Policy'; + + +#----------------------------------------------------------------------------- + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Hash my %LOW_BOOLEANS => hashify( qw( not or and ) ); +Readonly::Hash my %HIGH_BOOLEANS => hashify( qw( ! || && ||= &&= //=) ); + +Readonly::Hash my %EXEMPT_TYPES => hashify( + qw( + PPI::Statement::Block + PPI::Statement::Scheduled + PPI::Statement::Package + PPI::Statement::Include + PPI::Statement::Sub + PPI::Statement::Variable + PPI::Statement::Compound + PPI::Statement::Data + PPI::Statement::End + ) +); + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Mixed high and low-precedence booleans}; +Readonly::Scalar my $EXPL => [ 70 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core bugs pbp certrec ) } +sub applies_to { return 'PPI::Statement' } + +#----------------------------------------------------------------------------- + +sub violates { + + my ( $self, $elem, undef ) = @_; + + # PPI::Statement is the ancestor of several types of PPI elements. + # But for this policy, we only want the ones that generally + # represent a single statement or expression. There might be + # better ways to do this, such as scanning for a semi-colon or + # some other marker. + + return if exists $EXEMPT_TYPES{ ref $elem }; + + if ( $elem->find_first(\&_low_boolean) + && $elem->find_first(\&_high_boolean) ) { + + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +#----------------------------------------------------------------------------- + +sub _low_boolean { + my (undef, $elem) = @_; + return if $elem->isa('PPI::Statement'); + $elem->isa('PPI::Token::Operator') || return 0; + return exists $LOW_BOOLEANS{$elem}; +} + +#----------------------------------------------------------------------------- + +sub _high_boolean { + my (undef, $elem) = @_; + return if $elem->isa('PPI::Statement'); + $elem->isa('PPI::Token::Operator') || return 0; + return exists $HIGH_BOOLEANS{$elem}; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators - Write C< !$foo && $bar || $baz > instead of C< not $foo && $bar or $baz>. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway advises against combining the low-precedence booleans ( C ) with the high-precedence boolean operators ( C<&& || !> ) in +the same expression. Unless you fully understand the differences +between the high and low-precedence operators, it is easy to +misinterpret expressions that use both. And even if you do understand +them, it is not always clear if the author actually intended it. + + next if not $foo || $bar; #not ok + next if !$foo || $bar; #ok + next if !( $foo || $bar ); #ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitNoisyQuotes.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitNoisyQuotes.pm new file mode 100644 index 0000000..e6fadd3 --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitNoisyQuotes.pm @@ -0,0 +1,111 @@ +package Perl::Critic::Policy::ValuesAndExpressions::ProhibitNoisyQuotes; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $NOISE_RX => qr{\A ["'] [^ \w () {} [\] <> ]{1,2} ['"] \z}xms; +Readonly::Scalar my $DESC => q{Quotes used with a noisy string}; +Readonly::Scalar my $EXPL => [ 53 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core pbp cosmetic) } +sub applies_to { return qw(PPI::Token::Quote::Double + PPI::Token::Quote::Single) } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + return if $elem !~ $NOISE_RX; + my $statement = $elem->statement; + return if $statement + && $statement->isa('PPI::Statement::Include') + && $statement->type eq 'use' + && $statement->module eq 'overload'; + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::ProhibitNoisyQuotes - Use C or C instead of quotes for awkward-looking strings. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Don't use quotes for one or two-character strings of non-alphanumeric +characters (i.e. noise). These tend to be hard to read. For +legibility, use C or a named value. However, braces, +parentheses and brackets tend to look better in quotes, so those +are allowed. + + $str = join ',', @list; #not ok + $str = join ",", @list; #not ok + $str = join q{,}, @list; #better + + $COMMA = q{,}; + $str = join $COMMA, @list; #best + + $lbrace = '('; #ok + $rbrace = ')'; #ok + print '(', @list, ')'; #ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitQuotesAsQuotelikeOperatorDelimiters.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitQuotesAsQuotelikeOperatorDelimiters.pm new file mode 100644 index 0000000..44e2c30 --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitQuotesAsQuotelikeOperatorDelimiters.pm @@ -0,0 +1,294 @@ +package Perl::Critic::Policy::ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ + :booleans :characters :severities :data_conversion +}; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Hash my %DESCRIPTIONS => ( + $QUOTE => q{Single-quote used as quote-like operator delimiter}, + $DQUOTE => q{Double-quote used as quote-like operator delimiter}, + $BACKTICK => q{Back-quote (back-tick) used as quote-like operator delimiter}, +); + +Readonly::Scalar my $EXPL => + q{Using quotes as delimiters for quote-like operators obfuscates code}; + +Readonly::Array my @OPERATORS => qw{ m q qq qr qw qx s tr y }; + +Readonly::Hash my %INFO_RETRIEVERS_BY_PPI_CLASS => ( + 'PPI::Token::Quote::Literal' => \&_info_for_single_character_operator, + 'PPI::Token::Quote::Interpolate' => \&_info_for_two_character_operator, + 'PPI::Token::QuoteLike::Command' => \&_info_for_two_character_operator, + 'PPI::Token::QuoteLike::Regexp' => \&_info_for_two_character_operator, + 'PPI::Token::QuoteLike::Words' => \&_info_for_two_character_operator, + 'PPI::Token::Regexp::Match' => \&_info_for_match, + 'PPI::Token::Regexp::Substitute' => \&_info_for_single_character_operator, + 'PPI::Token::Regexp::Transliterate' => \&_info_for_transliterate, +); + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'single_quote_allowed_operators', + description => + 'The operators to allow single-quotes as delimiters for.', + default_string => 'm s qr qx', + behavior => 'enumeration', + enumeration_values => [ @OPERATORS ], + enumeration_allow_multiple_values => 1, + }, + { + name => 'double_quote_allowed_operators', + description => + 'The operators to allow double-quotes as delimiters for.', + default_string => $EMPTY, + behavior => 'enumeration', + enumeration_values => [ @OPERATORS ], + enumeration_allow_multiple_values => 1, + }, + { + name => 'back_quote_allowed_operators', + description => + 'The operators to allow back-quotes (back-ticks) as delimiters for.', + default_string => $EMPTY, + behavior => 'enumeration', + enumeration_values => [ @OPERATORS ], + enumeration_allow_multiple_values => 1, + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core maintenance ) } + +sub applies_to { + return qw{ + PPI::Token::Quote::Interpolate + PPI::Token::Quote::Literal + PPI::Token::QuoteLike::Command + PPI::Token::QuoteLike::Regexp + PPI::Token::QuoteLike::Words + PPI::Token::Regexp::Match + PPI::Token::Regexp::Substitute + PPI::Token::Regexp::Transliterate + }; +} + +#----------------------------------------------------------------------------- + +sub initialize_if_enabled { + my ($self, $config) = @_; + + $self->{_allowed_operators_by_delimiter} = { + $QUOTE => $self->_single_quote_allowed_operators(), + $DQUOTE => $self->_double_quote_allowed_operators(), + $BACKTICK => $self->_back_quote_allowed_operators(), + }; + + return $TRUE; +} + +#----------------------------------------------------------------------------- + +sub _single_quote_allowed_operators { + my ( $self ) = @_; + + return $self->{_single_quote_allowed_operators}; +} + +sub _double_quote_allowed_operators { + my ( $self ) = @_; + + return $self->{_double_quote_allowed_operators}; +} + +sub _back_quote_allowed_operators { + my ( $self ) = @_; + + return $self->{_back_quote_allowed_operators}; +} + +sub _allowed_operators_by_delimiter { + my ( $self ) = @_; + + return $self->{_allowed_operators_by_delimiter}; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + my $info_retriever = $INFO_RETRIEVERS_BY_PPI_CLASS{ ref $elem }; + return if not $info_retriever; + + my ($operator, $delimiter) = $info_retriever->( $elem ); + + my $allowed_operators = + $self->_allowed_operators_by_delimiter()->{$delimiter}; + return if not $allowed_operators; + + if ( not $allowed_operators->{$operator} ) { + return $self->violation( $DESCRIPTIONS{$delimiter}, $EXPL, $elem ); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _info_for_single_character_operator { + my ( $elem ) = @_; + + ## no critic (ProhibitParensWithBuiltins) + return ( substr ($elem, 0, 1), substr ($elem, 1, 1) ); + ## use critic +} + +#----------------------------------------------------------------------------- + +sub _info_for_two_character_operator { + my ( $elem ) = @_; + + ## no critic (ProhibitParensWithBuiltins) + return ( substr ($elem, 0, 2), substr ($elem, 2, 1) ); + ## use critic +} + +#----------------------------------------------------------------------------- + +sub _info_for_match { + my ( $elem ) = @_; + + if ( $elem =~ m/ ^ m /xms ) { + return ('m', substr $elem, 1, 1); + } + + return ('m', q{/}); +} + +#----------------------------------------------------------------------------- + +sub _info_for_transliterate { + my ( $elem ) = @_; + + if ( $elem =~ m/ ^ tr /xms ) { + return ('tr', substr $elem, 2, 1); + } + + return ('y', substr $elem, 1, 1); +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords Schwern + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters - Don't use quotes (C<'>, C<">, C<`>) as delimiters for the quote-like operators. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +With the obvious exception of using single-quotes to prevent +interpolation, using quotes with the quote-like operators kind of +defeats the purpose of them and produces obfuscated code, causing +problems for future maintainers and their editors/IDEs. + + $x = q"q"; #not ok + $x = q'q'; #not ok + $x = q`q`; #not ok + + $x = qq"q"; #not ok + $x = qr"r"; #not ok + $x = qw"w"; #not ok + + $x = qx`date`; #not ok + + $x =~ m"m"; #not ok + $x =~ s"s"x"; #not ok + $x =~ tr"t"r"; #not ok + $x =~ y"x"y"; #not ok + + $x =~ m'$x'; #ok + $x =~ s'$x'y'; #ok + $x = qr'$x'm; #ok + $x = qx'finger foo@bar'; #ok + + +=head1 CONFIGURATION + +This policy has three options: C, +C, and +C, which control which operators are +allowed to use each of C<'>, C<">, C<`> as delimiters, respectively. + +The values allowed for these options are a whitespace delimited +selection of the C, C, C, C, C, C, C, C, +and C operators. + +By default, double quotes and back quotes (backticks) are not allowed +as delimiters for any operators and single quotes are allowed as +delimiters for the C, C, C, and C operators. These +defaults are equivalent to having the following in your +F<.perlcriticrc>: + + [ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters] + single_quote_allowed_operators = m s qr qx + double_quote_allowed_operators = + back_quote_allowed_operators = + + +=head1 SUGGESTED BY + +Michael Schwern + + +=head1 AUTHOR + +Elliot Shank C<< >> + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitSpecialLiteralHeredocTerminator.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitSpecialLiteralHeredocTerminator.pm new file mode 100644 index 0000000..e71e2c4 --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitSpecialLiteralHeredocTerminator.pm @@ -0,0 +1,128 @@ +package Perl::Critic::Policy::ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Hash my %SPECIAL_LITERAL => map { '__' . $_ . '__' => 1 } + qw( FILE LINE PACKAGE END DATA ); +Readonly::Scalar my $DESC => + q{Heredoc terminator must not be a special literal}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw(core maintenance) } +sub applies_to { return 'PPI::Token::HereDoc' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + # remove << and (optional) quotes from around terminator + ( my $heredoc_terminator = $elem ) =~ + s{ \A << ~? \s* (["']?) (.*) \1 \z }{$2}xms; + + if ( $SPECIAL_LITERAL{ $heredoc_terminator } ) { + my $expl = qq{Used "$heredoc_terminator" as heredoc terminator}; + return $self->violation( $DESC, $expl, $elem ); + } + + return; #ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator - Don't write C< print <<'__END__' >. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Using one of Perl's special literals as a HEREDOC terminator could be +confusing to tools that try to parse perl. + + print <<'__END__'; #not ok + Hello world + __END__ + + print <<'__END_OF_WORLD__'; #ok + Goodbye world! + __END_OF_WORLD__ + +The special literals that this policy prohibits are: + +=over + +=item __END__ + +=item __DATA__ + +=item __PACKAGE__ + +=item __FILE__ + +=item __LINE__ + +=back + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L + +L + + +=head1 AUTHOR + +Kyle Hasselbacher + + +=head1 COPYRIGHT + +Copyright (c) 2009-2011 Kyle Hasselbacher. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitVersionStrings.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitVersionStrings.pm new file mode 100644 index 0000000..e3fffdc --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitVersionStrings.pm @@ -0,0 +1,105 @@ +package Perl::Critic::Policy::ValuesAndExpressions::ProhibitVersionStrings; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Version string used}; +Readonly::Scalar my $EXPL => q{Use a real number instead}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw(core pbp maintenance) } +sub applies_to { return 'PPI::Statement::Include' } + +#----------------------------------------------------------------------------- + +sub violates { + my ($self, $elem, undef) = @_; + + my $version; + + if ( my $module = $elem->module() ) { + return if $module eq 'lib'; + + $version = $elem->module_version(); + } else { + $version = $elem->schild(1); + } + + return if not defined $version; + return if not $version->isa('PPI::Token::Number::Version'); + + return $self->violation($DESC, $EXPL, $elem); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::ProhibitVersionStrings - Don't use strings like C or C<1.4.5> when including other modules. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Whenever you C or C a module, you can specify a minimum +version requirement. To ensure compatibility with older Perls, this +version number should be expressed as a floating-point number. Do not +use v-strings or three-part numbers. The Perl convention for +expressing version numbers as floats is: version + (patch level / +1000). + + use Foo v1.2 qw(foo bar); # not ok + use Foo 1.2.03 qw(foo bar); # not ok + use Foo 1.00203 qw(foo bar); # ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireConstantVersion.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireConstantVersion.pm new file mode 100644 index 0000000..a6b4d34 --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireConstantVersion.pm @@ -0,0 +1,435 @@ +package Perl::Critic::Policy::ValuesAndExpressions::RequireConstantVersion; + +use 5.006001; +use strict; +use warnings; + +use Carp; +use English qw(-no_match_vars); +use Perl::Critic::Utils qw< + :booleans :characters :classification :data_conversion :language + :severities +>; +use Perl::Critic::Utils::PPI qw{ + is_ppi_constant_element + get_next_element_in_same_simple_statement + get_previous_module_used_on_same_line +}; +use Readonly; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $BIND_REGEX => q<=~>; +Readonly::Scalar my $DOLLAR => q<$>; +# All uses of the $DOLLAR variable below are to prevent false failures in +# xt/93_version.t. +Readonly::Scalar my $QV => q; +Readonly::Scalar my $VERSION_MODULE => q; +Readonly::Scalar my $VERSION_VARIABLE => $DOLLAR . q; + +# Operators which would make a new value our of our $VERSION, and therefore +# not modify it. I'm sure this list is not exhaustive. The logical operators +# generally do not qualify for this list. At least, I think not. +Readonly::Hash my %OPERATOR_WHICH_MAKES_NEW_VALUE => hashify( qw{ + = . + - * ** / % ^ ~ & | > < == != >= <= eq ne gt lt ge le + } ); + +Readonly::Scalar my $DESC => $DOLLAR . q; +Readonly::Scalar my $EXPL => qq; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return ( + { + name => 'allow_version_without_use_on_same_line', + description => + q{Allow qv() and version->new() without a 'use version' on the same line.}, + default_string => $FALSE, + behavior => 'boolean', + } + ); +} +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw( core maintenance ) } +sub applies_to { return 'PPI::Token::Symbol' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + + # Any variable other than $VERSION is ignored. + return if $VERSION_VARIABLE ne $elem->content(); + + # Get the next thing (presumably an operator) after $VERSION. The $VERSION + # might be in a list, so if we get nothing we move upwards until we hit a + # simple statement. If we have nothing at this point, we do not understand + # the code, and so we return. + my $operator; + return if + not $operator = get_next_element_in_same_simple_statement( $elem ); + + # If the next operator is a regex binding, and its other operand is a + # substitution operator, it is an attempt to modify $VERSION, so we + # return an error to that effect. + return $self->violation( $DESC, $EXPL, $elem ) + if $self->_validate_operator_bind_regex( $operator, $elem ); + + # If the presumptive operator is not an assignment operator of some sort, + # we are not modifying $VERSION at all, and so we just return. + return if not $operator = _check_for_assignment_operator( $operator ); + + # If there is no operand to the right of the assignment, we do not + # understand the code; simply return. + my $value; + return if not $value = $operator->snext_sibling(); + + # If the value is symbol '$VERSION', just return as we will see it again + # later. + return if + $value->isa( 'PPI::Token::Symbol' ) + and $value->content() eq $VERSION_VARIABLE; + + # If the value is a word, there are a number of acceptable things it could + # be. Check for these. If there was a problem, return it. + $value = $self->_validate_word_token( $elem, $value ); + return $value if $value->isa( 'Perl::Critic::Exception' ); + + # If the value is anything but a constant, we cry foul. + return $self->violation( $DESC, $EXPL, $elem ) + if not is_ppi_constant_element( $value ); + + # If we have nothing after the value, it is OK. + my $structure; + return if + not $structure = get_next_element_in_same_simple_statement( $value ); + + # If we have a semicolon after the value, it is OK. + return if $SCOLON eq $structure->content(); + + # If there is anything else after the value, we cry foul. + return $self->violation( $DESC, $EXPL, $elem ); +} + +#----------------------------------------------------------------------------- + +# Check if the element is an assignment operator. + +sub _check_for_assignment_operator { + my ( $operator ) = @_; + + return if not $operator->isa( 'PPI::Token::Operator' ); + return $operator if is_assignment_operator($operator->content()); + return; +} + +#----------------------------------------------------------------------------- + +# Validate a bind_regex ('=~') operator appearing after $VERSION. We return +# true if the operator is in fact '=~', and its next sibling isa +# PPI::Token::Regexp::Substitute. Otherwise we return false. + +sub _validate_operator_bind_regex { + my ( $self, $operator, $elem ) = @_; + + # We are not interested in anything but '=~ s/../../'. + return if $BIND_REGEX ne $operator->content(); + my $operand; + return if not $operand = $operator->snext_sibling(); + return if not $operand->isa( 'PPI::Token::Regexp::Substitute' ); + + # The substitution is OK if it is of the form + # '($var = $VERSION) =~ s/../../'. + + # We can't look like the desired form if we have a next sig. sib. + return $TRUE if $elem->snext_sibling(); + + # We can't look like the desired form if we are not in a list. + my $containing_list; + $containing_list = $elem->parent() + and $containing_list->isa( 'PPI::Statement' ) + and $containing_list = $containing_list->parent() + and $containing_list->isa( 'PPI::Structure::List' ) + or return $TRUE; + + # If we have no prior element, we're ( $VERSION ) =~ s/../../, + # which flunks. + my $prior = $elem->sprevious_sibling() or return $TRUE; + + # If the prior element is an operator which makes a new value, we pass. + return if $prior->isa( 'PPI::Token::Operator' ) + && $OPERATOR_WHICH_MAKES_NEW_VALUE{ $prior->content() }; + + # Now things get complicated, as RT #55600 shows. We need to grub through + # the entire list, looking for something that looks like a subroutine + # call, but without parens around the argument list. This catches the + # ticket's case, which was + # ( $foo = sprintf '%s/%s', __PACKAGE__, $VERSION ) =~ s/../../. + my $current = $prior; + while( $prior = $current->sprevious_sibling() ) { + $prior->isa( 'PPI::Token::Word' ) or next; + is_function_call( $prior) or next; + # If this function has its own argument list, we need to keep looking; + # otherwise we have found a function with no parens, and we can + # return. + $current->isa( 'PPI::Structure::List' ) + or return; + } continue { + $current = $prior; + } + + # Maybe the whole list was arguments for a subroutine or method call. + $prior = $containing_list->sprevious_sibling() + or return $TRUE; + if ( $prior->isa( 'PPI::Token::Word' ) ) { + return if is_method_call( $prior ); + return if is_function_call( $prior ); + } + + # Anything left is presumed a violation. + return $TRUE; +} + +#----------------------------------------------------------------------------- + +# Validating a PPI::Token::Word is a complicated business, so we split it out +# into its own subroutine. The $elem is to be used in forming the error +# message, and the $value is the PPI::Token::Word we just encountered. The +# return is either a PPI::Element for further analysis, or a +# Perl::Critic::Exception to be returned. + +sub _validate_word_token { + my ( $self, $elem, $value ) = @_; + + if ( $value->isa( 'PPI::Token::Word' ) ) { + my $content = $value->content(); + + # If the word is of the form 'v\d+' it may be the first portion of a + # misparsed (by PPI) v-string. It is really a v-string if the next + # element is a number. Unless v-strings are allowed, we return an + # error. + if ( $content =~ m/ \A v \d+ \z /smx ) { + $value = $self->_validate_word_vstring( $elem, $value ); + } + elsif ( $QV eq $content ) { + # If the word is 'qv' we suspect use of the version module. If + # 'use version' appears on the same line, _and_ the remainder of + # the expression is of the form '(value)', we extract the value + # for further analysis. + + $value = $self->_validate_word_qv( $elem, $value ); + } + elsif ( $VERSION_MODULE eq $content ) { + # If the word is 'version' we suspect use of the version module. + # Check to see if it is properly used. + $value = $self->_validate_word_version( $elem, $value ); + } + } + + return $value; +} + +#----------------------------------------------------------------------------- + +# Validate $VERSION = v1.2.3; +# Note that this is needed because PPI mis-parses the 'v1.2.3' construct into +# a word ('v1') and a number of some sort ('.2.3'). This method should only be +# called if it is already known that the $value is a PPI::Token::Word matching +# m/ \A v \d+ \z /smx; + +sub _validate_word_vstring { + my ( $self, $elem, $value ) = @_; + + # Check for the second part of the mis-parsed v-string, flunking if it is + # not found. + my $next; + return $self->violation( $DESC, $EXPL, $elem ) + if + not $next = $value->snext_sibling() + or not $next->isa( 'PPI::Token::Number' ); + + # Return the second part of the v-string for further analysis. + return $next; +} + +#----------------------------------------------------------------------------- + +# Validate $VERSION = qv(); + +sub _validate_word_qv { + my ( $self, $elem, $value ) = @_; + + # Unless we are specifically allowing this construction without the + # 'use version;' on the same line, check for it and flunk if we do not + # find it. + $self->{_allow_version_without_use_on_same_line} + or do { + my $module; + return $self->violation( $DESC, $EXPL, $elem ) + if not + $module = get_previous_module_used_on_same_line($value); + return $self->violation( $DESC, $EXPL, $elem ) + if $VERSION_MODULE ne $module->content(); + }; + + # Dig out the first argument of 'qv()', flunking if we can not find it. + my $next; + return $self->violation( $DESC, $EXPL, $elem ) + if not ( + $next = $value->snext_sibling() + and $next->isa( 'PPI::Structure::List' ) + and $next = $next->schild( 0 ) + and $next->isa( 'PPI::Statement::Expression' ) + and $next = $next->schild( 0 ) + ); + + # Return the qv() argument for further analysis. + return $next; +} + +#----------------------------------------------------------------------------- + +# Validate $VERSION = version->new(); + +# TODO: Fix this EVIL dual-purpose return value. This is ugggggleeeee. +sub _validate_word_version { + my ( $self, $elem, $value ) = @_; + + # Unless we are specifically allowing this construction without the + # 'use version;' on the same line, check for it and flunk if we do not + # find it. + $self->{_allow_version_without_use_on_same_line} + or do { + my $module; + return $self->violation( $DESC, $EXPL, $elem ) + if not + $module = get_previous_module_used_on_same_line($value); + return $self->violation( $DESC, $EXPL, $elem ) + if $VERSION_MODULE ne $module->content(); + }; + + # Dig out the first argument of '->new()', flunking if we can not find it. + my $next; + return $next if + $next = $value->snext_sibling() + and $next->isa( 'PPI::Token::Operator' ) + and q{->} eq $next->content() + and $next = $next->snext_sibling() + and $next->isa( 'PPI::Token::Word' ) + and q{new} eq $next->content() + and $next = $next->snext_sibling() + and $next->isa( 'PPI::Structure::List' ) + and $next = $next->schild( 0 ) + and $next->isa( 'PPI::Statement::Expression' ) + and $next = $next->schild( 0 ); + + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::RequireConstantVersion - Require $VERSION to be a constant rather than a computed value. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +The $VERSION variable of a module should be a simple constant - either a +number, a single-quotish string, or a 'use version' object. In the latter case +the 'use version;' must appear on the same line as the object construction. + +Computing the version has problems of various severities. + +The most benign violation is computing the version from (e.g.) a Subversion +revision number: + + our ($VERSION) = q$REVISION: 42$ =~ /(\d+)/; + +The problem here is that the version is tied to a single repository. The code +can not be moved to another repository (even of the same type) without +changing its version, possibly in the wrong direction. + +This policy accepts v-strings (C or just plain C<1.2.3>), since these +are already flagged by +L. + + +=head1 CONFIGURATION + +The proper way to set a module's $VERSION to a C object is to +C on the same line of code that assigns the value of $VERSION. +That way, L and +L can extract the version when packaging the +module for CPAN. By default, this policy declares an error if this is not +done. + +Should you wish to allow version objects without loading the version module on +the same line, add the following to your configuration file: + + [ValuesAndExpressions::RequireConstantVersion] + allow_version_without_use_on_same_line = 1 + + +=head1 CAVEATS + +There will be false negatives if the $VERSION appears on the left-hand side of +a list assignment that assigns to more than one variable, or to C. + +There may be false positives if the $VERSION is assigned the value of a here +document. This will probably remain the case until +L acquires the relevant portions of +the L interface. + +There will be false positives if $VERSION is assigned the value of a constant +created by the L module or the L pragma, +because the necessary infrastructure appears not to exist, and the author of +the present module lacked the knowledge/expertise/gumption to put it in place. + +Currently the idiom + + our $VERSION = '1.005_05'; + $VERSION = eval $VERSION; + +will produce a violation on the second line of the example. + + +=head1 AUTHOR + +Thomas R. Wyant, III F + + +=head1 COPYRIGHT + +Copyright (c) 2009-2011 Tom Wyant. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireInterpolationOfMetachars.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireInterpolationOfMetachars.pm new file mode 100644 index 0000000..a263d3c --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireInterpolationOfMetachars.pm @@ -0,0 +1,264 @@ +package Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use Perl::Critic::Utils qw< :booleans :characters :severities >; +use base 'Perl::Critic::Policy'; + +#----------------------------------------------------------------------------- + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q; +Readonly::Scalar my $EXPL => [ 51 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'rcs_keywords', + description => 'RCS keywords to ignore in potential interpolation.', + default_string => $EMPTY, + behavior => 'string list', + }, + ); +} + +sub default_severity { return $SEVERITY_LOWEST } +sub default_themes { return qw(core pbp cosmetic) } + +sub applies_to { + return qw< PPI::Token::Quote::Single PPI::Token::Quote::Literal >; +} + +#----------------------------------------------------------------------------- + +sub initialize_if_enabled { + my ($self, $config) = @_; + + my $rcs_keywords = $self->{_rcs_keywords}; + my @rcs_keywords = keys %{$rcs_keywords}; + + if (@rcs_keywords) { + my $rcs_regexes = [ map { qr/ \$ $_ [^\n\$]* \$ /xms } @rcs_keywords ]; + $self->{_rcs_regexes} = $rcs_regexes; + } + + return $TRUE; +} + +sub violates { + my ( $self, $elem, undef ) = @_; + + # The string() method strips off the quotes + my $string = $elem->string(); + return if not _needs_interpolation($string); + return if _looks_like_email_address($string); + return if _looks_like_use_vars($elem); + + my $rcs_regexes = $self->{_rcs_regexes}; + return if $rcs_regexes and _contains_rcs_variable($string, $rcs_regexes); + + return $self->violation( $DESC, $EXPL, $elem ); +} + +#----------------------------------------------------------------------------- + +sub _needs_interpolation { + my ($string) = @_; + + return + # Contains a $ or @ not followed by "{}". + $string =~ m< [\$\@] (?! [{] [}] ) \S+ >xms + # Contains metachars + # Note that \1 ... are not documented (that I can find), but are + # treated the same way as \0 by S_scan_const in toke.c, at least + # for regular double-quotish strings. Not, obviously, where + # regexes are involved. + || $string =~ m< + (?: \A | [^\\] ) + (?: \\{2} )* + \\ [tnrfbae01234567xcNluLUEQ] + >xms; +} + +#----------------------------------------------------------------------------- + +# Stolen from Email::Address, which is deprecated. Since we are not modifying +# the original code at all, we are less stringent in being Critic-compliant. + +## no critic ( RegularExpressions::RequireDotMatchAnything ) +## no critic ( RegularExpressions::RequireLineBoundaryMatching ) +## no critic ( RegularExpressions::ProhibitEscapedMetacharacters ) + +my $CTL = q{\x00-\x1F\x7F}; ## no critic ( ValuesAndExpressions::RequireInterpolationOfMetachars ) +my $special = q{()<>\\[\\]:;@\\\\,."}; ## no critic ( ValuesAndExpressions::RequireInterpolationOfMetachars ) + +my $text = qr/[^\x0A\x0D]/x; +my $quoted_pair = qr/\\$text/x; +my $ctext = qr/(?>[^()\\]+)/x; +my $ccontent = qr/$ctext|$quoted_pair/x; +my $comment = qr/\s*\((?:\s*$ccontent)*\s*\)\s*/x; +my $cfws = qr/$comment|\s+/x; +my $atext = qq/[^$CTL$special\\s]/; +my $atom = qr/$cfws*$atext+$cfws*/x; +my $dot_atom_text = qr/$atext+(?:\.$atext+)*/x; +my $dot_atom = qr/$cfws*$dot_atom_text$cfws*/x; +my $qtext = qr/[^\\"]/x; +my $qcontent = qr/$qtext|$quoted_pair/x; +my $quoted_string = qr/$cfws*"$qcontent*"$cfws*/x; +my $local_part = qr/$dot_atom|$quoted_string/x; +my $dtext = qr/[^\[\]\\]/x; +my $dcontent = qr/$dtext|$quoted_pair/x; +my $domain_literal = qr/$cfws*\[(?:\s*$dcontent)*\s*\]$cfws*/x; +my $domain = qr/$dot_atom|$domain_literal/x; +my $addr_spec = qr/$local_part\@$domain/x; + +sub _looks_like_email_address { + my ($string) = @_; + + return if index ($string, q<@>) < 0; + return if $string =~ m< \W \@ >xms; + return if $string =~ m< \A \@ \w+ \b >xms; + + return $string =~ $addr_spec; +} + +#----------------------------------------------------------------------------- + +sub _contains_rcs_variable { + my ($string, $rcs_regexes) = @_; + + foreach my $regex ( @{$rcs_regexes} ) { + return $TRUE if $string =~ m/$regex/xms; + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _looks_like_use_vars { + my ($elem) = @_; + + my $statement = $elem; + while ( not $statement->isa('PPI::Statement::Include') ) { + $statement = $statement->parent() or return; + } + + return if $statement->type() ne q; + return $statement->module() eq q; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords RCS + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars - Warns that you might have used single quotes when you really wanted double-quotes. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +This policy warns you if you use single-quotes or C with a string +that has unescaped metacharacters that may need interpolation. Its +hard to know for sure if a string really should be interpolated +without looking into the symbol table. This policy just makes an +educated guess by looking for metacharacters and sigils which usually +indicate that the string should be interpolated. + + +=head2 Exceptions + +=over + +=item * + +Variable names to C: + + use vars '$x'; # ok + use vars ('$y', '$z'); # ok + use vars qw< $a $b >; # ok + + +=item * + +Things that look like e-mail addresses: + + print 'john@foo.com'; # ok + $address = 'suzy.bar@baz.net'; # ok + +=back + + +=head1 CONFIGURATION + +The C option allows you to stop this policy from complaining +about things that look like RCS variables, for example, in deriving values for +C<$VERSION> variables. + +For example, if you've got code like + + our ($VERSION) = (q<$Revision$> =~ m/(\d+)/mx); + +You can specify + + [ValuesAndExpressions::RequireInterpolationOfMetachars] + rcs_keywords = Revision + +in your F<.perlcriticrc> to provide an exemption. + + +=head1 NOTES + +Perl's own C pragma also warns you about this. + + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireNumberSeparators.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireNumberSeparators.pm new file mode 100644 index 0000000..a29d728 --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireNumberSeparators.pm @@ -0,0 +1,119 @@ +package Perl::Critic::Policy::ValuesAndExpressions::RequireNumberSeparators; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Long number not separated with underscores}; +Readonly::Scalar my $EXPL => [ 59 ]; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $MINIMUM_INTEGER_WITH_MULTIPLE_DIGITS => 10; + +sub supported_parameters { + return ( + { + name => 'min_value', + description => 'The minimum absolute value to require separators in.', + default_string => '10_000', + behavior => 'integer', + integer_minimum => $MINIMUM_INTEGER_WITH_MULTIPLE_DIGITS, + }, + ); +} + +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw( core pbp cosmetic ) } +sub applies_to { return 'PPI::Token::Number' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + my $min = $self->{_min_value}; + + return if $elem !~ m{ \d{4} }xms; + return if abs $elem->literal() < $min; + + return $self->violation( $DESC, $EXPL, $elem ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::RequireNumberSeparators - Write C< 141_234_397.0145 > instead of C< 141234397.0145 >. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Long numbers can be difficult to read. To improve legibility, Perl +allows numbers to be split into groups of digits separated by +underscores. This policy requires number sequences of more than three +digits to be separated. + + $long_int = 123456789; #not ok + $long_int = 123_456_789; #ok + + $long_float = 12345678.001; #not ok + $long_float = 12_345_678.001; #ok + +=head1 CONFIGURATION + +The minimum absolute value of numbers that must contain separators can +be configured via the C option. The default is 10,000; +thus, all numbers >= 10,000 and <= -10,000 must have separators. For +example: + + [ValuesAndExpressions::RequireNumberSeparators] + min_value = 100000 # That's one-hundred-thousand! + +=head1 NOTES + +As it is currently written, this policy only works properly with +decimal (base 10) numbers. And it is obviously biased toward Western +notation. I'll try and address those issues in the future. + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireQuotedHeredocTerminator.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireQuotedHeredocTerminator.pm new file mode 100644 index 0000000..ee96fc8 --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireQuotedHeredocTerminator.pm @@ -0,0 +1,103 @@ +package Perl::Critic::Policy::ValuesAndExpressions::RequireQuotedHeredocTerminator; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $HEREDOC_RX => qr/ \A << ~? \s* ["'] .* ['"] \z /xms; +Readonly::Scalar my $DESC => q{Heredoc terminator must be quoted}; +Readonly::Scalar my $EXPL => [ 64 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw(core pbp maintenance) } +sub applies_to { return 'PPI::Token::HereDoc' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + if ( $elem !~ $HEREDOC_RX ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::RequireQuotedHeredocTerminator - Write C< print <<'THE_END' > or C< print <<"THE_END" >. + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Putting single or double-quotes around your HEREDOC terminator make it +obvious to the reader whether the content is going to be interpolated +or not. + + print < + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireUpperCaseHeredocTerminator.pm b/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireUpperCaseHeredocTerminator.pm new file mode 100644 index 0000000..30b0756 --- /dev/null +++ b/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireUpperCaseHeredocTerminator.pm @@ -0,0 +1,103 @@ +package Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $HEREDOC_RX => qr{ \A << ~? \s* (["']?) [[:upper:]_] [[:upper:]\d_]* \1 \z }xms; +Readonly::Scalar my $DESC => q{Heredoc terminator not alphanumeric and upper-case}; +Readonly::Scalar my $EXPL => [ 64 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core pbp cosmetic) } +sub applies_to { return 'PPI::Token::HereDoc' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + if ( $elem !~ $HEREDOC_RX ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator - Write C< <<'THE_END'; > instead of C< <<'theEnd'; >. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +For legibility, HEREDOC terminators should be all UPPER CASE letters +(and numbers), without any whitespace. Conway also recommends using a +standard prefix like "END_" but this policy doesn't enforce that. + + print <<'the End'; #not ok + Hello World + the End + + print <<'THE_END'; #ok + Hello World + THE_END + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Variables/ProhibitAugmentedAssignmentInDeclaration.pm b/lib/Perl/Critic/Policy/Variables/ProhibitAugmentedAssignmentInDeclaration.pm new file mode 100644 index 0000000..61253a8 --- /dev/null +++ b/lib/Perl/Critic/Policy/Variables/ProhibitAugmentedAssignmentInDeclaration.pm @@ -0,0 +1,113 @@ +package Perl::Critic::Policy::Variables::ProhibitAugmentedAssignmentInDeclaration; + +use 5.006001; +use strict; +use warnings; +use List::MoreUtils qw{ firstval }; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :data_conversion }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Augmented assignment operator '%s' used in declaration}; +Readonly::Scalar my $EXPL => q{Use simple assignment when initializing variables}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core bugs ) } +sub applies_to { return 'PPI::Statement::Variable' } + +#----------------------------------------------------------------------------- + +my %augmented_assignments = hashify( qw( **= += -= .= *= /= %= x= &= |= ^= <<= >>= &&= ||= //= ) ); + +sub violates { + my ( $self, $elem, undef ) = @_; + + # The assignment operator associated with a PPI::Statement::Variable + # element is assumed to be the first immediate child of that element. + # Other operators in the statement, e.g. the ',' in "my ( $a, $b ) = ();", + # as assumed to never be immediate children. + + my $found = firstval { $_->isa('PPI::Token::Operator') } $elem->children(); + if ( $found ) { + my $op = $found->content(); + if ( exists $augmented_assignments{ $op } ) { + return $self->violation( sprintf( $DESC, $op ), $EXPL, $found ); + } + } + + return; +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords O'Regan + +=head1 NAME + +Perl::Critic::Policy::Variables::ProhibitAugmentedAssignmentInDeclaration - Do not write C< my $foo .= 'bar'; >. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Variable declarations that also do initialization with '=' are common. +Perl also allows you to use operators like '.=', '+=', etc., but it +it is more clear to not do so. + + my $foo .= 'bar'; # same as my $foo = 'bar'; + our $foo *= 2; # same as our $foo = 0; + my ( $foo, $bar ) += ( 1, 2 ); # same as my ( $foo, $bar ) = ( undef, 2 ); + local $Carp::CarpLevel += 1; # same as local $Carp::CarpLevel = 1; + state $foo += 2; # adds 2 every time it's encountered + +Such constructs are usually the result of botched cut-and-paste, and often are +bugs. Some produce warnings. + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Mike O'Regan + + +=head1 COPYRIGHT + +Copyright (c) 2011 Mike O'Regan. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Variables/ProhibitConditionalDeclarations.pm b/lib/Perl/Critic/Policy/Variables/ProhibitConditionalDeclarations.pm new file mode 100644 index 0000000..cadfaa8 --- /dev/null +++ b/lib/Perl/Critic/Policy/Variables/ProhibitConditionalDeclarations.pm @@ -0,0 +1,110 @@ +package Perl::Critic::Policy::Variables::ProhibitConditionalDeclarations; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification :data_conversion }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Variable declared in conditional statement}; +Readonly::Scalar my $EXPL => q{Declare variables outside of the condition}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw( core bugs ) } +sub applies_to { return 'PPI::Statement::Variable' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + return if $elem->type() eq 'local'; + + if ( $elem->find(\&_is_conditional) ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +my @conditionals = qw( if while foreach for until unless ); +my %conditionals = hashify( @conditionals ); + +sub _is_conditional { + my (undef, $elem) = @_; + + return if !$conditionals{$elem}; + return if ! $elem->isa('PPI::Token::Word'); + return if is_hash_key($elem); + return if is_method_call($elem); + + return 1; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Variables::ProhibitConditionalDeclarations - Do not write C< my $foo = $bar if $baz; >. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Declaring a variable with a postfix conditional is really confusing. +If the conditional is false, its not clear if the variable will be +false, undefined, undeclared, or what. It's much more straightforward +to make variable declarations separately. + + my $foo = $baz if $bar; #not ok + my $foo = $baz unless $bar; #not ok + our $foo = $baz for @list; #not ok + local $foo = $baz foreach @list; #not ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey R. Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Variables/ProhibitEvilVariables.pm b/lib/Perl/Critic/Policy/Variables/ProhibitEvilVariables.pm new file mode 100644 index 0000000..dc98250 --- /dev/null +++ b/lib/Perl/Critic/Policy/Variables/ProhibitEvilVariables.pm @@ -0,0 +1,449 @@ +package Perl::Critic::Policy::Variables::ProhibitEvilVariables; + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); +use Readonly; + +use Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue + qw{ throw_policy_value }; +use Perl::Critic::Utils qw{ + :characters :severities :data_conversion +}; +use Perl::Critic::Utils::DataConversion qw{ dor }; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => q{Find an alternative variable}; + +Readonly::Hash my %SUBSCRIPTED_TYPE => hashify(qw{@ %}); + +Readonly::Scalar my $VARIABLE_NAME_REGEX => qr< [\$\@%] \S+ >xms; +Readonly::Scalar my $REGULAR_EXPRESSION_REGEX => + qr< [/] ( [^/]+ ) [/] >xms; +Readonly::Array my @DESCRIPTION_REGEXES => + qr< [{] ( [^}]+ ) [}] >xms, + qr{ < ( [^>]+ ) > }xms, + qr{ [[] ( [^]]+ ) []] }xms, + qr{ [(] ( [^)]+ ) [)] }xms, +; +Readonly::Scalar my $DESCRIPTION_REGEX => + qr< @{[join '|', @DESCRIPTION_REGEXES]} >xms; + +# It's kind of unfortunate that I had to put capturing parentheses in the +# component regexes above, because they're not visible here and so make +# figuring out the positions of captures hard. Too bad we can't make the +# minimum perl version 5.10. :] +Readonly::Scalar my $VARIABLES_REGEX => + qr< + \A + \s* + (?: + ( $VARIABLE_NAME_REGEX ) + | $REGULAR_EXPRESSION_REGEX + ) + (?: \s* $DESCRIPTION_REGEX )? + \s* + >xms; + +Readonly::Scalar my $VARIABLES_FILE_LINE_REGEX => + qr< + \A + \s* + (?: + ( $VARIABLE_NAME_REGEX ) + | $REGULAR_EXPRESSION_REGEX + ) + \s* + ( \S (?: .* \S )? )? + \s* + \z + >xms; + +# Indexes in the arrays of regexes for the "variables" option. +Readonly::Scalar my $INDEX_REGEX => 0; +Readonly::Scalar my $INDEX_DESCRIPTION => 1; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'variables', + description => 'The names of or patterns for variables to forbid.', + default_string => $EMPTY, + parser => \&_parse_variables, + }, + { + name => 'variables_file', + description => 'A file containing names of or patterns for variables to forbid.', + default_string => $EMPTY, + parser => \&_parse_variables_file, + }, + ); +} + +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw( core bugs ) } +sub applies_to { return qw{PPI::Token::Symbol} } + +#----------------------------------------------------------------------------- + +sub _parse_variables { + my ($self, $parameter, $config_string) = @_; + + return if not $config_string; + return if $config_string =~ m< \A \s* \z >xms; + + my $variable_specifications = $config_string; + + while ( my ($variable, $regex_string, @descrs) = + $variable_specifications =~ m< $VARIABLES_REGEX >xms) { + + substr $variable_specifications, 0, $LAST_MATCH_END[0], $EMPTY; + my $description = dor(@descrs); + + $self->_handle_variable_specification( + variable => $variable, + regex_string => $regex_string, + description => $description, + option_name => 'variables', + option_value => $config_string, + ); + } + + if ($variable_specifications) { + throw_policy_value + policy => $self->get_short_name(), + option_name => 'variables', + option_value => $config_string, + message_suffix => + qq{contains unparseable data: "$variable_specifications"}; + } + + return; +} + +sub _parse_variables_file { + my ($self, $parameter, $config_string) = @_; + + return if not $config_string; + return if $config_string =~ m< \A \s* \z >xms; + + open my $handle, '<', $config_string + or throw_policy_value + policy => $self->get_short_name(), + option_name => 'variables_file', + option_value => $config_string, + message_suffix => + qq; + while ( my $line = <$handle> ) { + $self->_handle_variable_specification_on_line($line, $config_string); + } + close $handle or warn qq; + + return; +} + +sub _handle_variable_specification_on_line { + my ($self, $line, $config_string) = @_; + + $line =~ s< [#] .* \z ><>xms; + $line =~ s< \s+ \z ><>xms; + $line =~ s< \A \s+ ><>xms; + + return if not $line; + + if ( my ($variable, $regex_string, $description) = + $line =~ m< $VARIABLES_FILE_LINE_REGEX >xms) { + + $self->_handle_variable_specification( + variable => $variable, + regex_string => $regex_string, + description => $description, + option_name => 'variables_file', + option_value => $config_string, + ); + } + else { + throw_policy_value + policy => $self->get_short_name(), + option_name => 'variables_file', + option_value => $config_string, + message_suffix => + qq{contains unparseable data: "$line"}; + } + + return; +} + +sub _handle_variable_specification { + my ($self, %arguments) = @_; + + my $description = $arguments{description} || $EMPTY; + + if ( my $regex_string = $arguments{regex_string} ) { + # These are variable name patterns (e.g. /acme/) + my $actual_regex; + + eval { $actual_regex = qr/$regex_string/sm; ## no critic (ExtendedFormatting) + 1 } + or throw_policy_value + policy => $self->get_short_name(), + option_name => $arguments{option_name}, + option_value => $arguments{option_value}, + message_suffix => + qq{contains an invalid regular expression: "$regex_string"}; + + # Can't use a hash due to stringification, so this is an AoA. + push + @{ $self->{_evil_variables_regexes} ||= [] }, + [ $actual_regex, $description ]; + } + else { + # These are literal variable names (e.g. $[) + $self->{_evil_variables} ||= {}; + my $name = $arguments{variable}; + $self->{_evil_variables}{$name} = $description; + } + + return; +} + +#----------------------------------------------------------------------------- + +sub initialize_if_enabled { + my ($self, $config) = @_; + + # Disable if no variables are specified; there's no point in running if + # there aren't any. + return + exists $self->{_evil_variables} + || exists $self->{_evil_variables_regexes}; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + return if not $elem; + + my @names = $self->_compute_symbol_names( $elem ) + or return; + + my $evil_variables = $self->{_evil_variables}; + my $evil_variables_regexes = $self->{_evil_variables_regexes}; + + foreach my $variable (@names) { + exists $evil_variables->{$variable} + and return $self->_make_violation( + $variable, + $evil_variables->{$variable}, + $elem, + ); + } + + foreach my $variable (@names) { + foreach my $regex ( @{$evil_variables_regexes} ) { + $variable =~ $regex->[$INDEX_REGEX] + and return $self->_make_violation( + $variable, + $regex->[$INDEX_DESCRIPTION], + $elem, + ); + } + } + + return; # ok! +} + +#----------------------------------------------------------------------------- + +# We are unconditionally interested in the names of the symbol itself. If the +# symbol is subscripted, we are interested in the subscripted form as well. + +sub _compute_symbol_names { + my ($self, $elem) = @_; + + my @names; + + my $name = $elem->symbol(); + push @names, $name; + + if ($SUBSCRIPTED_TYPE{$elem->symbol_type()}) { + $name = $elem->content(); + my $next = $elem->snext_sibling(); + my @subscr; + while ($next and $next->isa('PPI::Structure::Subscript')) { + push @subscr, $next->content(); + $next = $next->snext_sibling(); + } + if (@subscr) { + push @names, join $EMPTY, $name, @subscr; + } + } + + return @names; +} + +#----------------------------------------------------------------------------- + +sub _make_violation { + my ($self, $variable, $description, $elem) = @_; + return $self->violation( + $description || qq, + $EXPL, + $elem, + ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords subscripted + +=head1 NAME + +Perl::Critic::Policy::Variables::ProhibitEvilVariables - Ban variables that aren't blessed by your shop. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Use this policy if you wish to prohibit the use of specific variables. These +may be global variables warned against in C, or just variables whose +names you do not like. + + +=head1 CONFIGURATION + +The set of prohibited variables is configurable via the C and +C options. + +The value of C should be a string of space-delimited, fully +qualified variable names and/or regular expressions. An example of +prohibiting two specific variables in a F<.perlcriticrc> file: + + [Variables::ProhibitEvilVariables] + variables = $[ $^S $SIG{__DIE__} + +If you prohibit an array or hash (e.g. C<@INC>), use of elements of the array +or hash will be prohibited as well. If you specify a subscripted variable (e.g. +C<$SIG{__DIE__}>), only the literal subscript specified will be detected. The +above <.perlcritic> file, for example, will cause C to detect +C<$SIG{__DIE__} = \&foo>, but not + + my $foo = '__DIE__'; + $SIG{$foo} = \&foo; + +Regular expressions are identified by values beginning and ending with +slashes. Any variable with a name that matches C will be +forbidden. For example: + + [Variables::ProhibitEvilVariables] + variables = /acme/ + +would cause all variables that match C to be forbidden. If +you want a case-blind check, you can use (?i: ... ). For example + + [Variables::ProhibitEvilVariables] + variables = /(?i:acme)/ + +forbids variables that match C. + +In addition, you can override the default message ("Prohibited variable +"I" used") with your own, in order to give suggestions for +alternative action. To do so, put your message in curly braces after +the variable name or regular expression. Like this: + + [Variables::ProhibitEvilVariables] + variables = $[ {Found use of $[. Program to base index 0 instead} + +If your message contains curly braces, you can enclose it in parentheses, +angle brackets, or square brackets instead. + +Similarly, the C option gives the name of a file +containing specifications for prohibited variables. Only one variable +specification is allowed per line and comments start with an octothorp +and run to end of line; no curly braces are necessary for delimiting +messages: + + $[ # Prohibit the "$[" variable and use the default message. + + # Prohibit the "$^S" variable and give a replacement message. + $^S Having to think about $^S in exception handlers is just wrong + + # Use a regular expression. + /acme/ No coyotes allowed. + +By default, there are no prohibited variables, although I can think of a +few that should be. See C for a few suggestions. + + +=head1 RESTRICTIONS + +Variables of the form C<${^foo}> are not recognized by PPI as of version +1.206. When PPI recognizes these, this policy will Just Work for them too. + +Only direct references to prohibited variables and literal subscripts will be +recognized. For example, if you prohibit $[, the first line in + + my $foo = \$[; + $$foo = 1; + +will be flagged as a violation, but not the second, even though the second, in +fact, assigns to $[. Similarly, if you prohibit $SIG{__DIE__}, this policy +will not recognize + + my $foo = '__DIE__'; + $SIG{$foo} = sub {warn 'I cannot die!'}; + +as an assignment to $SIG{__DIE__}. + + +=head1 NOTES + +This policy leans heavily on +L +by Jeffrey Ryan Thalhammer. + + +=head1 AUTHOR + +Thomas R. Wyant, III F + + +=head1 COPYRIGHT + +Copyright (c) 2009-2011 Thomas R. Wyant, III + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Variables/ProhibitLocalVars.pm b/lib/Perl/Critic/Policy/Variables/ProhibitLocalVars.pm new file mode 100644 index 0000000..8d16089 --- /dev/null +++ b/lib/Perl/Critic/Policy/Variables/ProhibitLocalVars.pm @@ -0,0 +1,126 @@ +package Perl::Critic::Policy::Variables::ProhibitLocalVars; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $PACKAGE_RX => qr/::/xms; +Readonly::Scalar my $DESC => q{Variable declared as "local"}; +Readonly::Scalar my $EXPL => [ 77, 78, 79 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core pbp maintenance) } +sub applies_to { return 'PPI::Statement::Variable' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + if ( $elem->type() eq 'local' && !_all_global_vars($elem) ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +#----------------------------------------------------------------------------- + +sub _all_global_vars { + + my $elem = shift; + for my $variable_name ( $elem->variables() ) { + next if $variable_name =~ $PACKAGE_RX; + # special exception for Test::More + next if $variable_name eq '$TODO'; ## no critic (InterpolationOfMetachars) + return if ! is_perl_global( $variable_name ); + } + return 1; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Variables::ProhibitLocalVars - Use C instead of C, except when you have to. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Since Perl 5, there are very few reasons to declare C +variables. The most common exceptions are Perl's magical global +variables. If you do need to modify one of those global variables, +you should localize it first. You should also use the +L module to give those variables more meaningful +names. + + local $foo; #not ok + my $foo; #ok + + use English qw(-no_match_vars); + local $INPUT_RECORD_SEPARATOR #ok + local $RS #ok + local $/; #not ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 NOTES + +If an external module uses package variables as its interface, then +using C is actually a pretty sensible thing to do. So +Perl::Critic will not complain if you C-ize variables with a +fully qualified name such as C<$Some::Package::foo>. However, if +you're in a position to dictate the module's interface, I strongly +suggest using accessor methods instead. + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Variables/ProhibitMatchVars.pm b/lib/Perl/Critic/Policy/Variables/ProhibitMatchVars.pm new file mode 100644 index 0000000..c67a4e5 --- /dev/null +++ b/lib/Perl/Critic/Policy/Variables/ProhibitMatchVars.pm @@ -0,0 +1,121 @@ +package Perl::Critic::Policy::Variables::ProhibitMatchVars; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :data_conversion }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Match variable used}; +Readonly::Scalar my $EXPL => [ 82 ]; + +Readonly::Array my @FORBIDDEN => qw( $` $& $' $MATCH $PREMATCH $POSTMATCH ); +Readonly::Hash my %FORBIDDEN => hashify( @FORBIDDEN ); + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core performance pbp ) } +sub applies_to { return qw( PPI::Token::Symbol + PPI::Statement::Include ) } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + if (_is_use_english($elem) || _is_forbidden_var($elem)) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +#----------------------------------------------------------------------------- + +sub _is_use_english { + my $elem = shift; + $elem->isa('PPI::Statement::Include') || return; + $elem->type() eq 'use' || return; + $elem->module() eq 'English' || return; + + # Bare, lacking -no_match_vars. Now handled by + # Modules::RequireNoMatchVarsWithUseEnglish. + return 0 if ($elem =~ m/\A use \s+ English \s* ;\z/xms); + + return 1 if ($elem =~ m/\$(?:PRE|POST|)MATCH/xms); + return; # either "-no_match_vars" or a specific list +} + +sub _is_forbidden_var { + my $elem = shift; + $elem->isa('PPI::Token::Symbol') || return; + return exists $FORBIDDEN{$elem}; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Variables::ProhibitMatchVars - Avoid C<$`>, C<$&>, C<$'> and their English equivalents. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Using the "match variables" C<$`>, C<$&>, and/or C<$'> can +significantly degrade the performance of a program. This policy +forbids using them or their English equivalents. See B or PBP page 82 for more information. + +It used to forbid plain C because it ends up causing the +performance side-effects of the match variables. However, the message +emitted for that situation was not at all clear and there is now +L, +which addresses this situation directly. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Variables/ProhibitPackageVars.pm b/lib/Perl/Critic/Policy/Variables/ProhibitPackageVars.pm new file mode 100644 index 0000000..61e9388 --- /dev/null +++ b/lib/Perl/Critic/Policy/Variables/ProhibitPackageVars.pm @@ -0,0 +1,223 @@ +package Perl::Critic::Policy::Variables::ProhibitPackageVars; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use List::MoreUtils qw(all); + +use Perl::Critic::Utils qw{ + :booleans :characters :severities :data_conversion +}; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Package variable declared or used}; +Readonly::Scalar my $EXPL => [ 73, 75 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'packages', + description => 'The base set of packages to allow variables for.', + default_string => 'Data::Dumper File::Find FindBin Log::Log4perl', + behavior => 'string list', + }, + { + name => 'add_packages', + description => 'The set of packages to allow variables for, in addition to those given in "packages".', + default_string => $EMPTY, + behavior => 'string list', + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw(core pbp maintenance) } +sub applies_to { return qw(PPI::Token::Symbol + PPI::Statement::Variable + PPI::Statement::Include) } + +#----------------------------------------------------------------------------- + +sub initialize_if_enabled { + my ($self, $config) = @_; + + $self->{_all_packages} = { + hashify keys %{ $self->{_packages} }, keys %{ $self->{_add_packages} } + }; + + return $TRUE; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + if ( $self->_is_package_var($elem) || + _is_our_var($elem) || + _is_vars_pragma($elem) ) + { + + return $self->violation( $DESC, $EXPL, $elem ); + } + + return; # ok +} + +#----------------------------------------------------------------------------- + +sub _is_package_var { + my $self = shift; + my $elem = shift; + return if !$elem->isa('PPI::Token::Symbol'); + my ($package, $name) = $elem =~ m{ \A [@\$%] (.*) :: (\w+) \z }xms; + return if not defined $package; + return if _all_upcase( $name ); + return if $self->{_all_packages}->{$package}; + return 1; +} + +#----------------------------------------------------------------------------- + +sub _is_our_var { + my $elem = shift; + return if not $elem->isa('PPI::Statement::Variable'); + return if $elem->type() ne 'our'; + return if _all_upcase( $elem->variables() ); + return 1; +} + +#----------------------------------------------------------------------------- + +sub _is_vars_pragma { + my $elem = shift; + return if !$elem->isa('PPI::Statement::Include'); + return if $elem->pragma() ne 'vars'; + + # Older Perls don't support the C keyword, so we try to let + # people use the C pragma instead, but only if all the + # variable names are uppercase. Since there are lots of ways to + # pass arguments to pragmas (e.g. "$foo" or qw($foo) ) we just use + # a regex to match things that look like variables names. + + my @varnames = $elem =~ m{ [@\$%&] (\w+) }gxms; + + return if !@varnames; # no valid variables specified + return if _all_upcase( @varnames ); + return 1; +} + +sub _all_upcase { ##no critic(ArgUnpacking) + return all { $_ eq uc $_ } @_; ## no critic ( BuiltinFunctions::ProhibitUselessTopic ) +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Variables::ProhibitPackageVars - Eliminate globals declared with C or C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Conway suggests avoiding package variables completely, because they +expose your internals to other packages. Never use a package variable +when a lexical variable will suffice. If your package needs to keep +some dynamic state, consider using an object or closures to keep the +state private. + +This policy assumes that you're using C so that naked +variable declarations are not package variables by default. Thus, it +complains you declare a variable with C or C, or if you +make reference to variable with a fully-qualified package name. + + $Some::Package::foo = 1; # not ok + our $foo = 1; # not ok + use vars '$foo'; # not ok + $foo = 1; # not allowed by 'strict' + local $foo = 1; # bad taste, but technically ok. + use vars '$FOO'; # ok, because it's ALL CAPS + my $foo = 1; # ok + +In practice though, its not really practical to prohibit all package +variables. Common variables like C<$VERSION> and C<@EXPORT> need to +be global, as do any variables that you want to Export. To work +around this, the Policy overlooks any variables that are in ALL_CAPS. +This forces you to put all your exported variables in ALL_CAPS too, +which seems to be the usual practice anyway. + + +=head1 CONFIGURATION + +There is room for exceptions. Some modules, like the core File::Find +module, use package variables as their only interface, and others like +Data::Dumper use package variables as their most common interface. +These module can be specified from your F<.perlcriticrc> file, and the +policy will ignore them. + + [Variables::ProhibitPackageVars] + packages = Data::Dumper File::Find FindBin Log::Log4perl + +This is the default setting. Using C will override these +defaults. + +You can also add packages to the defaults like so: + + [Variables::ProhibitPackageVars] + add_packages = My::Package + +You can add package C
to the list of packages, but that will +only OK variables explicitly in the C
package. + + +=head1 SEE ALSO + +L + +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Variables/ProhibitPerl4PackageNames.pm b/lib/Perl/Critic/Policy/Variables/ProhibitPerl4PackageNames.pm new file mode 100644 index 0000000..03f7a31 --- /dev/null +++ b/lib/Perl/Critic/Policy/Variables/ProhibitPerl4PackageNames.pm @@ -0,0 +1,120 @@ +package Perl::Critic::Policy::Variables::ProhibitPerl4PackageNames; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :characters :severities :classification }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => + q{Use double colon (::) to separate package name components instead of single quotes (')}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw(core maintenance certrec ) } +sub applies_to { return qw( PPI::Token::Word PPI::Token::Symbol ) } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + my $content = $elem->content(); + + if ( (index $content, $QUOTE) < 0 ) { + return; + } + + if ( $content =~ m< \A [\$@%&*] ' \z >xms ) { + # We've found $POSTMATCH. + return; + } + + if ( $elem->isa('PPI::Token::Word') && is_hash_key($elem) ) { + return; + } + + return + $self->violation( + qq{"$content" uses the obsolete single quote package separator.}, + $EXPL, + $elem + ); +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords perlmod + +=head1 NAME + +Perl::Critic::Policy::Variables::ProhibitPerl4PackageNames - Use double colon (::) to separate package name components instead of single quotes ('). + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Perl 5 kept single quotes (C<'>) as package component separators in +order to remain backward compatible with prior Cs, but advocated +using double colon (C<::>) instead. In the more than a decade since +Perl 5, double colons have been overwhelmingly adopted and most people +are not even aware that the single quote can be used in this manner. +So, unless you're trying to obfuscate your code, don't use them. + + package Foo::Bar::Baz; #ok + package Foo'Bar'Baz; #not ok + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Elliot Shank C<< >> + + +=head1 COPYRIGHT + +Copyright (c) 2007-2014 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Variables/ProhibitPunctuationVars.pm b/lib/Perl/Critic/Policy/Variables/ProhibitPunctuationVars.pm new file mode 100644 index 0000000..f136daf --- /dev/null +++ b/lib/Perl/Critic/Policy/Variables/ProhibitPunctuationVars.pm @@ -0,0 +1,478 @@ +package Perl::Critic::Policy::Variables::ProhibitPunctuationVars; + +use 5.006001; +use strict; +use warnings; +use Readonly; +use English qw< -no_match_vars >; + +use PPI::Token::Magic; + +use Perl::Critic::Utils qw< + :characters :severities :data_conversion :booleans +>; + +use PPIx::Regexp; +use PPIx::Regexp::Util 0.068 qw< + is_ppi_regexp_element +>; + +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q; +Readonly::Scalar my $EXPL => [79]; + +#----------------------------------------------------------------------------- + +# There is no English.pm equivalent for $]. +sub supported_parameters { + return ( + { + name => 'allow', + description => 'The additional variables to allow.', + default_string => $EMPTY, + behavior => 'string list', + list_always_present_values => + [ qw< $_ @_ $1 $2 $3 $4 $5 $6 $7 $8 $9 _ $] > ], + }, + { + name => 'string_mode', + description => + 'Controls checking interpolated strings for punctuation variables.', + default_string => 'thorough', + behavior => 'enumeration', + enumeration_values => [ qw< simple disable thorough > ], + enumeration_allow_multiple_values => 0, + }, + ); +} + +sub default_severity { return $SEVERITY_LOW } +sub default_themes { return qw< core pbp cosmetic > } + +sub applies_to { + return qw< + PPI::Token::Magic + PPI::Token::Quote::Double + PPI::Token::Quote::Interpolate + PPI::Token::QuoteLike::Command + PPI::Token::QuoteLike::Backtick + PPI::Token::QuoteLike::Regexp + PPI::Token::QuoteLike::Readline + PPI::Token::HereDoc + >; +} + +#----------------------------------------------------------------------------- + + +# This list matches the initialization of %PPI::Token::Magic::magic. +## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars) +Readonly::Array my @MAGIC_VARIABLES => + qw{ + $1 $2 $3 $4 $5 $6 $7 $8 $9 + $_ $& $` $' $+ @+ %+ $* $. $/ $| + $\\ $" $; $% $= $- @- %- $) + $~ $^ $: $? $! %! $@ $$ $< $> + $( $0 $[ $] @_ @* + + $^L $^A $^E $^C $^D $^F $^H + $^I $^M $^N $^O $^P $^R $^S + $^T $^V $^W $^X %^H + + $::| + }, + q<$}>, + q<$,>, + q<$#>, + q<$#+>, + q<$#->; +## use critic + +# The main regular expression for detecting magic variables. +Readonly::Scalar my $MAGIC_REGEX => _create_magic_detector(); + +# The magic vars in this array will be ignored in interpolated strings +# in simple mode. See CONFIGURATION in the pod. +Readonly::Array my @IGNORE_FOR_INTERPOLATION => + ( q{$'}, q{$$}, q{$#}, q{$:}, ); ## no critic ( RequireInterpolationOfMetachars, ProhibitQuotedWordLists ) + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + + if ( $elem->isa('PPI::Token::Magic') ) { + return _violates_magic( $self, $elem ); + } + elsif ( $elem->isa('PPI::Token::HereDoc') ) { + return _violates_heredoc( $self, $elem ); + } + elsif ( is_ppi_regexp_element( $elem ) ) { # GitHub #843 + return _violates_regexp( $self, $elem, $doc ); + } + + #the remaining applies_to() classes are all interpolated strings + return _violates_string( $self, $elem ); +} + +#----------------------------------------------------------------------------- + +# Helper functions for the four types of violations: code, quotes, heredoc, +# regexp + +sub _violates_magic { + my ( $self, $elem, undef ) = @_; + + if ( !exists $self->{_allow}->{$elem} ) { + return $self->_make_violation( $DESC, $EXPL, $elem ); + } + + return; # no violation +} + +sub _violates_string { + my ( $self, $elem, undef ) = @_; + + # RT #55604: Variables::ProhibitPunctuationVars gives false-positive on + # qr// regexp's ending in '$' + # We want to analyze the content of the string in the dictionary sense of + # the word 'content'. We can not simply use the PPI content() method to + # get this, because content() includes the delimiters. + my $string; + if ( $elem->can( 'string' ) ) { + # If we have a string() method (currently only the PPI::Token::Quote + # classes) use it to extract the content of the string. + $string = $elem->string(); + } else { + # Lacking string(), we fake it under the assumption that the content + # of our element represents one of the 'normal' Perl strings, with a + # single-character delimiter, possibly preceded by an operator like + # 'qx' or 'qr'. If there is a leading operator, spaces may appear + # after it. + $string = $elem->content(); + $string =~ s/ \A \w* \s* . //smx; + chop $string; + } + + my %matches = _strings_helper( $self, $string ); + if (%matches) { + my $DESC = qq<$DESC in interpolated string>; + return $self->_make_violation( $DESC, $EXPL, $elem, \%matches ); + } + + return; # no violation +} + +sub _violates_heredoc { + my ( $self, $elem, undef ) = @_; + + if ( $elem->{_mode} eq 'interpolate' or $elem->{_mode} eq 'command' ) { + my $heredoc_string = join "\n", $elem->heredoc(); + my %matches = _strings_helper( $self, $heredoc_string ); + if (%matches) { + my $DESC = qq<$DESC in interpolated here-document>; + return $self->_make_violation( $DESC, $EXPL, $elem, \%matches ); + } + } + + return; # no violation +} + +sub _violates_regexp { # GitHub #843 (https://github.com/Perl-Critic/Perl-Critic/issues/843) + my ( $self, $elem, $doc ) = @_; + + return if ( $self->{_string_mode} eq 'disable' ); + + my $pre = $doc->ppix_regexp_from_element( $elem ) + or return; + $pre->failures() + and return; + + my @raw_matches; + foreach my $code ( @{ $pre->find( 'PPIx::Regexp::Token::Code' ) || [] } ) { + my $code_doc = $code->ppi() + or next; + push @raw_matches, map { $_->symbol() } @{ + $code_doc->find( 'PPI::Token::Magic' ) || [] }; + } + + my %matches = hashify( @raw_matches ); + delete @matches{ keys %{ $self->{_allow} } }; + if ( $self->{_string_mode} eq 'simple' ) { + delete @matches{@IGNORE_FOR_INTERPOLATION}; + } + + if ( keys %matches ) { + my $DESC = qq<$DESC in interpolated Regexp>; + return $self->_make_violation( $DESC, $EXPL, $elem, \%matches ); + } + + return; +} + +#----------------------------------------------------------------------------- + +# Helper functions specific to interpolated strings + +sub _strings_helper { + my ( $self, $target_string, undef ) = @_; + + return if ( $self->{_string_mode} eq 'disable' ); + return _strings_thorough( $self, $target_string ) + if $self->{_string_mode} eq 'thorough'; + + # we are in string_mode = simple + + my @raw_matches = map { _unbracket_variable_name( $_ ) } + $target_string =~ m/$MAGIC_REGEX/goxms; + return if not @raw_matches; + + my %matches = hashify(@raw_matches); + + delete @matches{ keys %{ $self->{_allow} } }; + delete @matches{@IGNORE_FOR_INTERPOLATION}; + + return %matches; +} + +sub _strings_thorough { + my ( $self, $target_string, undef ) = @_; + my %matches; + + MATCH: + while ( my ($match) = $target_string =~ m/$MAGIC_REGEX/gcxms ) { + my $nextchar = substr $target_string, $LAST_MATCH_END[0], 1; + my $vname = _unbracket_variable_name( $match ); + my $c = $vname . $nextchar; + + # These tests closely parallel those in PPI::Token::Magic, + # from which the regular expressions were taken. + # A degree of simplicity is sacrificed to maintain the parallel. + # $c is so named by analogy to that module. + + # possibly *not* a magic variable + if ($c =~ m/ ^ \$ .* [ \w : \$ { ] $ /xms) { + ## no critic (RequireInterpolationOfMetachars) + + if ( + $c =~ m/ ^(\$(?:\_[\w:]|::)) /xms + or $c =~ m/ ^\$\'[\w] /xms ) + { + next MATCH + if $c !~ m/ ^\$\'\d$ /xms; + # It not $' followed by a digit. + # So it's magic var with something immediately after. + } + + next MATCH + if $c =~ m/ ^\$\$\w /xms; # It's a scalar dereference + next MATCH + if $c eq '$#$' + or $c eq '$#{'; # It's an index dereferencing cast + next MATCH + if $c =~ m/ ^(\$\#)\w /xms + ; # It's an array index thingy, e.g. $#array_name + + # PPI's checks for long escaped vars like $^WIDE_SYSTEM_CALLS + # appear to be erroneous, and are omitted here. + # if ( $c =~ m/^\$\^\w{2}$/xms ) { + # } + + next MATCH if $c =~ m/ ^ \$ \# [{] /xms; # It's a $#{...} cast + } + + # The additional checking that PPI::Token::Magic does at this point + # is not necessary here, in an interpolated string context. + + $matches{$vname} = 1; + } + + delete @matches{ keys %{ $self->{_allow} } }; + + return %matches; +} + +# RT #72910: A magic variable may appear in bracketed form; e.g. "$$" as +# "${$}". Generate the bracketed form from the unbracketed form, and +# return both. +sub _bracketed_form_of_variable_name { + my ( $name ) = @_; + length $name > 1 + or return ( $name ); + my $brktd = $name; + substr $brktd, 1, 0, '{'; + $brktd .= '}'; + return( $name, $brktd ); +} + +# RT #72910: Since we loaded both bracketed and unbracketed forms of the +# punctuation variables into our detecting regex, we need to detect and +# strip the brackets if they are present to recover the canonical name. +sub _unbracket_variable_name { + my ( $name ) = @_; + $name =~ m/ \A ( . ) [{] ( .+ ) [}] \z /smx + and return "$1$2"; + return $name; +} + +#----------------------------------------------------------------------------- + +sub _create_magic_detector { + my ($config) = @_; + + # Set up the regexp alternation for matching magic variables. + # We can't process $config->{_allow} here because of a quirk in the + # way Perl::Critic handles testing. + # + # The sort is needed so that, e.g., $^ doesn't mask out $^M + my $magic_alternation = + '(?:' + . ( + join + q<|>, + map { quotemeta } + reverse sort { length $a <=> length $b } + map { _bracketed_form_of_variable_name( $_ ) } + grep { q<%> ne substr $_, 0, 1 } + @MAGIC_VARIABLES + ) + . ')'; + + return qr< + (?: \A | [^\\] ) # beginning-of-string or any non-backslash + (?: \\{2} )* # zero or more double-backslashes + ( $magic_alternation ) # any magic punctuation variable + >xsm; +} + +sub _make_violation { + my ( $self, $desc, $expl, $elem, $vars ) = @_; + + my $vname = 'HASH' eq ref $vars ? + join ', ', sort keys %{ $vars } : + $elem->content(); + return $self->violation( sprintf( $desc, $vname ), $expl, $elem ); +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Variables::ProhibitPunctuationVars - Write C<$EVAL_ERROR> instead of C<$@>. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Perl's vocabulary of punctuation variables such as C<$!>, C<$.>, and +C<$^> are perhaps the leading cause of its reputation as inscrutable +line noise. The simple alternative is to use the L +module to give them clear names. + + $| = undef; #not ok + + use English qw(-no_match_vars); + local $OUTPUT_AUTOFLUSH = undef; #ok + +=head1 CONFIGURATION + +The scratch variables C<$_> and C<@_> are very common and are pretty +well understood, so they are exempt from this policy. The same goes +for the less-frequently-used default filehandle C<_> used by stat(). +All the regexp capture variables (C<$1>, C<$2>, ...) are exempt too. +C<$]> is exempt because there is no L equivalent and +L is based upon it. + +You can add more exceptions to your configuration. In your +perlcriticrc file, add a block like this: + + [Variables::ProhibitPunctuationVars] + allow = $@ $! + +The C property should be a whitespace-delimited list of +punctuation variables. + +Other configuration options control the parsing of interpolated +strings in the search for forbidden variables. They have no effect +on detecting punctuation variables outside of interpolated strings. + + [Variables::ProhibitPunctuationVars] + string_mode = thorough + +The option C controls whether and how interpolated +strings are searched for punctuation variables. Setting +C, the default, checks for special cases +that may look like punctuation variables but aren't, for example +C<$#foo>, an array index count; C<$$bar>, a scalar dereference; or +C<$::baz>, a global symbol. + +Setting C causes all interpolated strings to +be ignored entirely. + +Setting C uses a simple regular expression to +find matches. In this mode, the magic variables C<$$>, C<$'>, C<$#> +and C<$:> are ignored within interpolated strings due to the high +risk of false positives. Simple mode is retained from an earlier +draft of the interpolated- strings code. Its use is only recommended +as a workaround if bugs appear in thorough mode. + +The C option will go away when the parsing of +interpolated strings is implemented in PPI. See L below. + + +=head1 BUGS + +Punctuation variables that confuse PPI's document parsing may not be +detected correctly or at all, and may prevent detection of +subsequent ones. In particular, C<$"> is known to cause difficulties +in interpolated strings. + + +=head1 CAVEATS + +ProhibitPunctuationVars relies exclusively on PPI to find +punctuation variables in code, but does all the parsing itself for +interpolated strings. When, at some point, this functionality is +transferred to PPI, ProhibitPunctuationVars will cease doing the +interpolating and the C option will go away. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Variables/ProhibitReusedNames.pm b/lib/Perl/Critic/Policy/Variables/ProhibitReusedNames.pm new file mode 100644 index 0000000..ce62b5c --- /dev/null +++ b/lib/Perl/Critic/Policy/Variables/ProhibitReusedNames.pm @@ -0,0 +1,185 @@ +package Perl::Critic::Policy::Variables::ProhibitReusedNames; + +use 5.006001; +use strict; +use warnings; +use List::MoreUtils qw(part); +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification :data_conversion }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Reused variable name in lexical scope: }; +Readonly::Scalar my $EXPL => q{Invent unique variable names}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'allow', + description => 'The variables to not consider as duplicates.', + default_string => '$self $class', ## no critic (RequireInterpolationOfMetachars) + behavior => 'string list', + }, + ); +} + +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw( core bugs ) } +sub applies_to { return 'PPI::Statement::Variable' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + return if 'local' eq $elem->type; + + my $allow = $self->{_allow}; + my $names = [ grep { not $allow->{$_} } $elem->variables() ]; + # Assert: it is impossible for @$names to be empty in valid Perl syntax + # But if it IS empty, this code should still work but will be inefficient + + # Walk up the PDOM looking for declared variables in the same + # scope or outer scopes. Quit when we hit the root or when we find + # violations for all vars (the latter is a shortcut). + my $outer = $elem; + my @violations; + while (1) { + my $up = $outer->sprevious_sibling; + if (not $up) { + $up = $outer->parent; + last if !$up; # top of PDOM, we're done + } + $outer = $up; + + if ($outer->isa('PPI::Statement::Variable') && 'local' ne $outer->type) { + my %vars = map {$_ => undef} $outer->variables; + my $hits; + ($hits, $names) = part { exists $vars{$_} ? 0 : 1 } @{$names}; + if ($hits) { + push @violations, map { $self->violation( $DESC . $_, $EXPL, $elem ) } @{$hits}; + last if not $names; # found violations for ALL variables, we're done + } + } + } + return @violations; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Variables::ProhibitReusedNames - Do not reuse a variable name in a lexical scope + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +It's really hard on future maintenance programmers if you reuse a +variable name in a lexical scope. The programmer is at risk of +confusing which variable is which. And, worse, the programmer could +accidentally remove the inner declaration, thus silently changing the +meaning of the inner code to use the outer variable. + + my $x = 1; + for my $i (0 .. 10) { + my $x = $i+1; # not OK, "$x" reused + } + +With C in effect, Perl will warn you if you reuse a +variable name at the same scope level but not within nested scopes. Like so: + + % perl -we 'my $x; my $x' + "my" variable $x masks earlier declaration in same scope at -e line 1. + +This policy takes that warning to a stricter level. + + +=head1 CAVEATS + +=head2 Crossing subroutines + +This policy looks across subroutine boundaries. So, the following may +be a false positive for you: + + sub make_accessor { + my ($self, $fieldname) = @_; + return sub { + my ($self) = @_; # false positive, $self declared as reused + return $self->{$fieldname}; + } + } + +This is intentional, though, because it catches bugs like this: + + my $debug_mode = 0; + sub set_debug { + my $debug_mode = 1; # accidental redeclaration + } + +I've done this myself several times -- it's a strong habit to put that +"my" in front of variables at the start of subroutines. + + +=head2 Performance + +The current implementation walks the tree over and over. For a big +file, this can be a huge time sink. I'm considering rewriting to +search the document just once for variable declarations and cache the +tree walking on that single analysis. + + +=head1 CONFIGURATION + +This policy has a single option, C, which is a list of names to +never count as duplicates. It defaults to containing C<$self> and +C<$class>. You add to this by adding something like this to your +F<.perlcriticrc>: + + [Variables::ProhibitReusedNames] + allow = $self $class @blah + + +=head1 AUTHOR + +Chris Dolan + +This policy is inspired by +L. Java does not allow +you to reuse variable names declared in outer scopes, which I think is +a nice feature. + +=head1 COPYRIGHT + +Copyright (c) 2008-2013 Chris Dolan + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Variables/ProhibitUnusedVariables.pm b/lib/Perl/Critic/Policy/Variables/ProhibitUnusedVariables.pm new file mode 100644 index 0000000..3fe5873 --- /dev/null +++ b/lib/Perl/Critic/Policy/Variables/ProhibitUnusedVariables.pm @@ -0,0 +1,202 @@ +package Perl::Critic::Policy::Variables::ProhibitUnusedVariables; + +use 5.006001; +use strict; +use warnings; + +use Readonly; +use List::MoreUtils qw< any >; + +use PPI::Token::Symbol; +use PPIx::QuoteLike; + +use Perl::Critic::Utils qw< :characters :severities >; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $EXPL => + q; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw< core maintenance certrec > } +sub applies_to { return qw< PPI::Document > } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $document ) = @_; + + my %symbol_usage; + _get_symbol_usage( \%symbol_usage, $document ); + _get_regexp_symbol_usage( \%symbol_usage, $document ); + return if not %symbol_usage; + + my $declarations = $document->find('PPI::Statement::Variable'); + return if not $declarations; + + my @violations; + + DECLARATION: + foreach my $declaration ( @{$declarations} ) { + next DECLARATION if 'my' ne $declaration->type(); + + my @children = $declaration->schildren(); + next DECLARATION if any { $_->content() eq q<=> } @children; + + VARIABLE: + foreach my $variable ( $declaration->variables() ) { + my $count = $symbol_usage{ $variable }; + next VARIABLE if not $count; # BUG! + next VARIABLE if $count > 1; + + push + @violations, + $self->violation( + qq<"$variable" is declared but not used.>, + $EXPL, + $declaration, + ); + } + } + + return @violations; +} + +sub _get_symbol_usage { + my ( $symbol_usage, $document ) = @_; + + my $symbols = $document->find('PPI::Token::Symbol'); + return if not $symbols; + + foreach my $symbol ( @{$symbols} ) { + $symbol_usage->{ $symbol->symbol() }++; + } + + foreach my $class ( qw{ + PPI::Token::Quote::Double + PPI::Token::Quote::Interpolate + PPI::Token::QuoteLike::Backtick + PPI::Token::QuoteLike::Command + PPI::Token::QuoteLike::Readline + PPI::Token::HereDoc + } ) { + foreach my $double_quotish ( + @{ $document->find( $class ) || [] } + ) { + my $str = PPIx::QuoteLike->new( $double_quotish ) + or next; + foreach my $var ( $str->variables() ) { + $symbol_usage->{ $var }++; + } + } + } + + return; +} + +sub _get_regexp_symbol_usage { + my ( $symbol_usage, $document ) = @_; + + foreach my $class ( qw{ + PPI::Token::Regexp::Match + PPI::Token::Regexp::Substitute + PPI::Token::QuoteLike::Regexp + } ) { + + foreach my $regex ( @{ $document->find( $class ) || [] } ) { + + my $ppix = $document->ppix_regexp_from_element( $regex ) or next; + $ppix->failures() and next; + + foreach my $code ( @{ + $ppix->find( 'PPIx::Regexp::Token::Code' ) || [] } ) { + my $subdoc = $code->ppi() or next; + _get_symbol_usage( $symbol_usage, $subdoc ); + } + + } + + } + + return; +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Variables::ProhibitUnusedVariables - Don't ask for storage you don't need. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Unused variables clutter code and require the reader to do mental +bookkeeping to figure out if the variable is actually used or not. + +At present, this Policy is very limited in order to ensure that there +aren't any false positives. Hopefully, this will become more +sophisticated soon. + +Right now, this only looks for simply declared, uninitialized lexical +variables. + + my $x; # not ok, assuming no other appearances. + my @y = (); # ok, not handled yet. + our $z; # ok, global. + local $w; # ok, global. + +This module is very dumb: it does no scoping detection, i.e. if the +same variable name is used in two different locations, even if they +aren't the same variable, this Policy won't complain. + +Have to start somewhere. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Elliot Shank C<< >> + + +=head1 COPYRIGHT + +Copyright (c) 2008-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Variables/ProtectPrivateVars.pm b/lib/Perl/Critic/Policy/Variables/ProtectPrivateVars.pm new file mode 100644 index 0000000..1cd4708 --- /dev/null +++ b/lib/Perl/Critic/Policy/Variables/ProtectPrivateVars.pm @@ -0,0 +1,100 @@ +package Perl::Critic::Policy::Variables::ProtectPrivateVars; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Private variable used}; +Readonly::Scalar my $EXPL => q{Use published APIs}; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw(core maintenance certrule ) } +sub applies_to { return 'PPI::Token::Symbol' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + if ( $elem =~ m{ \w::_\w+ \z }xms ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Variables::ProtectPrivateVars - Prevent access to private vars in other packages. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +By convention Perl authors (like authors in many other languages) +indicate private methods and variables by inserting a leading +underscore before the identifier. This policy catches attempts to +access private variables from outside the package itself. + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 HISTORY + +This policy is inspired by a similar test in L + + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Variables/RequireInitializationForLocalVars.pm b/lib/Perl/Critic/Policy/Variables/RequireInitializationForLocalVars.pm new file mode 100644 index 0000000..3121880 --- /dev/null +++ b/lib/Perl/Critic/Policy/Variables/RequireInitializationForLocalVars.pm @@ -0,0 +1,112 @@ +package Perl::Critic::Policy::Variables::RequireInitializationForLocalVars; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{"local" variable not initialized}; +Readonly::Scalar my $EXPL => [ 78 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_MEDIUM } +sub default_themes { return qw(core pbp bugs certrec ) } +sub applies_to { return 'PPI::Statement::Variable' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + if ( $elem->type() eq 'local' && !_is_initialized($elem) ) { + return $self->violation( $DESC, $EXPL, $elem ); + } + return; #ok! +} + +#----------------------------------------------------------------------------- + +sub _is_initialized { + my $elem = shift; + my $wanted = sub { $_[1]->isa('PPI::Token::Operator') && $_[1] eq q{=} }; + return $elem->find( $wanted ) ? 1 : 0; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Variables::RequireInitializationForLocalVars - Write C instead of just C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Most people don't realize that a localized copy of a variable does not +retain its original value. Unless you initialize the variable when +you C-ize it, it defaults to C. If you want the +variable to retain its original value, just initialize it to itself. +If you really do want the localized copy to be undef, then make it +explicit. + + package Foo; + $Bar = '42'; + + package Baz; + + sub frobulate { + + local $Foo::Bar; #not ok, local $Foo::Bar is 'undef' + local $Foo::Bar = undef; #ok, local $Foo::Bar is obviously 'undef' + local $Foo::Bar = $Foo::Bar; #ok, local $Foo::Bar still equals '42' + + } + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Variables/RequireLexicalLoopIterators.pm b/lib/Perl/Critic/Policy/Variables/RequireLexicalLoopIterators.pm new file mode 100644 index 0000000..6c3b084 --- /dev/null +++ b/lib/Perl/Critic/Policy/Variables/RequireLexicalLoopIterators.pm @@ -0,0 +1,169 @@ +package Perl::Critic::Policy::Variables::RequireLexicalLoopIterators; + +use 5.006001; +use strict; +use warnings; +use Readonly; +use version (); + +use Perl::Critic::Utils qw{ :booleans :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Loop iterator is not lexical}; +Readonly::Scalar my $EXPL => [ 108 ]; + +Readonly::Scalar my $MINIMUM_PERL_VERSION => version->new( 5.004 ); + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGHEST } +sub default_themes { return qw(core pbp bugs certrec ) } +sub applies_to { return 'PPI::Statement::Compound' } + +#----------------------------------------------------------------------------- + +sub prepare_to_scan_document { + my ( $self, $document ) = @_; + # perl5004delta says that is when lexical iterators were introduced, + # so ... (RT 67760) + my $version = $document->highest_explicit_perl_version(); + return ! $version || $version >= $MINIMUM_PERL_VERSION; +} + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + # First child will be 'for' or 'foreach' keyword + return if $elem->type() ne 'foreach'; + + my $first_child = $elem->schild(0); + return if not $first_child; + my $start = $first_child->isa('PPI::Token::Label') ? 1 : 0; + + my $potential_scope = $elem->schild($start + 1); + return if not $potential_scope; + return if $potential_scope->isa('PPI::Structure::List'); + + return if $potential_scope eq 'my'; + + return $self->violation( $DESC, $EXPL, $elem ); +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords foreach perlsyn + +=head1 NAME + +Perl::Critic::Policy::Variables::RequireLexicalLoopIterators - Write C instead of C. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +This policy asks you to use C-style lexical loop iterator variables: + + foreach my $zed (...) { + ... + } + +Unless you use C, C/C loops use a global variable with +its value C to the block. In other words, + + foreach $zed (...) { + ... + } + +is more-or-less equivalent to + + { + local $zed + foreach $zed (...) { + ... + } + } + +This may not seem like a big deal until you see code like + + my $bicycle; + for $bicycle (@things_attached_to_the_bike_rack) { + if ( + $bicycle->is_red() + and $bicycle->has_baseball_card_in_spokes() + and $bicycle->has_bent_kickstand() + ) { + $bicycle->remove_lock(); + + last; + } + } + + if ( $bicycle and $bicycle->is_unlocked() ) { + ride_home($bicycle); + } + +which is not going to allow you to arrive in time for dinner with your +family because the C<$bicycle> outside the loop is not changed by the +loop. You may have unlocked your bicycle, but you can't remember which +one it was. + +Lexical loop variables were introduced in Perl 5.004. This policy does +not report violations on code which explicitly specifies an earlier +version of Perl (e.g. C). + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 SEE ALSO + +L<"Foreach Loops" in perlsyn|perlsyn/Foreach Loops> + +L<"my() in Control Structures" in perl5004delta|perl5004delta/my() in control structures> + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Variables/RequireLocalizedPunctuationVars.pm b/lib/Perl/Critic/Policy/Variables/RequireLocalizedPunctuationVars.pm new file mode 100644 index 0000000..6a1b14d --- /dev/null +++ b/lib/Perl/Critic/Policy/Variables/RequireLocalizedPunctuationVars.pm @@ -0,0 +1,204 @@ +package Perl::Critic::Policy::Variables::RequireLocalizedPunctuationVars; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities :classification $EMPTY hashify}; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $PACKAGE_RX => qr/::/xms; +Readonly::Hash my %EXCEPTIONS => hashify(qw( + $_ + $ARG + @_ +)); +Readonly::Scalar my $DESC => q{Magic variable "%s" should be assigned as "local"}; +Readonly::Scalar my $EXPL => [ 81, 82 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { + return ( + { + name => 'allow', + description => + q, + default_string => $EMPTY, + behavior => 'string list', + list_always_present_values => [ qw< $_ $ARG @_ > ], + }, + ); +} + +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw(core pbp bugs certrec ) } +sub applies_to { return 'PPI::Token::Operator' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, undef ) = @_; + + return if $elem->content() ne q{=}; + + my $destination = $elem->sprevious_sibling; + return if !$destination; # huh? assignment in void context?? + while ($destination->isa('PPI::Structure::Subscript')) { + $destination = $destination->sprevious_sibling() + or return; + } + + if (my $var = $self->_is_non_local_magic_dest($destination)) { + return $self->violation( sprintf( $DESC, $var ), $EXPL, $elem ); + } + return; # OK +} + +sub _is_non_local_magic_dest { + my ($self, $elem) = @_; + + # Quick exit if in good form + my $modifier = $elem->sprevious_sibling; + return + if + $modifier + && $modifier->isa('PPI::Token::Word') + && ($modifier->content() eq 'local' + || $modifier->content() eq 'my'); + + # Implementation note: Can't rely on PPI::Token::Magic, + # unfortunately, because we need English too + + if ($elem->isa('PPI::Token::Symbol')) { + return $self->_is_magic_var($elem) ? $elem : undef; + } + elsif ( + $elem->isa('PPI::Structure::List') + or $elem->isa('PPI::Statement::Expression') + ) { + for my $child ($elem->schildren) { + my $var = $self->_is_non_local_magic_dest($child); + return $var if $var; + } + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _is_magic_var { + my ($self, $elem) = @_; + + my $variable_name = $elem->symbol(); + return if $self->{_allow}{$variable_name}; + return 1 if $elem->isa('PPI::Token::Magic'); # optimization(?), and + # helps with PPI 1.118 carat + # bug. This bug is gone as of + # 1.208, which is required for + # P::C 1.113. RT 65514 + return if not is_perl_global( $elem ); + + return 1; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Policy::Variables::RequireLocalizedPunctuationVars - Magic variables should be assigned as "local". + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Punctuation variables (and their English.pm equivalents) are global +variables. Messing with globals is dangerous in a complex program as +it can lead to very subtle and hard to fix bugs. If you must change a +magic variable in a non-trivial program, do it in a local scope. + +For example, to slurp a filehandle into a scalar, it's common to set +the record separator to undef instead of a newline. If you choose to +do this (instead of using L!) then be sure to +localize the global and change it for as short a time as possible. + + # BAD: + $/ = undef; + my $content = <$fh>; + + # BETTER: + my $content; + { + local $/ = undef; + $content = <$fh>; + } + + # A popular idiom: + my $content = do { local $/ = undef; <$fh> }; + +This policy also allows the use of C. Perl prevents using C +with "proper" punctuation variables, but allows C<$a>, C<@ARGV>, the +names declared by L, etc. This is not a good coding +practice, however it is not the concern of this specific policy to +complain about that. + +There are exemptions for C<$_> and C<@_>, and the English equivalent +C<$ARG>. + + +=head1 CONFIGURATION + +You can configure your own exemptions using the C option: + + [Variables::RequireLocalizedPunctuationVars] + allow = @ARGV $ARGV + +These are added to the default exemptions. + + +=head1 CREDITS + +Initial development of this policy was supported by a grant from the +Perl Foundation. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Chris Dolan. Many rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Policy/Variables/RequireNegativeIndices.pm b/lib/Perl/Critic/Policy/Variables/RequireNegativeIndices.pm new file mode 100644 index 0000000..8504e0e --- /dev/null +++ b/lib/Perl/Critic/Policy/Variables/RequireNegativeIndices.pm @@ -0,0 +1,246 @@ +package Perl::Critic::Policy::Variables::RequireNegativeIndices; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $DESC => q{Negative array index should be used}; +Readonly::Scalar my $EXPL => [ 88 ]; + +#----------------------------------------------------------------------------- + +sub supported_parameters { return () } +sub default_severity { return $SEVERITY_HIGH } +sub default_themes { return qw( core maintenance pbp ) } +sub applies_to { return 'PPI::Structure::Subscript' } + +#----------------------------------------------------------------------------- + +sub violates { + my ( $self, $elem, $doc ) = @_; + + return if $elem->braces ne '[]'; + my ($name, $isref) = _is_bad_index( $elem ); + return if ( !$name ); + return if !_is_array_name( $elem, $name, $isref ); + return $self->violation( $DESC, $EXPL, $elem ); +} + +Readonly::Scalar my $MAX_EXPRESSION_COMPLEXETY => 4; + +sub _is_bad_index { + # return (varname, 0|1) if this could be a violation + my ( $elem ) = @_; + + my @children = $elem->schildren(); + return if @children != 1; # too complex + return if !$children[0]->isa( 'PPI::Statement::Expression'); # too complex + + # This is the expression elements that compose the array indexing + my @expr = $children[0]->schildren(); + return if !@expr || @expr > $MAX_EXPRESSION_COMPLEXETY; + my ($name, $isref, $isindex) = _is_bad_var_in_index(\@expr); + return if !$name; + return $name, $isref if !@expr && $isindex; + return if !_is_minus_number(@expr); + return $name, $isref; +} + +sub _is_bad_var_in_index { + # return (varname, isref=0|1, isindex=0|1) if this could be a violation + my ( $expr ) = @_; + + if ( $expr->[0]->isa('PPI::Token::ArrayIndex') ) { + # [$#arr] + return _arrayindex($expr); + } + elsif ( $expr->[0]->isa('PPI::Token::Cast') ) { + # [$#{$arr} ...] or [$#$arr ...] or [@{$arr} ...] or [@$arr ...] + return _cast($expr); + } + elsif ($expr->[0]->isa('PPI::Token::Symbol')) { + # [@arr ...] + return _symbol($expr); + } + + return; +} + +sub _arrayindex { + # return (varname, isref=0|1, isindex=0|1) if this could be a violation + my ( $expr ) = @_; + my $arrindex = shift @{$expr}; + if ($arrindex->content =~ m/\A \$[#] (.*) \z /xms) { # What else could it be??? + return $1, 0, 1; + } + return; +} + +sub _cast { + # return (varname, isref=0|1, isindex=0|1) if this could be a violation + my ( $expr ) = @_; + my $cast = shift @{$expr}; + if ( $cast eq q{$#} || $cast eq q{@} ) { ## no critic(RequireInterpolationOfMetachars) + my $isindex = $cast eq q{$#} ? 1 : 0; ## no critic(RequireInterpolationOfMetachars) + my $arrvar = shift @{$expr}; + if ($arrvar->isa('PPI::Structure::Block')) { + # look for [$#{$arr} ...] or [@{$arr} ...] + my @blockchildren = $arrvar->schildren(); + return if @blockchildren != 1; + return if !$blockchildren[0]->isa('PPI::Statement'); + my @ggg = $blockchildren[0]->schildren; + return if @ggg != 1; + return if !$ggg[0]->isa('PPI::Token::Symbol'); + if ($ggg[0] =~ m/\A \$ (.*) \z/xms) { + return $1, 1, $isindex; + } + } + elsif ( $arrvar->isa('PPI::Token::Symbol') ) { + # look for [$#$arr ...] or [@$arr ...] + if ($arrvar =~ m/\A \$ (.*) \z/xms) { + return $1, 1, $isindex; + } + } + } + return; +} + +sub _symbol { + # return (varname, isref=0|1, isindex=0|1) if this could be a violation + my ( $expr ) = @_; + my $arrvar = shift @{$expr}; + if ($arrvar =~ m/\A \@ (.*) \z/xms) { + return $1, 0, 0; + } + return; +} + +sub _is_minus_number { # return true if @expr looks like "- n" + my @expr = @_; + + return if !@expr; + + return if @expr != 2; + + my $op = shift @expr; + return if !$op->isa('PPI::Token::Operator'); + return if $op ne q{-}; + + my $number = shift @expr; + return if !$number->isa('PPI::Token::Number'); + + return 1; +} + +sub _is_array_name { # return true if name and isref matches + my ( $elem, $name, $isref ) = @_; + + my $sib = $elem->sprevious_sibling; + return if !$sib; + + if ($sib->isa('PPI::Token::Operator') && $sib eq '->') { + return if ( !$isref ); + $isref = 0; + $sib = $sib->sprevious_sibling; + return if !$sib; + } + + return if !$sib->isa('PPI::Token::Symbol'); + return if $sib !~ m/\A \$ \Q$name\E \z/xms; + + my $cousin = $sib->sprevious_sibling; + return if $isref ^ _is_dereferencer( $cousin ); + return if $isref && _is_dereferencer( $cousin->sprevious_sibling ); + + return $elem; +} + +sub _is_dereferencer { # must return 0 or 1, not undef + my $elem = shift; + + return 0 if !$elem; + return 1 if $elem->isa('PPI::Token::Operator') && $elem eq '->'; + return 1 if $elem->isa('PPI::Token::Cast'); + return 0; +} + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=pod + +=for stopwords performant + +=head1 NAME + +Perl::Critic::Policy::Variables::RequireNegativeIndices - Negative array index should be used. + + +=head1 AFFILIATION + +This Policy is part of the core L +distribution. + + +=head1 DESCRIPTION + +Perl treats a negative array subscript as an offset from the end. Given +this, the preferred way to get the last element is C<$x[-1]>, not +C<$x[$#x]> or C<$x[@x-1]>, and the preferred way to get the next-to-last +is C<$x[-2]>, not C<$x[$#x-1> or C<$x[@x-2]>. + +The biggest argument against the non-preferred forms is that B when the computed index becomes negative. If C<@x> +contains at least two elements, C<$x[$#x-1]> and C<$x[@x-2]> are +equivalent to C<$x[-2]>. But if it contains a single element, +C<$x[$#x-1]> and C<$x[@x-2]> are both equivalent to C<$x[-1]>. Simply +put, the preferred form is more likely to do what you actually want. + +As Conway points out, the preferred forms also perform better, are more +readable, and are easier to maintain. + +This policy notices all of the simple forms of the above problem, but +does not recognize any of these more complex examples: + + $some->[$data_structure]->[$#{$some->[$data_structure]} -1]; + my $ref = \@arr; $ref->[$#arr]; + + +=head1 CONFIGURATION + +This Policy is not configurable except for the standard options. + + +=head1 AUTHOR + +Chris Dolan + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/PolicyConfig.pm b/lib/Perl/Critic/PolicyConfig.pm new file mode 100644 index 0000000..d87015e --- /dev/null +++ b/lib/Perl/Critic/PolicyConfig.pm @@ -0,0 +1,335 @@ +package Perl::Critic::PolicyConfig; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +our $VERSION = '1.140'; + +use Perl::Critic::Exception::AggregateConfiguration; +use Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue; +use Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter; +use Perl::Critic::Utils qw< :booleans :characters severity_to_number >; +use Perl::Critic::Utils::Constants qw< :profile_strictness >; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $NON_PUBLIC_DATA => '_non_public_data'; +Readonly::Scalar my $NO_LIMIT => 'no_limit'; + +#----------------------------------------------------------------------------- + +sub new { + my ($class, $policy_short_name, $specification) = @_; + + my %self = $specification ? %{ $specification } : (); + my %non_public_data; + + $non_public_data{_policy_short_name} = $policy_short_name; + $non_public_data{_profile_strictness} = + $self{$NON_PUBLIC_DATA}{_profile_strictness}; + + foreach my $standard_parameter ( + qw< maximum_violations_per_document severity set_themes add_themes > + ) { + if ( exists $self{$standard_parameter} ) { + $non_public_data{"_$standard_parameter"} = + delete $self{$standard_parameter}; + } + } + + $self{$NON_PUBLIC_DATA} = \%non_public_data; + + + return bless \%self, $class; +} + +#----------------------------------------------------------------------------- + +sub _get_non_public_data { + my $self = shift; + + return $self->{$NON_PUBLIC_DATA}; +} + +#----------------------------------------------------------------------------- + +sub get_policy_short_name { + my $self = shift; + + return $self->_get_non_public_data()->{_policy_short_name}; +} + +#----------------------------------------------------------------------------- + +sub get_set_themes { + my ($self) = @_; + + return $self->_get_non_public_data()->{_set_themes}; +} + +#----------------------------------------------------------------------------- + +sub get_add_themes { + my ($self) = @_; + + return $self->_get_non_public_data()->{_add_themes}; +} + +#----------------------------------------------------------------------------- + +sub get_severity { + my ($self) = @_; + + return $self->_get_non_public_data()->{_severity}; +} + +#----------------------------------------------------------------------------- + +sub is_maximum_violations_per_document_unlimited { + my ($self) = @_; + + my $maximum_violations = $self->get_maximum_violations_per_document(); + if ( + not defined $maximum_violations + or $maximum_violations eq $EMPTY + or $maximum_violations =~ m<\A $NO_LIMIT \z>xmsio + ) { + return $TRUE; + } + + return $FALSE; +} + +#----------------------------------------------------------------------------- + +sub get_maximum_violations_per_document { + my ($self) = @_; + + return $self->_get_non_public_data()->{_maximum_violations_per_document}; +} + +#----------------------------------------------------------------------------- + +sub get { + my ($self, $parameter) = @_; + + return if $parameter eq $NON_PUBLIC_DATA; + + return $self->{$parameter}; +} + +#----------------------------------------------------------------------------- + +sub remove { + my ($self, $parameter) = @_; + + return if $parameter eq $NON_PUBLIC_DATA; + + delete $self->{$parameter}; + + return; +} + +#----------------------------------------------------------------------------- + +sub is_empty { + my ($self) = @_; + + return 1 >= keys %{$self}; +} + +#----------------------------------------------------------------------------- + +sub get_parameter_names { + my ($self) = @_; + + return grep { $_ ne $NON_PUBLIC_DATA } keys %{$self}; +} + +#----------------------------------------------------------------------------- + +sub handle_extra_parameters { + my ($self, $policy, $errors) = @_; + + my $profile_strictness = $self->{$NON_PUBLIC_DATA}{_profile_strictness}; + defined $profile_strictness + or $profile_strictness = $PROFILE_STRICTNESS_DEFAULT; + + return if $profile_strictness eq $PROFILE_STRICTNESS_QUIET; + + my $parameter_errors = $profile_strictness eq $PROFILE_STRICTNESS_WARN ? + Perl::Critic::Exception::AggregateConfiguration->new() : $errors; + + foreach my $offered_param ( $self->get_parameter_names() ) { + $parameter_errors->add_exception( + Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter->new( + policy => $policy->get_short_name(), + option_name => $offered_param, + source => undef, + ) + ); + } + + warn qq<$parameter_errors\n> + if ($profile_strictness eq $PROFILE_STRICTNESS_WARN + && $parameter_errors->has_exceptions()); + + return; +} + +#----------------------------------------------------------------------------- + +sub set_profile_strictness { + my ($self, $profile_strictness) = @_; + + $self->{$NON_PUBLIC_DATA}{_profile_strictness} = $profile_strictness; + + return; +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::PolicyConfig - Configuration data for a Policy. + + + +=head1 DESCRIPTION + +A container for the configuration of a Policy. + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 METHODS + +=over + +=item C + +The name of the policy this configuration is for. Primarily here for +the sake of debugging. + + +=item C< get_set_themes() > + +The value of C in the user's F<.perlcriticrc>. + + +=item C< get_add_themes() > + +The value of C in the user's F<.perlcriticrc>. + + +=item C< get_severity() > + +The value of C in the user's F<.perlcriticrc>. + + +=item C< is_maximum_violations_per_document_unlimited() > + +Answer whether the value of C should +be considered to be unlimited. + + +=item C< get_maximum_violations_per_document() > + +The value of C in the user's +F<.perlcriticrc>. + + +=item C< get($parameter) > + +Retrieve the value of the specified parameter in the user's +F<.perlcriticrc>. + + +=item C< remove($parameter) > + +Delete the value of the specified parameter. + + +=item C< is_empty() > + +Answer whether there is any non-standard configuration information +left. + + +=item C< get_parameter_names() > + +Retrieve the names of the parameters in this object. + + +=item C< set_profile_strictness($profile_strictness) > + +Sets the profile strictness associated with the configuration. + + +=item C< handle_extra_parameters($policy,$errors) > + +Deals with any extra parameters according to the profile_strictness +setting. To be called by Perl::Critic::Policy->new() once all valid +policies have been processed and removed from the configuration. + +If profile_strictness is $PROFILE_STRICTNESS_QUIET, extra policy +parameters are ignored. + +If profile_strictness is $PROFILE_STRICTNESS_WARN, extra policy +parameters generate a warning. + +If profile_strictness is $PROFILE_STRICTNESS_FATAL, extra policy +parameters generate a fatal error. + +If no profile_strictness was set, the behavior is that specified by +$PROFILE_STRICTNESS_DEFAULT. + + +=back + + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Elliot Shank + + +=head1 COPYRIGHT + +Copyright (c) 2008-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/PolicyFactory.pm b/lib/Perl/Critic/PolicyFactory.pm new file mode 100644 index 0000000..c222a0b --- /dev/null +++ b/lib/Perl/Critic/PolicyFactory.pm @@ -0,0 +1,449 @@ +package Perl::Critic::PolicyFactory; + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); + +use File::Spec::Unix qw(); +use List::MoreUtils qw(any); + +use Perl::Critic::Utils qw{ + :characters + $POLICY_NAMESPACE + :data_conversion + policy_long_name + policy_short_name + :internal_lookup +}; +use Perl::Critic::PolicyConfig; +use Perl::Critic::Exception::AggregateConfiguration; +use Perl::Critic::Exception::Configuration; +use Perl::Critic::Exception::Fatal::Generic qw{ throw_generic }; +use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal }; +use Perl::Critic::Exception::Fatal::PolicyDefinition + qw{ throw_policy_definition }; +use Perl::Critic::Exception::Configuration::NonExistentPolicy qw< >; +use Perl::Critic::Utils::Constants qw{ :profile_strictness }; + +use Exception::Class; # this must come after "use P::C::Exception::*" + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +# Globals. Ick! +my @site_policy_names = (); + +#----------------------------------------------------------------------------- + +# Blech!!! This is ug-lee. Belongs in the constructor. And it shouldn't be +# called "test" mode. +sub import { + + my ( $class, %args ) = @_; + my $test_mode = $args{-test}; + my $extra_test_policies = $args{'-extra-test-policies'}; + + if ( not @site_policy_names ) { + my $eval_worked = eval { + require Module::Pluggable; + Module::Pluggable->import(search_path => $POLICY_NAMESPACE, + require => 1, inner => 0); + @site_policy_names = plugins(); #Exported by Module::Pluggable + 1; + }; + + if (not $eval_worked) { + if ( $EVAL_ERROR ) { + throw_generic + qq; + } + + throw_generic + qq; + } + + if ( not @site_policy_names ) { + throw_generic + qq; + } + } + + # In test mode, only load native policies, not third-party ones. So this + # filters out any policy that was loaded from within a directory called + # "blib". During the usual "./Build test" process this works fine, + # but it doesn't work if you are using prove to test against the code + # directly in the lib/ directory. + + if ( $test_mode && any {m/\b blib \b/xms} @INC ) { + @site_policy_names = _modules_from_blib( @site_policy_names ); + + if ($extra_test_policies) { + my @extra_policy_full_names = + map { "${POLICY_NAMESPACE}::$_" } @{$extra_test_policies}; + + push @site_policy_names, @extra_policy_full_names; + } + } + + return 1; +} + +#----------------------------------------------------------------------------- +# Some static helper subs + +sub _modules_from_blib { + my (@modules) = @_; + return grep { _was_loaded_from_blib( _module2path($_) ) } @modules; +} + +sub _module2path { + my $module = shift || return; + return File::Spec::Unix->catdir(split m/::/xms, $module) . '.pm'; +} + +sub _was_loaded_from_blib { + my $path = shift || return; + my $full_path = $INC{$path}; + return $full_path && $full_path =~ m/ (?: \A | \b b ) lib \b /xms; +} + +#----------------------------------------------------------------------------- + +sub new { + + my ( $class, %args ) = @_; + my $self = bless {}, $class; + $self->_init( %args ); + return $self; +} + +#----------------------------------------------------------------------------- + +sub _init { + + my ($self, %args) = @_; + + my $profile = $args{-profile}; + $self->{_profile} = $profile + or throw_internal q{The -profile argument is required}; + + my $incoming_errors = $args{-errors}; + my $profile_strictness = $args{'-profile-strictness'}; + $profile_strictness ||= $PROFILE_STRICTNESS_DEFAULT; + $self->{_profile_strictness} = $profile_strictness; + + if ( $profile_strictness ne $PROFILE_STRICTNESS_QUIET ) { + my $errors; + + # If we're supposed to be strict or problems have already been found... + if ( + $profile_strictness eq $PROFILE_STRICTNESS_FATAL + or ( $incoming_errors and @{ $incoming_errors->exceptions() } ) + ) { + $errors = + $incoming_errors + ? $incoming_errors + : Perl::Critic::Exception::AggregateConfiguration->new(); + } + + $self->_validate_policies_in_profile( $errors ); + + if ( + not $incoming_errors + and $errors + and $errors->has_exceptions() + ) { + $errors->rethrow(); + } + } + + return $self; +} + +#----------------------------------------------------------------------------- + +sub create_policy { + + my ($self, %args ) = @_; + + my $policy_name = $args{-name} + or throw_internal q{The -name argument is required}; + + # Normalize policy name to a fully-qualified package name + $policy_name = policy_long_name( $policy_name ); + my $policy_short_name = policy_short_name( $policy_name ); + + + # Get the policy parameters from the user profile if they were + # not given to us directly. If none exist, use an empty hash. + my $profile = $self->_profile(); + my $policy_config; + if ( $args{-params} ) { + $policy_config = + Perl::Critic::PolicyConfig->new( + $policy_short_name, $args{-params} + ); + } + else { + $policy_config = $profile->policy_params($policy_name); + $policy_config ||= + Perl::Critic::PolicyConfig->new( $policy_short_name ); + } + + # Pull out base parameters. + return $self->_instantiate_policy( $policy_name, $policy_config ); +} + +#----------------------------------------------------------------------------- + +sub create_all_policies { + + my ( $self, $incoming_errors ) = @_; + + my $errors = + $incoming_errors + ? $incoming_errors + : Perl::Critic::Exception::AggregateConfiguration->new(); + my @policies; + + foreach my $name ( site_policy_names() ) { + my $policy = eval { $self->create_policy( -name => $name ) }; + + $errors->add_exception_or_rethrow( $EVAL_ERROR ); + + if ( $policy ) { + push @policies, $policy; + } + } + + if ( not $incoming_errors and $errors->has_exceptions() ) { + $errors->rethrow(); + } + + return @policies; +} + +#----------------------------------------------------------------------------- + +sub site_policy_names { + my @sorted_policy_names = sort @site_policy_names; + return @sorted_policy_names; +} + +#----------------------------------------------------------------------------- + +sub _profile { + my ($self) = @_; + + return $self->{_profile}; +} + +#----------------------------------------------------------------------------- + +# This two-phase initialization is caused by the historical lack of a +# requirement for Policies to invoke their super-constructor. +sub _instantiate_policy { + my ($self, $policy_name, $policy_config) = @_; + + $policy_config->set_profile_strictness( $self->{_profile_strictness} ); + + my $policy = eval { $policy_name->new( %{$policy_config} ) }; + _handle_policy_instantiation_exception( + $policy_name, + $policy, # Note: being used as a boolean here. + $EVAL_ERROR, + ); + + $policy->__set_config( $policy_config ); + + my $eval_worked = eval { $policy->__set_base_parameters(); 1; }; + _handle_policy_instantiation_exception( + $policy_name, $eval_worked, $EVAL_ERROR, + ); + + return $policy; +} + +sub _handle_policy_instantiation_exception { + my ($policy_name, $eval_worked, $eval_error) = @_; + + if (not $eval_worked) { + if ($eval_error) { + my $exception = Exception::Class->caught(); + + if (ref $exception) { + $exception->rethrow(); + } + + throw_policy_definition + qq; + } + + throw_policy_definition + qq; + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _validate_policies_in_profile { + my ($self, $errors) = @_; + + my $profile = $self->_profile(); + my %known_policies = hashify( $self->site_policy_names() ); + + for my $policy_name ( $profile->listed_policies() ) { + if ( not exists $known_policies{$policy_name} ) { + my $message = qq{Policy "$policy_name" is not installed.}; + + if ( $errors ) { + $errors->add_exception( + Perl::Critic::Exception::Configuration::NonExistentPolicy->new( + policy => $policy_name, + ) + ); + } + else { + warn qq{$message\n}; + } + } + } + + return; +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + + +=pod + +=for stopwords PolicyFactory -params + +=head1 NAME + +Perl::Critic::PolicyFactory - Instantiates Policy objects. + + +=head1 DESCRIPTION + +This is a helper class that instantiates +L objects with the user's +preferred parameters. There are no user-serviceable parts here. + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 CONSTRUCTOR + +=over + +=item C<< new( -profile => $profile, -errors => $config_errors ) >> + +Returns a reference to a new Perl::Critic::PolicyFactory object. + +B<-profile> is a reference to a +L object. This +argument is required. + +B<-errors> is a reference to an instance of +L. This +argument is optional. If specified, than any problems found will be +added to the object. + + +=back + + +=head1 METHODS + +=over + +=item C<< create_policy( -name => $policy_name, -params => \%param_hash ) >> + +Creates one Policy object. If the object cannot be instantiated, it +will throw a fatal exception. Otherwise, it returns a reference to +the new Policy object. + +B<-name> is the name of a L +subclass module. The C<'Perl::Critic::Policy'> portion of the name +can be omitted for brevity. This argument is required. + +B<-params> is an optional reference to hash of parameters that will be +passed into the constructor of the Policy. If C<-params> is not +defined, we will use the appropriate Policy parameters from the +L. + +Note that the Policy will not have had +L invoked on it, so it +may not yet be usable. + + +=item C< create_all_policies() > + +Constructs and returns one instance of each +L subclass that is +installed on the local system. Each Policy will be created with the +appropriate parameters from the user's configuration profile. + +Note that the Policies will not have had +L invoked on them, so +they may not yet be usable. + + +=back + + +=head1 SUBROUTINES + +Perl::Critic::PolicyFactory has a few static subroutines that are used +internally, but may be useful to you in some way. + +=over + +=item C + +Returns a list of all the Policy modules that are currently installed +in the Perl::Critic:Policy namespace. These will include modules that +are distributed with Perl::Critic plus any third-party modules that +have been installed. + + +=back + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/PolicyListing.pm b/lib/Perl/Critic/PolicyListing.pm new file mode 100644 index 0000000..9289bee --- /dev/null +++ b/lib/Perl/Critic/PolicyListing.pm @@ -0,0 +1,121 @@ +package Perl::Critic::PolicyListing; + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); + +use Perl::Critic::Policy qw(); + +use overload ( q<""> => 'to_string' ); + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +sub new { + my ($class, %args) = @_; + + my $self = bless {}, $class; + + my $policies = $args{-policies} || []; + $self->{_policies} = [ sort _by_type @{ $policies } ]; + + return $self; +} + +#----------------------------------------------------------------------------- + +sub to_string { + my ($self) = @_; + + Perl::Critic::Policy::set_format( "%s %p [%t]\n" ); + + return join q{}, map { "$_" } @{ $self->{_policies} }; +} + +#----------------------------------------------------------------------------- + +sub _by_type { return ref $a cmp ref $b } + +1; + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::PolicyListing - Display minimal information about Policies. + + +=head1 DESCRIPTION + +This is a helper class that formats a set of Policy objects for +pretty-printing. There are no user-serviceable parts here. + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 CONSTRUCTOR + +=over + +=item C<< new( -policies => \@POLICY_OBJECTS ) >> + +Returns a reference to a new C object. + + +=back + + +=head1 METHODS + +=over + +=item to_string() + +Returns a string representation of this C. See +L<"OVERLOADS"> for more information. + + +=back + + +=head1 OVERLOADS + +When a L is +evaluated in string context, it produces a one-line summary of the +default severity, policy name, and default themes for each +L object that was given to +the constructor of this C. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/PolicyParameter.pm b/lib/Perl/Critic/PolicyParameter.pm new file mode 100644 index 0000000..2256768 --- /dev/null +++ b/lib/Perl/Critic/PolicyParameter.pm @@ -0,0 +1,401 @@ +package Perl::Critic::PolicyParameter; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Exporter 'import'; + +Readonly::Array our @EXPORT_OK => qw{ $NO_DESCRIPTION_AVAILABLE }; + +use String::Format qw{ stringf }; + +use Perl::Critic::Exception::Fatal::PolicyDefinition + qw{ throw_policy_definition }; +use Perl::Critic::PolicyParameter::Behavior; +use Perl::Critic::PolicyParameter::Behavior::Boolean; +use Perl::Critic::PolicyParameter::Behavior::Enumeration; +use Perl::Critic::PolicyParameter::Behavior::Integer; +use Perl::Critic::PolicyParameter::Behavior::String; +use Perl::Critic::PolicyParameter::Behavior::StringList; + +use Perl::Critic::Utils qw{ :characters &interpolate }; +use Perl::Critic::Utils::DataConversion qw{ &defined_or_empty }; + +our $VERSION = '1.140'; + +Readonly::Scalar our $NO_DESCRIPTION_AVAILABLE => 'No description available.'; + +#----------------------------------------------------------------------------- + +# Grrr... one of the OO limitations of Perl: you can't put references to +# subclases in a superclass (well, not nicely). This map and method belong +# in Behavior.pm. +Readonly::Hash my %BEHAVIORS => + ( + 'boolean' => Perl::Critic::PolicyParameter::Behavior::Boolean->new(), + 'enumeration' => Perl::Critic::PolicyParameter::Behavior::Enumeration->new(), + 'integer' => Perl::Critic::PolicyParameter::Behavior::Integer->new(), + 'string' => Perl::Critic::PolicyParameter::Behavior::String->new(), + 'string list' => Perl::Critic::PolicyParameter::Behavior::StringList->new(), + ); + +sub _get_behavior_for_name { + my $behavior_name = shift; + + my $behavior = $BEHAVIORS{$behavior_name} + or throw_policy_definition qq{There's no "$behavior_name" behavior.}; + + return $behavior; +} + +#----------------------------------------------------------------------------- + +sub new { + my ($class, $specification) = @_; + my $self = bless {}, $class; + + defined $specification + or throw_policy_definition + 'Attempt to create a ', __PACKAGE__, ' without a specification.'; + + my $behavior_specification; + + my $specification_type = ref $specification; + if ( not $specification_type ) { + $self->{_name} = $specification; + + $behavior_specification = {}; + } else { + $specification_type eq 'HASH' + or throw_policy_definition + 'Attempt to create a ', + __PACKAGE__, + " with a $specification_type as a specification.", + ; + + defined $specification->{name} + or throw_policy_definition + 'Attempt to create a ', __PACKAGE__, ' without a name.'; + $self->{_name} = $specification->{name}; + + $behavior_specification = $specification; + } + + $self->_initialize_from_behavior($behavior_specification); + $self->_finish_standard_initialization($behavior_specification); + + return $self; +} + +# See if the specification includes a Behavior name, and if so, let the +# Behavior with that name plug in its implementations of parser, etc. +sub _initialize_from_behavior { + my ($self, $specification) = @_; + + my $behavior_name = $specification->{behavior}; + my $behavior; + if ($behavior_name) { + $behavior = _get_behavior_for_name($behavior_name); + } else { + $behavior = _get_behavior_for_name('string'); + } + + $self->{_behavior} = $behavior; + $self->{_behavior_values} = {}; + + $behavior->initialize_parameter($self, $specification); + + return; +} + +# Grab the rest of the values out of the specification, including overrides +# of what the Behavior specified. +sub _finish_standard_initialization { + my ($self, $specification) = @_; + + my $description = + $specification->{description} || $NO_DESCRIPTION_AVAILABLE; + $self->_set_description($description); + $self->_set_default_string($specification->{default_string}); + + $self->_set_parser($specification->{parser}); + + return; +} + +#----------------------------------------------------------------------------- + +sub get_name { + my $self = shift; + + return $self->{_name}; +} + +#----------------------------------------------------------------------------- + +sub get_description { + my $self = shift; + + return $self->{_description}; +} + +sub _set_description { + my ($self, $new_value) = @_; + + return if not defined $new_value; + $self->{_description} = $new_value; + + return; +} + +sub _get_description_with_trailing_period { + my $self = shift; + + my $description = $self->get_description(); + if ($description) { + if ( $PERIOD ne substr $description, ( length $description ) - 1 ) { + $description .= $PERIOD; + } + } else { + $description = $EMPTY; + } + + return $description; +} + +#----------------------------------------------------------------------------- + +sub get_default_string { + my $self = shift; + + return $self->{_default_string}; +} + +sub _set_default_string { + my ($self, $new_value) = @_; + + return if not defined $new_value; + $self->{_default_string} = $new_value; + + return; +} + +#----------------------------------------------------------------------------- + +sub _get_behavior { + my $self = shift; + + return $self->{_behavior}; +} + +sub _get_behavior_values { + my $self = shift; + + return $self->{_behavior_values}; +} + +#----------------------------------------------------------------------------- + +sub _get_parser { + my $self = shift; + + return $self->{_parser}; +} + +sub _set_parser { + my ($self, $new_value) = @_; + + return if not defined $new_value; + $self->{_parser} = $new_value; + + return; +} + +#----------------------------------------------------------------------------- + +sub parse_and_validate_config_value { + my ($self, $policy, $config) = @_; + + my $config_string = $config->{$self->get_name()}; + + my $parser = $self->_get_parser(); + if ($parser) { + $parser->($policy, $self, $config_string); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub generate_full_description { + my ($self) = @_; + + return $self->_get_behavior()->generate_parameter_description($self); +} + +#----------------------------------------------------------------------------- + +sub _generate_full_description { + my ($self, $prefix) = @_; + + my $description = $self->generate_full_description(); + + if (not $description) { + return $EMPTY; + } + + if ($prefix) { + $description =~ s/ ^ /$prefix/xmsg; + } + + return $description; +} + +#----------------------------------------------------------------------------- + +sub to_formatted_string { + my ($self, $format) = @_; + + my %specification = ( + n => sub { $self->get_name() }, + d => sub { defined_or_empty( $self->get_description() ) }, + D => sub { defined_or_empty( $self->get_default_string() ) }, + f => sub { $self->_generate_full_description(@_) }, + ); + + return stringf( interpolate($format), %specification ); +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords parsable + +=head1 NAME + +Perl::Critic::PolicyParameter - Metadata about a parameter for a Policy. + + +=head1 DESCRIPTION + +A provider of validation and parsing of parameter values and metadata +about the parameter. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 METHODS + +=over + +=item C + +Return the name of the parameter. This is the key that will be looked +for in the F<.perlcriticrc>. + + +=item C + +Return an explanation of the significance of the parameter, as +provided by the developer of the policy. + + +=item C + +Return a representation of the default value of this parameter as it +would appear if it was specified in a F<.perlcriticrc> file. + + +=item C + +Extract the configuration value for this parameter from the overall +configuration and initialize the policy based upon it. + + +=item C + +Produce a more complete explanation of the significance of this +parameter than the value returned by C. + +If no description can be derived, returns the empty string. + +Note that the result may contain multiple lines. + + +=item C + +Generate a string representation of this parameter, based upon the +format. + +The format is a combination of literal and escape characters similar +to the way C works. If you want to know the specific +formatting capabilities, look at L. +Valid escape characters are: + +=over + +=item C<%n> + +The name of the parameter. + +=item C<%d> + +The description, as supplied by the programmer. + +=item C<%D> + +The default value, in a parsable form. + +=item C<%f> + +The full description, which is an extension of the value returned by +C<%d>. Takes a parameter of a prefix for the beginning of each line. + + +=back + + +=back + + +=head1 SEE ALSO + +L + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/PolicyParameter/Behavior.pm b/lib/Perl/Critic/PolicyParameter/Behavior.pm new file mode 100644 index 0000000..1570055 --- /dev/null +++ b/lib/Perl/Critic/PolicyParameter/Behavior.pm @@ -0,0 +1,115 @@ +package Perl::Critic::PolicyParameter::Behavior; + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::Utils qw{ :characters }; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +sub new { + my $class = shift; + + return bless {}, $class; +} + +#----------------------------------------------------------------------------- + +sub initialize_parameter { + my ($self, $parameter, $specification) = @_; + + return; +} + +#----------------------------------------------------------------------------- + +sub generate_parameter_description { + my ($self, $parameter) = @_; + + return $parameter->_get_description_with_trailing_period(); +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::PolicyParameter::Behavior - Default type-specific actions for a parameter. + + +=head1 DESCRIPTION + +Provides a standard set of functionality for a +L so that +the developer of a policy does not have to provide it her/himself. +The developer can override most of the functionality in the +subclasses; these are just defaults. + +All subclasses have singleton instances held onto by +L. + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 METHODS + +=over + +=item C + +Plug in the functionality this behavior provides into the parameter, +based upon the configuration provided by the specification. The +configuration items looked for depends upon the specific behavior +subclass. + +=item C + +Create a description of the parameter, based upon the description on +the parameter itself, but enhancing it with information from this +behavior. + +Note that this may return C if the parameter itself doesn't +have a description. Also, the returned value may include multiple +lines. + +=back + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/PolicyParameter/Behavior/Boolean.pm b/lib/Perl/Critic/PolicyParameter/Behavior/Boolean.pm new file mode 100644 index 0000000..5d3ce6a --- /dev/null +++ b/lib/Perl/Critic/PolicyParameter/Behavior/Boolean.pm @@ -0,0 +1,114 @@ +package Perl::Critic::PolicyParameter::Behavior::Boolean; + +use 5.006001; +use strict; +use warnings; +use Perl::Critic::Utils; + +use base qw{ Perl::Critic::PolicyParameter::Behavior }; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +sub _parse { + my ($policy, $parameter, $config_string) = @_; + + my $value; + my $value_string = $parameter->get_default_string(); + + if (defined $config_string) { + $value_string = $config_string; + } + + if ( $value_string ) { + $value = $TRUE; + } else { + $value = $FALSE; + } + + $policy->__set_parameter_value($parameter, $value); + + return; +} + +#----------------------------------------------------------------------------- + +sub initialize_parameter { + my ($self, $parameter, $specification) = @_; + + $parameter->_set_parser(\&_parse); + + return; +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::PolicyParameter::Behavior::Boolean - Actions appropriate for a boolean parameter. + + +=head1 DESCRIPTION + +Provides a standard set of functionality for a boolean +L so that +the developer of a policy does not have to provide it her/himself. + +NOTE: Do not instantiate this class. Use the singleton instance held +onto by +L. + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 METHODS + +=over + +=item C + +Plug in the functionality this behavior provides into the parameter. +At present, this behavior isn't customizable by the specification. + + +=back + + +=head1 AUTHOR + +Elliot Shank + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/PolicyParameter/Behavior/Enumeration.pm b/lib/Perl/Critic/PolicyParameter/Behavior/Enumeration.pm new file mode 100644 index 0000000..7599951 --- /dev/null +++ b/lib/Perl/Critic/PolicyParameter/Behavior/Enumeration.pm @@ -0,0 +1,241 @@ +package Perl::Critic::PolicyParameter::Behavior::Enumeration; + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::Exception::Fatal::PolicyDefinition + qw{ &throw_policy_definition }; +use Perl::Critic::Utils qw{ :characters &words_from_string &hashify }; + +use base qw{ Perl::Critic::PolicyParameter::Behavior }; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +sub initialize_parameter { + my ($self, $parameter, $specification) = @_; + + my $valid_values = $specification->{enumeration_values} + or throw_policy_definition + 'No enumeration_values given for ' + . $parameter->get_name() + . $PERIOD; + ref $valid_values eq 'ARRAY' + or throw_policy_definition + 'The value given for enumeration_values for ' + . $parameter->get_name() + . ' is not an array reference.'; + scalar @{$valid_values} > 1 + or throw_policy_definition + 'There were not at least two valid values given for' + . ' enumeration_values for ' + . $parameter->get_name() + . $PERIOD; + + # Unfortunately, this has to be a reference, rather than a regular hash, + # due to a problem in Devel::Cycle + # (http://rt.cpan.org/Ticket/Display.html?id=25360) which causes + # t/92_memory_leaks.t to fall over. + my $value_lookup = { hashify( @{$valid_values} ) }; + $parameter->_get_behavior_values()->{enumeration_values} = $value_lookup; + + my $allow_multiple_values = + $specification->{enumeration_allow_multiple_values}; + + if ($allow_multiple_values) { + $parameter->_set_parser( + sub { + # Normally bad thing, obscuring a variable in a outer scope + # with a variable with the same name is being done here in + # order to remain consistent with the parser function interface. + my ($policy, $parameter, $config_string) = @_; ## no critic(Variables::ProhibitReusedNames) + + my @potential_values; + my $value_string = $parameter->get_default_string(); + + if (defined $config_string) { + $value_string = $config_string; + } + + if ( defined $value_string ) { + @potential_values = words_from_string($value_string); + + my @bad_values = + grep { not exists $value_lookup->{$_} } @potential_values; + if (@bad_values) { + $policy->throw_parameter_value_exception( + $parameter->get_name(), + $value_string, + undef, + q{contains invalid values: } + . join (q{, }, @bad_values) + . q{. Allowed values are: } + . join (q{, }, sort keys %{$value_lookup}) + . qq{.\n}, + ); + } + } + + my %actual_values = hashify(@potential_values); + + $policy->__set_parameter_value($parameter, \%actual_values); + + return; + } + ); + } else { + $parameter->_set_parser( + sub { + # Normally bad thing, obscuring a variable in a outer scope + # with a variable with the same name is being done here in + # order to remain consistent with the parser function interface. + my ($policy, $parameter, $config_string) = @_; ## no critic(Variables::ProhibitReusedNames) + + my $value_string = $parameter->get_default_string(); + + if (defined $config_string) { + $value_string = $config_string; + } + + if ( + defined $value_string + and $EMPTY ne $value_string + and not defined $value_lookup->{$value_string} + ) { + $policy->throw_parameter_value_exception( + $parameter->get_name(), + $value_string, + undef, + q{is not one of the allowed values: } + . join (q{, }, sort keys %{$value_lookup}) + . qq{.\n}, + ); + } + + $policy->__set_parameter_value($parameter, $value_string); + + return; + } + ); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub generate_parameter_description { + my ($self, $parameter) = @_; + + my $description = $parameter->_get_description_with_trailing_period(); + if ( $description ) { + $description .= qq{\n}; + } + + my %values = %{$parameter->_get_behavior_values()->{enumeration_values}}; + return + $description + . 'Valid values: ' + . join (', ', sort keys %values) + . $PERIOD; +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::PolicyParameter::Behavior::Enumeration - Actions appropriate for an enumerated value. + + +=head1 DESCRIPTION + +Provides a standard set of functionality for an enumerated +L so that +the developer of a policy does not have to provide it her/himself. + +NOTE: Do not instantiate this class. Use the singleton instance held +onto by +L. + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 METHODS + +=over + +=item C + +Plug in the functionality this behavior provides into the parameter, +based upon the configuration provided by the specification. + +This behavior looks for two configuration items: + +=over + +=item enumeration_values + +Mandatory. The set of valid values for the parameter, as an array +reference. + + +=item enumeration_allow_multiple_values + +Optional, defaults to false. Should the parameter support a single +value or accept multiple? + + +=back + + +=item C + +Create a description of the parameter, based upon the description on +the parameter itself, but enhancing it with information from this +behavior. + +In this specific case, the universe of values is added at the end. + + +=back + + +=head1 AUTHOR + +Elliot Shank + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/PolicyParameter/Behavior/Integer.pm b/lib/Perl/Critic/PolicyParameter/Behavior/Integer.pm new file mode 100644 index 0000000..18c26e7 --- /dev/null +++ b/lib/Perl/Critic/PolicyParameter/Behavior/Integer.pm @@ -0,0 +1,210 @@ +package Perl::Critic::PolicyParameter::Behavior::Integer; + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::Utils qw{ :characters }; + +use base qw{ Perl::Critic::PolicyParameter::Behavior }; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +sub initialize_parameter { + my ($self, $parameter, $specification) = @_; + + my $minimum = $specification->{integer_minimum}; + my $maximum = $specification->{integer_maximum}; + + $parameter->_get_behavior_values()->{minimum} = $minimum; + $parameter->_get_behavior_values()->{maximum} = $maximum; + + $parameter->_set_parser( + sub { + # Normally bad thing, obscuring a variable in a outer scope + # with a variable with the same name is being done here in + # order to remain consistent with the parser function interface. + my ($policy, $parameter, $config_string) = @_; ## no critic(Variables::ProhibitReusedNames) + + my $value_string = $parameter->get_default_string(); + + if (defined $config_string) { + $value_string = $config_string; + } + + my $value; + if ( defined $value_string ) { + if ( + $value_string !~ m/ \A [-+]? [1-9] [\d_]* \z /xms + and $value_string ne '0' + ) { + $policy->throw_parameter_value_exception( + $parameter->get_name(), + $value_string, + undef, + 'does not look like an integer.', + ); + } + + $value_string =~ tr/_//d; + $value = $value_string + 0; + + if ( defined $minimum and $minimum > $value ) { + $policy->throw_parameter_value_exception( + $parameter->get_name(), + $value_string, + undef, + qq{is less than $minimum.}, + ); + } + + if ( defined $maximum and $maximum < $value ) { + $policy->throw_parameter_value_exception( + $parameter->get_name(), + $value_string, + undef, + qq{is greater than $maximum.}, + ); + } + } + + $policy->__set_parameter_value($parameter, $value); + return; + } + ); + + return; +} + +#----------------------------------------------------------------------------- + +sub generate_parameter_description { + my ($self, $parameter) = @_; + + my $minimum = $parameter->_get_behavior_values()->{minimum}; + my $maximum = $parameter->_get_behavior_values()->{maximum}; + + my $description = $parameter->_get_description_with_trailing_period(); + if ( $description ) { + $description .= qq{\n}; + } + + if (defined $minimum or defined $maximum) { + if (defined $minimum) { + $description .= "Minimum value $minimum. "; + } else { + $description .= 'No minimum. '; + } + + if (defined $maximum) { + $description .= "Maximum value $maximum."; + } else { + $description .= 'No maximum.'; + } + } else { + $description .= 'No limits.'; + } + + return $description; +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::PolicyParameter::Behavior::Integer - Actions appropriate for an integer parameter. + + +=head1 DESCRIPTION + +Provides a standard set of functionality for an integer +L so that +the developer of a policy does not have to provide it her/himself. + +The parser provided by this behavior allows underscores ("_") in input +values as in a Perl numeric literal. + +NOTE: Do not instantiate this class. Use the singleton instance held +onto by +L. + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 METHODS + +=over + +=item C + +Plug in the functionality this behavior provides into the parameter, +based upon the configuration provided by the specification. + +This behavior looks for two configuration items: + +=over + +=item integer_minimum + +Optional. The minimum acceptable value. Inclusive. + + +=item integer_maximum + +Optional. The maximum acceptable value. Inclusive. + + +=back + + +=item C + +Create a description of the parameter, based upon the description on +the parameter itself, but enhancing it with information from this +behavior. + +In this case, this means including the minimum and maximum values. + + +=back + + +=head1 AUTHOR + +Elliot Shank + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/PolicyParameter/Behavior/String.pm b/lib/Perl/Critic/PolicyParameter/Behavior/String.pm new file mode 100644 index 0000000..b81d3bb --- /dev/null +++ b/lib/Perl/Critic/PolicyParameter/Behavior/String.pm @@ -0,0 +1,108 @@ +package Perl::Critic::PolicyParameter::Behavior::String; + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::Utils; + +use base qw{ Perl::Critic::PolicyParameter::Behavior }; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +sub _parse { + my ($policy, $parameter, $config_string) = @_; + + my $value = $parameter->get_default_string(); + + if ( defined $config_string ) { + $value = $config_string; + } + + $policy->__set_parameter_value($parameter, $value); + + return; +} + +#----------------------------------------------------------------------------- + +sub initialize_parameter { + my ($self, $parameter, $specification) = @_; + + $parameter->_set_parser(\&_parse); + + return; +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::PolicyParameter::Behavior::String - Actions appropriate for a simple string parameter. + + +=head1 DESCRIPTION + +Provides a standard set of functionality for a string +L so that +the developer of a policy does not have to provide it her/himself. + +NOTE: Do not instantiate this class. Use the singleton instance held +onto by +L. + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 METHODS + +=over + +=item C + +Plug in the functionality this behavior provides into the parameter. +At present, this behavior isn't customizable by the specification. + + +=back + + +=head1 AUTHOR + +Elliot Shank + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/PolicyParameter/Behavior/StringList.pm b/lib/Perl/Critic/PolicyParameter/Behavior/StringList.pm new file mode 100644 index 0000000..113c8e3 --- /dev/null +++ b/lib/Perl/Critic/PolicyParameter/Behavior/StringList.pm @@ -0,0 +1,165 @@ +package Perl::Critic::PolicyParameter::Behavior::StringList; + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::Utils qw{ :characters &words_from_string &hashify }; + +use base qw{ Perl::Critic::PolicyParameter::Behavior }; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +sub initialize_parameter { + my ($self, $parameter, $specification) = @_; + + # Unfortunately, this has to be kept as a reference, rather than a regular + # array, due to a problem in Devel::Cycle + # (http://rt.cpan.org/Ticket/Display.html?id=25360) which causes + # t/92_memory_leaks.t to fall over. + my $always_present_values = $specification->{list_always_present_values}; + $parameter->_get_behavior_values()->{always_present_values} = + $always_present_values; + + if ( not $always_present_values ) { + $always_present_values = []; + } + + $parameter->_set_parser( + sub { + # Normally bad thing, obscuring a variable in a outer scope + # with a variable with the same name is being done here in + # order to remain consistent with the parser function interface. + my ($policy, $parameter, $config_string) = @_; ## no critic(Variables::ProhibitReusedNames) + + my @values = @{$always_present_values}; + my $value_string = $parameter->get_default_string(); + + if (defined $config_string) { + $value_string = $config_string; + } + + if ( defined $value_string ) { + push @values, words_from_string($value_string); + } + + my %values = hashify(@values); + + $policy->__set_parameter_value($parameter, \%values); + + return; + } + ); + + return; +} + +#----------------------------------------------------------------------------- + +sub generate_parameter_description { + my ($self, $parameter) = @_; + + my $always_present_values = + $parameter->_get_behavior_values()->{always_present_values}; + + my $description = $parameter->_get_description_with_trailing_period(); + if ( $description and $always_present_values ) { + $description .= qq{\n}; + } + + if ( $always_present_values ) { + $description .= 'Values that are always included: '; + $description .= join ', ', sort @{ $always_present_values }; + $description .= $PERIOD; + } + + return $description; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::PolicyParameter::Behavior::StringList - Actions appropriate for a parameter that is a list of strings. + + +=head1 DESCRIPTION + +Provides a standard set of functionality for a string list +L so that +the developer of a policy does not have to provide it her/himself. + +NOTE: Do not instantiate this class. Use the singleton instance held +onto by +L. + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 METHODS + +=over + +=item C + +Plug in the functionality this behavior provides into the parameter, +based upon the configuration provided by the specification. + +This behavior looks for one configuration item: + +=over + +=item always_present_values + +Optional. Values that should always be included, regardless of what +the configuration of the parameter specifies, as an array reference. + +=back + +=item C + +Create a description of the parameter, based upon the description on +the parameter itself, but enhancing it with information from this +behavior. + +In this specific case, the always present values are added at the end. + +=back + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/PolicySummary.pod b/lib/Perl/Critic/PolicySummary.pod new file mode 100644 index 0000000..aff6828 --- /dev/null +++ b/lib/Perl/Critic/PolicySummary.pod @@ -0,0 +1,618 @@ + +=head1 NAME + +Perl::Critic::PolicySummary - Descriptions of the Policy modules included with L itself. + + +=head1 DESCRIPTION + +The following Policy modules are distributed with Perl::Critic. (There are +additional Policies that can be found in add-on distributions.) The Policy +modules have been categorized according to the table of contents in Damian +Conway's book B. Since most coding standards take the +form "do this..." or "don't do that...", I have adopted the convention of +naming each module C or C. Each Policy +is listed here with its default severity. If you don't agree with the default +severity, you can change it in your F<.perlcriticrc> file (try C for a starting version). See the documentation of each +module for its specific details. + + +=head1 POLICIES + +=head2 L + +Use C instead of C in boolean context. [Default severity 2] + +=head2 L + +Map blocks should have a single statement. [Default severity 3] + +=head2 L + +Use 4-argument C instead of writing C. [Default severity 3] + +=head2 L + +Forbid $b before $a in sort blocks. [Default severity 1] + +=head2 L + +Prohibit C<\shift> in code [Default severity 3] + +=head2 L + +Use L instead of something like C. [Default severity 5] + +=head2 L + +Write C instead of C. [Default severity 5] + +=head2 L + +Write C instead of C. [Default severity 2] + +=head2 L + +Write C<< eval { $foo->can($name) } >> instead of C. [Default severity 3] + +=head2 L + +Write C<< eval { $foo->isa($pkg) } >> instead of C. [Default severity 3] + +=head2 L + +Don't pass $_ to built-in functions that assume it, or to most filetest operators. [Default severity 2] + +=head2 L + +Don't use C in void contexts. [Default severity 3] + +=head2 L + +Don't use C in void contexts. [Default severity 3] + +=head2 L + +Write C instead of C. [Default severity 4] + +=head2 L + +Write C instead of C. [Default severity 4] + +=head2 L + +Use C instead of <*>. [Default severity 5] + +=head2 L + +Sort blocks should have a single statement. [Default severity 3] + +=head2 L + +AUTOLOAD methods should be avoided. [Default severity 3] + +=head2 L + +Employ C instead of C<@ISA>. [Default severity 3] + +=head2 L + +Write C instead of just C. [Default severity 5] + +=head2 L + +Use spaces instead of tabs. [Default severity 3] + +=head2 L + +Write C instead of C. [Default severity 1] + +=head2 L + +Write C instead of C<('foo', 'bar', 'baz')>. [Default severity 2] + +=head2 L + +Don't use whitespace at the end of lines. [Default severity 1] + +=head2 L + +Use the same newline through the source. [Default severity 4] + +=head2 L + +Must run code through L. [Default severity 1] + +=head2 L + +Put a comma at the end of every multi-line list declaration, including the last one. [Default severity 1] + +=head2 L + +Write C instead of C. [Default severity 2] + +=head2 L + +Don't write long "if-elsif-elsif-elsif-elsif...else" chains. [Default severity 3] + +=head2 L + +Don't write deeply nested loops and conditionals. [Default severity 3] + +=head2 L + +Don't use labels that are the same as the special block names. [Default severity 4] + +=head2 L + +Don't modify C<$_> in list functions. [Default severity 5] + +=head2 L + +Don't use operators like C, C, and C within C and C. [Default severity 3] + +=head2 L + +Write C instead of C. [Default severity 2] + +=head2 L + +Write C instead of C. [Default severity 2] + +=head2 L + +Don't write code after an unconditional C. [Default severity 4] + +=head2 L + +Write C instead of C. [Default severity 2] + +=head2 L + +Never use C<...> in production code. [Default severity 4] + +=head2 L + +Check your spelling. [Default severity 1] + +=head2 L + +The C<=head1 NAME> section should match the package. [Default severity 1] + +=head2 L + +All POD should be after C<__END__>. [Default severity 1] + +=head2 L + +Organize your POD into the customary sections. [Default severity 2] + +=head2 L + +Use functions from L instead of C or C. [Default severity 3] + +=head2 L + +You can't depend upon the value of C<$@>/C<$EVAL_ERROR> to tell whether an C failed. [Default severity 3] + +=head2 L + +Discourage stuff like C<@files = `ls $directory`>. [Default severity 3] + +=head2 L + +Write C instead of C. [Default severity 5] + +=head2 L + +Use "<>" or "" or a prompting module instead of "". [Default severity 4] + +=head2 L + +Use prompt() instead of -t. [Default severity 5] + +=head2 L + +Use C or L instead of joined readline. [Default severity 3] + +=head2 L + +Never write C. [Default severity 4] + +=head2 L + +Write C<< while( $line = <> ){...} >> instead of C<< for(<>){...} >>. [Default severity 4] + +=head2 L + +Write C<< open $fh, q{<}, $filename; >> instead of C<< open $fh, "<$filename"; >>. [Default severity 5] + +=head2 L + +Write C instead of C. [Default severity 1] + +=head2 L + +Close filehandles as soon as possible after opening them. [Default severity 4] + +=head2 L + +Write C<< my $error = close $fh; >> instead of C<< close $fh; >>. [Default severity 2] + +=head2 L + +Write C<< my $error = open $fh, $mode, $filename; >> instead of C<< open $fh, $mode, $filename; >>. [Default severity 3] + +=head2 L + +Return value of flagged function ignored. [Default severity 1] + +=head2 L + +Write C<< open $fh, q{<:encoding(UTF-8)}, $filename; >> instead of C<< open $fh, q{<:utf8}, $filename; >>. [Default severity 5] + +=head2 L + +Do not use C. [Default severity 3] + +=head2 L + +Do not use C. [Default severity 2] + +=head2 L + +Forbid a bare C<## no critic> [Default severity 3] + +=head2 L + +Remove ineffective "## no critic" annotations. [Default severity 2] + +=head2 L + +Export symbols via C<@EXPORT_OK> or C<%EXPORT_TAGS> instead of C<@EXPORT>. [Default severity 4] + +=head2 L + +Avoid putting conditional logic around compile-time includes. [Default severity 3] + +=head2 L + +Ban modules that aren't blessed by your shop. [Default severity 5] + +=head2 L + +Minimize complexity in code that is B of subroutines. [Default severity 3] + +=head2 L + +Put packages (especially subclasses) in separate files. [Default severity 4] + +=head2 L + +Write C instead of C. [Default severity 5] + +=head2 L + +End each module with an explicitly C<1;> instead of some funky expression. [Default severity 4] + +=head2 L + +Always make the C explicit. [Default severity 4] + +=head2 L + +Package declaration must match filename. [Default severity 5] + +=head2 L + +C must be passed a C<-no_match_vars> argument. [Default severity 2] + +=head2 L + +Give every module a C<$VERSION> number. [Default severity 2] + +=head2 L + +Distinguish different program components by case. [Default severity 1] + +=head2 L + +Don't use vague variable or subroutine names like 'last' or 'record'. [Default severity 3] + +=head2 L + +Prohibit indirect object call syntax. [Default severity 4] + +=head2 L + +Write C<@{ $array_ref }> instead of C<@$array_ref>. [Default severity 2] + +=head2 L + +Capture variable used outside conditional. [Default severity 3] + +=head2 L + +Split long regexps into smaller C chunks. [Default severity 3] + +=head2 L + +Use named character classes instead of explicit character lists. [Default severity 1] + +=head2 L + +Use character classes for literal meta-characters instead of escapes. [Default severity 1] + +=head2 L + +Use C or hash instead of fixed-pattern regexps. [Default severity 2] + +=head2 L + +Use C<[abc]> instead of C. [Default severity 1] + +=head2 L + +Only use a capturing group if you plan to use the captured value. [Default severity 3] + +=head2 L + +Use only C or C<{}> to delimit regexps. [Default severity 1] + +=head2 L + +Don't use $_ to match against regexes. [Default severity 2] + +=head2 L + +Use C<{> and C<}> to delimit multi-line regexps. [Default severity 1] + +=head2 L + +Always use the C modifier with regular expressions. [Default severity 2] + +=head2 L + +Always use the C modifier with regular expressions. [Default severity 3] + +=head2 L + +Always use the C modifier with regular expressions. [Default severity 2] + +=head2 L + +Don't call functions with a leading ampersand sigil. [Default severity 2] + +=head2 L + +Don't declare your own C function. [Default severity 4] + +=head2 L + +Minimize complexity by factoring code into smaller subroutines. [Default severity 3] + +=head2 L + +Return failure with bare C instead of C. [Default severity 5] + +=head2 L + +Too many arguments. [Default severity 3] + +=head2 L + +C. [Default severity 5] + +=head2 L + +Behavior of C is not defined if called in scalar context. [Default severity 5] + +=head2 L + +Don't write C. [Default severity 5] + +=head2 L + +Prevent unused private subroutines. [Default severity 3] + +=head2 L + +Prevent access to private subs in other packages. [Default severity 3] + +=head2 L + +Always unpack C<@_> first. [Default severity 4] + +=head2 L + +End every path through a subroutine with an explicit C statement. [Default severity 4] + +=head2 L + +Prohibit various flavors of C. [Default severity 5] + +=head2 L + +Prohibit various flavors of C. [Default severity 4] + +=head2 L + +Don't turn off strict for large blocks of code. [Default severity 4] + +=head2 L + +Tests should all have labels. [Default severity 3] + +=head2 L + +Always C. [Default severity 5] + +=head2 L + +Always C. [Default severity 4] + +=head2 L + +Don't use the comma operator as a statement separator. [Default severity 4] + +=head2 L + +Prohibit version values from outside the module. [Default severity 3] + +=head2 L + +Don't C<< use constant FOO => 15 >>. [Default severity 4] + +=head2 L + +Write C instead of C<''>. [Default severity 2] + +=head2 L + +Write C<"\N{DELETE}"> instead of C<"\x7F">, etc. [Default severity 2] + +=head2 L + +Use concatenation or HEREDOCs instead of literal line breaks in strings. [Default severity 3] + +=head2 L + +Always use single quotes for literal strings. [Default severity 1] + +=head2 L + +Write C instead of C<0755>. [Default severity 5] + +=head2 L + +Long chains of method calls indicate tightly coupled code. [Default severity 2] + +=head2 L + +Don't use values that don't explain themselves. [Default severity 2] + +=head2 L + +Don't mix numeric operators with string operands, or vice-versa. [Default severity 3] + +=head2 L + +Write C< !$foo && $bar || $baz > instead of C< not $foo && $bar or $baz>. [Default severity 4] + +=head2 L + +Use C or C instead of quotes for awkward-looking strings. [Default severity 2] + +=head2 L + +Don't use quotes (C<'>, C<">, C<`>) as delimiters for the quote-like operators. [Default severity 3] + +=head2 L + +Don't write C< print <<'__END__' >. [Default severity 3] + +=head2 L + +Don't use strings like C or C<1.4.5> when including other modules. [Default severity 3] + +=head2 L + +Require $VERSION to be a constant rather than a computed value. [Default severity 2] + +=head2 L + +Warns that you might have used single quotes when you really wanted double-quotes. [Default severity 1] + +=head2 L + +Write C< 141_234_397.0145 > instead of C< 141234397.0145 >. [Default severity 2] + +=head2 L + +Write C< print <<'THE_END' > or C< print <<"THE_END" >. [Default severity 3] + +=head2 L + +Write C< <<'THE_END'; > instead of C< <<'theEnd'; >. [Default severity 2] + +=head2 L + +Do not write C< my $foo .= 'bar'; >. [Default severity 4] + +=head2 L + +Do not write C< my $foo = $bar if $baz; >. [Default severity 5] + +=head2 L + +Ban variables that aren't blessed by your shop. [Default severity 5] + +=head2 L + +Use C instead of C, except when you have to. [Default severity 2] + +=head2 L + +Avoid C<$`>, C<$&>, C<$'> and their English equivalents. [Default severity 4] + +=head2 L + +Eliminate globals declared with C or C. [Default severity 3] + +=head2 L + +Use double colon (::) to separate package name components instead of single quotes ('). [Default severity 2] + +=head2 L + +Write C<$EVAL_ERROR> instead of C<$@>. [Default severity 2] + +=head2 L + +Do not reuse a variable name in a lexical scope [Default severity 3] + +=head2 L + +Don't ask for storage you don't need. [Default severity 3] + +=head2 L + +Prevent access to private vars in other packages. [Default severity 3] + +=head2 L + +Write C instead of just C. [Default severity 3] + +=head2 L + +Write C instead of C. [Default severity 5] + +=head2 L + +Magic variables should be assigned as "local". [Default severity 4] + +=head2 L + +Negative array index should be used. [Default severity 4] + + +=head1 VERSION + +This is part of L version 1.126. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut diff --git a/lib/Perl/Critic/ProfilePrototype.pm b/lib/Perl/Critic/ProfilePrototype.pm new file mode 100644 index 0000000..fa60b2c --- /dev/null +++ b/lib/Perl/Critic/ProfilePrototype.pm @@ -0,0 +1,288 @@ +package Perl::Critic::ProfilePrototype; + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); + +use Perl::Critic::Config qw{}; +use Perl::Critic::Policy qw{}; +use Perl::Critic::Utils qw{ :characters }; +use overload ( q{""} => 'to_string' ); + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +sub new { + my ($class, %args) = @_; + my $self = bless {}, $class; + + my $policies = $args{-policies} || []; + $self->{_policies} = [ sort _by_type @{ $policies } ]; + + my $comment_out_parameters = $args{'-comment-out-parameters'}; + if (not defined $comment_out_parameters) { + $comment_out_parameters = 1; + } + $self->{_comment_out_parameters} = $comment_out_parameters; + + my $configuration = $args{'-config'}; + if (not $configuration) { + $configuration = Perl::Critic::Config->new(-profile => $EMPTY); + } + $self->{_configuration} = $configuration; + + + return $self; +} + +#----------------------------------------------------------------------------- + +sub _get_policies { + my ($self) = @_; + + return $self->{_policies}; +} + +sub _comment_out_parameters { + my ($self) = @_; + + return $self->{_comment_out_parameters}; +} + +sub _configuration { + my ($self) = @_; + + return $self->{_configuration}; +} + +#----------------------------------------------------------------------------- + +sub _line_prefix { + my ($self) = @_; + + return $self->_comment_out_parameters() ? q{# } : $EMPTY; +} + +#----------------------------------------------------------------------------- + +sub to_string { + my ($self) = @_; + + my $prefix = $self->_line_prefix(); + my $configuration = $self->_configuration(); + + my $prototype = "# Globals\n"; + + $prototype .= $prefix; + $prototype .= q{severity = }; + $prototype .= $configuration->severity(); + $prototype .= "\n"; + + $prototype .= $prefix; + $prototype .= q{force = }; + $prototype .= $configuration->force(); + $prototype .= "\n"; + + $prototype .= $prefix; + $prototype .= q{only = }; + $prototype .= $configuration->only(); + $prototype .= "\n"; + + $prototype .= $prefix; + $prototype .= q{allow-unsafe = }; + $prototype .= $configuration->unsafe_allowed(); + $prototype .= "\n"; + + $prototype .= $prefix; + $prototype .= q{profile-strictness = }; + $prototype .= $configuration->profile_strictness(); + $prototype .= "\n"; + + $prototype .= $prefix; + $prototype .= q{color = }; + $prototype .= $configuration->color(); + $prototype .= "\n"; + + $prototype .= $prefix; + $prototype .= q{pager = }; + $prototype .= $configuration->pager(); + $prototype .= "\n"; + + $prototype .= $prefix; + $prototype .= q{top = }; + $prototype .= $configuration->top(); + $prototype .= "\n"; + + $prototype .= $prefix; + $prototype .= q{verbose = }; + $prototype .= $configuration->verbose(); + $prototype .= "\n"; + + $prototype .= $prefix; + $prototype .= q{include = }; + $prototype .= join $SPACE, $configuration->include(); + $prototype .= "\n"; + + $prototype .= $prefix; + $prototype .= q{exclude = }; + $prototype .= join $SPACE, $configuration->exclude(); + $prototype .= "\n"; + + $prototype .= $prefix; + $prototype .= q{single-policy = }; + $prototype .= join $SPACE, $configuration->single_policy(); + $prototype .= "\n"; + + $prototype .= $prefix; + $prototype .= q{theme = }; + $prototype .= $configuration->theme()->rule(); + $prototype .= "\n"; + + foreach my $item (qw< + color-severity-highest + color-severity-high + color-severity-medium + color-severity-low + color-severity-lowest + >) { + ( my $accessor = $item ) =~ s/ - /_/gmsx; + $prototype .= $prefix; + $prototype .= "$item = "; + $prototype .= $configuration->$accessor; + $prototype .= "\n"; + } + + $prototype .= $prefix; + $prototype .= q{program-extensions = }; + $prototype .= join $SPACE, $configuration->program_extensions(); + + Perl::Critic::Policy::set_format( $self->_proto_format() ); + + my $policy_prototypes = join qq{\n}, map { "$_" } @{ $self->_get_policies() }; + $policy_prototypes =~ s/\s+ \z//xms; # Trim trailing whitespace + return $prototype . "\n\n" . $policy_prototypes . "\n"; +} + +#----------------------------------------------------------------------------- + +# About "%{\\n%\\x7b# \\x7df\n${prefix}%n = %D\\n}O" below: +# +# The %0 format for a policy specifies how to format parameters. +# For a parameter %f specifies the full description. +# +# The problem is that both of these need to take options, but String::Format +# doesn't allow nesting of {}. So, to get the option to the %f, the braces +# are hex encoded. I.e., assuming that comment_out_parameters is in effect, +# the parameter sees: +# +# \n%{# }f\n# %n = %D\n + +sub _proto_format { + my ($self) = @_; + + my $prefix = $self->_line_prefix(); + + return <<"END_OF_FORMAT"; +# %a +[%p] +${prefix}set_themes = %t +${prefix}add_themes = +${prefix}severity = %s +${prefix}maximum_violations_per_document = %v +%{\\n%\\x7b# \\x7df\\n${prefix}%n = %D\\n}O%{${prefix}Cannot programmatically discover what parameters this policy takes.\\n}U +END_OF_FORMAT + +} + +#----------------------------------------------------------------------------- + +sub _by_type { return ref $a cmp ref $b } + +1; + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::ProfilePrototype - Generate an initial Perl::Critic profile. + + +=head1 DESCRIPTION + +This is a helper class that generates a prototype of a +L profile (e.g. a F<.perlcriticrc> file. +There are no user-serviceable parts here. + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 CONSTRUCTOR + +=over + +=item C<< new( -policies => \@POLICY_OBJECTS ) >> + +Returns a reference to a new C object. + + +=back + + +=head1 METHODS + +=over + +=item to_string() + +Returns a string representation of this C. See +L<"OVERLOADS"> for more information. + + +=back + + +=head1 OVERLOADS + +When a +L is +evaluated in string context, it produces a multi-line summary of the +policy name, default themes, and default severity for each +L object that was given to +the constructor of this C. If the Policy supports +an additional parameters, they will also be listed (but +commented-out). The format is suitable for use as a F<.perlcriticrc> +file. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Statistics.pm b/lib/Perl/Critic/Statistics.pm new file mode 100644 index 0000000..64860cf --- /dev/null +++ b/lib/Perl/Critic/Statistics.pm @@ -0,0 +1,412 @@ +package Perl::Critic::Statistics; + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); + +use Perl::Critic::Utils::McCabe qw{ calculate_mccabe_of_sub }; + +#----------------------------------------------------------------------------- + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +sub new { + my ( $class ) = @_; + + my $self = bless {}, $class; + + $self->{_modules} = 0; + $self->{_subs} = 0; + $self->{_statements} = 0; + $self->{_lines} = 0; + $self->{_lines_of_blank} = 0; + $self->{_lines_of_comment} = 0; + $self->{_lines_of_data} = 0; + $self->{_lines_of_perl} = 0; + $self->{_lines_of_pod} = 0; + $self->{_violations_by_policy} = {}; + $self->{_violations_by_severity} = {}; + $self->{_total_violations} = 0; + + return $self; +} + +#----------------------------------------------------------------------------- + +sub accumulate { + my ($self, $doc, $violations) = @_; + + $self->{_modules}++; + + my $subs = $doc->find('PPI::Statement::Sub'); + if ($subs) { + foreach my $sub ( @{$subs} ) { + $self->{_subs}++; + $self->{_subs_total_mccabe} += calculate_mccabe_of_sub( $sub ); + } + } + + my $statements = $doc->find('PPI::Statement'); + $self->{_statements} += $statements ? scalar @{$statements} : 0; + + ## no critic (RequireDotMatchAnything, RequireExtendedFormatting, RequireLineBoundaryMatching) + my @lines = split /$INPUT_RECORD_SEPARATOR/, $doc->serialize(); + ## use critic + $self->{_lines} += scalar @lines; + { + my ( $in_data, $in_pod ); + foreach ( @lines ) { + if ( q{=} eq substr $_, 0, 1 ) { ## no critic (ProhibitCascadingIfElse) + $in_pod = not m/ \A \s* =cut \b /smx; + $self->{_lines_of_pod}++; + } elsif ( $in_pod ) { + $self->{_lines_of_pod}++; + } elsif ( q{__END__} eq $_ || q{__DATA__} eq $_ ) { + $in_data = 1; + $self->{_lines_of_perl}++; + } elsif ( $in_data ) { + $self->{_lines_of_data}++; + } elsif ( m/ \A \s* \# /smx ) { + $self->{_lines_of_comment}++; + } elsif ( m/ \A \s* \z /smx ) { + $self->{_lines_of_blank}++; + } else { + $self->{_lines_of_perl}++; + } + } + } + + foreach my $violation ( @{ $violations } ) { + $self->{_violations_by_severity}->{ $violation->severity() }++; + $self->{_violations_by_policy}->{ $violation->policy() }++; + $self->{_total_violations}++; + } + + return; +} + +#----------------------------------------------------------------------------- + +sub modules { + my ( $self ) = @_; + + return $self->{_modules}; +} + +#----------------------------------------------------------------------------- + +sub subs { + my ( $self ) = @_; + + return $self->{_subs}; +} + +#----------------------------------------------------------------------------- + +sub statements { + my ( $self ) = @_; + + return $self->{_statements}; +} + +#----------------------------------------------------------------------------- + +sub lines { + my ( $self ) = @_; + + return $self->{_lines}; +} + +#----------------------------------------------------------------------------- + +sub lines_of_blank { + my ( $self ) = @_; + + return $self->{_lines_of_blank}; +} + +#----------------------------------------------------------------------------- + +sub lines_of_comment { + my ( $self ) = @_; + + return $self->{_lines_of_comment}; +} + +#----------------------------------------------------------------------------- + +sub lines_of_data { + my ( $self ) = @_; + + return $self->{_lines_of_data}; +} + +#----------------------------------------------------------------------------- + +sub lines_of_perl { + my ( $self ) = @_; + + return $self->{_lines_of_perl}; +} + +#----------------------------------------------------------------------------- + +sub lines_of_pod { + my ( $self ) = @_; + + return $self->{_lines_of_pod}; +} + +#----------------------------------------------------------------------------- + +sub _subs_total_mccabe { + my ( $self ) = @_; + + return $self->{_subs_total_mccabe}; +} + +#----------------------------------------------------------------------------- + +sub violations_by_severity { + my ( $self ) = @_; + + return $self->{_violations_by_severity}; +} + +#----------------------------------------------------------------------------- + +sub violations_by_policy { + my ( $self ) = @_; + + return $self->{_violations_by_policy}; +} + +#----------------------------------------------------------------------------- + +sub total_violations { + my ( $self ) = @_; + + return $self->{_total_violations}; +} + +#----------------------------------------------------------------------------- + +sub statements_other_than_subs { + my ( $self ) = @_; + + return $self->statements() - $self->subs(); +} + +#----------------------------------------------------------------------------- + +sub average_sub_mccabe { + my ( $self ) = @_; + + return if $self->subs() == 0; + + return $self->_subs_total_mccabe() / $self->subs(); +} + +#----------------------------------------------------------------------------- + +sub violations_per_file { + my ( $self ) = @_; + + return if $self->modules() == 0; + + return $self->total_violations() / $self->modules(); +} + +#----------------------------------------------------------------------------- + +sub violations_per_statement { + my ( $self ) = @_; + + my $statements = $self->statements_other_than_subs(); + + return if $statements == 0; + + return $self->total_violations() / $statements; +} + +#----------------------------------------------------------------------------- + +sub violations_per_line_of_code { + my ( $self ) = @_; + + return if $self->lines() == 0; + + return $self->total_violations() / $self->lines(); +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords McCabe + +=head1 NAME + +Perl::Critic::Statistics - Compile stats on Perl::Critic violations. + + +=head1 DESCRIPTION + +This class accumulates statistics on Perl::Critic violations across one or +more files. NOTE: This class is experimental and subject to change. + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 METHODS + +=over + +=item C + +Create a new instance of Perl::Critic::Statistics. No arguments are supported +at this time. + + +=item C< accumulate( $doc, \@violations ) > + +Accumulates statistics about the C<$doc> and the C<@violations> that were +found. + + +=item C + +The number of chunks of code (usually files) that have been analyzed. + + +=item C + +The total number of subroutines analyzed by this Critic. + + +=item C + +The total number of statements analyzed by this Critic. + + +=item C + +The total number of lines of code analyzed by this Critic. + + +=item C + +The total number of blank lines analyzed by this Critic. This includes only +blank lines in code, not POD or data. + + +=item C + +The total number of comment lines analyzed by this Critic. This includes only +lines whose first non-whitespace character is C<#>. + + +=item C + +The total number of lines of data section analyzed by this Critic, not +counting the C<__END__> or C<__DATA__> line. POD in a data section is counted +as POD, not data. + + +=item C + +The total number of lines of Perl code analyzed by this Critic. Perl appearing +in the data section is not counted. + + +=item C + +The total number of lines of POD analyzed by this Critic. Pod occurring in a +data section is counted as POD, not as data. + + +=item C + +The number of violations of each severity found by this Critic as a +reference to a hash keyed by severity. + + +=item C + +The number of violations of each policy found by this Critic as a +reference to a hash keyed by full policy name. + + +=item C + +The total number of violations found by this Critic. + + +=item C + +The total number of statements minus the number of subroutines. +Useful because a subroutine is considered a statement by PPI. + + +=item C + +The average McCabe score of all scanned subroutines. + + +=item C + +The total violations divided by the number of modules. + + +=item C + +The total violations divided by the number statements minus +subroutines. + + +=item C + +The total violations divided by the lines of code. + + +=back + + +=head1 AUTHOR + +Elliot Shank C<< >> + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/TestUtils.pm b/lib/Perl/Critic/TestUtils.pm new file mode 100644 index 0000000..4cc412f --- /dev/null +++ b/lib/Perl/Critic/TestUtils.pm @@ -0,0 +1,660 @@ +package Perl::Critic::TestUtils; + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); +use Readonly; + +use Exporter 'import'; + +use File::Path (); +use File::Spec (); +use File::Spec::Unix (); +use File::Temp (); +use File::Find qw( find ); + +use Perl::Critic; +use Perl::Critic::Config; +use Perl::Critic::Exception::Fatal::Generic qw{ &throw_generic }; +use Perl::Critic::Exception::Fatal::Internal qw{ &throw_internal }; +use Perl::Critic::Utils qw{ :severities :data_conversion policy_long_name }; +use Perl::Critic::PolicyFactory (-test => 1); + +our $VERSION = '1.140'; + +Readonly::Array our @EXPORT_OK => qw( + pcritique pcritique_with_violations + critique critique_with_violations + fcritique fcritique_with_violations + subtests_in_tree + should_skip_author_tests + get_author_test_skip_message + starting_points_including_examples + bundled_policy_names + names_of_policies_willing_to_work +); + +sub assert_version { + my $expected_version = shift; + + if ( $expected_version ne $Perl::Critic::VERSION ) { + require Carp; + Carp::confess( "Expected Perl::Critic $expected_version but it is actually $Perl::Critic::VERSION" ); + } + + return; +} + +#----------------------------------------------------------------------------- +# If the user already has an existing perlcriticrc file, it will get +# in the way of these test. This little tweak to ensures that we +# don't find the perlcriticrc file. + +sub block_perlcriticrc { + no warnings 'redefine'; ## no critic (ProhibitNoWarnings); + *Perl::Critic::UserProfile::_find_profile_path = sub { return }; ## no critic (ProtectPrivateVars) + return 1; +} + +#----------------------------------------------------------------------------- +# Criticize a code snippet using only one policy. Returns the violations. + +sub pcritique_with_violations { + my($policy, $code_ref, $config_ref) = @_; + my $c = Perl::Critic->new( -profile => 'NONE' ); + $c->add_policy(-policy => $policy, -config => $config_ref); + return $c->critique($code_ref); +} + +#----------------------------------------------------------------------------- +# Criticize a code snippet using only one policy. Returns the number +# of violations + +sub pcritique { ##no critic(ArgUnpacking) + return scalar pcritique_with_violations(@_); +} + +#----------------------------------------------------------------------------- +# Criticize a code snippet using a specified config. Returns the violations. + +sub critique_with_violations { + my ($code_ref, $config_ref) = @_; + my $c = Perl::Critic->new( %{$config_ref} ); + return $c->critique($code_ref); +} + +#----------------------------------------------------------------------------- +# Criticize a code snippet using a specified config. Returns the +# number of violations + +sub critique { ##no critic(ArgUnpacking) + return scalar critique_with_violations(@_); +} + +#----------------------------------------------------------------------------- +# Like pcritique_with_violations, but forces a PPI::Document::File context. +# The $filename arg is a Unix-style relative path, like 'Foo/Bar.pm' + +Readonly::Scalar my $TEMP_FILE_PERMISSIONS => oct 700; + +sub fcritique_with_violations { + my($policy, $code_ref, $filename, $config_ref) = @_; + my $c = Perl::Critic->new( -profile => 'NONE' ); + $c->add_policy(-policy => $policy, -config => $config_ref); + + my $dir = File::Temp::tempdir( 'PerlCritic-tmpXXXXXX', TMPDIR => 1 ); + $filename ||= 'Temp.pm'; + my @fileparts = File::Spec::Unix->splitdir($filename); + if (@fileparts > 1) { + my $subdir = File::Spec->catdir($dir, @fileparts[0..$#fileparts-1]); + File::Path::mkpath($subdir, 0, $TEMP_FILE_PERMISSIONS); + } + my $file = File::Spec->catfile($dir, @fileparts); + if (open my $fh, '>', $file) { + print {$fh} ${$code_ref}; + close $fh or throw_generic "unable to close $file: $OS_ERROR"; + } + + # Use eval so we can clean up before throwing an exception in case of + # error. + my @v = eval {$c->critique($file)}; + my $err = $EVAL_ERROR; + File::Path::rmtree($dir, 0, 1); + if ($err) { + throw_generic $err; + } + return @v; +} + +#----------------------------------------------------------------------------- +# Like pcritique, but forces a PPI::Document::File context. The +# $filename arg is a Unix-style relative path, like 'Foo/Bar.pm' + +sub fcritique { ##no critic(ArgUnpacking) + return scalar fcritique_with_violations(@_); +} + +# Note: $include_extras is not documented in the POD because I'm not +# committing to the interface yet. +sub subtests_in_tree { + my ($start, $include_extras) = @_; + + my %subtests; + + find( + { + wanted => sub { + return if not -f; + + my ($fileroot) = m{(.+)[.]run\z}xms; + + return if not $fileroot; + + my @pathparts = File::Spec->splitdir($fileroot); + if (@pathparts < 2) { + throw_internal 'confusing policy test filename ' . $_; + } + + my $policy = join q{::}, @pathparts[-2, -1]; ## no critic (MagicNumbers) + + my $globals = _globals_from_file( $_ ); + if ( my $prerequisites = $globals->{prerequisites} ) { + foreach my $prerequisite ( keys %{$prerequisites} ) { + eval "require $prerequisite; 1" or return; + } + } + + my @subtests = _subtests_from_file( $_ ); + + if ($include_extras) { + $subtests{$policy} = + { subtests => [ @subtests ], globals => $globals }; + } + else { + $subtests{$policy} = [ @subtests ]; + } + + return; + }, + no_chdir => 1, + }, + $start + ); + + return \%subtests; +} + +# Answer whether author test should be run. +# +# Note: this code is duplicated in +# t/tlib/Perl/Critic/TestUtilitiesWithMinimalDependencies.pm. +# If you change this here, make sure to change it there. + +sub should_skip_author_tests { + return not $ENV{TEST_AUTHOR_PERL_CRITIC} +} + +sub get_author_test_skip_message { + ## no critic (RequireInterpolation); + return 'Author test. Set $ENV{TEST_AUTHOR_PERL_CRITIC} to a true value to run.'; +} + + +sub starting_points_including_examples { + return (-e 'blib' ? 'blib' : 'lib', 'examples'); +} + +sub _globals_from_file { + my $test_file = shift; + + my %valid_keys = hashify qw< prerequisites >; + + return if -z $test_file; # Skip if the Policy has a regular .t file. + + my %globals; + + open my $handle, '<', $test_file ## no critic (RequireBriefOpen) + or throw_internal "Couldn't open $test_file: $OS_ERROR"; + + while ( my $line = <$handle> ) { + chomp; + + if ( + my ($key,$value) = + $line =~ m<\A [#][#] [ ] global [ ] (\S+) (?:\s+(.+))? >xms + ) { + next if not $key; + if ( not $valid_keys{$key} ) { + throw_internal "Unknown global key $key in $test_file"; + } + + if ( $key eq 'prerequisites' ) { + $value = { hashify( words_from_string($value) ) }; + } + $globals{$key} = $value; + } + } + close $handle or throw_generic "unable to close $test_file: $OS_ERROR"; + + return \%globals; +} + +# The internal representation of a subtest is just a hash with some +# named keys. It could be an object with accessors for safety's sake, +# but at this point I don't see why. +sub _subtests_from_file { + my $test_file = shift; + + my %valid_keys = hashify qw( name failures parms TODO error filename optional_modules ); + + return if -z $test_file; # Skip if the Policy has a regular .t file. + + open my $fh, '<', $test_file ## no critic (RequireBriefOpen) + or throw_internal "Couldn't open $test_file: $OS_ERROR"; + + my @subtests; + + my $incode = 0; + my $cut_in_code = 0; + my $subtest; + my $lineno; + while ( <$fh> ) { + ++$lineno; + chomp; + my $inheader = /^## name/ .. /^## cut/; ## no critic (ExtendedFormatting LineBoundaryMatching DotMatchAnything) + + my $line = $_; + + if ( $inheader ) { + $line =~ m/\A [#]/xms or throw_internal "Code before cut: $test_file"; + my ($key,$value) = $line =~ m/\A [#][#] [ ] (\S+) (?:\s+(.+))? /xms; + next if !$key; + next if $key eq 'cut'; + if ( not $valid_keys{$key} ) { + throw_internal "Unknown key $key in $test_file"; + } + + if ( $key eq 'name' ) { + if ( $subtest ) { # Stash any current subtest + push @subtests, _finalize_subtest( $subtest ); + undef $subtest; + } + $subtest->{lineno} = $lineno; + $incode = 0; + $cut_in_code = 0; + } + if ($incode) { + throw_internal "Header line found while still in code: $test_file"; + } + $subtest->{$key} = $value; + } + elsif ( $subtest ) { + $incode = 1; + $cut_in_code ||= $line =~ m/ \A [#][#] [ ] cut \z /smx; + # Don't start a subtest if we're not in one. + # Don't add to the test if we have seen a '## cut'. + $cut_in_code or push @{$subtest->{code}}, $line; + } + elsif (@subtests) { + ## don't complain if we have not yet hit the first test + throw_internal "Got some code but I'm not in a subtest: $test_file"; + } + } + close $fh or throw_generic "unable to close $test_file: $OS_ERROR"; + if ( $subtest ) { + if ( $incode ) { + push @subtests, _finalize_subtest( $subtest ); + } + else { + throw_internal "Incomplete subtest in $test_file"; + } + } + + return @subtests; +} + +sub _finalize_subtest { + my $subtest = shift; + + if ( $subtest->{code} ) { + $subtest->{code} = join "\n", @{$subtest->{code}}; + } + else { + throw_internal "$subtest->{name} has no code lines"; + } + if ( !defined $subtest->{failures} ) { + throw_internal "$subtest->{name} does not specify failures"; + } + if ($subtest->{parms}) { + $subtest->{parms} = eval $subtest->{parms}; ## no critic(StringyEval) + if ($EVAL_ERROR) { + throw_internal + "$subtest->{name} has an error in the 'parms' property:\n" + . $EVAL_ERROR; + } + if ('HASH' ne ref $subtest->{parms}) { + throw_internal + "$subtest->{name} 'parms' did not evaluate to a hashref"; + } + } else { + $subtest->{parms} = {}; + } + + if (defined $subtest->{error}) { + if ( $subtest->{error} =~ m{ \A / (.*) / \z }xms) { + $subtest->{error} = eval {qr/$1/}; ## no critic (ExtendedFormatting LineBoundaryMatching DotMatchAnything) + if ($EVAL_ERROR) { + throw_internal + "$subtest->{name} 'error' has a malformed regular expression"; + } + } + } + + return $subtest; +} + +sub bundled_policy_names { + require ExtUtils::Manifest; + my $manifest = ExtUtils::Manifest::maniread(); + my @policy_paths = map {m{\A lib/(Perl/Critic/Policy/.*).pm \z}xms} keys %{$manifest}; + my @policies = map { join q{::}, split m{/}xms } @policy_paths; + my @sorted_policies = sort @policies; + return @sorted_policies; +} + +sub names_of_policies_willing_to_work { + my %configuration = @_; + + my @policies_willing_to_work = + Perl::Critic::Config + ->new( %configuration ) + ->policies(); + + return map { ref } @policies_willing_to_work; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords RCS subtest subtests + +=head1 NAME + +Perl::Critic::TestUtils - Utility functions for testing new Policies. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public module. Any changes to its +interface will go through a deprecation cycle. + + +=head1 SYNOPSIS + + use Perl::Critic::TestUtils qw(critique pcritique fcritique); + + my $code = '< 2 }; + my $violation_count = critique( \$code, $perl_critic_config); + + # Critique code against one policy... + my $custom_policy = 'Miscellanea::ProhibitFrobulation' + my $violation_count = pcritique( $custom_policy, \$code ); + + # Critique code against one filename-related policy... + my $custom_policy = 'Modules::RequireFilenameMatchesPackage' + my $violation_count = fcritique( $custom_policy, \$code, 'Foo/Bar.pm' ); + + +=head1 DESCRIPTION + +This module is used by L only for +self-testing. It provides a few handy subroutines for testing new +Perl::Critic::Policy modules. Look at the test programs that ship with +Perl::Critic for more examples of how to use these subroutines. + + +=head1 EXPORTS + +=over + +=item assert_version( $version ) + +Asserts that the C<$version> passed matches the version of Perl::Critic. + + +=item block_perlcriticrc() + +If a user has a F<~/.perlcriticrc> file, this can interfere with +testing. This handy method disables the search for that file -- +simply call it at the top of your F<.t> program. Note that this is +not easily reversible, but that should not matter. + + +=item critique_with_violations( $code_string_ref, $config_ref ) + +Test a block of code against the specified Perl::Critic::Config +instance (or C for the default). Returns the violations that +occurred. + + +=item critique( $code_string_ref, $config_ref ) + +Test a block of code against the specified Perl::Critic::Config +instance (or C for the default). Returns the number of +violations that occurred. + + +=item pcritique_with_violations( $policy_name, $code_string_ref, $config_ref ) + +Like C, but tests only a single policy +instead of the whole bunch. + + +=item pcritique( $policy_name, $code_string_ref, $config_ref ) + +Like C, but tests only a single policy instead of the +whole bunch. + + +=item fcritique_with_violations( $policy_name, $code_string_ref, $filename, $config_ref ) + +Like C, but pretends that the code was +loaded from the specified filename. This is handy for testing +policies like C which care +about the filename that the source derived from. + +The C<$filename> parameter must be a relative path, not absolute. The +file and all necessary subdirectories will be created via +L and will be automatically deleted. + + +=item fcritique( $policy_name, $code_string_ref, $filename, $config_ref ) + +Like C, but pretends that the code was loaded from the +specified filename. This is handy for testing policies like +C which care about the +filename that the source derived from. + +The C<$filename> parameter must be a relative path, not absolute. The +file and all necessary subdirectories will be created via +L and will be automatically deleted. + + +=item subtests_in_tree( $dir ) + +Searches the specified directory recursively for F<.run> files. Each +one found is parsed and a hash-of-list-of-hashes is returned. The +outer hash is keyed on policy short name, like +C. The inner hash specifies a single test +to be handed to C or C, including the code +string, test name, etc. See below for the syntax of the F<.run> +files. + + +=item should_skip_author_tests() + +Answers whether author tests should run. + + +=item get_author_test_skip_message() + +Returns a string containing the message that should be emitted when a +test is skipped due to it being an author test when author tests are +not enabled. + + +=item starting_points_including_examples() + +Returns a list of the directories contain code that needs to be tested +when it is desired that the examples be included. + + +=item bundled_policy_names() + +Returns a list of Policy packages that come bundled with this package. +This functions by searching F for +F and converts the results to package +names. + + +=item names_of_policies_willing_to_work( %configuration ) + +Returns a list of the packages of policies that are willing to +function on the current system using the specified configuration. + + +=back + + +=head1 F<.run> file information + +Testing a policy follows a very simple pattern: + + * Policy name + * Subtest name + * Optional parameters + * Number of failures expected + * Optional exception expected + * Optional filename for code + +Each of the subtests for a policy is collected in a single F<.run> +file, with test properties as comments in front of each code block +that describes how we expect Perl::Critic to react to the code. For +example, say you have a policy called Variables::ProhibitVowels: + + (In file t/Variables/ProhibitVowels.run) + + ## name Basics + ## failures 1 + ## cut + + my $vrbl_nm = 'foo'; # Good, vowel-free name + my $wango = 12; # Bad, pronouncable name + + + ## name Sometimes Y + ## failures 1 + ## cut + + my $yllw = 0; # "y" not a vowel here + my $rhythm = 12; # But here it is + +These are called "subtests", and two are shown above. The beauty of +incorporating multiple subtests in a file is that the F<.run> is +itself a (mostly) valid Perl file, and not hidden in a HEREDOC, so +your editor's color-coding still works, and it is much easier to work +with the code and the POD. + +If you need to pass any configuration parameters for your subtest, do +so like this: + + ## parms { allow_y => '0' } + +Note that all the values in this hash must be strings because that's +what Perl::Critic will hand you from a F<.perlcriticrc>. + +If it's a TODO subtest (probably because of some weird corner of PPI +that we exercised that Adam is getting around to fixing, right?), then +make a C<##TODO> entry. + + ## TODO Should pass when PPI 1.xxx comes out + +If the code is expected to trigger an exception in the policy, +indicate that like so: + + ## error 1 + +If you want to test the error message, mark it with C to +indicate a C test: + + ## error /Can't load Foo::Bar/ + +If the policy you are testing cares about the filename of the code, +you can indicate that C should be used like so (see +C for more details): + + ## filename lib/Foo/Bar.pm + +The value of C will get Ced and passed to C, +so be careful. + +In general, a subtest document runs from the C<## cut> that starts it to +either the next C<## name> or the end of the file. In very rare circumstances +you may need to end the test document earlier. A second C<## cut> will do +this. The only known need for this is in +F, where it is used to prevent the RCS +keywords in the file footer from producing false positives or negatives in the +last test. + +Note that nowhere within the F<.run> file itself do you specify the +policy that you're testing. That's implicit within the filename. + + +=head1 BUGS AND CAVEATS AND TODO ITEMS + +Test that we have a t/*/*.run for each lib/*/*.pm + +Allow us to specify the nature of the failures, and which one. If +there are 15 lines of code, and six of them fail, how do we know +they're the right six? + + +=head1 AUTHOR + +Chris Dolan +and the rest of the L team. + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Chris Dolan. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Theme.pm b/lib/Perl/Critic/Theme.pm new file mode 100644 index 0000000..7aadede --- /dev/null +++ b/lib/Perl/Critic/Theme.pm @@ -0,0 +1,250 @@ +package Perl::Critic::Theme; + +use 5.006001; +use strict; +use warnings; +use English qw(-no_match_vars); +use Readonly; + +use Exporter 'import'; + +use Perl::Critic::Utils qw{ :characters :data_conversion }; +use Perl::Critic::Exception::Fatal::Internal qw{ &throw_internal }; +use Perl::Critic::Exception::Configuration::Option::Global::ParameterValue + qw{ &throw_global_value }; + +#----------------------------------------------------------------------------- + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Array our @EXPORT_OK => qw{ + $RULE_INVALID_CHARACTER_REGEX + cook_rule +}; + +#----------------------------------------------------------------------------- + +Readonly::Scalar our $RULE_INVALID_CHARACTER_REGEX => + qr/ ( [^()\s\w\d+\-*&|!] ) /xms; + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $CONFIG_KEY => 'theme'; + +#----------------------------------------------------------------------------- + +sub new { + + my ( $class, %args ) = @_; + my $self = bless {}, $class; + $self->_init( %args ); + return $self; +} + +#----------------------------------------------------------------------------- + +sub _init { + + my ($self, %args) = @_; + my $rule = $args{-rule} || $EMPTY; + + if ( $rule =~ m/$RULE_INVALID_CHARACTER_REGEX/xms ) { + throw_global_value + option_name => $CONFIG_KEY, + option_value => $rule, + message_suffix => qq{contains an invalid character: "$1".}; + } + + $self->{_rule} = cook_rule( $rule ); + + return $self; +} + +#----------------------------------------------------------------------------- + +sub rule { + my $self = shift; + return $self->{_rule}; +} + +#----------------------------------------------------------------------------- + +sub policy_is_thematic { + + my ($self, %args) = @_; + my $policy = $args{-policy} + || throw_internal 'The -policy argument is required'; + ref $policy + || throw_internal 'The -policy must be an object'; + + my $rule = $self->{_rule} or return 1; + my %themes = hashify( $policy->get_themes() ); + + # This bit of magic turns the rule into a perl expression that can be + # eval-ed for truth. Each theme name in the rule is translated to 1 or 0 + # if the $policy belongs in that theme. For example: + # + # 'bugs && (pbp || core)' ...could become... '1 && (0 || 1)' + + my $as_code = $rule; #Making a copy, so $rule is preserved + $as_code =~ s/ ( [\w\d]+ ) /exists $themes{$1} || 0/gexms; + my $is_thematic = eval $as_code; ## no critic (ProhibitStringyEval) + + if ($EVAL_ERROR) { + throw_global_value + option_name => $CONFIG_KEY, + option_value => $rule, + message_suffix => q{contains a syntax error.}; + } + + return $is_thematic; +} + +#----------------------------------------------------------------------------- + +sub cook_rule { + my ($raw_rule) = @_; + return if not defined $raw_rule; + + #Translate logical operators + $raw_rule =~ s{\b not \b}{!}ixmsg; # "not" -> "!" + $raw_rule =~ s{\b and \b}{&&}ixmsg; # "and" -> "&&" + $raw_rule =~ s{\b or \b}{||}ixmsg; # "or" -> "||" + + #Translate algebra operators (for backward compatibility) + $raw_rule =~ s{\A [-] }{!}ixmsg; # "-" -> "!" e.g. difference + $raw_rule =~ s{ [-] }{&& !}ixmsg; # "-" -> "&& !" e.g. difference + $raw_rule =~ s{ [*] }{&&}ixmsg; # "*" -> "&&" e.g. intersection + $raw_rule =~ s{ [+] }{||}ixmsg; # "+" -> "||" e.g. union + + my $cooked_rule = lc $raw_rule; #Is now cooked! + return $cooked_rule; +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +Perl::Critic::Theme - Construct thematic sets of policies. + + +=head1 DESCRIPTION + +This is a helper class for evaluating theme expressions into sets of +Policy objects. There are no user-serviceable parts here. + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 METHODS + +=over + +=item C<< new( -rule => $rule_expression ) >> + +Returns a reference to a new Perl::Critic::Theme object. C<-rule> is +a string expression that evaluates to true or false for each Policy.. +See L<"THEME RULES"> for more information. + + +=item C<< policy_is_thematic( -policy => $policy ) >> + +Given a reference to a L +object, this method returns evaluates the rule against the themes that +are associated with the Policy. Returns 1 if the Policy satisfies the +rule, 0 otherwise. + + +=item C< rule() > + +Returns the rule expression that was used to construct this Theme. +The rule may have been translated into a normalized expression. See +L<"THEME RULES"> for more information. + +=back + + +=head2 THEME RULES + +A theme rule is a simple boolean expression, where the operands are +the names of any of the themes associated with the +Perl::Critic::Polices. + +Theme names can be combined with logical operators to form arbitrarily +complex expressions. Precedence is the same as normal mathematics, +but you can use parentheses to enforce precedence as well. Supported +operators are: + + Operator Altertative Example + ---------------------------------------------------------------- + && and 'pbp && core' + || or 'pbp || (bugs && security)' + ! not 'pbp && ! (portability || complexity) + +See L for more information about +customizing the themes for each Policy. + + +=head1 SUBROUTINES + +=over + +=item C + +Standardize a rule into a almost executable Perl code. The "almost" +comes from the fact that theme names are left as is. + + +=back + + +=head1 CONSTANTS + +=over + +=item C<$RULE_INVALID_CHARACTER_REGEX> + +A regular expression that will return the first character in the +matched expression that is not valid in a rule. + + +=back + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2006-2011 Imaginative Software Systems + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/ThemeListing.pm b/lib/Perl/Critic/ThemeListing.pm new file mode 100644 index 0000000..190225f --- /dev/null +++ b/lib/Perl/Critic/ThemeListing.pm @@ -0,0 +1,124 @@ +package Perl::Critic::ThemeListing; + +use 5.006001; +use strict; +use warnings; + +use English qw<-no_match_vars>; + +use Perl::Critic::Utils qw< hashify >; + +use overload ( q<""> => 'to_string' ); + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +sub new { + my ($class, %args) = @_; + + my $self = bless {}, $class; + + $self->{_policies} = $args{-policies} || []; + + return $self; +} + +#----------------------------------------------------------------------------- + +sub to_string { + my ($self) = @_; + + my %themes; + foreach my $policy ( @{ $self->{_policies} } ) { + my @themes = $policy->get_themes(); + @themes{ @themes } = @themes; + } + + return join ("\n", sort keys %themes) . "\n"; +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::ThemeListing - List the themes of the installed Policies. + + +=head1 DESCRIPTION + +This is a helper class that gathers the themes of the installed +Policies. There are no user-serviceable parts here. + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 CONSTRUCTOR + +=over + +=item C<< new( -policies => \@POLICY_OBJECTS ) >> + +Returns a reference to a new C object. + + +=back + + +=head1 METHODS + +=over + + +=item to_string() + +Returns a string representation of this C. See +L<"OVERLOADS"> for more information. + + +=back + + +=head1 OVERLOADS + + +When a L is +evaluated in string context, it produces a one-line summary of the +default severity, policy name, and default themes for each +L object that was given to +the constructor of this C. + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/UserProfile.pm b/lib/Perl/Critic/UserProfile.pm new file mode 100644 index 0000000..ac7b44f --- /dev/null +++ b/lib/Perl/Critic/UserProfile.pm @@ -0,0 +1,418 @@ +package Perl::Critic::UserProfile; + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); +use Readonly; + +use Config::Tiny qw(); +use File::Spec qw(); + +use Perl::Critic::OptionsProcessor qw(); +use Perl::Critic::Utils qw{ $EMPTY policy_long_name policy_short_name }; +use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal }; +use Perl::Critic::Exception::Configuration::Generic qw{ throw_generic }; +use Perl::Critic::PolicyConfig; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +sub new { + + my ( $class, %args ) = @_; + my $self = bless {}, $class; + $self->_init( %args ); + return $self; +} + +#----------------------------------------------------------------------------- + +sub _init { + + my ( $self, %args ) = @_; + # The profile can be defined, undefined, or an empty string. + my $profile = defined $args{-profile} ? $args{-profile} : _find_profile_path(); + $self->_load_profile( $profile ); + $self->_set_options_processor(); + return $self; +} + +#----------------------------------------------------------------------------- + +sub options_processor { + + my ($self) = @_; + return $self->{_options_processor}; +} + +#----------------------------------------------------------------------------- + +sub policy_params { + + my ( $self, $policy ) = @_; + + my $short_name = policy_short_name($policy); + + return Perl::Critic::PolicyConfig->new( + $short_name, + $self->raw_policy_params($policy), + ); +} + +#----------------------------------------------------------------------------- + +sub raw_policy_params { + + my ( $self, $policy ) = @_; + my $profile = $self->{_profile}; + my $long_name = ref $policy || policy_long_name( $policy ); + my $short_name = policy_short_name( $long_name ); + + return + $profile->{$short_name} + || $profile->{$long_name} + || $profile->{"-$short_name"} + || $profile->{"-$long_name"} + || {}; +} + +#----------------------------------------------------------------------------- + +sub policy_is_disabled { + + my ( $self, $policy ) = @_; + my $profile = $self->{_profile}; + my $long_name = ref $policy || policy_long_name( $policy ); + my $short_name = policy_short_name( $long_name ); + + return exists $profile->{"-$short_name"} + || exists $profile->{"-$long_name"}; +} + +#----------------------------------------------------------------------------- + +sub policy_is_enabled { + + my ( $self, $policy ) = @_; + my $profile = $self->{_profile}; + my $long_name = ref $policy || policy_long_name( $policy ); + my $short_name = policy_short_name( $long_name ); + + return exists $profile->{$short_name} + || exists $profile->{$long_name}; +} + +#----------------------------------------------------------------------------- + +sub listed_policies { + + my ( $self, $policy ) = @_; + my @normalized_policy_names = (); + + for my $policy_name ( sort keys %{$self->{_profile}} ) { + $policy_name =~ s/\A - //xmso; #Chomp leading "-" + my $policy_long_name = policy_long_name( $policy_name ); + push @normalized_policy_names, $policy_long_name; + } + + return @normalized_policy_names; +} + +#----------------------------------------------------------------------------- + +sub source { + my ( $self ) = @_; + + return $self->{_source}; +} + +sub _set_source { + my ( $self, $source ) = @_; + + $self->{_source} = $source; + + return; +} + +#----------------------------------------------------------------------------- +# Begin PRIVATE methods + +Readonly::Hash my %LOADER_FOR => ( + ARRAY => \&_load_profile_from_array, + DEFAULT => \&_load_profile_from_file, + HASH => \&_load_profile_from_hash, + SCALAR => \&_load_profile_from_string, +); + +sub _load_profile { + + my ( $self, $profile ) = @_; + + my $ref_type = ref $profile || 'DEFAULT'; + my $loader = $LOADER_FOR{$ref_type}; + + if (not $loader) { + throw_internal qq{Can't load UserProfile from type "$ref_type"}; + } + + $self->{_profile} = $loader->($self, $profile); + return $self; +} + +#----------------------------------------------------------------------------- + +sub _set_options_processor { + + my ($self) = @_; + my $profile = $self->{_profile}; + my $defaults = delete $profile->{__defaults__} || {}; + $self->{_options_processor} = + Perl::Critic::OptionsProcessor->new( %{ $defaults } ); + return $self; +} + +#----------------------------------------------------------------------------- + +sub _load_profile_from_file { + my ( $self, $file ) = @_; + + # Handle special cases. + return {} if not defined $file; + return {} if $file eq $EMPTY; + return {} if $file eq 'NONE'; + + $self->_set_source( $file ); + + my $profile = Config::Tiny->read( $file ); + if (not defined $profile) { + my $errstr = Config::Tiny::errstr(); + throw_generic + message => qq{Could not parse profile "$file": $errstr}, + source => $file; + } + + _fix_defaults_key( $profile ); + + return $profile; +} + +#----------------------------------------------------------------------------- + +sub _load_profile_from_array { + my ( $self, $array_ref ) = @_; + my $joined = join qq{\n}, @{ $array_ref }; + my $profile = Config::Tiny->read_string( $joined ); + + if (not defined $profile) { + throw_generic 'Profile error: ' . Config::Tiny::errstr(); + } + + _fix_defaults_key( $profile ); + + return $profile; +} + +#----------------------------------------------------------------------------- + +sub _load_profile_from_string { + my ( $self, $string ) = @_; + my $profile = Config::Tiny->read_string( ${ $string } ); + + if (not defined $profile) { + throw_generic 'Profile error: ' . Config::Tiny::errstr(); + } + + _fix_defaults_key( $profile ); + + return $profile; +} + +#----------------------------------------------------------------------------- + +sub _load_profile_from_hash { + my ( $self, $hash_ref ) = @_; + return $hash_ref; +} + +#----------------------------------------------------------------------------- + +sub _find_profile_path { + + #Define default filename + my $rc_file = '.perlcriticrc'; + + #Check explicit environment setting + return $ENV{PERLCRITIC} if exists $ENV{PERLCRITIC}; + + #Check current directory + return $rc_file if -f $rc_file; + + #Check home directory + if ( my $home_dir = _find_home_dir() ) { + my $path = File::Spec->catfile( $home_dir, $rc_file ); + return $path if -f $path; + } + + #No profile defined + return; +} + +#----------------------------------------------------------------------------- + +sub _find_home_dir { + # This logic is taken from File::HomeDir::Tiny. + return + ($^O eq 'MSWin32') && ("$]" < 5.016) ## no critic ( Variables::ProhibitPunctuationVars ValuesAndExpressions::ProhibitMagicNumbers ValuesAndExpressions::ProhibitMismatchedOperators ) + ? ($ENV{HOME} || $ENV{USERPROFILE}) + : (<~>)[0]; +} + +#----------------------------------------------------------------------------- + +# !$%@$%^ Config::Tiny uses a completely non-descriptive name for global +# values. +sub _fix_defaults_key { + my ( $profile ) = @_; + + my $defaults = delete $profile->{_}; + if ($defaults) { + $profile->{__defaults__} = $defaults; + } + + return; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords UserProfile + +=head1 NAME + +Perl::Critic::UserProfile - The contents of the user's profile, often F<.perlcriticrc>. + + +=head1 DESCRIPTION + +This is a helper class that encapsulates the contents of the user's +profile, which is usually stored in a F<.perlcriticrc> file. There are +no user-serviceable parts here. + + +=head1 INTERFACE SUPPORT + +This is considered to be a non-public class. Its interface is subject +to change without notice. + + +=head1 CONSTRUCTOR + +=over + +=item C< new( -profile => $p ) > + +B<-profile> is the path to the user's profile. If -profile is not +defined, then it looks for the profile at F<./.perlcriticrc> and then +F<$HOME/.perlcriticrc>. If neither of those files exists, then the +UserProfile is created with default values. + +This object does not take into account any command-line overrides; +L does that. + + +=back + + +=head1 METHODS + +=over + +=item C< options_processor() > + +Returns the +L +object for this UserProfile. + + +=item C< policy_is_disabled( $policy ) > + +Given a reference to a L +object or the name of one, returns true if the user has disabled that +policy in their profile. + + +=item C< policy_is_enabled( $policy ) > + +Given a reference to a L +object or the name of one, returns true if the user has explicitly +enabled that policy in their user profile. + + +=item C< policy_params( $policy ) > + +Given a reference to a L +object or the name of one, returns a +L for the +user's configuration parameters for that policy. + + +=item C< raw_policy_params( $policy ) > + +Given a reference to a L +object or the name of one, returns a reference to a hash of the user's +configuration parameters for that policy. + + +=item C< listed_policies() > + +Returns a list of the names of all the Policies that are mentioned in +the profile. The Policy names will be fully qualified (e.g. +Perl::Critic::Foo). + + +=item C< source() > + +The place where the profile information came from, if available. +Usually the path to a F<.perlcriticrc>. + + +=back + + +=head1 SEE ALSO + +L, +L + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Utils.pm b/lib/Perl/Critic/Utils.pm new file mode 100644 index 0000000..4383317 --- /dev/null +++ b/lib/Perl/Critic/Utils.pm @@ -0,0 +1,2021 @@ +# NOTE: This module is way too large. Please think about adding new +# functionality into a P::C::Utils::* module instead. + +package Perl::Critic::Utils; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Carp qw( confess ); +use English qw(-no_match_vars); +use File::Find qw(); +use File::Spec qw(); +use Scalar::Util qw( blessed ); +use B::Keywords qw(); +use PPI::Token::Quote::Single; +use List::MoreUtils qw(any); + +use Perl::Critic::Exception::Fatal::Generic qw{ throw_generic }; +use Perl::Critic::Utils::PPI qw< is_ppi_expression_or_generic_statement >; + +use Exporter 'import'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- +# Exportable symbols here. + +Readonly::Array our @EXPORT_OK => qw( + $TRUE + $FALSE + + $POLICY_NAMESPACE + + $SEVERITY_HIGHEST + $SEVERITY_HIGH + $SEVERITY_MEDIUM + $SEVERITY_LOW + $SEVERITY_LOWEST + @SEVERITY_NAMES + + $DEFAULT_VERBOSITY + $DEFAULT_VERBOSITY_WITH_FILE_NAME + + $COLON + $COMMA + $DQUOTE + $EMPTY + $EQUAL + $FATCOMMA + $PERIOD + $PIPE + $QUOTE + $BACKTICK + $SCOLON + $SPACE + $SLASH + $BSLASH + $LEFT_PAREN + $RIGHT_PAREN + + all_perl_files + find_keywords + first_arg + hashify + interpolate + is_assignment_operator + is_class_name + is_function_call + is_hash_key + is_in_void_context + is_included_module_name + is_integer + is_label_pointer + is_method_call + is_package_declaration + is_perl_bareword + is_perl_builtin + is_perl_builtin_with_list_context + is_perl_builtin_with_multiple_arguments + is_perl_builtin_with_no_arguments + is_perl_builtin_with_one_argument + is_perl_builtin_with_optional_argument + is_perl_builtin_with_zero_and_or_one_arguments + is_perl_filehandle + is_perl_global + is_qualified_name + is_script + is_subroutine_name + is_unchecked_call + is_valid_numeric_verbosity + parse_arg_list + policy_long_name + policy_short_name + precedence_of + severity_to_number + shebang_line + split_nodes_on_comma + verbosity_to_format + words_from_string +); + + +# Note: this is deprecated. This should also violate ProhibitAutomaticExportation, +# but at the moment, we aren't smart enough to deal with Readonly variables. +Readonly::Array our @EXPORT => @EXPORT_OK; + + +Readonly::Hash our %EXPORT_TAGS => ( + all => [ @EXPORT_OK ], + booleans => [ qw{ $TRUE $FALSE } ], + severities => [ + qw{ + $SEVERITY_HIGHEST + $SEVERITY_HIGH + $SEVERITY_MEDIUM + $SEVERITY_LOW + $SEVERITY_LOWEST + @SEVERITY_NAMES + } + ], + characters => [ + qw{ + $COLON + $COMMA + $DQUOTE + $EMPTY + $EQUAL + $FATCOMMA + $PERIOD + $PIPE + $QUOTE + $BACKTICK + $SCOLON + $SPACE + $SLASH + $BSLASH + $LEFT_PAREN + $RIGHT_PAREN + } + ], + classification => [ + qw{ + is_assignment_operator + is_class_name + is_function_call + is_hash_key + is_included_module_name + is_integer + is_label_pointer + is_method_call + is_package_declaration + is_perl_bareword + is_perl_builtin + is_perl_filehandle + is_perl_global + is_perl_builtin_with_list_context + is_perl_builtin_with_multiple_arguments + is_perl_builtin_with_no_arguments + is_perl_builtin_with_one_argument + is_perl_builtin_with_optional_argument + is_perl_builtin_with_zero_and_or_one_arguments + is_qualified_name + is_script + is_subroutine_name + is_unchecked_call + is_valid_numeric_verbosity + } + ], + data_conversion => [ qw{ hashify words_from_string interpolate } ], + ppi => [ qw{ first_arg parse_arg_list } ], + internal_lookup => [ qw{ severity_to_number verbosity_to_format } ], + language => [ qw{ precedence_of } ], + deprecated => [ qw{ find_keywords } ], +); + +#----------------------------------------------------------------------------- + +Readonly::Scalar our $POLICY_NAMESPACE => 'Perl::Critic::Policy'; + +#----------------------------------------------------------------------------- + +Readonly::Scalar our $SEVERITY_HIGHEST => 5; +Readonly::Scalar our $SEVERITY_HIGH => 4; +Readonly::Scalar our $SEVERITY_MEDIUM => 3; +Readonly::Scalar our $SEVERITY_LOW => 2; +Readonly::Scalar our $SEVERITY_LOWEST => 1; + +#----------------------------------------------------------------------------- + +Readonly::Scalar our $COMMA => q{,}; +Readonly::Scalar our $EQUAL => q{=}; +Readonly::Scalar our $FATCOMMA => q{=>}; +Readonly::Scalar our $COLON => q{:}; +Readonly::Scalar our $SCOLON => q{;}; +Readonly::Scalar our $QUOTE => q{'}; +Readonly::Scalar our $DQUOTE => q{"}; +Readonly::Scalar our $BACKTICK => q{`}; +Readonly::Scalar our $PERIOD => q{.}; +Readonly::Scalar our $PIPE => q{|}; +Readonly::Scalar our $SPACE => q{ }; +Readonly::Scalar our $SLASH => q{/}; +Readonly::Scalar our $BSLASH => q{\\}; +Readonly::Scalar our $LEFT_PAREN => q{(}; +Readonly::Scalar our $RIGHT_PAREN => q{)}; +Readonly::Scalar our $EMPTY => q{}; +Readonly::Scalar our $TRUE => 1; +Readonly::Scalar our $FALSE => 0; + +#----------------------------------------------------------------------------- + +#TODO: Should this include punctuations vars? + + + +#----------------------------------------------------------------------------- +## no critic (ProhibitNoisyQuotes); + +Readonly::Hash my %PRECEDENCE_OF => ( + '->' => 1, + '++' => 2, + '--' => 2, + '**' => 3, + '!' => 4, + '~' => 4, + '\\' => 4, + '=~' => 5, + '!~' => 5, + '*' => 6, + '/' => 6, + '%' => 6, + 'x' => 6, + '+' => 7, + '-' => 7, + '.' => 7, + '<<' => 8, + '>>' => 8, + '-R' => 9, + '-W' => 9, + '-X' => 9, + '-r' => 9, + '-w' => 9, + '-x' => 9, + '-e' => 9, + '-O' => 9, + '-o' => 9, + '-z' => 9, + '-s' => 9, + '-M' => 9, + '-A' => 9, + '-C' => 9, + '-S' => 9, + '-c' => 9, + '-b' => 9, + '-f' => 9, + '-d' => 9, + '-p' => 9, + '-l' => 9, + '-u' => 9, + '-g' => 9, + '-k' => 9, + '-t' => 9, + '-T' => 9, + '-B' => 9, + '<' => 10, + '>' => 10, + '<=' => 10, + '>=' => 10, + 'lt' => 10, + 'gt' => 10, + 'le' => 10, + 'ge' => 10, + '==' => 11, + '!=' => 11, + '<=>' => 11, + 'eq' => 11, + 'ne' => 11, + 'cmp' => 11, + '~~' => 11, + '&' => 12, + '|' => 13, + '^' => 13, + '&&' => 14, + '//' => 15, + '||' => 15, + '..' => 16, + '...' => 17, + '?' => 18, + ':' => 18, + '=' => 19, + '+=' => 19, + '-=' => 19, + '*=' => 19, + '/=' => 19, + '%=' => 19, + '||=' => 19, + '&&=' => 19, + '|=' => 19, + '&=' => 19, + '**=' => 19, + 'x=' => 19, + '.=' => 19, + '^=' => 19, + '<<=' => 19, + '>>=' => 19, + '//=' => 19, + ',' => 20, + '=>' => 20, + 'not' => 22, + 'and' => 23, + 'or' => 24, + 'xor' => 24, +); + +## use critic + +Readonly::Scalar my $MIN_PRECEDENCE_TO_TERMINATE_PARENLESS_ARG_LIST => + precedence_of( 'not' ); + +#----------------------------------------------------------------------------- + +sub hashify { ## no critic (ArgUnpacking) + return map { $_ => 1 } @_; +} + +#----------------------------------------------------------------------------- + +sub interpolate { + my ( $literal ) = @_; + return eval "\"$literal\"" || confess $EVAL_ERROR; ## no critic (StringyEval); +} + +#----------------------------------------------------------------------------- + +sub find_keywords { + my ( $doc, $keyword ) = @_; + my $nodes_ref = $doc->find('PPI::Token::Word'); + return if !$nodes_ref; + my @matches = grep { $_ eq $keyword } @{$nodes_ref}; + return @matches ? \@matches : undef; +} + +#----------------------------------------------------------------------------- + +sub _name_for_sub_or_stringified_element { + my $elem = shift; + + if ( blessed $elem and $elem->isa('PPI::Statement::Sub') ) { + return $elem->name(); + } + + return "$elem"; +} + +#----------------------------------------------------------------------------- +## no critic (ProhibitPackageVars) + +Readonly::Hash my %BUILTINS => hashify( @B::Keywords::Functions ); + +sub is_perl_builtin { + my $elem = shift; + return if !$elem; + + return exists $BUILTINS{ _name_for_sub_or_stringified_element($elem) }; +} + +#----------------------------------------------------------------------------- + +Readonly::Hash my %BAREWORDS => hashify( @B::Keywords::Barewords ); + +sub is_perl_bareword { + my $elem = shift; + return if !$elem; + + return exists $BAREWORDS{ _name_for_sub_or_stringified_element($elem) }; +} + +#----------------------------------------------------------------------------- + +sub _build_globals_without_sigils { + # B::Keywords as of 1.08 forgot $\ + my @globals = + map { substr $_, 1 } + @B::Keywords::Arrays, + @B::Keywords::Hashes, + @B::Keywords::Scalars, + '$\\'; ## no critic (RequireInterpolationOfMetachars) + + # Not all of these have sigils + foreach my $filehandle (@B::Keywords::Filehandles) { + (my $stripped = $filehandle) =~ s< \A [*] ><>xms; + push @globals, $stripped; + } + + return @globals; +} + +Readonly::Array my @GLOBALS_WITHOUT_SIGILS => _build_globals_without_sigils(); + +Readonly::Hash my %GLOBALS => hashify( @GLOBALS_WITHOUT_SIGILS ); + +sub is_perl_global { + my $elem = shift; + return if !$elem; + my $var_name = "$elem"; #Convert Token::Symbol to string + $var_name =~ s{\A [\$@%*] }{}xms; #Chop off the sigil + return exists $GLOBALS{ $var_name }; +} + +#----------------------------------------------------------------------------- + +Readonly::Hash my %FILEHANDLES => hashify( @B::Keywords::Filehandles ); + +sub is_perl_filehandle { + my $elem = shift; + return if !$elem; + + return exists $FILEHANDLES{ _name_for_sub_or_stringified_element($elem) }; +} + +## use critic +#----------------------------------------------------------------------------- + +# egrep '=item.*LIST' perlfunc.pod +Readonly::Hash my %BUILTINS_WHICH_PROVIDE_LIST_CONTEXT => + hashify( + qw{ + chmod + chown + die + exec + formline + grep + import + join + kill + map + no + open + pack + print + printf + push + reverse + say + sort + splice + sprintf + syscall + system + tie + unlink + unshift + use + utime + warn + }, + ); + +sub is_perl_builtin_with_list_context { + my $elem = shift; + + return + exists + $BUILTINS_WHICH_PROVIDE_LIST_CONTEXT{ + _name_for_sub_or_stringified_element($elem) + }; +} + +#----------------------------------------------------------------------------- + +# egrep '=item.*[A-Z],' perlfunc.pod +Readonly::Hash my %BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS => + hashify( + qw{ + accept + atan2 + bind + binmode + bless + connect + crypt + dbmopen + fcntl + flock + gethostbyaddr + getnetbyaddr + getpriority + getservbyname + getservbyport + getsockopt + index + ioctl + link + listen + mkdir + msgctl + msgget + msgrcv + msgsnd + open + opendir + pipe + read + recv + rename + rindex + seek + seekdir + select + semctl + semget + semop + send + setpgrp + setpriority + setsockopt + shmctl + shmget + shmread + shmwrite + shutdown + socket + socketpair + splice + split + substr + symlink + sysopen + sysread + sysseek + syswrite + truncate + unpack + vec + waitpid + }, + keys %BUILTINS_WHICH_PROVIDE_LIST_CONTEXT + ); + +sub is_perl_builtin_with_multiple_arguments { + my $elem = shift; + + return + exists + $BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS{ + _name_for_sub_or_stringified_element($elem) + }; +} + +#----------------------------------------------------------------------------- + +Readonly::Hash my %BUILTINS_WHICH_TAKE_NO_ARGUMENTS => + hashify( + qw{ + endgrent + endhostent + endnetent + endprotoent + endpwent + endservent + fork + format + getgrent + gethostent + getlogin + getnetent + getppid + getprotoent + getpwent + getservent + setgrent + setpwent + split + time + times + wait + wantarray + } + ); + +sub is_perl_builtin_with_no_arguments { + my $elem = shift; + + return + exists + $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{ + _name_for_sub_or_stringified_element($elem) + }; +} + +#----------------------------------------------------------------------------- + +Readonly::Hash my %BUILTINS_WHICH_TAKE_ONE_ARGUMENT => + hashify( + qw{ + closedir + dbmclose + delete + each + exists + fileno + getgrgid + getgrnam + gethostbyname + getnetbyname + getpeername + getpgrp + getprotobyname + getprotobynumber + getpwnam + getpwuid + getsockname + goto + keys + local + prototype + readdir + readline + readpipe + rewinddir + scalar + sethostent + setnetent + setprotoent + setservent + telldir + tied + untie + values + } + ); + +sub is_perl_builtin_with_one_argument { + my $elem = shift; + + return + exists + $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{ + _name_for_sub_or_stringified_element($elem) + }; +} + +#----------------------------------------------------------------------------- + +## no critic (ProhibitPackageVars) +Readonly::Hash my %BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT => + hashify( + grep { not exists $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{ $_ } } + grep { not exists $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{ $_ } } + grep { not exists $BUILTINS_WHICH_TAKE_MULTIPLE_ARGUMENTS{ $_ } } + @B::Keywords::Functions + ); +## use critic + +sub is_perl_builtin_with_optional_argument { + my $elem = shift; + + return + exists + $BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT{ + _name_for_sub_or_stringified_element($elem) + }; +} + +#----------------------------------------------------------------------------- + +sub is_perl_builtin_with_zero_and_or_one_arguments { + my $elem = shift; + + return if not $elem; + + my $name = _name_for_sub_or_stringified_element($elem); + + return ( + exists $BUILTINS_WHICH_TAKE_ONE_ARGUMENT{ $name } + or exists $BUILTINS_WHICH_TAKE_NO_ARGUMENTS{ $name } + or exists $BUILTINS_WHICH_TAKE_OPTIONAL_ARGUMENT{ $name } + ); +} + +#----------------------------------------------------------------------------- + +sub is_qualified_name { + my $name = shift; + + return if not $name; + + return index ( $name, q{::} ) >= 0; +} + +#----------------------------------------------------------------------------- + +sub precedence_of { + my $elem = shift; + return if !$elem; + return $PRECEDENCE_OF{ ref $elem ? "$elem" : $elem }; +} + +#----------------------------------------------------------------------------- + +sub is_hash_key { + my $elem = shift; + return if !$elem; + + #If followed by an argument list, then its a function call, not a literal + return if _is_followed_by_parens($elem); + + #Check curly-brace style: $hash{foo} = bar; + my $parent = $elem->parent(); + return if !$parent; + my $grandparent = $parent->parent(); + return if !$grandparent; + return 1 if $grandparent->isa('PPI::Structure::Subscript'); + + + #Check declarative style: %hash = (foo => bar); + my $sib = $elem->snext_sibling(); + return if !$sib; + return 1 if $sib->isa('PPI::Token::Operator') && $sib eq '=>'; + + return; +} + +#----------------------------------------------------------------------------- + +sub _is_followed_by_parens { + my $elem = shift; + return if !$elem; + + my $sibling = $elem->snext_sibling() || return; + return $sibling->isa('PPI::Structure::List'); +} + +#----------------------------------------------------------------------------- + +sub is_included_module_name { + my $elem = shift; + return if !$elem; + my $stmnt = $elem->statement(); + return if !$stmnt; + return if !$stmnt->isa('PPI::Statement::Include'); + return $stmnt->schild(1) == $elem; +} + +#----------------------------------------------------------------------------- + +sub is_integer { + my ($value) = @_; + return 0 if not defined $value; + + return $value =~ m{ \A [+-]? \d+ \z }xms; +} + +#----------------------------------------------------------------------------- + +sub is_label_pointer { + my $elem = shift; + return if !$elem; + + my $statement = $elem->statement(); + return if !$statement; + + my $psib = $elem->sprevious_sibling(); + return if !$psib; + + return $statement->isa('PPI::Statement::Break') + && $psib =~ m/(?:redo|goto|next|last)/xmso; +} + +#----------------------------------------------------------------------------- + +sub is_method_call { + my $elem = shift; + return if !$elem; + + return _is_dereference_operator( $elem->sprevious_sibling() ); +} + +#----------------------------------------------------------------------------- + +sub is_class_name { + my $elem = shift; + return if !$elem; + + return _is_dereference_operator( $elem->snext_sibling() ) + && !_is_dereference_operator( $elem->sprevious_sibling() ); +} + +#----------------------------------------------------------------------------- + +sub _is_dereference_operator { + my $elem = shift; + return if !$elem; + + return $elem->isa('PPI::Token::Operator') && $elem eq q{->}; +} + +#----------------------------------------------------------------------------- + +sub is_package_declaration { + my $elem = shift; + return if !$elem; + my $stmnt = $elem->statement(); + return if !$stmnt; + return if !$stmnt->isa('PPI::Statement::Package'); + return $stmnt->schild(1) == $elem; +} + +#----------------------------------------------------------------------------- + +sub is_subroutine_name { + my $elem = shift; + return if !$elem; + my $sib = $elem->sprevious_sibling(); + return if !$sib; + my $stmnt = $elem->statement(); + return if !$stmnt; + return $stmnt->isa('PPI::Statement::Sub') && $sib eq 'sub'; +} + +#----------------------------------------------------------------------------- + +sub is_function_call { + my $elem = shift or return; + + return if is_perl_bareword($elem); + return if is_perl_filehandle($elem); + return if is_package_declaration($elem); + return if is_included_module_name($elem); + return if is_method_call($elem); + return if is_class_name($elem); + return if is_subroutine_name($elem); + return if is_label_pointer($elem); + return if is_hash_key($elem); + + return 1; +} + +#----------------------------------------------------------------------------- + +sub is_script { + my $doc = shift; + + warnings::warnif( + 'deprecated', + 'Perl::Critic::Utils::is_script($doc) deprecated, use $doc->is_program() instead.', ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars) + ); + + return $doc->is_program() + if blessed($doc) && $doc->isa('Perl::Critic::Document'); + + return 1 if shebang_line($doc); + return 1 if _is_PL_file($doc); + return 0; +} + +#----------------------------------------------------------------------------- + +sub _is_PL_file { ## no critic (NamingConventions::Capitalization) + my ($doc) = @_; + return if not $doc->can('filename'); + my $filename = $doc->filename() || return; + return 1 if $filename =~ m/[.] PL \z/xms; + return 0; +} + +#----------------------------------------------------------------------------- + +sub is_in_void_context { + my ($token) = @_; + + # If part of a collective, can't be void. + return if $token->sprevious_sibling(); + + my $parent = $token->statement()->parent(); + if ($parent) { + return if $parent->isa('PPI::Structure::List'); + return if $parent->isa('PPI::Structure::For'); + return if $parent->isa('PPI::Structure::Condition'); + return if $parent->isa('PPI::Structure::Constructor'); + return if $parent->isa('PPI::Structure::Subscript'); + + my $grand_parent = $parent->parent(); + if ($grand_parent) { + return if + $parent->isa('PPI::Structure::Block') + and not $grand_parent->isa('PPI::Statement::Compound'); + } + } + + return $TRUE; +} + +#----------------------------------------------------------------------------- + +sub policy_long_name { + my ( $policy_name ) = @_; + if ( $policy_name !~ m{ \A $POLICY_NAMESPACE }xms ) { + $policy_name = $POLICY_NAMESPACE . q{::} . $policy_name; + } + return $policy_name; +} + +#----------------------------------------------------------------------------- + +sub policy_short_name { + my ( $policy_name ) = @_; + $policy_name =~ s{\A $POLICY_NAMESPACE ::}{}xms; + return $policy_name; +} + +#----------------------------------------------------------------------------- + +sub first_arg { + my $elem = shift; + my $sib = $elem->snext_sibling(); + return if !$sib; + + if ( $sib->isa('PPI::Structure::List') ) { + + my $expr = $sib->schild(0); + return if !$expr; + return $expr->isa('PPI::Statement') ? $expr->schild(0) : $expr; + } + + return $sib; +} + +#----------------------------------------------------------------------------- + +sub parse_arg_list { + my $elem = shift; + my $sib = $elem->snext_sibling(); + return if !$sib; + + if ( $sib->isa('PPI::Structure::List') ) { + + #Pull siblings from list + my @list_contents = $sib->schildren(); + return if not @list_contents; + + my @list_expressions; + foreach my $item (@list_contents) { + if ( + is_ppi_expression_or_generic_statement($item) + ) { + push + @list_expressions, + split_nodes_on_comma( $item->schildren() ); + } + else { + push @list_expressions, $item; + } + } + + return @list_expressions; + } + else { + + #Gather up remaining nodes in the statement + my $iter = $elem; + my @arg_list = (); + + while ($iter = $iter->snext_sibling() ) { + last if $iter->isa('PPI::Token::Structure') and $iter eq $SCOLON; + last if $iter->isa('PPI::Token::Operator') + and $MIN_PRECEDENCE_TO_TERMINATE_PARENLESS_ARG_LIST <= + precedence_of( $iter ); + push @arg_list, $iter; + } + return split_nodes_on_comma( @arg_list ); + } +} + +#--------------------------------- + +sub split_nodes_on_comma { + my @nodes = @_; + + my $i = 0; + my @node_stacks; + for my $node (@nodes) { + if ( + $node->isa('PPI::Token::Operator') + and ($node eq $COMMA or $node eq $FATCOMMA) + ) { + if (@node_stacks) { + $i++; #Move forward to next 'node stack' + } + next; + } elsif ( $node->isa('PPI::Token::QuoteLike::Words' )) { + my $section = $node->{sections}->[0]; + my @words = words_from_string(substr $node->content, $section->{position}, $section->{size}); + my $loc = $node->location; + for my $word (@words) { + my $token = PPI::Token::Quote::Single->new(q{'} . $word . q{'}); + $token->{_location} = $loc; + push @{ $node_stacks[$i++] }, $token; + } + next; + } + push @{ $node_stacks[$i] }, $node; + } + return @node_stacks; +} + +#----------------------------------------------------------------------------- + +# XXX: You must keep the regular expressions in extras/perlcritic.el in sync +# if you change these. +Readonly::Hash my %FORMAT_OF => ( + 1 => "%f:%l:%c:%m\n", + 2 => "%f: (%l:%c) %m\n", + 3 => "%m at %f line %l\n", + 4 => "%m at line %l, column %c. %e. (Severity: %s)\n", + 5 => "%f: %m at line %l, column %c. %e. (Severity: %s)\n", + 6 => "%m at line %l, near '%r'. (Severity: %s)\n", + 7 => "%f: %m at line %l near '%r'. (Severity: %s)\n", + 8 => "[%p] %m at line %l, column %c. (Severity: %s)\n", + 9 => "[%p] %m at line %l, near '%r'. (Severity: %s)\n", + 10 => "%m at line %l, column %c.\n %p (Severity: %s)\n%d\n", + 11 => "%m at line %l, near '%r'.\n %p (Severity: %s)\n%d\n", +); + +Readonly::Scalar our $DEFAULT_VERBOSITY => 4; +Readonly::Scalar our $DEFAULT_VERBOSITY_WITH_FILE_NAME => 5; +Readonly::Scalar my $DEFAULT_FORMAT => $FORMAT_OF{$DEFAULT_VERBOSITY}; + +sub is_valid_numeric_verbosity { + my ($verbosity) = @_; + + return exists $FORMAT_OF{$verbosity}; +} + +sub verbosity_to_format { + my ($verbosity) = @_; + return $DEFAULT_FORMAT if not defined $verbosity; + return $FORMAT_OF{abs int $verbosity} || $DEFAULT_FORMAT if is_integer($verbosity); + return interpolate( $verbosity ); #Otherwise, treat as a format spec +} + +#----------------------------------------------------------------------------- + +Readonly::Hash my %SEVERITY_NUMBER_OF => ( + gentle => 5, + stern => 4, + harsh => 3, + cruel => 2, + brutal => 1, +); + +Readonly::Array our @SEVERITY_NAMES => #This is exported! + sort + { $SEVERITY_NUMBER_OF{$a} <=> $SEVERITY_NUMBER_OF{$b} } + keys %SEVERITY_NUMBER_OF; + +sub severity_to_number { + my ($severity) = @_; + return _normalize_severity( $severity ) if is_integer( $severity ); + my $severity_number = $SEVERITY_NUMBER_OF{lc $severity}; + + if ( not defined $severity_number ) { + throw_generic qq{Invalid severity: "$severity"}; + } + + return $severity_number; +} + +sub _normalize_severity { + my $s = shift || return $SEVERITY_HIGHEST; + $s = $s > $SEVERITY_HIGHEST ? $SEVERITY_HIGHEST : $s; + $s = $s < $SEVERITY_LOWEST ? $SEVERITY_LOWEST : $s; + return $s; +} + +#----------------------------------------------------------------------------- + +Readonly::Array my @SKIP_DIR => qw( CVS RCS .svn _darcs {arch} .bzr .cdv .git .hg .pc _build blib ); +Readonly::Hash my %SKIP_DIR => hashify( @SKIP_DIR ); + +sub all_perl_files { + my @arg = @_; + my @code_files; + + # The old code did a breadth-first search (documentation to the + # contrary notwithstanding,) whereas File::Find does depth-first. So + # there appears to be no way to use File::Find without changing the + # order in which the files are returned. + File::Find::find( { + wanted => sub { + if ( -d && $SKIP_DIR{$_} ) { + $File::Find::prune = 1; + } elsif ( -f && ! _is_backup( $_ ) && _is_perl( $_ ) ) { + push @code_files, $File::Find::name; + } + return; + }, + }, + @arg, + ); + + # Use File::Spec->abs2rel() to get rid of leading './' or other OS + # equivalent on relative filenames. + # Use map {} to get rid of leading './', or other OS equivalent + return ( map { File::Spec->file_name_is_absolute( $_ ) ? + $_ : File::Spec->abs2rel( $_ ) } @code_files ); +} + + +#----------------------------------------------------------------------------- +# Decide if it's some sort of backup file + +sub _is_backup { + my ($file) = @_; + return 1 if $file =~ m{ [.] swp \z}xms; + return 1 if $file =~ m{ [.] bak \z}xms; + return 1 if $file =~ m{ ~ \z}xms; + return 1 if $file =~ m{ \A [#] .+ [#] \z}xms; + return; +} + +#----------------------------------------------------------------------------- +# Returns true if the argument ends with a perl-ish file +# extension, or if it has a shebang-line containing 'perl' This +# subroutine was also poached from Test::Perl::Critic + +sub _is_perl { + my ($file) = @_; + + #Check filename extensions + return 1 if $file =~ m{ [.] PL \z}xms; + return 1 if $file =~ m{ [.] p[lm] \z}xms; + return 1 if $file =~ m{ [.] psgi \z}xms; + return 1 if $file =~ m{ [.] t \z}xms; + + #Check for shebang + open my $fh, '<', $file or return; + my $first = <$fh>; + close $fh or throw_generic "unable to close $file: $OS_ERROR"; + + return 1 if defined $first && ( $first =~ m{ \A [#]!.*perl }xms ); + return; +} + +#----------------------------------------------------------------------------- + +sub shebang_line { + my $doc = shift; + my $first_element = $doc->first_element(); + return if not $first_element; + return if not $first_element->isa('PPI::Token::Comment'); + my $location = $first_element->location(); + return if !$location; + # The shebang must be the first two characters in the file, according to + # http://en.wikipedia.org/wiki/Shebang_(Unix) + return if $location->[0] != 1; # line number + return if $location->[1] != 1; # column number + my $shebang = $first_element->content; + return if $shebang !~ m{ \A [#]! }xms; + return $shebang; +} + +#----------------------------------------------------------------------------- + +sub words_from_string { + my $str = shift; + + return split q{ }, $str; # This must be a literal space, not $SPACE +} + +#----------------------------------------------------------------------------- + +Readonly::Hash my %ASSIGNMENT_OPERATORS => hashify( qw( = **= += -= .= *= /= %= x= &= |= ^= <<= >>= &&= ||= //= ) ); + +sub is_assignment_operator { + my $elem = shift; + + return $ASSIGNMENT_OPERATORS{ $elem }; +} + +#----------------------------------------------------------------------------- + +sub is_unchecked_call { + my ( $elem, $autodie_modules ) = @_; + + return if not is_function_call( $elem ); + + # check to see if there's an '=' or 'unless' or something before this. + if( my $sib = $elem->sprevious_sibling() ){ + return if $sib; + } + + + if( my $statement = $elem->statement() ){ + + # "open or die" is OK. + # We can't check snext_sibling for 'or' since the next siblings are an + # unknown number of arguments to the system call. Instead, check all of + # the elements to this statement to see if we find 'or' or '||'. + + my $or_operators = sub { + my (undef, $elem) = @_; ## no critic(Variables::ProhibitReusedNames) + return if not $elem->isa('PPI::Token::Operator'); + return if $elem ne q{or} && $elem ne q{||}; + return 1; + }; + + return if $statement->find( $or_operators ); + + + if( my $parent = $elem->statement()->parent() ){ + + # Check if we're in an if( open ) {good} else {bad} condition + return if $parent->isa('PPI::Structure::Condition'); + + # Return val could be captured in data structure and checked later + return if $parent->isa('PPI::Structure::Constructor'); + + # "die if not ( open() )" - It's in list context. + if ( $parent->isa('PPI::Structure::List') ) { + if( my $uncle = $parent->sprevious_sibling() ){ + return if $uncle; + } + } + } + } + + return if _is_fatal($elem, $autodie_modules); + + # Otherwise, return. this system call is unchecked. + return 1; +} + +# Based upon autodie 2.10. +Readonly::Hash my %AUTODIE_PARAMETER_TO_AFFECTED_BUILTINS_MAP => ( + # Map builtins to themselves. + ( + map { $_ => { hashify( $_ ) } } + qw< + accept bind binmode chdir chmod close closedir connect + dbmclose dbmopen exec fcntl fileno flock fork getsockopt ioctl + link listen mkdir msgctl msgget msgrcv msgsnd open opendir + pipe read readlink recv rename rmdir seek semctl semget semop + send setsockopt shmctl shmget shmread shutdown socketpair + symlink sysopen sysread sysseek system syswrite truncate umask + unlink + > + ), + + # Generate these using tools/dump-autodie-tag-contents + ':threads' => { hashify( qw< fork > ) }, + ':system' => { hashify( qw< exec system > ) }, + ':dbm' => { hashify( qw< dbmclose dbmopen > ) }, + ':semaphore' => { hashify( qw< semctl semget semop > ) }, + ':shm' => { hashify( qw< shmctl shmget shmread > ) }, + ':msg' => { hashify( qw< msgctl msgget msgrcv msgsnd > ) }, + ':file' => { + hashify( + qw< + binmode chmod close fcntl fileno flock ioctl open sysopen + truncate + > + ) + }, + ':filesys' => { + hashify( + qw< + chdir closedir link mkdir opendir readlink rename rmdir + symlink umask unlink + > + ) + }, + ':ipc' => { + hashify( + qw< + msgctl msgget msgrcv msgsnd pipe semctl semget semop shmctl + shmget shmread + > + ) + }, + ':socket' => { + hashify( + qw< + accept bind connect getsockopt listen recv send setsockopt + shutdown socketpair + > + ) + }, + ':io' => { + hashify( + qw< + accept bind binmode chdir chmod close closedir connect + dbmclose dbmopen fcntl fileno flock getsockopt ioctl link + listen mkdir msgctl msgget msgrcv msgsnd open opendir pipe + read readlink recv rename rmdir seek semctl semget semop send + setsockopt shmctl shmget shmread shutdown socketpair symlink + sysopen sysread sysseek syswrite truncate umask unlink + > + ) + }, + ':default' => { + hashify( + qw< + accept bind binmode chdir chmod close closedir connect + dbmclose dbmopen fcntl fileno flock fork getsockopt ioctl link + listen mkdir msgctl msgget msgrcv msgsnd open opendir pipe + read readlink recv rename rmdir seek semctl semget semop send + setsockopt shmctl shmget shmread shutdown socketpair symlink + sysopen sysread sysseek syswrite truncate umask unlink + > + ) + }, + ':all' => { + hashify( + qw< + accept bind binmode chdir chmod close closedir connect + dbmclose dbmopen exec fcntl fileno flock fork getsockopt ioctl + link listen mkdir msgctl msgget msgrcv msgsnd open opendir + pipe read readlink recv rename rmdir seek semctl semget semop + send setsockopt shmctl shmget shmread shutdown socketpair + symlink sysopen sysread sysseek system syswrite truncate umask + unlink + > + ) + }, +); + +sub _is_fatal { + my ( $elem, $autodie_modules ) = @_; + + my $top = $elem->top(); + return if not $top->isa('PPI::Document'); + + my $includes = $top->find('PPI::Statement::Include'); + return if not $includes; + + for my $include (@{$includes}) { + next if 'use' ne $include->type(); + + if ('Fatal' eq $include->module()) { + my @args = parse_arg_list($include->schild(1)); + foreach my $arg (@args) { + return $TRUE if $arg->[0]->isa('PPI::Token::Quote') && $elem eq $arg->[0]->string(); + } + } + elsif ('Fatal::Exception' eq $include->module()) { + my @args = parse_arg_list($include->schild(1)); + shift @args; # skip exception class name + foreach my $arg (@args) { + return $TRUE if $arg->[0]->isa('PPI::Token::Quote') && $elem eq $arg->[0]->string(); + } + } + elsif ($include->pragma eq 'autodie' || any {$_ eq $include->module()} @{$autodie_modules || []}) { + return _is_covered_by_autodie($elem, $include); + } + } + + return; +} + +sub _is_covered_by_autodie { + my ($elem, $include) = @_; + + my $autodie = $include->schild(1); + my @args = parse_arg_list($autodie); + my $first_arg = first_arg($autodie); + + # The first argument to any `use` pragma could be a version number. + # If so, then we just discard it. We only want the arguments after it. + if ($first_arg and $first_arg->isa('PPI::Token::Number')){ shift @args }; + + if (@args) { + foreach my $arg (@args) { + my $builtins = + $AUTODIE_PARAMETER_TO_AFFECTED_BUILTINS_MAP{ + $arg->[0]->string + }; + + return $TRUE if $builtins and $builtins->{$elem->content()}; + } + } + else { + my $builtins = + $AUTODIE_PARAMETER_TO_AFFECTED_BUILTINS_MAP{':default'}; + + return $TRUE if $builtins and $builtins->{$elem->content()}; + } + + return; +} + +1; + +__END__ + +=pod + +=head1 NAME + +Perl::Critic::Utils - General utility subroutines and constants for Perl::Critic and derivative distributions. + + +=head1 DESCRIPTION + +This module provides several static subs and variables that are useful +for developing L +subclasses. Unless you are writing Policy modules, you probably don't +care about this package. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public module. Any changes to its +interface will go through a deprecation cycle. + + +=head1 IMPORTABLE SUBS + +=over + +=item C + +B Since version 0.11, every Policy is evaluated at each +element of the document. So you shouldn't need to go looking for a +particular keyword. If you I want to use this, please import it +via the C<:deprecated> tag, rather than directly, to mark the module +as needing updating. + +Given a L as C<$doc>, returns a reference +to an array containing all the L +elements that match C<$keyword>. This can be used to find any +built-in function, method call, bareword, or reserved keyword. It +will not match variables, subroutine names, literal strings, numbers, +or symbols. If the document doesn't contain any matches, returns +undef. + +=item C + +Given a L or a string, +returns true if that token represents one of the assignment operators +(e.g. C<= &&= ||= //= += -=> etc.). + +=item C + +Given a L or a string, returns +true if that token represents one of the global variables provided by +the L module, or one of the builtin global variables +like C<%SIG>, C<%ENV>, or C<@ARGV>. The sigil on the symbol is +ignored, so things like C<$ARGV> or C<$ENV> will still return true. + + +=item C + +Given a L, +L, or string, returns true if +that token represents a call to any of the builtin functions defined +in Perl 5.8.8. + + +=item C + +Given a L, +L, or string, returns true if +that token represents a bareword (e.g. "if", "else", "sub", "package") +defined in Perl 5.8.8. + + +=item C + +Given a L, or string, returns true +if that token represents one of the global filehandles (e.g. C, +C, C, C) that are defined in Perl 5.8.8. Note +that this function will return false if given a filehandle that is +represented as a typeglob (e.g. C<*STDIN>) + + +=item C + +Given a L, +L, or string, returns true if +that token represents a call to any of the builtin functions defined +in Perl 5.8.8 that provide a list context to the following tokens. + + +=item C + +Given a L, +L, or string, returns true if +that token represents a call to any of the builtin functions defined +in Perl 5.8.8 that B take multiple arguments. + + +=item C + +Given a L, +L, or string, returns true if +that token represents a call to any of the builtin functions defined +in Perl 5.8.8 that B take any arguments. + + +=item C + +Given a L, +L, or string, returns true if +that token represents a call to any of the builtin functions defined +in Perl 5.8.8 that takes B argument. + + +=item C + +Given a L, +L, or string, returns true if +that token represents a call to any of the builtin functions defined +in Perl 5.8.8 that takes B argument. + +The sets of values for which +C, +C, +C, and +C return true are disjoint +and their union is precisely the set of values that +C will return true for. + + +=item C + +Given a L, +L, or string, returns true if +that token represents a call to any of the builtin functions defined +in Perl 5.8.8 that takes no and/or one argument. + +Returns true if any of C, +C, and +C returns true. + + +=item C + +Given a string, L, or +L, answers whether it has a +module component, i.e. contains "::". + + +=item C + +Given a L or a string, +returns the precedence of the operator, where 1 is the highest +precedence. Returns undef if the precedence can't be determined +(which is usually because it is not an operator). + + +=item C + +Given a L, returns true if the element is a +literal hash key. PPI doesn't distinguish between regular barewords +(like keywords or subroutine calls) and barewords in hash subscripts +(which are considered literal). So this subroutine is useful if your +Policy is searching for L elements +and you want to filter out the hash subscript variety. In both of the +following examples, "foo" is considered a hash key: + + $hash1{foo} = 1; + %hash2 = (foo => 1); + +But if the bareword is followed by an argument list, then perl treats +it as a function call. So in these examples, "foo" is B +considered a hash key: + + $hash1{ foo() } = 1; + &hash2 = (foo() => 1); + + +=item C + +Given a L, returns true if the +element is the name of a module that is being included via C, +C, or C. + + +=item C + +Answers whether the parameter, as a string, looks like an integral +value. + + +=item C + +Given a L, returns true if the +element that immediately follows this element is the dereference +operator "->". When a bareword has a "->" on the B side, it +usually means that it is the name of the class (from which a method is +being called). + + +=item C + +Given a L, returns true if the +element is the label in a C, C, C, or C +statement. Note this is not the same thing as the label declaration. + + +=item C + +Given a L, returns true if the +element that immediately precedes this element is the dereference +operator "->". When a bareword has a "->" on the B side, it +usually means that it is the name of a method (that is being called +from a class). + + +=item C + +Given a L, returns true if the +element is the name of a package that is being declared. + + +=item C + +Given a L, returns true if the +element is the name of a subroutine declaration. This is useful for +distinguishing barewords and from function calls from subroutine +declarations. + + +=item C + +Given a L returns true if the +element appears to be call to a static function. Specifically, this +function returns true if C, C, +C, C, +C, C, C, +C and C all return false for the +given element. + + +=item C + +Given a L that is presumed to be a function +call (which is usually a L), return +the first argument. This is similar of C and +follows the same logic. Note that for the code: + + int($x + 0.5) + +this function will return just the C<$x>, not the whole expression. +This is different from the behavior of C. Another +caveat is: + + int(($x + $y) + 0.5) + +which returns C<($x + $y)> as a +L instance. + + +=item C + +Given a L that is presumed to be a function +call (which is usually a L), splits +the argument expressions into arrays of tokens. Returns a list +containing references to each of those arrays. This is useful because +parentheses are optional when calling a function, and PPI parses them +very differently. So this method is a poor-man's parse tree of PPI +nodes. It's not bullet-proof because it doesn't respect precedence. +In general, I don't like the way this function works, so don't count +on it to be stable (or even present). + + +=item C + +This has the same return type as C but expects to be +passed the nodes that represent the interior of a list, like: + + 'foo', 1, 2, 'bar' + + +=item C + +B You +should use the L method instead. + + +=item C + +Given a L, answer whether it appears to be in a +void context. + + +=item C + +Given a policy class name in long or short form, return the long form. + + +=item C + +Given a policy class name in long or short form, return the short +form. + + +=item C + +Given a list of directories, recursively searches through all the +directories (depth first) and returns a list of paths for all the +files that are Perl code files. Any administrative files for CVS or +Subversion are skipped, as are things that look like temporary or +backup files. + +A Perl code file is: + +=over + +=item * Any file that ends in F<.PL>, F<.pl>, F<.pm>, F<.psgi>, or F<.t> + +=item * Any file that has a first line with a shebang containing 'perl' + +=back + + +=item C + +If C<$severity> is given as an integer, this function returns +C<$severity> but normalized to lie between C<$SEVERITY_LOWEST> and +C<$SEVERITY_HIGHEST>. If C<$severity> is given as a string, this +function returns the corresponding severity number. If the string +doesn't have a corresponding number, this function will throw an +exception. + + +=item C + +Answers whether the argument has a translation to a Violation format. + + +=item C + +Given a verbosity level between 1 and 10, returns the corresponding +predefined format string. These formats are suitable for passing to +the C method in +L. See the +L documentation for a listing of the predefined +formats. + + +=item C + +Given C<@list>, return a hash where C<@list> is in the keys and each +value is 1. Duplicate values in C<@list> are silently squished. + + +=item C + +Given a C<$literal> string that may contain control characters (e.g.. +'\t' '\n'), this function does a double interpolation on the string +and returns it as if it had been declared in double quotes. For +example: + + 'foo \t bar \n' ...becomes... "foo \t bar \n" + + +=item C + +Given a L, test if it starts with C<#!>. +If so, return that line. Otherwise return undef. + + +=item C + +Given config string I<$str>, return all the words from the string. +This is safer than splitting on whitespace. + + +=item C + +Given a L, test to see if it contains a +function call whose return value is not checked. The second argument +is an array reference of module names which export C. The +C module is always included in this list by default. + + +=back + + +=head1 IMPORTABLE VARIABLES + +=over + +=item C<$COMMA> + +=item C<$FATCOMMA> + +=item C<$COLON> + +=item C<$SCOLON> + +=item C<$QUOTE> + +=item C<$DQUOTE> + +=item C<$BACKTICK> + +=item C<$PERIOD> + +=item C<$PIPE> + +=item C<$EMPTY> + +=item C<$EQUAL> + +=item C<$SPACE> + +=item C<$SLASH> + +=item C<$BSLASH> + +=item C<$LEFT_PAREN> + +=item C<$RIGHT_PAREN> + +These character constants give clear names to commonly-used strings +that can be hard to read when surrounded by quotes and other +punctuation. Can be imported in one go via the C<:characters> tag. + +=item C<$SEVERITY_HIGHEST> + +=item C<$SEVERITY_HIGH> + +=item C<$SEVERITY_MEDIUM> + +=item C<$SEVERITY_LOW> + +=item C<$SEVERITY_LOWEST> + +These numeric constants define the relative severity of violating each +L. The C and +C methods of every Policy subclass must return one +of these values. Can be imported via the C<:severities> tag. + +=item C<$DEFAULT_VERBOSITY> + +The default numeric verbosity. + +=item C<$DEFAULT_VERBOSITY_WITH_FILE_NAME> + +The numeric verbosity that corresponds to the format indicated by +C<$DEFAULT_VERBOSITY>, but with the file name prefixed to it. + +=item C<$TRUE> + +=item C<$FALSE> + +These are simple booleans. 1 and 0 respectively. Be mindful of using +these with string equality. C<$FALSE ne $EMPTY>. Can be imported via +the C<:booleans> tag. + + +=back + + +=head1 IMPORT TAGS + +The following groups of functions and constants are available as +parameters to a C statement. + +=over + +=item C<:all> + +The lot. + + +=item C<:booleans> + +Includes: +C<$TRUE>, C<$FALSE> + + +=item C<:severities> + +Includes: +C<$SEVERITY_HIGHEST>, +C<$SEVERITY_HIGH>, +C<$SEVERITY_MEDIUM>, +C<$SEVERITY_LOW>, +C<$SEVERITY_LOWEST>, +C<@SEVERITY_NAMES> + + +=item C<:characters> + +Includes: +C<$COLON>, +C<$COMMA>, +C<$DQUOTE>, +C<$EMPTY>, +C<$FATCOMMA>, +C<$PERIOD>, +C<$PIPE>, +C<$QUOTE>, +C<$BACKTICK>, +C<$SCOLON>, +C<$SPACE>, +C<$SLASH>, +C<$BSLASH> +C<$LEFT_PAREN> +C<$RIGHT_PAREN> + + +=item C<:classification> + +Includes: +C, +C, +C, +C, +C, +C, +C, +C, +C, +C, +C, +C, +C, +C +C +C +C +C +C +C, +C, +C, +C +C + +See also L. + + +=item C<:data_conversion> + +Generic manipulation, not having anything specific to do with +Perl::Critic. + +Includes: +C, +C, +C + + +=item C<:ppi> + +Things for dealing with L, other than classification. + +Includes: +C, +C + +See also L. + + +=item C<:internal_lookup> + +Translations between internal representations. + +Includes: +C, +C + + +=item C<:language> + +Information about Perl not programmatically available elsewhere. + +Includes: +C + + +=item C<:deprecated> + +Not surprisingly, things that are deprecated. It is preferred to use +this tag to get to these functions, rather than the function names +themselves, so as to mark any module using them as needing cleanup. + +Includes: +C + + +=back + + +=head1 SEE ALSO + +L, +L, +L, + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Utils/Constants.pm b/lib/Perl/Critic/Utils/Constants.pm new file mode 100644 index 0000000..0a5d01f --- /dev/null +++ b/lib/Perl/Critic/Utils/Constants.pm @@ -0,0 +1,241 @@ +package Perl::Critic::Utils::Constants; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ $EMPTY hashify }; + +use Exporter 'import'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +our @EXPORT_OK = qw{ + $PROFILE_STRICTNESS_WARN + $PROFILE_STRICTNESS_FATAL + $PROFILE_STRICTNESS_QUIET + $PROFILE_STRICTNESS_DEFAULT + %PROFILE_STRICTNESSES + $PROFILE_COLOR_SEVERITY_HIGHEST_DEFAULT + $PROFILE_COLOR_SEVERITY_HIGH_DEFAULT + $PROFILE_COLOR_SEVERITY_MEDIUM_DEFAULT + $PROFILE_COLOR_SEVERITY_LOW_DEFAULT + $PROFILE_COLOR_SEVERITY_LOWEST_DEFAULT + $_MODULE_VERSION_TERM_ANSICOLOR + @STRICT_EQUIVALENT_MODULES + @WARNINGS_EQUIVALENT_MODULES +}; + +our %EXPORT_TAGS = ( + all => \@EXPORT_OK, + profile_strictness => [ + qw{ + $PROFILE_STRICTNESS_WARN + $PROFILE_STRICTNESS_FATAL + $PROFILE_STRICTNESS_QUIET + $PROFILE_STRICTNESS_DEFAULT + %PROFILE_STRICTNESSES + } + ], + color_severity => [ + qw{ + $PROFILE_COLOR_SEVERITY_HIGHEST_DEFAULT + $PROFILE_COLOR_SEVERITY_HIGH_DEFAULT + $PROFILE_COLOR_SEVERITY_MEDIUM_DEFAULT + $PROFILE_COLOR_SEVERITY_LOW_DEFAULT + $PROFILE_COLOR_SEVERITY_LOWEST_DEFAULT + } + ], + equivalent_modules => [ + qw{ + @STRICT_EQUIVALENT_MODULES + @WARNINGS_EQUIVALENT_MODULES + } + ], +); + +#----------------------------------------------------------------------------- + +Readonly::Scalar our $PROFILE_STRICTNESS_WARN => 'warn'; +Readonly::Scalar our $PROFILE_STRICTNESS_FATAL => 'fatal'; +Readonly::Scalar our $PROFILE_STRICTNESS_QUIET => 'quiet'; +Readonly::Scalar our $PROFILE_STRICTNESS_DEFAULT => $PROFILE_STRICTNESS_WARN; + +Readonly::Hash our %PROFILE_STRICTNESSES => + hashify( + $PROFILE_STRICTNESS_WARN, + $PROFILE_STRICTNESS_FATAL, + $PROFILE_STRICTNESS_QUIET, + ); + +Readonly::Scalar our $PROFILE_COLOR_SEVERITY_HIGHEST_DEFAULT => 'bold red'; +Readonly::Scalar our $PROFILE_COLOR_SEVERITY_HIGH_DEFAULT => 'magenta'; +Readonly::Scalar our $PROFILE_COLOR_SEVERITY_MEDIUM_DEFAULT => $EMPTY; +Readonly::Scalar our $PROFILE_COLOR_SEVERITY_LOW_DEFAULT => $EMPTY; +Readonly::Scalar our $PROFILE_COLOR_SEVERITY_LOWEST_DEFAULT => $EMPTY; + +# If the following changes, the corresponding change needs to be made in +# inc/Perl/Critic/BuildUtilities.pm, sub recommended_module_versions(). +Readonly::Scalar our $_MODULE_VERSION_TERM_ANSICOLOR => 2.02; + +Readonly::Array our @STRICT_EQUIVALENT_MODULES => qw( + Mo + + Moo + Moo::Role + + Moose + Moose::Role + Moose::Exporter + Moose::Util::TypeConstraints + + MooseX::NonMoose + MooseX::Singleton + MooseX::Role::Parameterized + + Mouse + Mouse::Role + Mouse::Exporter + Mouse::Util + Mouse::Util::TypeConstraints + + Moos + + Mousse + + Any::Moose + + Modern::Perl + + Dancer + Dancer2 + + Mojolicious::Lite + Mojo::Base + + Object::Simple + + Role::Tiny + + sane + shit + strictures +); + +# Such modules tend to inflict both strictures and warnings, so for +# the moment these equivalent module lists are exactly the same. +Readonly::Array our @WARNINGS_EQUIVALENT_MODULES + => @STRICT_EQUIVALENT_MODULES; + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Utils::Constants - Global constants. + +=head1 DESCRIPTION + +Defines commonly used constants for L. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public module. Any changes to its +interface will go through a deprecation cycle. + + +=head1 IMPORTABLE CONSTANTS + +=over + +=item C<$PROFILE_STRICTNESS_WARN> + +=item C<$PROFILE_STRICTNESS_FATAL> + +=item C<$PROFILE_STRICTNESS_QUIET> + +=item C<$PROFILE_STRICTNESS_DEFAULT> + +=item C<%PROFILE_STRICTNESSES> + +Valid values for the L option. +Determines whether recoverable problems found in a profile file appear +as warnings, are fatal, or are ignored. +C<$PROFILE_STRICTNESS_DEFAULT> is set to C<$PROFILE_STRICTNESS_WARN>. +Importable via the C<:profile_strictness> tag. + + +=item C<$PROFILE_COLOR_SEVERITY_HIGHEST_DEFAULT> + +Default for the -color-severity-highest option. Importable via the +C<:color_severity> tag. + +=item C<$PROFILE_COLOR_SEVERITY_HIGH_DEFAULT> + +Default for the -color-severity-high option. Importable via the +C<:color_severity> tag. + +=item C<$PROFILE_COLOR_SEVERITY_MEDIUM_DEFAULT> + +Default for the -color-severity-medium option. Importable via the +C<:color_severity> tag. + +=item C<$PROFILE_COLOR_SEVERITY_LOW_DEFAULT> + +Default for the -color-severity-low option. Importable via the +C<:color_severity> tag. + +=item C<$PROFILE_COLOR_SEVERITY_LOWEST_DEFAULT> + +Default for the -color-severity-lowest option. Importable via the +C<:color_severity> tag. + +=item C<@STRICT_EQUIVALENT_MODULES> + +=item C<@WARNINGS_EQUIVALENT_MODULES> + +As the names suggest, these are lists of modules that are equivalent to +applying the L or L pragma when loaded. At +the moment, both lists are exactly the same. B These lists are not +exhaustive; they only include the most commonly used modules. Policies that +use these lists should permit configuration of additional modules. + +=back + + +=head1 AUTHOR + +Elliot Shank + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Utils/DataConversion.pm b/lib/Perl/Critic/Utils/DataConversion.pm new file mode 100644 index 0000000..919dd33 --- /dev/null +++ b/lib/Perl/Critic/Utils/DataConversion.pm @@ -0,0 +1,119 @@ +package Perl::Critic::Utils::DataConversion; + +use 5.006001; +use strict; +use warnings; +use Readonly; + +use Perl::Critic::Utils qw{ :characters :booleans }; + +use Exporter 'import'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Array our @EXPORT_OK => qw( + boolean_to_number + dor + defined_or_empty +); + +#----------------------------------------------------------------------------- + +sub boolean_to_number { ## no critic (RequireArgUnpacking) + return $_[0] ? $TRUE : $FALSE; +} + +#----------------------------------------------------------------------------- + +sub dor { ## no critic (RequireArgUnpacking) + foreach (@_) { + return $_ if defined; + } + return; +} + +#----------------------------------------------------------------------------- + +sub defined_or_empty { ## no critic (RequireArgUnpacking) + return defined $_[0] ? $_[0] : $EMPTY; +} + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Utils::DataConversion - Utilities for converting from one type of data to another. + +=head1 DESCRIPTION + +Provides data conversion functions. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public module. Any changes to its +interface will go through a deprecation cycle. + + +=head1 IMPORTABLE SUBS + +=over + +=item C + +Return 0 or 1 based upon the value of parameter in a boolean context. + + +=item C + +Return either the value or the default based upon whether the value is +defined or not. + +=item C + +Returns the first defined value among its arguments. If none is defined, +simply returns. + + + +=item C + +Return either the parameter or an empty string based upon whether the +parameter is defined or not. + + +=back + + +=head1 AUTHOR + +Elliot Shank + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Utils/McCabe.pm b/lib/Perl/Critic/Utils/McCabe.pm new file mode 100644 index 0000000..693f0bc --- /dev/null +++ b/lib/Perl/Critic/Utils/McCabe.pm @@ -0,0 +1,203 @@ +package Perl::Critic::Utils::McCabe; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use Perl::Critic::Utils qw{ :data_conversion :classification }; + +use Exporter 'import'; + +#----------------------------------------------------------------------------- + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +Readonly::Array our @EXPORT_OK => + qw( calculate_mccabe_of_sub calculate_mccabe_of_main ); + +#----------------------------------------------------------------------------- + +Readonly::Hash my %LOGIC_OPS => + hashify( qw( && || ||= &&= or and xor ? <<= >>= ) ); + +Readonly::Hash my %LOGIC_KEYWORDS => + hashify( qw( if else elsif unless until while for foreach ) ); + +#----------------------------------------------------------------------------- + +sub calculate_mccabe_of_sub { + + my ( $sub ) = @_; + + my $count = 1; # Minimum score is 1 + $count += _count_logic_keywords( $sub ); + $count += _count_logic_operators( $sub ); + + return $count; +} + +#----------------------------------------------------------------------------- + +sub calculate_mccabe_of_main { + + my ( $doc ) = @_; + + my $count = 1; # Minimum score is 1 + $count += _count_main_logic_operators_and_keywords( $doc ); + return $count; +} + +#----------------------------------------------------------------------------- + +sub _count_main_logic_operators_and_keywords { + + my ( $doc ) = @_; + + # I can't leverage Perl::Critic::Document's fast search mechanism here + # because we're not searching for elements by class name. So to speed + # things up, search for both keywords and operators at the same time. + + my $wanted = sub { + + my (undef, $elem) = @_; + + # Only count things that *are not* in a subroutine. Returning an + # explicit 'undef' here prevents PPI from descending into the node. + + ## no critic (ProhibitExplicitReturnUndef) + return undef if $elem->isa('PPI::Statement::Sub'); + + + if ( $elem->isa('PPI::Token::Word') ) { + return 0 if is_hash_key( $elem ); + return exists $LOGIC_KEYWORDS{$elem}; + } + elsif ($elem->isa('PPI::Token::Operator') ) { + return exists $LOGIC_OPS{$elem}; + } + }; + + my $logic_operators_and_keywords = $doc->find( $wanted ); + + my $count = $logic_operators_and_keywords ? + scalar @{$logic_operators_and_keywords} : 0; + + return $count; +} + +#----------------------------------------------------------------------------- + +sub _count_logic_keywords { + + my ( $sub ) = @_; + my $count = 0; + + # Here, I'm using this round-about method of finding elements so + # that I can take advantage of Perl::Critic::Document's faster + # find() mechanism. It can only search for elements by class name. + + my $keywords_ref = $sub->find('PPI::Token::Word'); + if ( $keywords_ref ) { # should always be true due to "sub" keyword + my @filtered = grep { ! is_hash_key($_) } @{ $keywords_ref }; + $count = grep { exists $LOGIC_KEYWORDS{$_} } @filtered; + } + return $count; +} + +#----------------------------------------------------------------------------- + +sub _count_logic_operators { + + my ( $sub ) = @_; + my $count = 0; + + # Here, I'm using this round-about method of finding elements so + # that I can take advantage of Perl::Critic::Document's faster + # find() mechanism. It can only search for elements by class name. + + my $operators_ref = $sub->find('PPI::Token::Operator'); + if ( $operators_ref ) { + $count = grep { exists $LOGIC_OPS{$_} } @{ $operators_ref }; + } + + return $count; +} + + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords McCabe + +=head1 NAME + +Perl::Critic::Utils::McCabe - Functions that calculate the McCabe score of source code. + + +=head1 DESCRIPTION + +Provides approximations of McCabe scores. The McCabe score of a set +of code describes the number of possible paths through it. The +functions here approximate the McCabe score by summing the number of +conditional statements and operators within a set of code. See +L for +some discussion about the McCabe number and other complexity metrics. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public module. Any changes to its +interface will go through a deprecation cycle. + + +=head1 IMPORTABLE SUBS + +=over + +=item C + +Calculates an approximation of the McCabe number of the code in a +L. + + +=item C + +Calculates an approximation of the McCabe number of all the code in a +L that is B +contained in a subroutine. + +=back + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Utils/POD.pm b/lib/Perl/Critic/Utils/POD.pm new file mode 100644 index 0000000..647be2a --- /dev/null +++ b/lib/Perl/Critic/Utils/POD.pm @@ -0,0 +1,713 @@ +package Perl::Critic::Utils::POD; + +use 5.006001; +use strict; +use warnings; + +use English qw< -no_match_vars >; + +use IO::String (); +use Pod::PlainText (); +use Pod::Select (); + +# TODO: non-fatal generic? +use Perl::Critic::Exception::Fatal::Generic qw< throw_generic >; +use Perl::Critic::Exception::IO qw< throw_io >; +use Perl::Critic::Utils qw< :characters >; + +use Exporter 'import'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +our @EXPORT_OK = qw( + get_pod_file_for_module + get_raw_pod_section_from_file + get_raw_pod_section_from_filehandle + get_raw_pod_section_from_string + get_raw_pod_section_for_module + get_pod_section_from_file + get_pod_section_from_filehandle + get_pod_section_from_string + get_pod_section_for_module + trim_raw_pod_section + trim_pod_section + get_raw_module_abstract_from_file + get_raw_module_abstract_from_filehandle + get_raw_module_abstract_from_string + get_raw_module_abstract_for_module + get_module_abstract_from_file + get_module_abstract_from_filehandle + get_module_abstract_from_string + get_module_abstract_for_module +); + +our %EXPORT_TAGS = ( + all => \@EXPORT_OK, +); + +#----------------------------------------------------------------------------- + +sub get_pod_file_for_module { + my ($module_name) = @_; + + # No File::Spec: %INC always uses forward slashes. + (my $relative_path = $module_name) =~ s< :: >xmsg; + $relative_path .= '.pm'; + + my $absolute_path = $INC{$relative_path} or return; + + (my $pod_path = $absolute_path) =~ s< [.] [^.]+ \z><.pod>xms; + return $pod_path if -f $pod_path; + + return $absolute_path; +} + +#----------------------------------------------------------------------------- + +sub get_raw_pod_section_from_file { + my ($file_name, $section_name) = @_; + + return _get_pod_section_from_file( + $file_name, + $section_name, + Pod::Select->new(), + ); +} + +#----------------------------------------------------------------------------- + +sub get_raw_pod_section_from_filehandle { + my ($file_handle, $section_name) = @_; + + return _get_pod_section_from_filehandle( + $file_handle, + $section_name, + Pod::Select->new(), + ); +} + +#----------------------------------------------------------------------------- + +sub get_raw_pod_section_from_string { + my ($source, $section_name) = @_; + + return _get_pod_section_from_string( + $source, + $section_name, + Pod::Select->new(), + ); +} + +#----------------------------------------------------------------------------- + +sub get_raw_pod_section_for_module { + my ($module_name, $section_name) = @_; + + my $file_name = get_pod_file_for_module($module_name) + or throw_generic qq; + + return get_raw_pod_section_from_file($file_name, $section_name); +} + +#----------------------------------------------------------------------------- + +sub get_pod_section_from_file { + my ($file_name, $section_name) = @_; + + return _get_pod_section_from_file( + $file_name, + $section_name, + Pod::PlainText->new(), + ); +} + +#----------------------------------------------------------------------------- + +sub get_pod_section_from_filehandle { + my ($file_handle, $section_name) = @_; + + return _get_pod_section_from_filehandle( + $file_handle, + $section_name, + Pod::PlainText->new(), + ); +} + +#----------------------------------------------------------------------------- + +sub get_pod_section_from_string { + my ($source, $section_name) = @_; + + return _get_pod_section_from_string( + $source, + $section_name, + Pod::PlainText->new(), + ); +} + +#----------------------------------------------------------------------------- + +sub get_pod_section_for_module { + my ($module_name, $section_name) = @_; + + my $file_name = get_pod_file_for_module($module_name) + or throw_generic qq; + + return get_pod_section_from_file($file_name, $section_name); +} + +#----------------------------------------------------------------------------- + +sub _get_pod_section_from_file { + my ($file_name, $section_name, $parser) = @_; + + open my $file_handle, '<', $file_name + or throw_io + message => qq, + file_name => $file_name, + errno => $ERRNO; + + my $content = + _get_pod_section_from_filehandle( + $file_handle, $section_name, $parser, + ); + + close $file_handle + or throw_io + message => qq, + file_name => $file_name, + errno => $ERRNO; + + return $content; +} + +#----------------------------------------------------------------------------- + +sub _get_pod_section_from_filehandle { + my ($file_handle, $section_name, $parser) = @_; + + $parser->select($section_name); + + my $content = $EMPTY; + my $content_handle = IO::String->new( \$content ); + + $parser->parse_from_filehandle( $file_handle, $content_handle ); + + return if $content eq $EMPTY; + return $content; +} + +#----------------------------------------------------------------------------- + +sub _get_pod_section_from_string { + my ($source, $section_name, $parser) = @_; + + my $source_handle = IO::String->new( \$source ); + + return + _get_pod_section_from_filehandle( + $source_handle, $section_name, $parser, + ); +} + +#----------------------------------------------------------------------------- + +sub trim_raw_pod_section { + my ($pod) = @_; + + return if not defined $pod; + + $pod =~ s< \A =head1 \b [^\n]* \n $ ><>xms; + $pod =~ s< \A \s+ ><>xms; + $pod =~ s< \s+ \z ><>xms; + + return $pod; +} + +#----------------------------------------------------------------------------- + +sub trim_pod_section { + my ($pod) = @_; + + return if not defined $pod; + + $pod =~ s< \A [^\n]* \n ><>xms; + $pod =~ s< \A \s* \n ><>xms; + $pod =~ s< \s+ \z ><>xms; + + return $pod; +} + +#----------------------------------------------------------------------------- + +sub get_raw_module_abstract_from_file { + my ($file_name) = @_; + + return + _get_module_abstract_from_file( + $file_name, + Pod::Select->new(), + \&trim_raw_pod_section, + ); +} + +#----------------------------------------------------------------------------- + +sub get_raw_module_abstract_from_filehandle { + my ($file_handle) = @_; + + return + _get_module_abstract_from_filehandle( + $file_handle, + Pod::Select->new(), + \&trim_raw_pod_section, + ); +} + +#----------------------------------------------------------------------------- + +sub get_raw_module_abstract_from_string { + my ($source) = @_; + + return + _get_module_abstract_from_string( + $source, + Pod::Select->new(), + \&trim_raw_pod_section, + ); +} + +#----------------------------------------------------------------------------- + +sub get_raw_module_abstract_for_module { + my ($module_name) = @_; + + my $file_name = get_pod_file_for_module($module_name) + or throw_generic qq; + + return get_raw_module_abstract_from_file($file_name); +} + +#----------------------------------------------------------------------------- + +sub get_module_abstract_from_file { + my ($file_name) = @_; + + return + _get_module_abstract_from_file( + $file_name, + Pod::PlainText->new(), + \&trim_pod_section, + ); +} + +#----------------------------------------------------------------------------- + +sub get_module_abstract_from_filehandle { + my ($file_handle) = @_; + + return + _get_module_abstract_from_filehandle( + $file_handle, + Pod::PlainText->new(), + \&trim_pod_section, + ); +} + +#----------------------------------------------------------------------------- + +sub get_module_abstract_from_string { + my ($source) = @_; + + return + _get_module_abstract_from_string( + $source, + Pod::PlainText->new(), + \&trim_pod_section, + ); +} + +#----------------------------------------------------------------------------- + +sub get_module_abstract_for_module { + my ($module_name) = @_; + + my $file_name = get_pod_file_for_module($module_name) + or throw_generic qq; + + return get_module_abstract_from_file($file_name); +} + +#----------------------------------------------------------------------------- + +sub _get_module_abstract_from_file { + my ($file_name, $parser, $trimmer) = @_; + + open my $file_handle, '<', $file_name + or throw_io + message => qq, + file_name => $file_name, + errno => $ERRNO; + + my $module_abstract = + _get_module_abstract_from_filehandle( + $file_handle, $parser, $trimmer, + ); + + close $file_handle + or throw_io + message => qq, + file_name => $file_name, + errno => $ERRNO; + + return $module_abstract; +} + +#----------------------------------------------------------------------------- + +sub _get_module_abstract_from_filehandle { ## no critic (RequireFinalReturn) + my ($file_handle, $parser, $trimmer) = @_; + + my $name_section = + _get_pod_section_from_filehandle( $file_handle, 'NAME', $parser ); + return if not $name_section; + + $name_section = $trimmer->($name_section); + return if not $name_section; + + # Testing for parser class, blech. But it's a lot simpler and it's all + # hidden in the implementation. + if ('Pod::Select' eq ref $parser) { + if ( $name_section =~ m< \n >xms ) { + throw_generic + qq + . q; + } + } + else { + $name_section =~ s< \s+ >< >xmsg; + + # Ugh. Pod::PlainText splits up module names. + if ( + $name_section =~ m< + \A + \s* + ( + \w [ \w:]+ \w + ) + ( + \s* + - + .* + )? + \z + >xms + ) { + my ($module_name, $rest) = ($1, $2); + + $module_name =~ s/ [ ] //xms; + + $name_section = $module_name . ( $rest ? $rest : $EMPTY ); + } + } + + if ( + $name_section =~ m< + \A + \s* + [\w:]+ # Module name. + \s+ + - # The required single hyphen. + \s+ + ( + \S # At least one non-whitespace. + (?: .* \S)? # Everything up to the last non-whitespace. + ) + \s* + \z + >xms + ) { + my $module_abstract = $1; + return $module_abstract; + } + + if ( + $name_section =~ m< + \A + \s* + [\w:]+ # Module name. + (?: \s* - )? # The single hyphen is now optional. + \s* + \z + >xms + ) { + return; + } + + throw_generic qq; +} + +#----------------------------------------------------------------------------- + +sub _get_module_abstract_from_string { + my ($source, $parser, $trimmer) = @_; + + my $source_handle = IO::String->new( \$source ); + + return + _get_module_abstract_from_filehandle( + $source_handle, $parser, $trimmer, + ); +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Utils::POD - Utility functions for dealing with POD. + + +=head1 SYNOPSIS + + use Perl::Critic::Utils::POD qw< get_pod_section_from_file >; + + my $synopsis = + get_pod_section_from_file('Perl/Critic/Utils/POD.pm', 'SYNOPSIS'); + + my $see_also = + get_pod_section_from_filehandle($file_handle, 'SEE ALSO'); + + + my $see_also_content = trim_pod_section($see_also); + + + # "Utility functions for dealing with POD." + my $module_abstract = + get_module_abstract_from_file('Perl/Critic/Utils/POD.pm'); + + my $module_abstract = + get_module_abstract_from_filehandle($file_handle); + + +=head1 DESCRIPTION + +Provides means of accessing chunks of POD. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public module. Any changes to its +interface will go through a deprecation cycle. + + +=head1 IMPORTABLE SUBROUTINES + +=over + +=item C + +Figure out where to find the POD for the parameter. + +This depends upon the module already being loaded; it will not find +the path for arbitrary modules. + +If there is a file with a ".pod" extension next to the real module +location, it will be returned in preference to the actual module. + + +=item C + +Retrieves the specified section of POD (i.e. something marked by +C<=head1>) from the file. This is uninterpreted; escapes are not +processed and any sub-sections will be present. E.g. if the content +contains "CZ<><$x>", the return value will contain "CZ<><$x>". + +Returns nothing if no such section is found. + +Throws a L if +there's a problem with the file. + + +=item C + +Does the same as C, but with a file +handle. + + +=item C + +Does the same as C, but with a string +that contains the raw POD. + + +=item C + +Does the same as C, but with a module +name. + +Throws a +L +if a file containing POD for the module can't be found. + + +=item C + +Retrieves the specified section of POD (i.e. something marked by +C<=head1>) from the file. This is interpreted into plain text. + +Returns nothing if no such section is found. + +Throws a L if +there's a problem with the file. + + +=item C + +Does the same as C, but with a file +handle. + + +=item C + +Does the same as C, but with a string +that contains the raw POD. + + +=item C + +Does the same as C, but with a module +name. + +Throws a +L +if a file containing POD for the module can't be found. + + +=item C + +Returns a copy of the parameter, with any starting C<=item1 BLAH> +removed and all leading and trailing whitespace (including newlines) +removed after that. + +For example, using one of the C functions +to get the "NAME" section of this module and then calling +C on the result would give you +"Perl::Critic::Utils::POD - Utility functions for dealing with POD.". + + +=item C + +Returns a copy of the parameter, with any starting line removed and +leading blank lines and trailing whitespace (including newlines) +removed after that. Note that only leading whitespace on the first +real line of the section will remain. + +Since this cannot count upon a C<=item1> marker, this is much less +reliable than C. + + +=item C + +Attempts to parse the "NAME" section of the specified file and get the +abstract of the module from that. If it succeeds, it returns the +abstract. If it fails, either because there is no "NAME" section or +there is no abstract after the module name, returns nothing. If it +looks like there's a malformed abstract, throws a +L. + +Example "well formed" "NAME" sections without abstracts: + + Some::Module + + Some::Other::Module - + +Example "NAME" sections that will result in an exception: + + Some::Bad::Module This has no hyphen. + + Some::Mean::Module -- This has double hyphens. + + Some::Nasty::Module - This one attempts to + span multiple lines. + + +=item C + +Does the same as C, but with a +file handle. + + +=item C + +Does the same as C, but with a +string that contains the raw POD. + + +=item C + +Does the same as C, but for a +module name. + + +=item C + +Does the same as C, but with +escapes interpreted. + + +=item C + +Does the same as C, but with a file +handle. + + +=item C + +Does the same as C, but with a string +that contains the raw POD. + + +=item C + +Does the same as C, but for a module +name. + + +=back + + +=head1 AUTHOR + +Elliot Shank + + +=head1 COPYRIGHT + +Copyright (c) 2008-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Utils/POD/ParseInteriorSequence.pm b/lib/Perl/Critic/Utils/POD/ParseInteriorSequence.pm new file mode 100644 index 0000000..a75887f --- /dev/null +++ b/lib/Perl/Critic/Utils/POD/ParseInteriorSequence.pm @@ -0,0 +1,112 @@ +package Perl::Critic::Utils::POD::ParseInteriorSequence; + +use 5.006001; +use strict; +use warnings; + +use base qw{ Pod::Parser }; + +use IO::String; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +sub interior_sequence { + my ( $self, $seq_cmd, $seq_arg, $pod_seq ) = @_; + push @{ $self->{+__PACKAGE__}{interior_sequence} ||= [] }, $pod_seq; + return $self->SUPER::interior_sequence( $seq_cmd, $seq_arg, $pod_seq ); +} + +#----------------------------------------------------------------------------- + +sub get_interior_sequences { + my ( $self, $pod ) = @_; + $self->{+__PACKAGE__}{interior_sequence} = []; + my $result; + $self->parse_from_filehandle( + IO::String->new( \$pod ), + IO::String->new( \$result ) + ); + return @{ $self->{+__PACKAGE__}{interior_sequence} }; +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Utils::POD::ParseInteriorSequence - Pod::Parser subclass to find all interior sequences. + + +=head1 SYNOPSIS + + use Perl::Critic::Utils::POD::ParseInteriorSequence; + + my $parser = Perl::Critic::Utils::POD::ParseInteriorSequence->new(); + my @sequences = $parser->parse_interior_sequences( + $pod->content() ); + + +=head1 DESCRIPTION + +Provides a means to extract interior sequences from POD text. + + +=head1 INTERFACE SUPPORT + +This module is considered to be private to Perl::Critic. It can be +changed or removed without notice. + + +=head1 METHODS + +=over + +=item C + +Returns an array of all the interior sequences from a given chunk of POD +text, represented as L objects. +The POD text is assumed to begin with a POD command (e.g. C<=pod>). + +=item C + +Overrides the parent's method of the same name. Stashes the $pod_seq +argument, which is a C object, so that +C has access to it. + +=back + + +=head1 AUTHOR + +Thomas R. Wyant, III F + + +=head1 COPYRIGHT + +Copyright (c) 2011 Thomas R. Wyant, III + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Utils/PPI.pm b/lib/Perl/Critic/Utils/PPI.pm new file mode 100644 index 0000000..5700d3f --- /dev/null +++ b/lib/Perl/Critic/Utils/PPI.pm @@ -0,0 +1,415 @@ +package Perl::Critic::Utils::PPI; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use Scalar::Util qw< blessed readonly >; + +use Exporter 'import'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +our @EXPORT_OK = qw( + is_ppi_expression_or_generic_statement + is_ppi_generic_statement + is_ppi_statement_subclass + is_ppi_simple_statement + is_ppi_constant_element + is_subroutine_declaration + is_in_subroutine + get_constant_name_element_from_declaring_statement + get_next_element_in_same_simple_statement + get_previous_module_used_on_same_line +); + +our %EXPORT_TAGS = ( + all => \@EXPORT_OK, +); + +#----------------------------------------------------------------------------- + +sub is_ppi_expression_or_generic_statement { + my $element = shift; + + return if not $element; + return if not $element->isa('PPI::Statement'); + return 1 if $element->isa('PPI::Statement::Expression'); + + my $element_class = blessed($element); + + return if not $element_class; + return $element_class eq 'PPI::Statement'; +} + +#----------------------------------------------------------------------------- + +sub is_ppi_generic_statement { + my $element = shift; + + my $element_class = blessed($element); + + return if not $element_class; + return if not $element->isa('PPI::Statement'); + + return $element_class eq 'PPI::Statement'; +} + +#----------------------------------------------------------------------------- + +sub is_ppi_statement_subclass { + my $element = shift; + + my $element_class = blessed($element); + + return if not $element_class; + return if not $element->isa('PPI::Statement'); + + return $element_class ne 'PPI::Statement'; +} + +#----------------------------------------------------------------------------- + +# Can not use hashify() here because Perl::Critic::Utils already depends on +# this module. +Readonly::Hash my %SIMPLE_STATEMENT_CLASS => map { $_ => 1 } qw< + PPI::Statement + PPI::Statement::Break + PPI::Statement::Include + PPI::Statement::Null + PPI::Statement::Package + PPI::Statement::Variable +>; + +sub is_ppi_simple_statement { + my $element = shift or return; + + my $element_class = blessed( $element ) or return; + + return $SIMPLE_STATEMENT_CLASS{ $element_class }; +} + +#----------------------------------------------------------------------------- + +sub is_ppi_constant_element { + my $element = shift or return; + + blessed( $element ) or return; + + # TODO implement here documents once PPI::Token::HereDoc grows the + # necessary PPI::Token::Quote interface. + return + $element->isa( 'PPI::Token::Number' ) + || $element->isa( 'PPI::Token::Quote::Literal' ) + || $element->isa( 'PPI::Token::Quote::Single' ) + || $element->isa( 'PPI::Token::QuoteLike::Words' ) + || ( + $element->isa( 'PPI::Token::Quote::Double' ) + || $element->isa( 'PPI::Token::Quote::Interpolate' ) ) + && $element->string() !~ m< (?: \A | [^\\] ) (?: \\\\)* [\$\@] >smx + ; +} + +#----------------------------------------------------------------------------- + +sub is_subroutine_declaration { + my $element = shift; + + return if not $element; + + return 1 if $element->isa('PPI::Statement::Sub'); + + if ( is_ppi_generic_statement($element) ) { + my $first_element = $element->first_element(); + + return 1 if + $first_element + and $first_element->isa('PPI::Token::Word') + and $first_element->content() eq 'sub'; + } + + return; +} + +#----------------------------------------------------------------------------- + +sub is_in_subroutine { + my ($element) = @_; + + return if not $element; + return 1 if is_subroutine_declaration($element); + + while ( $element = $element->parent() ) { + return 1 if is_subroutine_declaration($element); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub get_constant_name_element_from_declaring_statement { + my ($element) = @_; + + warnings::warnif( + 'deprecated', + 'Perl::Critic::Utils::PPI::get_constant_name_element_from_declaring_statement() is deprecated. Use PPIx::Utilities::Statement::get_constant_name_elements_from_declaring_statement() instead.', + ); + + return if not $element; + return if not $element->isa('PPI::Statement'); + + if ( $element->isa('PPI::Statement::Include') ) { + my $pragma; + if ( $pragma = $element->pragma() and $pragma eq 'constant' ) { + return _constant_name_from_constant_pragma($element); + } + } + elsif ( + is_ppi_generic_statement($element) + and $element->schild(0)->content() =~ m< \A Readonly \b >xms + ) { + return $element->schild(2); + } + + return; +} + +sub _constant_name_from_constant_pragma { + my ($include) = @_; + + my @arguments = $include->arguments() or return; + + my $follower = $arguments[0]; + return if not defined $follower; + + return $follower; +} + +#----------------------------------------------------------------------------- + +sub get_next_element_in_same_simple_statement { + my $element = shift or return; + + while ( $element and ( + not is_ppi_simple_statement( $element ) + or $element->parent() + and $element->parent()->isa( 'PPI::Structure::List' ) ) ) { + my $next; + $next = $element->snext_sibling() and return $next; + $element = $element->parent(); + } + return; + +} + +#----------------------------------------------------------------------------- + +sub get_previous_module_used_on_same_line { + my $element = shift or return; + + my ( $line ) = @{ $element->location() || []}; + + while (not is_ppi_simple_statement( $element )) { + $element = $element->parent() or return; + } + + while ( $element = $element->sprevious_sibling() ) { + ( @{ $element->location() || []} )[0] == $line or return; + $element->isa( 'PPI::Statement::Include' ) + and return $element->schild( 1 ); + } + + return; +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Utils::PPI - Utility functions for dealing with PPI objects. + + +=head1 DESCRIPTION + +Provides classification of L. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public module. Any changes to its +interface will go through a deprecation cycle. + + +=head1 IMPORTABLE SUBS + +=over + +=item C + +Answers whether the parameter is an expression or an undifferentiated +statement. I.e. the parameter either is a +L or the class +of the parameter is L and not one of +its subclasses other than C. + + +=item C + +Answers whether the parameter is an undifferentiated statement, i.e. +the parameter is a L but not one of its +subclasses. + + +=item C + +Answers whether the parameter is a specialized statement, i.e. the +parameter is a L but the class of the +parameter is not L. + + +=item C + +Answers whether the parameter represents a simple statement, i.e. whether the +parameter is a L, +L, +L, +L, +L, or +L. + + +=item C + +Answers whether the parameter represents a constant value, i.e. whether the +parameter is a L, +L, +L, or +L, or is a +L or +L which does +not in fact contain any interpolated variables. + +This subroutine does B interpret any form of here document as a constant +value, and may not until L acquires +the relevant portions of the L interface. + +This subroutine also does B interpret entities created by the +L module or the L pragma as constants, +because the infrastructure to detect these appears not to be present, and the +author of this subroutine (B Mr. Shank or Mr. Thalhammer) lacks the +knowledge/expertise/gumption to put it in place. + + +=item C + +Is the parameter a subroutine declaration, named or not? + + +=item C + +Is the parameter a subroutine or inside one? + + +=item C + +B You should use +L +instead. + +Given a L, if the statement is a C or L declaration statement, return the name of +the thing being defined. + +Given + + use constant 1.16 FOO => 'bar'; + +this will return "FOO". Similarly, given + + Readonly::Hash my %FOO => ( bar => 'baz' ); + +this will return "%FOO". + +B in the case where multiple constants are declared using the same +C statement (e.g. C<< use constant { FOO => 1, BAR => 2 }; >>, +this subroutine will return the declaring +L. In the case of +C<< use constant 1.16 { FOO => 1, BAR => 2 }; >> it may return a +L instead of a +L, due to a parse +error in L. + + +=item C + +Given a L, this subroutine returns the next element +in the same simple statement as defined by is_ppi_simple_statement(). If no +next element can be found, this subroutine simply returns. + +If the $element is undefined or unblessed, we simply return. + +If the $element satisfies C, we return, B +it has a parent which is a L. + +If the $element is the last significant element in its L, +we replace it with its parent and iterate again. + +Otherwise, we return C<< $element->snext_sibling() >>. + + +=item C + +Given a L, returns the L +representing the name of the module included by the previous C or +C on the same line as the $element. If none is found, simply returns. + +For example, with the line + + use version; our $VERSION = ...; + +given the L instance for C<$VERSION>, this will return +"version". + +If the given element is in a C or , the return is from the +previous C or C on the line, if any. + + +=back + + +=head1 AUTHOR + +Elliot Shank + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Utils/Perl.pm b/lib/Perl/Critic/Utils/Perl.pm new file mode 100644 index 0000000..e01b03b --- /dev/null +++ b/lib/Perl/Critic/Utils/Perl.pm @@ -0,0 +1,100 @@ +package Perl::Critic::Utils::Perl; + +use 5.006001; +use strict; +use warnings; + +use Exporter 'import'; + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +our @EXPORT_OK = qw( + symbol_without_sigil +); + +our %EXPORT_TAGS = ( + all => \@EXPORT_OK, +); + +#----------------------------------------------------------------------------- + +sub symbol_without_sigil { + my ($symbol) = @_; + + (my $without_sigil = $symbol) =~ s< \A [\$@%*&] ><>xms; + + return $without_sigil; +} + +#----------------------------------------------------------------------------- + +1; + +__END__ + +=pod + +=for stopwords + +=head1 NAME + +Perl::Critic::Utils::Perl - Utility functions for dealing with Perl language issues. + + +=head1 SYNOPSIS + + use Perl::Critic::Utils::Perl qw< :all >; + + my $name = symbol_without_sigil('$foo'); # $name is "foo". + + +=head1 DESCRIPTION + +This handles various issues with Perl, the language, that aren't necessarily +L related. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public module. Any changes to its +interface will go through a deprecation cycle. + + +=head1 IMPORTABLE SUBROUTINES + +=over + +=item C + +Returns the name of the specified symbol with any sigil at the front. +The parameter can be a vanilla Perl string or a L. + + +=back + + +=head1 AUTHOR + +Elliot Shank + + +=head1 COPYRIGHT + +Copyright (c) 2007-2011 Elliot Shank. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Perl/Critic/Violation.pm b/lib/Perl/Critic/Violation.pm new file mode 100644 index 0000000..39b9b51 --- /dev/null +++ b/lib/Perl/Critic/Violation.pm @@ -0,0 +1,599 @@ +package Perl::Critic::Violation; + +use 5.006001; +use strict; +use warnings; + +use Readonly; + +use File::Basename qw< basename >; +use Scalar::Util qw< blessed >; +use String::Format qw< stringf >; + +use overload ( q{""} => 'to_string', cmp => '_compare' ); + +use Perl::Critic::Utils qw< :characters :internal_lookup >; +use Perl::Critic::Utils::POD qw< + get_pod_section_for_module + trim_pod_section +>; +use Perl::Critic::Exception::Fatal::Internal qw< throw_internal >; + +our $VERSION = '1.140'; + +Readonly::Scalar my $NO_EXCEPTION_NO_SPLIT_LIMIT => -1; +Readonly::Scalar my $LOCATION_LINE_NUMBER => 0; +Readonly::Scalar my $LOCATION_COLUMN_NUMBER => 1; +Readonly::Scalar my $LOCATION_VISUAL_COLUMN_NUMBER => 2; +Readonly::Scalar my $LOCATION_LOGICAL_LINE_NUMBER => 3; +Readonly::Scalar my $LOCATION_LOGICAL_FILENAME => 4; + +# Class variables... +my $format = "%m at line %l, column %c. %e.\n"; # Default stringy format +my %diagnostics = (); # Cache of diagnostic messages + +#----------------------------------------------------------------------------- + +Readonly::Scalar my $CONSTRUCTOR_ARG_COUNT => 5; + +sub new { + my ( $class, $desc, $expl, $elem, $sev ) = @_; + + # Check arguments to help out developers who might + # be creating new Perl::Critic::Policy modules. + + if ( @_ != $CONSTRUCTOR_ARG_COUNT ) { + throw_internal 'Wrong number of args to Violation->new()'; + } + + if ( eval { $elem->isa( 'Perl::Critic::Document' ) } ) { + # break the facade, return the real PPI::Document + $elem = $elem->ppi_document(); + } + + if ( not eval { $elem->isa( 'PPI::Element' ) } ) { + throw_internal '3rd arg to Violation->new() must be a PPI::Element'; + } + + # Strip punctuation. These are controlled by the user via the + # formats. He/She can use whatever makes sense to them. + ($desc, $expl) = _chomp_periods($desc, $expl); + + # Create object + my $self = bless {}, $class; + $self->{_description} = $desc; + $self->{_explanation} = $expl; + $self->{_severity} = $sev; + $self->{_policy} = caller; + + # PPI eviscerates the Elements in a Document when the Document gets + # DESTROY()ed, and thus they aren't useful after it is gone. So we have + # to preemptively grab everything we could possibly want. + $self->{_element_class} = blessed $elem; + + my $top = $elem->top(); + $self->{_filename} = $top->can('filename') ? $top->filename() : undef; + $self->{_source} = _line_containing_violation( $elem ); + $self->{_location} = + $elem->location() || [ 0, 0, 0, 0, $self->filename() ]; + + return $self; +} + +#----------------------------------------------------------------------------- + +sub set_format { return $format = verbosity_to_format( $_[0] ); } ## no critic(ArgUnpacking) +sub get_format { return $format; } + +#----------------------------------------------------------------------------- + +sub sort_by_location { ## no critic(ArgUnpacking) + + ref $_[0] || shift; # Can call as object or class method + return scalar @_ if ! wantarray; # In case we are called in scalar context + + ## TODO: What if $a and $b are not Violation objects? + return + map {$_->[0]} + sort { ($a->[1] <=> $b->[1]) || ($a->[2] <=> $b->[2]) } + map {[$_, $_->location->[0] || 0, $_->location->[1] || 0]} + @_; +} + +#----------------------------------------------------------------------------- + +sub sort_by_severity { ## no critic(ArgUnpacking) + + ref $_[0] || shift; # Can call as object or class method + return scalar @_ if ! wantarray; # In case we are called in scalar context + + ## TODO: What if $a and $b are not Violation objects? + return + map {$_->[0]} + sort { $a->[1] <=> $b->[1] } + map {[$_, $_->severity() || 0]} + @_; +} + +#----------------------------------------------------------------------------- + +sub location { + my $self = shift; + + return $self->{_location}; +} + +#----------------------------------------------------------------------------- + +sub line_number { + my ($self) = @_; + + return $self->location()->[$LOCATION_LINE_NUMBER]; +} + +#----------------------------------------------------------------------------- + +sub logical_line_number { + my ($self) = @_; + + return $self->location()->[$LOCATION_LOGICAL_LINE_NUMBER]; +} + +#----------------------------------------------------------------------------- + +sub column_number { + my ($self) = @_; + + return $self->location()->[$LOCATION_COLUMN_NUMBER]; +} + +#----------------------------------------------------------------------------- + +sub visual_column_number { + my ($self) = @_; + + return $self->location()->[$LOCATION_VISUAL_COLUMN_NUMBER]; +} + +#----------------------------------------------------------------------------- + +sub diagnostics { + my ($self) = @_; + my $policy = $self->policy(); + + if ( not $diagnostics{$policy} ) { + eval { ## no critic (RequireCheckingReturnValueOfEval) + my $module_name = ref $policy || $policy; + $diagnostics{$policy} = + trim_pod_section( + get_pod_section_for_module( $module_name, 'DESCRIPTION' ) + ); + }; + $diagnostics{$policy} ||= " No diagnostics available\n"; + } + return $diagnostics{$policy}; +} + +#----------------------------------------------------------------------------- + +sub description { + my $self = shift; + return $self->{_description}; +} + +#----------------------------------------------------------------------------- + +sub explanation { + my $self = shift; + my $expl = $self->{_explanation}; + if ( !$expl ) { + $expl = '(no explanation)'; + } + if ( ref $expl eq 'ARRAY' ) { + my $page = @{$expl} > 1 ? 'pages' : 'page'; + $page .= $SPACE . join $COMMA, @{$expl}; + $expl = "See $page of PBP"; + } + return $expl; +} + +#----------------------------------------------------------------------------- + +sub severity { + my $self = shift; + return $self->{_severity}; +} + +#----------------------------------------------------------------------------- + +sub policy { + my $self = shift; + return $self->{_policy}; +} + +#----------------------------------------------------------------------------- + +sub filename { + my $self = shift; + return $self->{_filename}; +} + +#----------------------------------------------------------------------------- + +sub logical_filename { + my ($self) = @_; + + return $self->location()->[$LOCATION_LOGICAL_FILENAME]; +} + +#----------------------------------------------------------------------------- + +sub source { + my $self = shift; + return $self->{_source}; +} + +#----------------------------------------------------------------------------- + +sub element_class { + my ($self) = @_; + + return $self->{_element_class}; +} + +#----------------------------------------------------------------------------- + +sub to_string { + my $self = shift; + + my $long_policy = $self->policy(); + (my $short_policy = $long_policy) =~ s/ \A Perl::Critic::Policy:: //xms; + + # Wrap the more expensive ones in sub{} to postpone evaluation + my %fspec = ( + 'f' => sub { $self->logical_filename() }, + 'F' => sub { basename( $self->logical_filename() ) }, + 'g' => sub { $self->filename() }, + 'G' => sub { basename( $self->filename() ) }, + 'l' => sub { $self->logical_line_number() }, + 'L' => sub { $self->line_number() }, + 'c' => sub { $self->visual_column_number() }, + 'C' => sub { $self->element_class() }, + 'm' => $self->description(), + 'e' => $self->explanation(), + 's' => $self->severity(), + 'd' => sub { $self->diagnostics() }, + 'r' => sub { $self->source() }, + 'P' => $long_policy, + 'p' => $short_policy, + ); + return stringf($format, %fspec); +} + +#----------------------------------------------------------------------------- +# Apparently, some perls do not implicitly stringify overloading +# objects before doing a comparison. This causes a couple of our +# sorting tests to fail. To work around this, we overload C to +# do it explicitly. +# +# 20060503 - More information: This problem has been traced to +# Test::Simple versions <= 0.60, not perl itself. Upgrading to +# Test::Simple v0.62 will fix the problem. But rather than forcing +# everyone to upgrade, I have decided to leave this workaround in +# place. + +sub _compare { return "$_[0]" cmp "$_[1]" } + +#----------------------------------------------------------------------------- + +sub _line_containing_violation { + my ( $elem ) = @_; + + my $stmnt = $elem->statement() || $elem; + my $code_string = $stmnt->content() || $EMPTY; + + # Split into individual lines + # From `perldoc -f split`: + # If LIMIT is negative, it is treated as if it were instead + # arbitrarily large; as many fields as possible are produced. + # + # If it's omitted, it's the same except trailing empty fields, so we need + # without a limit for the split and without an exception + my @lines = split qr{ \n }xms, $code_string, $NO_EXCEPTION_NO_SPLIT_LIMIT; + + # Take the line containing the element that is in violation + my $inx = ( $elem->line_number() || 0 ) - + ( $stmnt->line_number() || 0 ); + $inx > @lines and return $EMPTY; + return $lines[$inx]; +} + +#----------------------------------------------------------------------------- + +sub _chomp_periods { + my @args = @_; + + for (@args) { + next if not defined or ref; + s{ [.]+ \z }{}xms + } + + return @args; +} + +#----------------------------------------------------------------------------- + +1; + +#----------------------------------------------------------------------------- + +__END__ + +=head1 NAME + +Perl::Critic::Violation - A violation of a Policy found in some source code. + + +=head1 SYNOPSIS + + use PPI; + use Perl::Critic::Violation; + + my $elem = $doc->child(0); # $doc is a PPI::Document object + my $desc = 'Offending code'; # Describe the violation + my $expl = [1,45,67]; # Page numbers from PBP + my $sev = 5; # Severity level of this violation + + my $vio = Perl::Critic::Violation->new($desc, $expl, $node, $sev); + + +=head1 DESCRIPTION + +Perl::Critic::Violation is the generic representation of an individual +Policy violation. Its primary purpose is to provide an abstraction +layer so that clients of L don't have to +know anything about L. The C method of all +L subclasses must return a +list of these Perl::Critic::Violation objects. + + +=head1 INTERFACE SUPPORT + +This is considered to be a public class. Any changes to its interface +will go through a deprecation cycle. + + +=head1 CONSTRUCTOR + +=over + +=item C + +Returns a reference to a new C object. The +arguments are a description of the violation (as string), an +explanation for the policy (as string) or a series of page numbers in +PBP (as an ARRAY ref), a reference to the L element that +caused the violation, and the severity of the violation (as an +integer). + + +=back + + +=head1 METHODS + +=over + +=item C + +Returns a brief description of the specific violation. In other +words, this value may change on a per violation basis. + + +=item C + +Returns an explanation of the policy as a string or as reference to an +array of page numbers in PBP. This value will generally not change +based upon the specific code violating the policy. + + +=item C + +Don't use this method. Use the C, +C, C, +C, and C methods instead. + +Returns a five-element array reference containing the line and real & +virtual column and logical numbers and logical file name where this +Violation occurred, as in L. + + +=item C + +Returns the physical line number that the violation was found on. + + +=item C + +Returns the logical line number that the violation was found on. This +can differ from the physical line number when there were C<#line> +directives in the code. + + +=item C + +Returns the physical column that the violation was found at. This +means that hard tab characters count as a single character. + + +=item C + +Returns the column that the violation was found at, as it would appear +if hard tab characters were expanded, based upon the value of +L. + + +=item C + +Returns the path to the file where this Violation occurred. In some +cases, the path may be undefined because the source code was not read +directly from a file. + + +=item C + +Returns the logical path to the file where the Violation occurred. +This can differ from C when there was a C<#line> directive +in the code. + + +=item C + +Returns the severity of this Violation as an integer ranging from 1 to +5, where 5 is the "most" severe. + + +=item C + +If you need to sort Violations by severity, use this handy routine: + + @sorted = Perl::Critic::Violation::sort_by_severity(@violations); + + +=item C + +If you need to sort Violations by location, use this handy routine: + + @sorted = Perl::Critic::Violation::sort_by_location(@violations); + + +=item C + +Returns a formatted string containing a full discussion of the +motivation for and details of the Policy module that created this +Violation. This information is automatically extracted from the +C section of the Policy module's POD. + + +=item C + +Returns the name of the L +that created this Violation. + + +=item C + +Returns the string of source code that caused this exception. If the +code spans multiple lines (e.g. multi-line statements, subroutines or +other blocks), then only the line containing the violation will be +returned. + + +=item C + +Returns the L subclass of the code that caused this +exception. + + +=item C + +Class method. Sets the format for all Violation objects when they are +evaluated in string context. The default is C<'%d at line %l, column +%c. %e'>. See L<"OVERLOADS"> for formatting options. + + +=item C + +Class method. Returns the current format for all Violation objects +when they are evaluated in string context. + + +=item C + +Returns a string representation of this violation. The content of the +string depends on the current value of the C<$format> package +variable. See L<"OVERLOADS"> for the details. + + +=back + + +=head1 OVERLOADS + +Perl::Critic::Violation overloads the C<""> operator to produce neat +little messages when evaluated in string context. + +Formats are a combination of literal and escape characters similar to +the way C works. If you want to know the specific formatting +capabilities, look at L. Valid escape +characters are: + + Escape Meaning + ------- ---------------------------------------------------------------- + %c Column number where the violation occurred + %d Full diagnostic discussion of the violation (DESCRIPTION in POD) + %e Explanation of violation or page numbers in PBP + %F Just the name of the logical file where the violation occurred. + %f Path to the logical file where the violation occurred. + %G Just the name of the physical file where the violation occurred. + %g Path to the physical file where the violation occurred. + %l Logical line number where the violation occurred + %L Physical line number where the violation occurred + %m Brief description of the violation + %P Full name of the Policy module that created the violation + %p Name of the Policy without the Perl::Critic::Policy:: prefix + %r The string of source code that caused the violation + %C The class of the PPI::Element that caused the violation + %s The severity level of the violation + +Explanation of the C<%F>, C<%f>, C<%G>, C<%G>, C<%l>, and C<%L> formats: +Using C<#line> directives, you can affect what perl thinks the current line +number and file name are; see L for +the details. Under normal circumstances, the values of C<%F>, C<%f>, and +C<%l> will match the values of C<%G>, C<%g>, and C<%L>, respectively. In the +presence of a C<#line> directive, the values of C<%F>, C<%f>, and C<%l> will +change to take that directive into account. The values of C<%G>, C<%g>, and +C<%L> are unaffected by those directives. + +Here are some examples: + + Perl::Critic::Violation::set_format("%m at line %l, column %c.\n"); + # looks like "Mixed case variable name at line 6, column 23." + + Perl::Critic::Violation::set_format("%m near '%r'\n"); + # looks like "Mixed case variable name near 'my $theGreatAnswer = 42;'" + + Perl::Critic::Violation::set_format("%l:%c:%p\n"); + # looks like "6:23:NamingConventions::Capitalization" + + Perl::Critic::Violation::set_format("%m at line %l. %e. \n%d\n"); + # looks like "Mixed case variable name at line 6. See page 44 of PBP. + Conway's recommended naming convention is to use lower-case words + separated by underscores. Well-recognized acronyms can be in ALL + CAPS, but must be separated by underscores from other parts of the + name." + + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/lib/Test/Perl/Critic/Policy.pm b/lib/Test/Perl/Critic/Policy.pm new file mode 100644 index 0000000..2809c24 --- /dev/null +++ b/lib/Test/Perl/Critic/Policy.pm @@ -0,0 +1,427 @@ +package Test::Perl::Critic::Policy; + +use 5.006001; + +use strict; +use warnings; + +use Carp qw< croak confess >; +use English qw< -no_match_vars >; +use List::MoreUtils qw< all none >; +use Readonly; + +use Test::Builder qw<>; +use Test::More; + +use Perl::Critic::Violation; +use Perl::Critic::TestUtils qw< + pcritique_with_violations fcritique_with_violations subtests_in_tree +>; + +#----------------------------------------------------------------------------- + +our $VERSION = '1.140'; + +#----------------------------------------------------------------------------- + +use Exporter 'import'; + +Readonly::Array our @EXPORT_OK => qw< all_policies_ok >; +Readonly::Hash our %EXPORT_TAGS => (all => \@EXPORT_OK); + +#----------------------------------------------------------------------------- + +Perl::Critic::Violation::set_format( "%m at line %l, column %c. (%r)\n" ); +Perl::Critic::TestUtils::block_perlcriticrc(); + +#----------------------------------------------------------------------------- + +my $TEST = Test::Builder->new(); + +#----------------------------------------------------------------------------- + +sub all_policies_ok { + my (%args) = @_; + my $wanted_policies = $args{-policies}; + my $test_dir = $args{'-test-directory'} || 't'; + + my $subtests_with_extras = subtests_in_tree( $test_dir, 'include extras' ); + + if ($wanted_policies) { + _validate_wanted_policy_names($wanted_policies, $subtests_with_extras); + _filter_unwanted_subtests($wanted_policies, $subtests_with_extras); + } + + $TEST->plan( tests => _compute_test_count($subtests_with_extras) ); + my $policies_to_test = join q{, }, keys %{$subtests_with_extras}; + $TEST->note("Running tests for policies: $policies_to_test"); + + for my $policy ( sort keys %{$subtests_with_extras} ) { + + my ($full_policy_name, $method) = ("Perl::Critic::Policy::$policy", 'violates'); + my $can_ok_label = qq{Class '$full_policy_name' has method '$method'}; + $TEST->ok( $full_policy_name->can($method), $can_ok_label ); + + for my $subtest ( @{ $subtests_with_extras->{$policy}{subtests} } ) { + my $todo = $subtest->{TODO}; + if ($todo) { $TEST->todo_start( $todo ); } + + my ($error, @violations) = _run_subtest($policy, $subtest); + my ($ok, @diag)= _evaluate_test_results($subtest, $error, \@violations); + $TEST->ok( $ok, _create_test_name($policy, $subtest) ); + + if (@diag) { $TEST->diag(@diag); } + if ($todo) { $TEST->todo_end(); } + } + } + + return; +} + +#----------------------------------------------------------------------------- + +sub _validate_wanted_policy_names { + my ($wanted_policies, $subtests_with_extras) = @_; + return 1 if not $wanted_policies; + my @all_testable_policies = keys %{ $subtests_with_extras }; + my @wanted_policies = @{ $wanted_policies }; + + + my @invalid = grep {my $p = $_; none { $_ =~ $p } @all_testable_policies} @wanted_policies; + croak( q{No tests found for policies matching: } . join q{, }, @invalid ) if @invalid; + return 1; +} + +#----------------------------------------------------------------------------- + +sub _filter_unwanted_subtests { + my ($wanted_policies, $subtests_with_extras) = @_; + return 1 if not $wanted_policies; + my @all_testable_policies = keys %{ $subtests_with_extras }; + my @wanted_policies = @{ $wanted_policies }; + + for my $p (@all_testable_policies) { + if (none {$p =~ m/$_/xism} @wanted_policies) { + delete $subtests_with_extras->{$p}; # side-effects! + } + } + return 1; +} + +#----------------------------------------------------------------------------- + +sub _run_subtest { + my ($policy, $subtest) = @_; + + my @violations; + my $error; + if ( $subtest->{filename} ) { + eval { + @violations = + fcritique_with_violations( + $policy, + \$subtest->{code}, + $subtest->{filename}, + $subtest->{parms}, + ); + 1; + } or do { + $error = $EVAL_ERROR || 'An unknown problem occurred.'; + }; + } + else { + eval { + @violations = + pcritique_with_violations( + $policy, + \$subtest->{code}, + $subtest->{parms}, + ); + 1; + } or do { + $error = $EVAL_ERROR || 'An unknown problem occurred.'; + }; + } + + return ($error, @violations); +} + +#----------------------------------------------------------------------------- + +sub _evaluate_test_results { + my ($subtest, $error, $violations) = @_; + + if ($subtest->{error}) { + return _evaluate_error_case($subtest, $error); + } + elsif ($error) { + confess $error; + } + else { + return _evaluate_violation_case($subtest, $violations); + } +} + +#----------------------------------------------------------------------------- + +sub _evaluate_violation_case { + my ($subtest, $violations) = @_; + my ($ok, @diagnostics); + + my @violations = @{$violations}; + my $have = scalar @violations; + my $want = _compute_wanted_violation_count($subtest); + if ( not $ok = $have == $want ) { + my $msg = qq(Expected $want violations, got $have. ); + if (@violations) { $msg .= q(Found violations follow...); } + push @diagnostics, $msg . "\n"; + push @diagnostics, map { qq(Found violation: $_) } @violations; + } + + return ($ok, @diagnostics) +} + +#----------------------------------------------------------------------------- + +sub _evaluate_error_case { + my ($subtest, $error) = @_; + my ($ok, @diagnostics); + + if ( 'Regexp' eq ref $subtest->{error} ) { + $ok = $error =~ $subtest->{error} + or push @diagnostics, qq(Error message '$error' doesn't match $subtest->{error}.); + } + else { + $ok = $subtest->{error} + or push @diagnostics, q(Didn't get an error message when we expected one.); + } + + return ($ok, @diagnostics); +} + +#----------------------------------------------------------------------------- + +sub _compute_test_count { + my ($subtests_with_extras) = @_; + + # one can_ok() for each policy + my $npolicies = scalar keys %{ $subtests_with_extras }; + + my $nsubtests = 0; + for my $subtest_with_extras ( values %{$subtests_with_extras} ) { + # one [pf]critique() test per subtest + $nsubtests += @{ $subtest_with_extras->{subtests} }; + } + + return $nsubtests + $npolicies; +} + +#----------------------------------------------------------------------------- + +sub _compute_wanted_violation_count { + my ($subtest) = @_; + + # If any optional modules are NOT available, then there should be no violations. + return 0 if not _all_optional_modules_are_available($subtest); + return $subtest->{failures}; +} + +#----------------------------------------------------------------------------- + +sub _all_optional_modules_are_available { + my ($subtest) = @_; + my $optional_modules = $subtest->{optional_modules} or return 1; + return all {eval "require $_;" or 0;} split m/,\s*/xms, $optional_modules; +} + +#----------------------------------------------------------------------------- + +sub _create_test_name { + my ($policy, $subtest) = @_; + return join ' - ', $policy, "line $subtest->{lineno}", $subtest->{name}; +} + +#----------------------------------------------------------------------------- +1; + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=for stopwords subtest subtests RCS + +=head1 NAME + +Test::Perl::Critic::Policy - A framework for testing your custom Policies + +=head1 SYNOPSIS + + use Test::Perl::Critic::Policy qw< all_policies_ok >; + + # Assuming .run files are inside 't' directory... + all_policies_ok() + + # Or if your .run files are in a different directory... + all_policies_ok( '-test-directory' => 'run' ); + + # And if you just want to run tests for some polices... + all_policies_ok( -policies => ['Some::Policy', 'Another::Policy'] ); + + # If you want your test program to accept short Policy names as + # command-line parameters... + # + # You can then test a single policy by running + # "perl -Ilib t/policy-test.t My::Policy". + my %args = @ARGV ? ( -policies => [ @ARGV ] ) : (); + all_policies_ok(%args); + + +=head1 DESCRIPTION + +This module provides a framework for function-testing your custom +L modules. Policy testing usually +involves feeding it a string of Perl code and checking its behavior. In the +old days, those strings of Perl code were mixed directly in the test script. +That sucked. + +=head1 IMPORTABLE SUBROUTINES + +=over + +=item all_policies_ok('-test-directory' => $path, -policies => \@policy_names) + +Loads all the F<*.run> files beneath the C<-test-directory> and runs the +tests. If C<-test-directory> is not specified, it defaults to F. +C<-policies> is an optional reference to an array of shortened Policy names. +If C<-policies> specified, only the tests for Policies that match one of the +C will be run. + + +=back + + +=head1 CREATING THE *.run FILES + +Testing a policy follows a very simple pattern: + + * Policy name + * Subtest name + * Optional parameters + * Number of failures expected + * Optional exception expected + * Optional filename for code + +Each of the subtests for a policy is collected in a single F<.run> +file, with test properties as comments in front of each code block +that describes how we expect Perl::Critic to react to the code. For +example, say you have a policy called Variables::ProhibitVowels: + + (In file t/Variables/ProhibitVowels.run) + + ## name Basics + ## failures 1 + ## cut + + my $vrbl_nm = 'foo'; # Good, vowel-free name + my $wango = 12; # Bad, pronouncable name + + + ## name Sometimes Y + ## failures 1 + ## cut + + my $yllw = 0; # "y" not a vowel here + my $rhythm = 12; # But here it is + +These are called "subtests", and two are shown above. The beauty of +incorporating multiple subtests in a file is that the F<.run> is +itself a (mostly) valid Perl file, and not hidden in a HEREDOC, so +your editor's color-coding still works, and it is much easier to work +with the code and the POD. + +If you need to pass any configuration parameters for your subtest, do +so like this: + + ## parms { allow_y => '0' } + +Note that all the values in this hash must be strings because that's +what Perl::Critic will hand you from a F<.perlcriticrc>. + +If it's a TODO subtest (probably because of some weird corner of PPI +that we exercised that Adam is getting around to fixing, right?), then +make a C<##TODO> entry. + + ## TODO Should pass when PPI 1.xxx comes out + +If the code is expected to trigger an exception in the policy, +indicate that like so: + + ## error 1 + +If you want to test the error message, mark it with C to +indicate a C test: + + ## error /Can't load Foo::Bar/ + +If the policy you are testing cares about the filename of the code, +you can indicate that C should be used like so (see +C for more details): + + ## filename lib/Foo/Bar.pm + +The value of C will get Ced and passed to C, +so be careful. + +In general, a subtest document runs from the C<## cut> that starts it to +either the next C<## name> or the end of the file. In very rare circumstances +you may need to end the test document earlier. A second C<## cut> will do +this. The only known need for this is in +F, where it is used to prevent the RCS +keywords in the file footer from producing false positives or negatives in the +last test. + +Note that nowhere within the F<.run> file itself do you specify the +policy that you're testing. That's implicit within the filename. + + +=head1 BUGS AND CAVEATS AND TODO ITEMS + +Add policy_ok() method for running subtests in just a single TODO file. + +Can users mark this entire test as TODO or SKIP, using the normal mechanisms? + +Allow us to specify the nature of the failures, and which one. If there are +15 lines of code, and six of them fail, how do we know they're the right six? + +Consolidate code from L and possibly deprecate some +functions there. + +Write unit tests for this module. + +Test that we have a t/*/*.run for each lib/*/*.pm + +=head1 AUTHOR + +Andy Lester, Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2009-2021 Andy Lester + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/00_modules.t b/t/00_modules.t new file mode 100644 index 0000000..285bd12 --- /dev/null +++ b/t/00_modules.t @@ -0,0 +1,326 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use PPI::Document; + +use Perl::Critic::TestUtils qw(bundled_policy_names); + +use Test::More; + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); +Perl::Critic::TestUtils::block_perlcriticrc(); + +my @bundled_policy_names = bundled_policy_names(); + +my @concrete_exceptions = qw{ + AggregateConfiguration + Configuration::Generic + Configuration::NonExistentPolicy + Configuration::Option::Global::ExtraParameter + Configuration::Option::Global::ParameterValue + Configuration::Option::Policy::ExtraParameter + Configuration::Option::Policy::ParameterValue + Fatal::Generic + Fatal::Internal + Fatal::PolicyDefinition + IO +}; + +plan tests => + 144 + + ( 9 * scalar @concrete_exceptions ) + + ( 17 * scalar @bundled_policy_names ); + +diag( "Testing Perl::Critic $Perl::Critic::VERSION with PPI $PPI::VERSION under Perl $], $^X" ); + +# pre-compute for version comparisons +my $version_string = __PACKAGE__->VERSION; + +#----------------------------------------------------------------------------- +# Test Perl::Critic module interface + +use_ok('Perl::Critic') or BAIL_OUT(q); +can_ok('Perl::Critic', 'new'); +can_ok('Perl::Critic', 'add_policy'); +can_ok('Perl::Critic', 'config'); +can_ok('Perl::Critic', 'critique'); +can_ok('Perl::Critic', 'policies'); + +#Set -profile to avoid messing with .perlcriticrc +my $critic = Perl::Critic->new( -profile => 'NONE' ); +isa_ok($critic, 'Perl::Critic'); +is($critic->VERSION(), $version_string, 'Perl::Critic version'); + +#----------------------------------------------------------------------------- +# Test Perl::Critic::Config module interface + +use_ok('Perl::Critic::Config') or BAIL_OUT(q); +can_ok('Perl::Critic::Config', 'new'); +can_ok('Perl::Critic::Config', 'add_policy'); +can_ok('Perl::Critic::Config', 'policies'); +can_ok('Perl::Critic::Config', 'exclude'); +can_ok('Perl::Critic::Config', 'force'); +can_ok('Perl::Critic::Config', 'include'); +can_ok('Perl::Critic::Config', 'only'); +can_ok('Perl::Critic::Config', 'profile_strictness'); +can_ok('Perl::Critic::Config', 'severity'); +can_ok('Perl::Critic::Config', 'single_policy'); +can_ok('Perl::Critic::Config', 'theme'); +can_ok('Perl::Critic::Config', 'top'); +can_ok('Perl::Critic::Config', 'verbose'); +can_ok('Perl::Critic::Config', 'color'); +can_ok('Perl::Critic::Config', 'unsafe_allowed'); +can_ok('Perl::Critic::Config', 'criticism_fatal'); +can_ok('Perl::Critic::Config', 'site_policy_names'); +can_ok('Perl::Critic::Config', 'color_severity_highest'); +can_ok('Perl::Critic::Config', 'color_severity_high'); +can_ok('Perl::Critic::Config', 'color_severity_medium'); +can_ok('Perl::Critic::Config', 'color_severity_low'); +can_ok('Perl::Critic::Config', 'color_severity_lowest'); +can_ok('Perl::Critic::Config', 'program_extensions'); +can_ok('Perl::Critic::Config', 'program_extensions_as_regexes'); + +#Set -profile to avoid messing with .perlcriticrc +my $config = Perl::Critic::Config->new( -profile => 'NONE'); +isa_ok($config, 'Perl::Critic::Config'); +is($config->VERSION(), $version_string, 'Perl::Critic::Config version'); + +#----------------------------------------------------------------------------- +# Test Perl::Critic::Config::OptionsProcessor module interface + +use_ok('Perl::Critic::OptionsProcessor') or BAIL_OUT(q); +can_ok('Perl::Critic::OptionsProcessor', 'new'); +can_ok('Perl::Critic::OptionsProcessor', 'exclude'); +can_ok('Perl::Critic::OptionsProcessor', 'include'); +can_ok('Perl::Critic::OptionsProcessor', 'force'); +can_ok('Perl::Critic::OptionsProcessor', 'only'); +can_ok('Perl::Critic::OptionsProcessor', 'profile_strictness'); +can_ok('Perl::Critic::OptionsProcessor', 'single_policy'); +can_ok('Perl::Critic::OptionsProcessor', 'severity'); +can_ok('Perl::Critic::OptionsProcessor', 'theme'); +can_ok('Perl::Critic::OptionsProcessor', 'top'); +can_ok('Perl::Critic::OptionsProcessor', 'verbose'); +can_ok('Perl::Critic::OptionsProcessor', 'color'); +can_ok('Perl::Critic::OptionsProcessor', 'allow_unsafe'); +can_ok('Perl::Critic::OptionsProcessor', 'criticism_fatal'); +can_ok('Perl::Critic::OptionsProcessor', 'color_severity_highest'); +can_ok('Perl::Critic::OptionsProcessor', 'color_severity_high'); +can_ok('Perl::Critic::OptionsProcessor', 'color_severity_medium'); +can_ok('Perl::Critic::OptionsProcessor', 'color_severity_low'); +can_ok('Perl::Critic::OptionsProcessor', 'color_severity_lowest'); +can_ok('Perl::Critic::OptionsProcessor', 'program_extensions'); + +my $processor = Perl::Critic::OptionsProcessor->new(); +isa_ok($processor, 'Perl::Critic::OptionsProcessor'); +is($processor->VERSION(), $version_string, 'Perl::Critic::OptionsProcessor version'); + +#----------------------------------------------------------------------------- +# Test Perl::Critic::Policy module interface + +use_ok('Perl::Critic::Policy') or BAIL_OUT(q); +can_ok('Perl::Critic::Policy', 'add_themes'); +can_ok('Perl::Critic::Policy', 'applies_to'); +can_ok('Perl::Critic::Policy', 'default_maximum_violations_per_document'); +can_ok('Perl::Critic::Policy', 'default_severity'); +can_ok('Perl::Critic::Policy', 'default_themes'); +can_ok('Perl::Critic::Policy', 'get_abstract'); +can_ok('Perl::Critic::Policy', 'get_format'); +can_ok('Perl::Critic::Policy', 'get_long_name'); +can_ok('Perl::Critic::Policy', 'get_maximum_violations_per_document'); +can_ok('Perl::Critic::Policy', 'get_parameters'); +can_ok('Perl::Critic::Policy', 'get_raw_abstract'); +can_ok('Perl::Critic::Policy', 'get_severity'); +can_ok('Perl::Critic::Policy', 'get_short_name'); +can_ok('Perl::Critic::Policy', 'get_themes'); +can_ok('Perl::Critic::Policy', 'initialize_if_enabled'); +can_ok('Perl::Critic::Policy', 'is_enabled'); +can_ok('Perl::Critic::Policy', 'is_safe'); +can_ok('Perl::Critic::Policy', 'new'); +can_ok('Perl::Critic::Policy', 'new_parameter_value_exception'); +can_ok('Perl::Critic::Policy', 'parameter_metadata_available'); +can_ok('Perl::Critic::Policy', 'prepare_to_scan_document'); +can_ok('Perl::Critic::Policy', 'set_format'); +can_ok('Perl::Critic::Policy', 'set_maximum_violations_per_document'); +can_ok('Perl::Critic::Policy', 'set_severity'); +can_ok('Perl::Critic::Policy', 'set_themes'); +can_ok('Perl::Critic::Policy', 'throw_parameter_value_exception'); +can_ok('Perl::Critic::Policy', 'to_string'); +can_ok('Perl::Critic::Policy', 'violates'); +can_ok('Perl::Critic::Policy', 'violation'); +can_ok('Perl::Critic::Policy', 'is_safe'); + +{ + my $policy = Perl::Critic::Policy->new(); + isa_ok($policy, 'Perl::Critic::Policy'); + is($policy->VERSION(), $version_string, 'Perl::Critic::Policy version'); +} + +#----------------------------------------------------------------------------- +# Test Perl::Critic::Violation module interface + +use_ok('Perl::Critic::Violation') or BAIL_OUT(q); +can_ok('Perl::Critic::Violation', 'description'); +can_ok('Perl::Critic::Violation', 'diagnostics'); +can_ok('Perl::Critic::Violation', 'explanation'); +can_ok('Perl::Critic::Violation', 'get_format'); +can_ok('Perl::Critic::Violation', 'location'); +can_ok('Perl::Critic::Violation', 'new'); +can_ok('Perl::Critic::Violation', 'policy'); +can_ok('Perl::Critic::Violation', 'set_format'); +can_ok('Perl::Critic::Violation', 'severity'); +can_ok('Perl::Critic::Violation', 'sort_by_location'); +can_ok('Perl::Critic::Violation', 'sort_by_severity'); +can_ok('Perl::Critic::Violation', 'source'); +can_ok('Perl::Critic::Violation', 'to_string'); + +my $code = q{print 'Hello World';}; +my $doc = PPI::Document->new(\$code); +my $viol = Perl::Critic::Violation->new(undef, undef, $doc, undef); +isa_ok($viol, 'Perl::Critic::Violation'); +is($viol->VERSION(), $version_string, 'Perl::Critic::Violation version'); + +#----------------------------------------------------------------------------- +# Test Perl::Critic::UserProfile module interface + +use_ok('Perl::Critic::UserProfile') or BAIL_OUT(q); +can_ok('Perl::Critic::UserProfile', 'options_processor'); +can_ok('Perl::Critic::UserProfile', 'new'); +can_ok('Perl::Critic::UserProfile', 'policy_is_disabled'); +can_ok('Perl::Critic::UserProfile', 'policy_is_enabled'); + +my $up = Perl::Critic::UserProfile->new(); +isa_ok($up, 'Perl::Critic::UserProfile'); +is($up->VERSION(), $version_string, 'Perl::Critic::UserProfile version'); + +#----------------------------------------------------------------------------- +# Test Perl::Critic::PolicyFactory module interface + +use_ok('Perl::Critic::PolicyFactory') or BAIL_OUT(q); +can_ok('Perl::Critic::PolicyFactory', 'create_policy'); +can_ok('Perl::Critic::PolicyFactory', 'new'); +can_ok('Perl::Critic::PolicyFactory', 'site_policy_names'); + + +my $profile = Perl::Critic::UserProfile->new(); +my $factory = Perl::Critic::PolicyFactory->new( -profile => $profile ); +isa_ok($factory, 'Perl::Critic::PolicyFactory'); +is($factory->VERSION(), $version_string, 'Perl::Critic::PolicyFactory version'); + +#----------------------------------------------------------------------------- +# Test Perl::Critic::Theme module interface + +use_ok('Perl::Critic::Theme') or BAIL_OUT(q); +can_ok('Perl::Critic::Theme', 'new'); +can_ok('Perl::Critic::Theme', 'rule'); +can_ok('Perl::Critic::Theme', 'policy_is_thematic'); + + +my $theme = Perl::Critic::Theme->new( -rule => 'foo' ); +isa_ok($theme, 'Perl::Critic::Theme'); +is($theme->VERSION(), $version_string, 'Perl::Critic::Theme version'); + +#----------------------------------------------------------------------------- +# Test Perl::Critic::PolicyListing module interface + +use_ok('Perl::Critic::PolicyListing') or BAIL_OUT(q); +can_ok('Perl::Critic::PolicyListing', 'new'); +can_ok('Perl::Critic::PolicyListing', 'to_string'); + +my $listing = Perl::Critic::PolicyListing->new(); +isa_ok($listing, 'Perl::Critic::PolicyListing'); +is($listing->VERSION(), $version_string, 'Perl::Critic::PolicyListing version'); + +#----------------------------------------------------------------------------- +# Test Perl::Critic::ProfilePrototype module interface + +use_ok('Perl::Critic::ProfilePrototype') or BAIL_OUT(q); +can_ok('Perl::Critic::ProfilePrototype', 'new'); +can_ok('Perl::Critic::ProfilePrototype', 'to_string'); + +my $prototype = Perl::Critic::ProfilePrototype->new(); +isa_ok($prototype, 'Perl::Critic::ProfilePrototype'); +is($prototype->VERSION(), $version_string, 'Perl::Critic::ProfilePrototype version'); + +#----------------------------------------------------------------------------- +# Test Perl::Critic::Command module interface + +use_ok('Perl::Critic::Command') or BAIL_OUT(q); +can_ok('Perl::Critic::Command', 'run'); + +#----------------------------------------------------------------------------- +# Test module interface for exceptions + +{ + foreach my $class ( + map { "Perl::Critic::Exception::$_" } @concrete_exceptions + ) { + use_ok($class) or BAIL_OUT(q); + can_ok($class, 'new'); + can_ok($class, 'throw'); + can_ok($class, 'message'); + can_ok($class, 'error'); + can_ok($class, 'full_message'); + can_ok($class, 'as_string'); + + my $exception = $class->new(); + isa_ok($exception, $class); + is($exception->VERSION(), $version_string, "$class version"); + } +} + +#----------------------------------------------------------------------------- +# Test module interface for each Policy subclass + +{ + for my $mod ( @bundled_policy_names ) { + + use_ok($mod) or BAIL_OUT(q); + can_ok($mod, 'applies_to'); + can_ok($mod, 'default_severity'); + can_ok($mod, 'default_themes'); + can_ok($mod, 'get_severity'); + can_ok($mod, 'get_themes'); + can_ok($mod, 'is_enabled'); + can_ok($mod, 'new'); + can_ok($mod, 'set_severity'); + can_ok($mod, 'set_themes'); + can_ok($mod, 'set_themes'); + can_ok($mod, 'violates'); + can_ok($mod, 'violation'); + can_ok($mod, 'is_safe'); + + my $policy = $mod->new(); + isa_ok($policy, 'Perl::Critic::Policy'); + is($policy->VERSION(), $version_string, "Version of $mod"); + ok($policy->is_safe(), "CORE policy $mod is marked safe"); + } +} + +#----------------------------------------------------------------------------- +# Test functional interface to Perl::Critic + +Perl::Critic->import( qw(critique) ); +can_ok('main', 'critique'); #Export test + +# TODO: These tests are weak. They just verify that it doesn't +# blow up, and that at least one violation is returned. +ok( critique( \$code ), 'Functional style, no config' ); +ok( critique( {}, \$code ), 'Functional style, empty config' ); +ok( critique( {severity => 1}, \$code ), 'Functional style, with config'); +ok( !critique(), 'Functional style, no args at all'); +ok( !critique(undef, undef), 'Functional style, undef args'); + + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/00_versions.t b/t/00_versions.t new file mode 100644 index 0000000..4859064 --- /dev/null +++ b/t/00_versions.t @@ -0,0 +1,81 @@ +#!perl + +use strict; +use warnings; + +use English qw< -no_match_vars >; +use Carp qw< confess >; + +use File::Find; + +use Test::More; + +plan 'no_plan'; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +find({wanted => \&check_version, no_chdir => 1}, 'blib'); + +sub check_version { + return if (! m< blib/script/ >xms && ! m< [.] pm \z >xms); + + my $content = read_content($_); + + # Only look at Perl programs, not sh scripts. + return if (m{blib/script/}xms && $content !~ m/\A \#![^\r\n]+?perl/xms); + + my @version_lines = $content =~ m/ ( [^\n]* \$VERSION\b [^\n]* ) /gxms; + # Special cases for printing/documenting version numbers + @version_lines = grep {! m/(?:[\\\"\'v]|C<)\$VERSION/xms} @version_lines; + @version_lines = grep {! m/^\s*\#/xms} @version_lines; + if (@version_lines == 0) { + fail($_); + } + my $expected = qq{our \$VERSION = '$VERSION';}; + for my $line (@version_lines) { + is($line, $expected, $_); + } + + return; +} + + + +find({wanted => \&check_asserts, no_chdir => 1}, 't', 'xt'); + +sub check_asserts { + return if !/ [.]t \z /xms; + + my $content = read_content( $_ ); + ok( $content =~ m/Perl::Critic::TestUtils::assert_version/xms, "Found assert_version in $_" ); + + return; +} + + +sub read_content { + my $filename = shift; + + local $INPUT_RECORD_SEPARATOR = undef; + open my $fh, '<', $filename or confess "$OS_ERROR"; + my $content = <$fh>; + close $fh or confess "$OS_ERROR"; + + # Skip POD + $content =~ s/^__END__.*//xms; + + return $content; +} + + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/01_bad_perlcriticrc b/t/01_bad_perlcriticrc new file mode 100644 index 0000000..ad0bf5c --- /dev/null +++ b/t/01_bad_perlcriticrc @@ -0,0 +1,38 @@ +# Test that all the problems in an rc file get reported and not just the first +# one that is found. + +# Purposely bad values +severity = 6 +theme = && +include = * +exclude = * +single-policy = * +profile-strictness = silly +top = -1 +verbose = 2095 +color-severity-highest = chartreuse +color-severity-high = fuschia +color-severity-medium = aquamarine +color-severity-low = paisley +color-severity-lowest = they've gone to plaid + +# This profile is used by t/01_config_color_severity.t to load invalid +# severity colors + +# Test non-existent parameter +[BuiltinFunctions::RequireBlockGrep] +# No test, since this is now a warning. +# no_such_parameter = foo + +# Test invalid parameter value +[Documentation::RequirePodSections] +source = Zen_and_the_Art_of_Motorcycle_Maintenance + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=conf expandtab shiftround : diff --git a/t/01_config.t b/t/01_config.t new file mode 100644 index 0000000..95af967 --- /dev/null +++ b/t/01_config.t @@ -0,0 +1,554 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use English qw< -no_match_vars >; + +use File::Spec; +use List::MoreUtils qw(any); + +use Perl::Critic::Exception::AggregateConfiguration; +use Perl::Critic::Config qw<>; +use Perl::Critic::PolicyFactory (-test => 1); +use Perl::Critic::TestUtils qw< + bundled_policy_names + names_of_policies_willing_to_work +>; +use Perl::Critic::Utils qw< :booleans :characters :severities >; +use Perl::Critic::Utils::Constants qw< :color_severity >; + +use Test::More; + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); +Perl::Critic::TestUtils::block_perlcriticrc(); + +#----------------------------------------------------------------------------- + +my @names_of_policies_willing_to_work = + names_of_policies_willing_to_work( + -severity => $SEVERITY_LOWEST, + -theme => 'core', + ); +my @native_policy_names = bundled_policy_names(); +my $total_policies = scalar @names_of_policies_willing_to_work; + +#----------------------------------------------------------------------------- + +{ + my $all_policy_count = + scalar + Perl::Critic::Config + ->new( + -severity => $SEVERITY_LOWEST, + -theme => 'core', + ) + ->all_policies_enabled_or_not(); + + plan tests => 93 + $all_policy_count; +} + +#----------------------------------------------------------------------------- +# Test default config. Increasing the severity should yield +# fewer and fewer policies. The exact number will fluctuate +# as we introduce new polices and/or change their severity. + +{ + my $last_policy_count = $total_policies + 1; + for my $severity ($SEVERITY_LOWEST .. $SEVERITY_HIGHEST) { + my $configuration = + Perl::Critic::Config->new( + -severity => $severity, + -theme => 'core', + ); + my $policy_count = scalar $configuration->policies(); + my $test_name = "Count native policies, severity: $severity"; + cmp_ok($policy_count, '<', $last_policy_count, $test_name); + $last_policy_count = $policy_count; + } +} + + +#----------------------------------------------------------------------------- +# Same tests as above, but using a generated config + +{ + my %profile = map { $_ => {} } @native_policy_names; + my $last_policy_count = $total_policies + 1; + for my $severity ($SEVERITY_LOWEST .. $SEVERITY_HIGHEST) { + my %pc_args = ( + -profile => \%profile, + -severity => $severity, + -theme => 'core', + ); + my $critic = Perl::Critic::Config->new( %pc_args ); + my $policy_count = scalar $critic->policies(); + my $test_name = "Count all policies, severity: $severity"; + cmp_ok($policy_count, '<', $last_policy_count, $test_name); + $last_policy_count = $policy_count; + } +} + +#----------------------------------------------------------------------------- + +{ + my $configuration = + Perl::Critic::Config->new( + -severity => $SEVERITY_LOWEST, + -theme => 'core', + ); + my %policies_by_name = + map { $_->get_short_name() => $_ } $configuration->policies(); + + foreach my $policy ( $configuration->all_policies_enabled_or_not() ) { + my $enabled = $policy->is_enabled(); + if ( delete $policies_by_name{ $policy->get_short_name() } ) { + ok( + $enabled, + $policy->get_short_name() . ' is enabled.', + ); + } + else { + ok( + ! $enabled && defined $enabled, + $policy->get_short_name() . ' is not enabled.', + ); + } + } + +} + + +#----------------------------------------------------------------------------- +# Test all-off config w/ various severity levels. In this case, the +# severity level should not affect the number of polices because we've +# turned them all off in the profile. + +#{ +# my %profile = map { '-' . $_ => {} } @native_policy_names; +# for my $severity (undef, $SEVERITY_LOWEST .. $SEVERITY_HIGHEST) { +# my $severity_string = $severity ? $severity : ''; +# my %pc_args = ( +# -profile => \%profile, +# -severity => $severity, +# -theme => 'core', +# ); +# +# eval { +# Perl::Critic::Config->new( %pc_args )->policies(); +# }; +# my $exception = Perl::Critic::Exception::AggregateConfiguration->caught(); +# ok( +# defined $exception, +# "got exception when no policies were enabled at severity $severity_string.", +# ); +# like( +# $exception, +# qr, +# "got correct exception message when no policies were enabled at severity $severity_string.", +# ); +# } +#} + +#----------------------------------------------------------------------------- +# Test config w/ multiple severity levels. In this profile, we +# define an arbitrary severity for each Policy so that severity +# levels 5 through 2 each have 10 Policies. All remaining Policies +# are in the 1st severity level. + + +{ + my %profile = (); + my $severity = $SEVERITY_HIGHEST; + for my $index ( 0 .. $#names_of_policies_willing_to_work ) { + if ($index and $index % 10 == 0) { + $severity--; + } + if ($severity < $SEVERITY_LOWEST) { + $severity = $SEVERITY_LOWEST; + } + + $profile{$names_of_policies_willing_to_work[$index]} = + {severity => $severity}; + } + + for my $severity ( reverse $SEVERITY_LOWEST+1 .. $SEVERITY_HIGHEST ) { + my %pc_args = ( + -profile => \%profile, + -severity => $severity, + -theme => 'core', + ); + my $critic = Perl::Critic::Config->new( %pc_args ); + my $policy_count = scalar $critic->policies(); + my $expected_count = ($SEVERITY_HIGHEST - $severity + 1) * 10; + my $test_name = "user-defined severity level: $severity"; + is( $policy_count, $expected_count, $test_name ); + } + + # All remaining policies should be at the lowest severity + my %pc_args = (-profile => \%profile, -severity => $SEVERITY_LOWEST); + my $critic = Perl::Critic::Config->new( %pc_args ); + my $policy_count = scalar $critic->policies(); + my $expected_count = $SEVERITY_HIGHEST * 10; + my $test_name = 'user-defined severity, all remaining policies'; + cmp_ok( $policy_count, '>=', $expected_count, $test_name); +} + +#----------------------------------------------------------------------------- +# Test config with defaults + +{ + my $examples_dir = 'examples'; + my $profile = File::Spec->catfile( $examples_dir, 'perlcriticrc' ); + my $c = Perl::Critic::Config->new( -profile => $profile ); + + is_deeply([$c->exclude()], [ qw(Documentation Naming) ], + 'user default exclude from file' ); + + is_deeply([$c->include()], [ qw(CodeLayout Modules) ], + 'user default include from file' ); + + is($c->force(), 1, 'user default force from file' ); + is($c->only(), 1, 'user default only from file' ); + is($c->severity(), 3, 'user default severity from file' ); + is($c->theme()->rule(), 'danger || risky && ! pbp', 'user default theme from file'); + is($c->top(), 50, 'user default top from file' ); + is($c->verbose(), 5, 'user default verbose from file' ); + + is($c->color_severity_highest(), 'bold red underline', + 'user default color-severity-highest from file'); + is($c->color_severity_high(), 'bold magenta', + 'user default color-severity-high from file'); + is($c->color_severity_medium(), 'blue', + 'user default color-severity-medium from file'); + is($c->color_severity_low(), $EMPTY, + 'user default color-severity-low from file'); + is($c->color_severity_lowest(), $EMPTY, + 'user default color-severity-lowest from file'); + + is_deeply([$c->program_extensions], [], + 'user default program-extensions from file'); + is_deeply([$c->program_extensions_as_regexes], + [qr< @{[ quotemeta '.PL' ]} \z >smx ], + 'user default program-extensions from file, as regexes'); +} + +#----------------------------------------------------------------------------- +#Test pattern matching + + +{ + # In this test, we'll use a cusotm profile to deactivate some + # policies, and then use the -include option to re-activate them. So + # the net result is that we should still end up with the all the + # policies. + + my %profile = ( + '-NamingConventions::Capitalization' => {}, + '-CodeLayout::ProhibitQuotedWordLists' => {}, + ); + + my @include = qw(capital quoted); + my %pc_args = ( + -profile => \%profile, + -severity => 1, + -include => \@include, + -theme => 'core', + ); + my @policies = Perl::Critic::Config->new( %pc_args )->policies(); + is(scalar @policies, $total_policies, 'include pattern matching'); +} + +#----------------------------------------------------------------------------- + +{ + # For this test, we'll load the default config, but deactivate some of + # the policies using the -exclude option. Then we make sure that none + # of the remaining policies match the -exclude patterns. + + my @exclude = qw(quote mixed VALUES); #Some assorted pattterns + my %pc_args = ( + -severity => 1, + -exclude => \@exclude, + ); + my @policies = Perl::Critic::Config->new( %pc_args )->policies(); + my $matches = grep { my $pol = ref; grep { $pol !~ /$_/ixms} @exclude } @policies; + is(scalar @policies, $matches, 'exclude pattern matching'); +} + +#----------------------------------------------------------------------------- + +{ + # In this test, we set -include and -exclude patterns to both match + # some of the same policies. The -exclude option should have + # precendece. + + my @include = qw(builtinfunc); #Include BuiltinFunctions::* + my @exclude = qw(block); #Exclude RequireBlockGrep, RequireBlockMap + my %pc_args = ( + -severity => 1, + -include => \@include, + -exclude => \@exclude, + ); + my @policies = Perl::Critic::Config->new( %pc_args )->policies(); + my @pol_names = map {ref} @policies; + is_deeply( + [grep {/block/ixms} @pol_names], + [], + 'include/exclude pattern match had no "block" policies', + ); + # This odd construct arises because "any" can't be used with parens without syntax error(!) + ok( + @{[any {/builtinfunc/ixms} @pol_names]}, + 'include/exclude pattern match had "builtinfunc" policies', + ); +} + +#----------------------------------------------------------------------------- +# Test the switch behavior + +{ + my @switches = qw( + -top + -verbose + -theme + -severity + -only + -force + -color + -pager + -allow-unsafe + -criticism-fatal + -color-severity-highest + -color-severity-high + -color-severity-medium + -color-severity-low + -color-severity-lowest + ); + + # Can't use IO::Interactive here because we /don't/ want to check STDIN. + my $color = -t *STDOUT ? $TRUE : $FALSE; ## no critic (ProhibitInteractiveTest) + + my %undef_args = map { $_ => undef } @switches; + my $c = Perl::Critic::Config->new( %undef_args ); + $c = Perl::Critic::Config->new( %undef_args ); + is( $c->force(), 0, 'Undefined -force'); + is( $c->only(), 0, 'Undefined -only'); + is( $c->severity(), 5, 'Undefined -severity'); + is( $c->theme()->rule(), q{}, 'Undefined -theme'); + is( $c->top(), 0, 'Undefined -top'); + is( $c->color(), $color, 'Undefined -color'); + is( $c->pager(), q{}, 'Undefined -pager'); + is( $c->unsafe_allowed(), 0, 'Undefined -allow-unsafe'); + is( $c->verbose(), 4, 'Undefined -verbose'); + is( $c->criticism_fatal(), 0, 'Undefined -criticism-fatal'); + is( $c->color_severity_highest(), + $PROFILE_COLOR_SEVERITY_HIGHEST_DEFAULT, + 'Undefined -color-severity-highest' + ); + is( $c->color_severity_high(), + $PROFILE_COLOR_SEVERITY_HIGH_DEFAULT, + 'Undefined -color-severity-high' + ); + is( $c->color_severity_medium(), + $PROFILE_COLOR_SEVERITY_MEDIUM_DEFAULT, + 'Undefined -color-severity-medium' + ); + is( $c->color_severity_low(), + $PROFILE_COLOR_SEVERITY_LOW_DEFAULT, + 'Undefined -color-severity-low' + ); + is( $c->color_severity_lowest(), + $PROFILE_COLOR_SEVERITY_LOWEST_DEFAULT, + 'Undefined -color-severity-lowest' + ); + + my %zero_args = map { $_ => 0 } + # Zero is an invalid Term::ANSIColor value. + grep { ! / \A-color-severity- /smx } @switches; + $c = Perl::Critic::Config->new( %zero_args ); + is( $c->force(), 0, 'zero -force'); + is( $c->only(), 0, 'zero -only'); + is( $c->severity(), 1, 'zero -severity'); + is( $c->theme()->rule(), q{}, 'zero -theme'); + is( $c->top(), 0, 'zero -top'); + is( $c->color(), $FALSE, 'zero -color'); + is( $c->pager(), $EMPTY, 'zero -pager'); + is( $c->unsafe_allowed(), 0, 'zero -allow-unsafe'); + is( $c->verbose(), 4, 'zero -verbose'); + is( $c->criticism_fatal(), 0, 'zero -criticism-fatal'); + + my %empty_args = map { $_ => q{} } @switches; + $c = Perl::Critic::Config->new( %empty_args ); + is( $c->force(), 0, 'empty -force'); + is( $c->only(), 0, 'empty -only'); + is( $c->severity(), 1, 'empty -severity'); + is( $c->theme->rule(), q{}, 'empty -theme'); + is( $c->top(), 0, 'empty -top'); + is( $c->color(), $FALSE, 'empty -color'); + is( $c->pager(), q{}, 'empty -pager'); + is( $c->unsafe_allowed(), 0, 'empty -allow-unsafe'); + is( $c->verbose(), 4, 'empty -verbose'); + is( $c->criticism_fatal(), 0, 'empty -criticism-fatal'); + is( $c->color_severity_highest(), $EMPTY, 'empty -color-severity-highest'); + is( $c->color_severity_high(), $EMPTY, 'empty -color-severity-high'); + is( $c->color_severity_medium(), $EMPTY, 'empty -color-severity-medium'); + is( $c->color_severity_low(), $EMPTY, 'empty -color-severity-low'); + is( $c->color_severity_lowest(), $EMPTY, 'empty -color-severity-lowest'); +} + +#----------------------------------------------------------------------------- +# Test the -only switch + +{ + my %profile = ( + 'NamingConventions::Capitalization' => {}, + 'CodeLayout::ProhibitQuotedWordLists' => {}, + ); + + my %pc_config = (-severity => 1, -only => 1, -profile => \%profile); + my @policies = Perl::Critic::Config->new( %pc_config )->policies(); + is(scalar @policies, 2, '-only switch'); + +# %pc_config = ( -severity => 1, -only => 1, -profile => {} ); +# eval { Perl::Critic::Config->new( %pc_config )->policies() }; +# my $exception = Perl::Critic::Exception::AggregateConfiguration->caught(); +# ok( +# defined $exception, +# "got exception with -only switch, empty profile.", +# ); +# like( +# $exception, +# qr, +# "got correct exception message with -only switch, empty profile.", +# ); +} + +#----------------------------------------------------------------------------- +# Test the -single-policy switch + +{ + my %pc_config = ('-single-policy' => 'ProhibitMagicNumbers'); + my @policies = Perl::Critic::Config->new( %pc_config )->policies(); + is(scalar @policies, 1, '-single-policy switch'); +} + +#----------------------------------------------------------------------------- +# Test interaction between switches and defaults + +{ + my %true_defaults = ( + force => 1, only => 1, top => 10, 'allow-unsafe' => 1, + ); + my %profile = ( '__defaults__' => \%true_defaults ); + + my %pc_config = ( + -force => 0, + -only => 0, + -top => 0, + '-allow-unsafe' => 0, + -profile => \%profile, + ); + my $config = Perl::Critic::Config->new( %pc_config ); + is( $config->force, 0, '-force: default is true, arg is false'); + is( $config->only, 0, '-only: default is true, arg is false'); + is( $config->top, 0, '-top: default is true, arg is false'); + is( $config->unsafe_allowed, 0, '-allow-unsafe: default is true, arg is false'); +} + +#----------------------------------------------------------------------------- +# Test named severity levels + +{ + my %severity_levels = (gentle=>5, stern=>4, harsh=>3, cruel=>2, brutal=>1); + while (my ($name, $number) = each %severity_levels) { + my $config = Perl::Critic::Config->new( -severity => $name ); + is( $config->severity(), $number, qq{Severity "$name" is "$number"}); + } +} + + +#----------------------------------------------------------------------------- +# Test exception handling + +{ + my $config = Perl::Critic::Config->new( -profile => 'NONE' ); + + # Try adding a bogus policy + eval{ $config->add_policy( -policy => 'Bogus::Policy') }; + like( + $EVAL_ERROR, + qr/Unable [ ] to [ ] create [ ] policy/xms, + 'add_policy w/ bad args', + ); + + # Try adding w/o policy + eval { $config->add_policy() }; + like( + $EVAL_ERROR, + qr/The [ ] -policy [ ] argument [ ] is [ ] required/xms, + 'add_policy w/o args', + ); + + # Try using bogus named severity level + eval{ Perl::Critic::Config->new( -severity => 'bogus' ) }; + like( + $EVAL_ERROR, + qr/The value for the global "-severity" option [(]"bogus"[)] is not one of the valid severity names/ms, ## no critic (RequireExtendedFormatting) + 'invalid severity' + ); + + # Try using vague -single-policy option + eval{ Perl::Critic::Config->new( '-single-policy' => q<.*> ) }; + like( + $EVAL_ERROR, + qr/matched [ ] multiple [ ] policies/xms, + 'vague -single-policy', + ); + + # Try using invalid -single-policy option + eval{ Perl::Critic::Config->new( '-single-policy' => 'bogus' ) }; + like( + $EVAL_ERROR, + qr/did [ ] not [ ] match [ ] any [ ] policies/xms, + 'invalid -single-policy', + ); +} + +#----------------------------------------------------------------------------- +# Test the -allow-unsafe switch +{ + my %profile = ( + 'NamingConventions::Capitalization' => {}, + 'CodeLayout::ProhibitQuotedWordLists' => {}, + ); + + # Pretend that ProhibitQuotedWordLists is actually unsafe + no warnings qw(redefine once); ## no critic qw(ProhibitNoWarnings) + local *Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists::is_safe = sub {return 0}; + + my %safe_pc_config = (-severity => 1, -only => 1, -profile => \%profile); + my @p = Perl::Critic::Config->new( %safe_pc_config )->policies(); + is(scalar @p, 1, 'Only loaded safe policies without -unsafe switch'); + + my %unsafe_pc_config = (%safe_pc_config, '-allow-unsafe' => 1); + @p = Perl::Critic::Config->new( %unsafe_pc_config )->policies(); + is(scalar @p, 2, 'Also loaded unsafe policies with -allow-unsafe switch'); + + my %singular_pc_config = ('-single-policy' => 'QuotedWordLists'); + @p = Perl::Critic::Config->new( %singular_pc_config )->policies(); + is(scalar @p, 1, '-single-policy always loads Policy, even if unsafe'); +} + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/01_config_bad_perlcriticrc.t b/t/01_config_bad_perlcriticrc.t new file mode 100644 index 0000000..5278361 --- /dev/null +++ b/t/01_config_bad_perlcriticrc.t @@ -0,0 +1,169 @@ +#!perl + +# Test that all the problems in an rc file get reported and not just the first +# one that is found. + +use 5.006001; +use strict; +use warnings; + +use English qw< -no_match_vars >; +use Readonly; + +use Test::More; + +use Perl::Critic::PolicyFactory (-test => 1); +use Perl::Critic; +use Perl::Critic::Utils::Constants qw< $_MODULE_VERSION_TERM_ANSICOLOR >; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +my @color_severity_params; +my $skip_color_severity = + eval { + require Term::ANSIColor; + Term::ANSIColor->VERSION( $_MODULE_VERSION_TERM_ANSICOLOR ); + 1; + } + ? undef + : "Term::ANSIColor $_MODULE_VERSION_TERM_ANSICOLOR is not available"; + +# We can not do the color-severity tests if Term::ANSIColor is not available, +# because without Term::ANSIColor the parameters are not validated, so any +# value will be accepted and we will not get any errors from them. +$skip_color_severity + or @color_severity_params = qw< + color-severity-highest + color-severity-high + color-severity-medium + color-severity-low + color-severity-lowest + >; + +plan tests => 13 + scalar @color_severity_params; + +Readonly::Scalar my $PROFILE => 't/01_bad_perlcriticrc'; +Readonly::Scalar my $NO_ENABLED_POLICIES_MESSAGE => + q; +Readonly::Scalar my $INVALID_PARAMETER_MESSAGE => + q; +Readonly::Scalar my $REQUIRE_POD_SECTIONS_SOURCE_MESSAGE_PREFIX => + q; + +eval { + Perl::Critic->new( '-profile' => $PROFILE ); +}; + +my $test_passed; +my $eval_result = $EVAL_ERROR; + +$test_passed = + ok( $eval_result, 'should get an exception when using a bad rc file' ); + +die "No point in continuing.\n" if not $test_passed; + +$test_passed = + isa_ok( + $eval_result, + 'Perl::Critic::Exception::AggregateConfiguration', + '$EVAL_ERROR', ## no critic (RequireInterpolationOfMetachars) + ); + +if ( not $test_passed ) { + diag( $eval_result ); + die "No point in continuing.\n"; +} + +my @exceptions = @{ $eval_result->exceptions() }; + +my @parameters = ( + qw< + exclude + include + profile-strictness + severity + single-policy + theme + top + verbose + >, + @color_severity_params, +); + +my %expected_regexes = + map + { $_ => generate_global_message_regex( $_, $PROFILE ) } + @parameters; + +my $expected_exceptions = 1 + scalar @parameters; +is( + scalar @exceptions, + $expected_exceptions, + 'should have received the correct number of exceptions' +); +if (@exceptions != $expected_exceptions) { + foreach my $exception (@exceptions) { + diag "Exception: $exception"; + } +} + +while (my ($parameter, $regex) = each %expected_regexes) { + is( + ( scalar grep { m/$regex/xms } @exceptions ), + 1, + "should have received one and only one exception for $parameter", + ); +} + +is( + ( scalar grep { $INVALID_PARAMETER_MESSAGE eq $_ } @exceptions ), + 0, + 'should not have received an extra-parameter exception', +); + +# Test that we get an exception for bad individual policy configuration. +# The selection of RequirePodSections is arbitrary. +is( + ( scalar grep { is_require_pod_sections_source_exception($_) } @exceptions ), + 1, + 'should have received an invalid source exception for RequirePodSections', +); + +sub generate_global_message_regex { + my ($parameter, $file) = @_; + + return + qr< + \A + The [ ] value [ ] for [ ] the [ ] global [ ] + "$parameter" + .* + found [ ] in [ ] "$file" + >xms; +} + +sub is_require_pod_sections_source_exception { + my ($exception) = @_; + + my $prefix = + substr + $exception, + 0, + length $REQUIRE_POD_SECTIONS_SOURCE_MESSAGE_PREFIX; + + return $prefix eq $REQUIRE_POD_SECTIONS_SOURCE_MESSAGE_PREFIX; +} + + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/01_policy_config.t b/t/01_policy_config.t new file mode 100644 index 0000000..63181bf --- /dev/null +++ b/t/01_policy_config.t @@ -0,0 +1,172 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Carp qw< confess >; + +use Perl::Critic::PolicyConfig; + +use Test::More tests => 28; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + + +{ + my $config = + Perl::Critic::PolicyConfig->new('Some::Policy'); + + is( + $config->get_policy_short_name(), + 'Some::Policy', + 'Policy short name gets saved.', + ); + is( + $config->get_set_themes(), + undef, + 'set_themes is undef when not specified.', + ); + is( + $config->get_add_themes(), + undef, + 'add_themes is undef when not specified.', + ); + is( + $config->get_severity(), + undef, + 'severity is undef when not specified.', + ); + is( + $config->get_maximum_violations_per_document(), + undef, + 'maximum_violations_per_document is undef when not specified.', + ); + ok( + $config->is_empty(), + 'is_empty() is true when there were no configuration values.', + ); + + my @parameter_names = $config->get_parameter_names(); + is( + scalar @parameter_names, + 0, + 'There are no parameter names left.', + ); + + test_standard_parameters_undef_via_get($config); +} + +{ + my $config = + Perl::Critic::PolicyConfig->new( + 'Some::Other::Policy', + { + custom_parameter => 'blargh', + + # Standard parameters + set_themes => 'thingy', + add_themes => 'another thingy', + severity => 'harsh', + maximum_violations_per_document => '2', + } + ); + + is( + $config->get_policy_short_name(), + 'Some::Other::Policy', + 'Policy short name gets saved.', + ); + is( + $config->get_set_themes(), + 'thingy', + 'set_themes gets saved.', + ); + is( + $config->get_add_themes(), + 'another thingy', + 'add_themes gets saved.', + ); + is( + $config->get_severity(), + 'harsh', + 'severity gets saved.', + ); + is( + $config->get_maximum_violations_per_document(), + '2', + 'maximum_violations_per_document gets saved.', + ); + is( + $config->get('custom_parameter'), + 'blargh', + 'custom_parameter gets saved.', + ); + ok( + ! $config->is_empty(), + 'is_empty() is false when there were configuration values.', + ); + + my @parameter_names = $config->get_parameter_names(); + is( + scalar @parameter_names, + 1, + 'There is one parameter name left after construction.', + ); + is( + $parameter_names[0], + 'custom_parameter', + 'There parameter name is the expected value.', + ); + + test_standard_parameters_undef_via_get($config); + + $config->remove('custom_parameter'); + ok( + $config->is_empty(), + 'is_empty() is true after removing "custom_parameter".', + ); + + @parameter_names = $config->get_parameter_names(); + is( + scalar @parameter_names, + 0, + 'There are no parameter names left after removing "custom_parameter".', + ); +} + + +sub test_standard_parameters_undef_via_get { + my ($config) = @_; + my $policy_short_name = $config->get_policy_short_name(); + + foreach my $parameter ( + qw< + set_themes + add_themes + severity + maximum_violations_per_document + _non_public_data + > + ) { + is( + $config->get($parameter), + undef, + qq<"$parameter" is not defined via get() for $policy_short_name.>, + ) + } + + return; +} + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/02_policy.t b/t/02_policy.t new file mode 100644 index 0000000..9464372 --- /dev/null +++ b/t/02_policy.t @@ -0,0 +1,180 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use English qw<-no_match_vars>; + +use Test::More tests => 29; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +# Perl::Critic::Policy is an abstract class, so it can't be instantiated +# directly. So we test it by declaring test classes that inherit from it. + +## no critic (ProhibitMultiplePackages, RequireFilenameMatchesPackage) +package PolicyTest; +use base 'Perl::Critic::Policy'; + +package PolicyTestOverriddenDefaultMaximumViolations; +use base 'Perl::Critic::Policy'; + +sub default_maximum_violations_per_document { return 31; } + +#----------------------------------------------------------------------------- + +package main; +## use critic + +my $p = PolicyTest->new(); +isa_ok($p, 'PolicyTest'); + + +local $EVAL_ERROR = undef; +eval { $p->violates(); 1 }; +ok($EVAL_ERROR, 'abstract violates() throws exception'); + + +is( + $p->is_enabled(), + undef, + 'is_enabled() initially returns undef', +); + + +ok( !! $p->is_safe(), 'is_safe() returns a true value by default.' ); + + +# Test default application... +is($p->applies_to(), 'PPI::Element', 'applies_to()'); + + +# Test default maximum violations per document... +is( + $p->default_maximum_violations_per_document(), + undef, + 'default_maximum_violations_per_document()', +); +is( + $p->get_maximum_violations_per_document(), + undef, + 'get_maximum_violations_per_document()', +); + +# Change maximum violations level... +$p->set_maximum_violations_per_document(3); + +# Test maximum violations again... +is( + $p->default_maximum_violations_per_document(), + undef, + q, +); +is( + $p->get_maximum_violations_per_document(), + 3, + q, +); + + +my $overridden_default = PolicyTestOverriddenDefaultMaximumViolations->new(); +isa_ok($overridden_default, 'PolicyTestOverriddenDefaultMaximumViolations'); + +is( + $overridden_default->is_enabled(), + undef, + 'is_enabled() initially returns undef', +); + +# Test default maximum violations per document... +is( + $overridden_default->default_maximum_violations_per_document(), + 31, + 'default_maximum_violations_per_document() overridden', +); +is( + $overridden_default->get_maximum_violations_per_document(), + 31, + 'get_maximum_violations_per_document() overridden', +); + +# Change maximum violations level... +$overridden_default->set_maximum_violations_per_document(undef); + +# Test maximum violations again... +is( + $overridden_default->default_maximum_violations_per_document(), + 31, + q, +); +is( + $overridden_default->get_maximum_violations_per_document(), + undef, + q, +); + + +# Test default severity... +is( $p->default_severity(), 1, 'default_severity()'); +is( $p->get_severity(), 1, 'get_severity()' ); + +# Change severity level... +$p->set_severity(3); + +# Test severity again... +is( $p->default_severity(), 1, q); +is( $p->get_severity(), 3, q ); + + +# Test default theme... +is_deeply( [$p->default_themes()], [], 'default_themes()'); +is_deeply( [$p->get_themes()], [], 'get_themes()'); + +# Change theme +$p->set_themes( qw(c b a) ); # unsorted + +# Test theme again... +is_deeply( [$p->default_themes()], [], q); +is_deeply( + [$p->get_themes()], + [qw(a b c)], + 'get_themes() returns the new value, sorted.', +); + +# Append theme +$p->add_themes( qw(f e d) ); # unsorted + +# Test theme again... +is_deeply( [$p->default_themes()], [], q); +is_deeply( + [$p->get_themes()], + [ qw(a b c d e f) ], + 'get_themes() returns the new value, sorted.', +); + + +# Test format getter/setters +is( Perl::Critic::Policy::get_format, '%p', 'Default policy format'); + +my $new_format = '%p %s [%t]'; +Perl::Critic::Policy::set_format( $new_format ); # Set format +is( Perl::Critic::Policy::get_format, $new_format, 'Changed policy format'); + +my $expected_string = 'PolicyTest 3 [a b c d e f]'; +is( $p->to_string(), $expected_string, 'Stringification by to_string()'); +is( "$p", $expected_string, 'Stringification by overloading'); + + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/03_annotations.t b/t/03_annotations.t new file mode 100644 index 0000000..de320d8 --- /dev/null +++ b/t/03_annotations.t @@ -0,0 +1,243 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use PPI::Document; + +use Perl::Critic::Annotation; +use Perl::Critic::TestUtils qw(bundled_policy_names); + +use Test::More; + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); +Perl::Critic::TestUtils::block_perlcriticrc(); + +my @bundled_policy_names = bundled_policy_names(); + +plan( tests => 85 ); + +#----------------------------------------------------------------------------- +# Test Perl::Critic::Annotation module interface + +can_ok('Perl::Critic::Annotation', 'new'); +can_ok('Perl::Critic::Annotation', 'create_annotations'); +can_ok('Perl::Critic::Annotation', 'element'); +can_ok('Perl::Critic::Annotation', 'effective_range'); +can_ok('Perl::Critic::Annotation', 'disabled_policies'); +can_ok('Perl::Critic::Annotation', 'disables_policy'); +can_ok('Perl::Critic::Annotation', 'disables_all_policies'); +can_ok('Perl::Critic::Annotation', 'disables_line'); + +annotate( <<"EOD", 0, 'Null case. Un-annotated document' ); +#!/usr/local/bin/perl + +print "Hello, world!\n"; +EOD + +annotate( <<"EOD", 1, 'Single block annotation for entire document' ); + +## no critic + +print "Hello, world!\n"; + +EOD +my $note = choose_annotation( 0 ); +ok( $note, 'Single block annotation defined' ); +SKIP: { + $note or skip( 'No annotation found', 4 ); + ok( $note->disables_all_policies(), + 'Single block annotation disables all policies' ); + ok( $note->disables_line( 4 ), + 'Single block annotation disables line 4' ); + my( $start, $finish ) = $note->effective_range(); + is( $start, 2, + 'Single block annotation starts at 2' ); + is( $finish, 6, + 'Single block annotation runs through 6' ); +} + +annotate( <<"EOD", 1, 'Block annotation for block (sorry!)' ); + +{ + ## no critic + + print "Hello, world!\n"; +} + +EOD +$note = choose_annotation( 0 ); +ok( $note, 'Block annotation defined' ); +SKIP: { + $note or skip( 'No annotation found', 4 ); + ok( $note->disables_all_policies(), + 'Block annotation disables all policies' ); + ok( $note->disables_line( 5 ), + 'Block annotation disables line 5' ); + my( $start, $finish ) = $note->effective_range(); + is( $start, 3, + 'Block annotation starts at 3' ); + is( $finish, 6, + 'Block annotation runs through 6' ); +} + +SKIP: { + foreach ( @bundled_policy_names ) { + m/ FroBozzBazzle /smxi or next; + skip( 'Policy FroBozzBazzle actually implemented', 6 ); + last; # probably not necessary. + } + + annotate( <<"EOD", 1, 'Bogus annotation' ); + +## no critic ( FroBozzBazzle ) + +print "Goodbye, cruel world!\n"; + +EOD + + $note = choose_annotation( 0 ); + ok( $note, 'Bogus annotation defined' ); + + SKIP: { + $note or skip( 'Bogus annotation not found', 4 ); + ok( ! $note->disables_all_policies(), + 'Bogus annotation does not disable all policies' ); + ok( $note->disables_line( 3 ), + 'Bogus annotation disables line 3' ); + my( $start, $finish ) = $note->effective_range(); + is( $start, 2, + 'Bogus annotation starts at 2' ); + is( $finish, 6, + 'Bogus annotation runs through 6' ); + } +} + +SKIP: { + @bundled_policy_names >= 8 + or skip( 'Need at least 8 bundled policies', 49 ); + my $max = 0; + my $doc; + my @annot; + foreach my $fmt ( '(%s)', '( %s )', '"%s"', q<'%s'> ) { + my $policy_name = $bundled_policy_names[$max++]; + $policy_name =~ s/ .* :: //smx; + $note = sprintf "no critic $fmt", $policy_name; + push @annot, $note; + $doc .= "## $note\n## use critic\n"; + $policy_name = $bundled_policy_names[$max++]; + $policy_name =~ s/ .* :: //smx; + $note = sprintf "no critic qw$fmt", $policy_name; + push @annot, $note; + $doc .= "## $note\n## use critic\n"; + } + + annotate( $doc, $max, 'Specific policies in various formats' ); + foreach my $inx ( 0 .. $max - 1 ) { + $note = choose_annotation( $inx ); + ok( $note, "Specific annotation $inx ($annot[$inx]) defined" ); + SKIP: { + $note or skip( "No annotation $inx found", 5 ); + ok( ! $note->disables_all_policies(), + "Specific annotation $inx does not disable all policies" ); + my ( $policy_name ) = $bundled_policy_names[$inx] =~ + m/ ( \w+ :: \w+ ) \z /smx; + ok ( $note->disables_policy( $bundled_policy_names[$inx] ), + "Specific annotation $inx disables $policy_name" ); + my $line = $inx * 2 + 1; + ok( $note->disables_line( $line ), + "Specific annotation $inx disables line $line" ); + my( $start, $finish ) = $note->effective_range(); + is( $start, $line, + "Specific annotation $inx starts at line $line" ); + is( $finish, $line + 1, + "Specific annotation $inx runs through line " . ( $line + 1 ) ); + } + } +} + +annotate( <<"EOD", 1, 'Annotation on split statement' ); + +my \$foo = + 'bar'; ## no critic ($bundled_policy_names[0]) + +my \$baz = 'burfle'; +EOD +$note = choose_annotation( 0 ); +ok( $note, 'Split statement annotation found' ); +SKIP: { + $note or skip( 'Split statement annotation not found', 4 ); + ok( ! $note->disables_all_policies(), + 'Split statement annotation does not disable all policies' ); + ok( $note->disables_line( 3 ), + 'Split statement annotation disables line 3' ); + my( $start, $finish ) = $note->effective_range(); + is( $start, 3, + 'Split statement annotation starts at line 3' ); + is( $finish, 3, + 'Split statement annotation runs through line 3' ); +} + +annotate (<<'EOD', 1, 'Ensure annotations can span __END__' ); +## no critic (RequirePackageMatchesPodName) + +package Foo; + +__END__ + +=head1 NAME + +Bar - The wrong name for this package + +=cut +EOD +$note = choose_annotation( 0 ); +ok( $note, 'Annotation (hopefully spanning __END__) found' ); +SKIP: { + skip( 'Annotation (hopefully spanning __END__) not found', 1 ) + if !$note; + ok( $note->disables_line( 7 ), + 'Annotation disables the POD after __END__' ); +} + + +#----------------------------------------------------------------------------- + +{ + my $doc; # P::C::Document, held to prevent annotations from + # going away due to garbage collection of the parent. + my @annotations; # P::C::Annotation objects + + sub annotate { ## no critic (RequireArgUnpacking) + my ( $source, $count, $title ) = @_; + $doc = PPI::Document->new( \$source ) or do { + @_ = ( "Can not make PPI::Document for $title" ); + goto &fail; + }; + $doc = Perl::Critic::Document->new( -source => $doc ) or do { + @_ = ( "Can not make Perl::Critic::Document for $title" ); + goto &fail; + }; + @annotations = Perl::Critic::Annotation->create_annotations( $doc ); + @_ = ( scalar @annotations, $count, $title ); + goto &is; + } + + sub choose_annotation { + my ( $index ) = @_; + return $annotations[$index]; + } + +} + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/03_pragmas.t b/t/03_pragmas.t new file mode 100644 index 0000000..b10c4bb --- /dev/null +++ b/t/03_pragmas.t @@ -0,0 +1,968 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Test::More (tests => 32); +use Perl::Critic::PolicyFactory (-test => 1); + +use Perl::Critic::TestUtils qw(critique); + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); +Perl::Critic::TestUtils::block_perlcriticrc(); + +# Configure Critic not to load certain policies. This +# just makes it a little easier to create test cases +my $profile = { + '-CodeLayout::RequireTidyCode' => {}, + '-Documentation::PodSpelling' => {}, + '-ErrorHandling::RequireCheckingReturnValueOfEval' => {}, + '-Miscellanea::ProhibitUnrestrictedNoCritic' => {}, + '-Miscellanea::ProhibitUselessNoCritic' => {}, + '-ValuesAndExpressions::ProhibitMagicNumbers' => {}, + '-Variables::ProhibitReusedNames' => {}, +}; + +my $code = undef; + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +require 'some_library.pl'; ## no critic +print $crap if $condition; ## no critic + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'} + ), + 0, + 'inline no-critic disables violations' +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +$foo = $bar; + +## no critic + +require 'some_library.pl'; +print $crap if $condition; + +## use critic + +$baz = $nuts; +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'}, + ), + 0, + 'region no-critic', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +for my $foo (@list) { + ## no critic + $long_int = 12345678; + $oct_num = 033; +} + +my $noisy = '!'; + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'}, + ), + 1, + 'scoped no-critic', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +{ + ## no critic + $long_int = 12345678; + $oct_num = 033; +} + +my $noisy = '!'; + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'}, + ), + 1, + 'scoped no-critic', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +## no critic +for my $foo (@list) { + $long_int = 12345678; + $oct_num = 033; +} + +## use critic +my $noisy = '!'; + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'}, + ), + 1, + 'region no-critic across a scope', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +for my $foo (@list) { + ## no critic + $long_int = 12345678; + $oct_num = 033; + ## use critic +} + +my $noisy = '!'; +my $empty = ''; + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'}, + ), + 2, + 'scoped region no-critic', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +## no critic +for my $foo (@list) { + $long_int = 12345678; + $oct_num = 033; +} + +my $noisy = '!'; +my $empty = ''; + +#No final '1;' +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'}, + ), + 0, + 'unterminated no-critic across a scope', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +$long_int = 12345678; ## no critic +$oct_num = 033; ## no critic +my $noisy = '!'; ## no critic +my $empty = ''; ## no critic +my $empty = ''; ## use critic + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'}, + ), + 1, + 'inline use-critic', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +$long_int = 12345678; ## no critic +$oct_num = 033; ## no critic +my $noisy = '!'; ## no critic +my $empty = ''; ## no critic + +$long_int = 12345678; +$oct_num = 033; +my $noisy = '!'; +my $empty = ''; + +#No final '1;' +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'}, + ), + 5, + q, +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +$long_int = 12345678; ## no critic +$oct_num = 033; ## no critic +my $noisy = '!'; ## no critic +my $empty = ''; ## no critic + +## no critic +$long_int = 12345678; +$oct_num = 033; +my $noisy = '!'; +my $empty = ''; + +#No final '1;' +END_PERL + +is( + critique( + \$code, + { + -profile => $profile, + -severity => 1, + -theme => 'core', + -force => 1, + } + ), + 9, + 'force option', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +for my $foo (@list) { + ## no critic + $long_int = 12345678; + $oct_num = 033; +} + +my $noisy = '!'; ## no critic +my $empty = ''; ## no critic + +1; +END_PERL + +is( + critique( + \$code, + { + -profile => $profile, + -severity => 1, + -theme => 'core', + -force => 1, + } + ), + 4, + 'force option', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +for my $foo (@list) { + ## no critic + $long_int = 12345678; + $oct_num = 033; +} + +## no critic +my $noisy = '!'; +my $empty = ''; + +#No final '1;' +END_PERL + +is( + critique( + \$code, + { + -profile => $profile, + -severity => 1, + -theme => 'core', + -force => 1, + } + ), + 5, + 'force option', +); + +#----------------------------------------------------------------------------- +# Check that '## no critic' on the top of a block doesn't extend +# to all code within the block. See RT bug #15295 + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +for ($i;$i++;$i<$j) { ## no critic + my $long_int = 12345678; + my $oct_num = 033; +} + +unless ( $condition1 + && $condition2 ) { ## no critic + my $noisy = '!'; + my $empty = ''; +} + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'}, + ), + 4, + 'RT bug 15295', +); + +#----------------------------------------------------------------------------- +# Check that '## no critic' on the top of a block doesn't extend +# to all code within the block. See RT bug #15295 + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +for ($i; $i++; $i<$j) { ## no critic + my $long_int = 12345678; + my $oct_num = 033; +} + +#Between blocks now +$Global::Variable = "foo"; #Package var; double-quotes + +unless ( $condition1 + && $condition2 ) { ## no critic + my $noisy = '!'; + my $empty = ''; +} + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'} + ), + 6, + 'RT bug 15295', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +sub grep { ## no critic; + return $foo; +} + +sub grep { return $foo; } ## no critic +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'}, + ), + 0, + 'no-critic on sub name', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +sub grep { ## no critic; + return undef; #Should find this! +} + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity =>1, -theme => 'core'} + ), + 1, + 'no-critic on sub name', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +## no critic (NoisyQuotes) +my $noisy = '!'; +my $empty = ''; +eval $string; + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'} + ), + 2, + 'per-policy no-critic', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +## no critic (ValuesAndExpressions) +my $noisy = '!'; +my $empty = ''; +eval $string; + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'} + ), + 1, + 'per-policy no-critic', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +## no critic (Noisy, Empty) +my $noisy = '!'; +my $empty = ''; +eval $string; + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'} + ), + 1, + 'per-policy no-critic', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +## no critic (NOISY, EMPTY, EVAL) +my $noisy = '!'; +my $empty = ''; +eval $string; + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'} + ), + 0, + 'per-policy no-critic', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +## no critic (Noisy, Empty, Eval) +my $noisy = '!'; +my $empty = ''; +eval $string; + +## use critic +my $noisy = '!'; +my $empty = ''; +eval $string; + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'} + ), + 3, + 'per-policy no-critic', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +## no critic (Critic::Policy) +my $noisy = '!'; +my $empty = ''; +eval $string; + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'} + ), + 0, + 'per-policy no-critic', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +## no critic (Foo::Bar, Baz, Boom) +my $noisy = '!'; +my $empty = ''; +eval $string; + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'} + ), + 3, + 'per-policy no-critic', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; +use warnings; +our $VERSION = 1.0; + +## no critic (Noisy) +my $noisy = '!'; #Should not find this +my $empty = ''; #Should find this + +sub foo { + + ## no critic (Empty) + my $nosiy = '!'; #Should not find this + my $empty = ''; #Should not find this + ## use critic; + + return 1; +} + +my $nosiy = '!'; #Should not find this +my $empty = ''; #Should find this + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'} + ), + 2, + 'per-policy no-critic', +); + +#----------------------------------------------------------------------------- +$code = <<'END_PERL'; +package FOO; + +use strict; +use warnings; +our $VERSION = 1.0; + +# with parentheses +my $noisy = '!'; ##no critic (NoisyQuotes) +barf() unless $$ eq ''; ##no critic (Postfix,Empty,Punctuation) +barf() unless $$ eq ''; ##no critic (Postfix , Empty , Punctuation) +barf() unless $$ eq ''; ##no critic (Postfix Empty Punctuation) + +# qw() style +my $noisy = '!'; ##no critic qw(NoisyQuotes); +barf() unless $$ eq ''; ##no critic qw(Postfix,Empty,Punctuation) +barf() unless $$ eq ''; ##no critic qw(Postfix , Empty , Punctuation) +barf() unless $$ eq ''; ##no critic qw(Postfix Empty Punctuation) + +# with quotes +my $noisy = '!'; ##no critic 'NoisyQuotes'; +barf() unless $$ eq ''; ##no critic 'Postfix,Empty,Punctuation'; +barf() unless $$ eq ''; ##no critic 'Postfix , Empty , Punctuation'; +barf() unless $$ eq ''; ##no critic 'Postfix Empty Punctuation'; + +# with double quotes +my $noisy = '!'; ##no critic "NoisyQuotes"; +barf() unless $$ eq ''; ##no critic "Postfix,Empty,Punctuation"; +barf() unless $$ eq ''; ##no critic "Postfix , Empty , Punctuation"; +barf() unless $$ eq ''; ##no critic "Postfix Empty Punctuation"; + +# with spacing variations +my $noisy = '!'; ##no critic (NoisyQuotes) +barf() unless $$ eq ''; ## no critic (Postfix,Empty,Punctuation) +barf() unless $$ eq ''; ##no critic(Postfix , Empty , Punctuation) +barf() unless $$ eq ''; ## no critic(Postfix Empty Punctuation) + +1; + +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'}, + ), + 0, + 'no critic: syntaxes', +); + +#----------------------------------------------------------------------------- +# Most policies apply to a particular type of PPI::Element and usually +# only return one Violation at a time. But the next three cases +# involve policies that apply to the whole document and can return +# multiple violations at a time. These tests make sure that the 'no +# critic' pragmas are effective with those Policies +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; + +#Code before 'use strict' +my $foo = 'baz'; ## no critic +my $bar = 42; # Should find this + +use strict; +use warnings; +our $VERSION = 1.0; + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 5, -theme => 'core'}, + ), + 1, + 'no critic & RequireUseStrict', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +package FOO; +use strict; + +#Code before 'use warnings' +my $foo = 'baz'; ## no critic +my $bar = 42; # Should find this + +use warnings; +our $VERSION = 1.0; + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 4, -theme => 'core'}, + ), + 1, + 'no critic & RequireUseWarnings', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +use strict; ##no critic +use warnings; #should find this +my $bar = 42; #this one will be squelched + +package FOO; + +our $VERSION = 1.0; + +1; +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 4, -theme => 'core'}, + ), + 1, + 'no critic & RequireExplicitPackage', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +#!/usr/bin/perl -w ## no critic + +package Foo; +use strict; +use warnings; +our $VERSION = 1; + +my $noisy = '!'; # should find this + +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'}, + ), + 1, + 'no-critic on shebang line' +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +#line 1 +## no critic; + +=pod + +=head1 SOME POD HERE + +This code has several POD-related violations at line 1. The "## no critic" +marker is on the second physical line. However, the "#line" directive should +cause it to treat it as if it actually were on the first physical line. Thus, +the violations should be suppressed. + +=cut + +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'}, + ), + 0, + 'no-critic where logical line == 1, but physical line != 1' +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +#line 7 +## no critic; + +=pod + +=head1 SOME POD HERE + +This code has several POD-related violations at line 1. The "## no critic" +marker is on the second physical line, and the "#line" directive should cause +it to treat it as if it actually were on the 7th physical line. Thus, the +violations should NOT be suppressed. + +=cut + +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'}, + ), + 2, + 'no-critic at logical line != 1, and physical line != 1' +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +#line 1 +#!perl ### no critic; + +package Foo; +use strict; +use warnings; +our $VERSION = 1; + +# In this case, the "## no critic" marker is on the first logical line, which +# is also the shebang line. + +1; + +END_PERL + +is( + critique( + \$code, + {-profile => $profile, -severity => 1, -theme => 'core'}, + ), + 0, + 'no-critic on shebang line, where physical line != 1, but logical line == 1' +); + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/04_options_processor.t b/t/04_options_processor.t new file mode 100644 index 0000000..950f97d --- /dev/null +++ b/t/04_options_processor.t @@ -0,0 +1,207 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); + +use Perl::Critic::OptionsProcessor; +use Perl::Critic::Utils qw< :booleans >; +use Perl::Critic::Utils::Constants qw< :color_severity >; + +use Test::More tests => 54; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +{ + # Can't use IO::Interactive here because we /don't/ want to check STDIN. + my $color = -t *STDOUT ? $TRUE : $FALSE; ## no critic (ProhibitInteractiveTest) + + my $processor = Perl::Critic::OptionsProcessor->new(); + is($processor->force(), 0, 'native default force'); + is($processor->only(), 0, 'native default only'); + is($processor->severity(), 5, 'native default severity'); + is($processor->theme(), q{}, 'native default theme'); + is($processor->top(), 0, 'native default top'); + is($processor->color(), $color, 'native default color'); + is($processor->pager(), q{}, 'native default pager'); + is($processor->verbose(), 4, 'native default verbose'); + is($processor->criticism_fatal, 0, 'native default criticism-fatal'); + is_deeply($processor->include(), [], 'native default include'); + is_deeply($processor->exclude(), [], 'native default exclude'); + is($processor->color_severity_highest(), + $PROFILE_COLOR_SEVERITY_HIGHEST_DEFAULT, + 'native default color-severity-highest'); + is($processor->color_severity_high(), + $PROFILE_COLOR_SEVERITY_HIGH_DEFAULT, + 'native default color-severity-high'); + is($processor->color_severity_medium(), + $PROFILE_COLOR_SEVERITY_MEDIUM_DEFAULT, + 'native default color-severity-medium'); + is($processor->color_severity_low(), + $PROFILE_COLOR_SEVERITY_LOW_DEFAULT, + 'native default color-severity-low'); + is($processor->color_severity_lowest(), + $PROFILE_COLOR_SEVERITY_LOWEST_DEFAULT, + 'native default color-severity-lowest'); + is_deeply($processor->program_extensions(), [], + 'native default program extensions'); +} + +#----------------------------------------------------------------------------- + +{ + my %user_defaults = ( + force => 1, + only => 1, + severity => 4, + theme => 'pbp', + top => 50, + color => $FALSE, + pager => 'less', + verbose => 7, + 'criticism-fatal' => 1, + include => 'foo bar', + exclude => 'baz nuts', + 'color-severity-highest' => 'chartreuse', + 'color-severity-high' => 'fuschia', + 'color-severity-medium' => 'blue', + 'color-severity-low' => 'gray', + 'color-severity-lowest' => 'scots tartan', + 'program-extensions' => '.PL .pl .t', + ); + + my $processor = Perl::Critic::OptionsProcessor->new( %user_defaults ); + is($processor->force(), 1, 'user default force'); + is($processor->only(), 1, 'user default only'); + is($processor->severity(), 4, 'user default severity'); + is($processor->theme(), 'pbp', 'user default theme'); + is($processor->top(), 50, 'user default top'); + is($processor->color(), $FALSE, 'user default color'); + is($processor->pager(), 'less', 'user default pager'); + is($processor->verbose(), 7, 'user default verbose'); + is($processor->criticism_fatal(), 1, 'user default criticism_fatal'); + is_deeply($processor->include(), [ qw(foo bar) ], 'user default include'); + is_deeply($processor->exclude(), [ qw(baz nuts)], 'user default exclude'); + is($processor->color_severity_highest(), + 'chartreuse', 'user default color_severity_highest'); + is($processor->color_severity_high(), + 'fuschia', 'user default color_severity_high'); + is($processor->color_severity_medium(), + 'blue', 'user default color_severity_medium'); + is($processor->color_severity_low(), + 'gray', 'user default color_severity_low'); + is($processor->color_severity_lowest(), + 'scots tartan', 'user default color_severity_lowest'); + is_deeply($processor->program_extensions(), [ qw(.PL .pl .t) ], + 'user default program-extensions'); +} + +#----------------------------------------------------------------------------- + +{ + my $processor = Perl::Critic::OptionsProcessor->new( 'colour' => 1 ); + is($processor->color(), $TRUE, 'user default colour true'); + + $processor = Perl::Critic::OptionsProcessor->new( 'colour' => 0 ); + is($processor->color(), $FALSE, 'user default colour false'); + + $processor = Perl::Critic::OptionsProcessor->new( + 'colour-severity-highest' => 'chartreuse', + 'colour-severity-high' => 'fuschia', + 'colour-severity-medium' => 'blue', + 'colour-severity-low' => 'gray', + 'colour-severity-lowest' => 'scots tartan', + ); + is( $processor->color_severity_highest(), + 'chartreuse', 'user default colour-severity-highest' ); + is( $processor->color_severity_high(), + 'fuschia', 'user default colour-severity-high' ); + is( $processor->color_severity_medium(), + 'blue', 'user default colour-severity-medium' ); + is( $processor->color_severity_low(), + 'gray', 'user default colour-severity-low' ); + is( $processor->color_severity_lowest(), + 'scots tartan', 'user default colour-severity-lowest' ); + + $processor = Perl::Critic::OptionsProcessor->new( + 'color-severity-5' => 'chartreuse', + 'color-severity-4' => 'fuschia', + 'color-severity-3' => 'blue', + 'color-severity-2' => 'gray', + 'color-severity-1' => 'scots tartan', + ); + is( $processor->color_severity_highest(), + 'chartreuse', 'user default color-severity-5' ); + is( $processor->color_severity_high(), + 'fuschia', 'user default color-severity-4' ); + is( $processor->color_severity_medium(), + 'blue', 'user default color-severity-3' ); + is( $processor->color_severity_low(), + 'gray', 'user default color-severity-2' ); + is( $processor->color_severity_lowest(), + 'scots tartan', 'user default color-severity-1' ); + + $processor = Perl::Critic::OptionsProcessor->new( + 'colour-severity-5' => 'chartreuse', + 'colour-severity-4' => 'fuschia', + 'colour-severity-3' => 'blue', + 'colour-severity-2' => 'gray', + 'colour-severity-1' => 'scots tartan', + ); + is( $processor->color_severity_highest(), + 'chartreuse', 'user default colour-severity-5' ); + is( $processor->color_severity_high(), + 'fuschia', 'user default colour-severity-4' ); + is( $processor->color_severity_medium(), + 'blue', 'user default colour-severity-3' ); + is( $processor->color_severity_low(), + 'gray', 'user default colour-severity-2' ); + is( $processor->color_severity_lowest(), + 'scots tartan', 'user default colour-severity-1' ); +} + +#----------------------------------------------------------------------------- + +{ + my $processor = Perl::Critic::OptionsProcessor->new( pager => 'foo' ); + is($processor->color(), $FALSE, 'pager set turns off color'); +} + +#----------------------------------------------------------------------------- +# Test exception handling + +{ + my %invalid_defaults = ( + foo => 1, + bar => 2, + ); + + eval { Perl::Critic::OptionsProcessor->new( %invalid_defaults ) }; + like( + $EVAL_ERROR, + qr/"foo" [ ] is [ ] not [ ] a [ ] supported [ ] option/xms, + 'First invalid default', + ); + like( + $EVAL_ERROR, + qr/"bar" [ ] is [ ] not [ ] a [ ] supported [ ] option/xms, + 'Second invalid default', + ); + +} + + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/05_utils.t b/t/05_utils.t new file mode 100644 index 0000000..642bc61 --- /dev/null +++ b/t/05_utils.t @@ -0,0 +1,558 @@ +#!perl + +## There's too much use of source code in strings. +## no critic (RequireInterpolationOfMetachars) + +use 5.006001; +use strict; +use warnings; + +use English qw< -no_match_vars >; +use Carp qw< confess >; + +use File::Temp qw< >; +use PPI::Document qw< >; +use PPI::Document::File qw< >; + +use Perl::Critic::PolicyFactory; +use Perl::Critic::TestUtils qw(bundled_policy_names); +use Perl::Critic::Utils; + +use Test::More tests => 156; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +test_export(); +test_find_keywords(); +test_is_assignment_operator(); +test_is_hash_key(); +test_is_script(); +test_is_script_with_PL_files(); +test_is_perl_builtin(); +test_is_perl_global(); +test_precedence_of(); +test_is_subroutine_name(); +test_policy_long_name_and_policy_short_name(); +test_interpolate(); +test_is_perl_and_shebang_line(); +test_is_backup(); +test_first_arg(); +test_parse_arg_list(); +test_is_function_call(); +test_find_bundled_policies(); +test_is_unchecked_call(); + +#----------------------------------------------------------------------------- + +sub test_export { + can_ok('main', 'all_perl_files'); + can_ok('main', 'find_keywords'); + can_ok('main', 'interpolate'); + can_ok('main', 'is_hash_key'); + can_ok('main', 'is_method_call'); + can_ok('main', 'is_perl_builtin'); + can_ok('main', 'is_perl_global'); + can_ok('main', 'is_script'); + can_ok('main', 'is_subroutine_name'); + can_ok('main', 'first_arg'); + can_ok('main', 'parse_arg_list'); + can_ok('main', 'policy_long_name'); + can_ok('main', 'policy_short_name'); + can_ok('main', 'precedence_of'); + can_ok('main', 'severity_to_number'); + can_ok('main', 'shebang_line'); + can_ok('main', 'verbosity_to_format'); + can_ok('main', 'is_unchecked_call'); + + is($SPACE, q< >, 'character constants'); + is($SEVERITY_LOWEST, 1, 'severity constants'); + is($POLICY_NAMESPACE, 'Perl::Critic::Policy', 'Policy namespace'); + + return; +} + +#----------------------------------------------------------------------------- + +sub count_matches { my $val = shift; return defined $val ? scalar @{$val} : 0; } +sub make_doc { + my $code = shift; + return + Perl::Critic::Document->new('-source' => ref $code ? $code : \$code); +} + +sub test_find_keywords { + my $doc = PPI::Document->new(); #Empty doc + is( count_matches( find_keywords($doc, 'return') ), 0, 'find_keywords, no doc' ); + + my $code = 'return;'; + $doc = make_doc( $code ); + is( count_matches( find_keywords($doc, 'return') ), 1, 'find_keywords, find 1'); + + $code = 'sub foo { }'; + $doc = make_doc( $code ); + is( count_matches( find_keywords($doc, 'return') ), 0, 'find_keywords, find 0'); + + $code = 'sub foo { return 1; }'; + $doc = make_doc( $code ); + is( count_matches( find_keywords($doc, 'return') ), 1, 'find_keywords, find 1'); + + $code = 'sub foo { return 0 if @_; return 1; }'; + $doc = make_doc( $code ); + is( count_matches( find_keywords($doc, 'return') ), 2, 'find_keywords, find 2'); + + return; +} + +#----------------------------------------------------------------------------- + +sub test_is_assignment_operator { + for ( qw( = **= += -= .= *= /= %= x= &= |= ^= <<= >>= &&= ||= //= ) ) { + is( is_assignment_operator($_), 1, "$_ is an assignment operator" ); + } + + for ( qw( == != =~ >= <= + - * / % x bogus= ) ) { + is( !!is_assignment_operator($_), q{}, "$_ is not an assignment operator" ); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub test_is_hash_key { + my $code = 'sub foo { return $h1{bar}, $h2->{baz}, $h3->{ nuts() } }'; + my $doc = PPI::Document->new(\$code); + my @words = @{$doc->find('PPI::Token::Word')}; + my @expect = ( + ['sub', undef], + ['foo', undef], + ['return', undef], + ['bar', 1], + ['baz', 1], + ['nuts', undef], + ); + is(scalar @words, scalar @expect, 'is_hash_key count'); + + for my $i (0 .. $#expect) { + is($words[$i], $expect[$i][0], 'is_hash_key word'); + is( !!is_hash_key($words[$i]), !!$expect[$i][1], 'is_hash_key boolean' ); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub test_is_script { + my @good = ( + "#!perl\n", + "#! perl\n", + "#!/usr/bin/perl -w\n", + "#!C:\\Perl\\bin\\perl\n", + "#!/bin/sh\n", + ); + + my @bad = ( + "package Foo;\n", + "\n#!perl\n", + ); + + no warnings qw< deprecated >; ## no critic (TestingAndDebugging::ProhibitNoWarnings) + + for my $code (@good) { + my $doc = PPI::Document->new(\$code) or confess; + $doc->index_locations(); + ok(is_script($doc), 'is_script, true'); + } + + for my $code (@bad) { + my $doc = PPI::Document->new(\$code) or confess; + $doc->index_locations(); + ok(!is_script($doc), 'is_script, false'); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub test_is_script_with_PL_files { ## no critic (NamingConventions::Capitalization) + + # Testing for .PL files (e.g. Makefile.PL, Build.PL) + # See http://rt.cpan.org/Ticket/Display.html?id=20481 + my $temp_file = File::Temp->new(SUFFIX => '.PL'); + + # The file must have content, or PPI will barf... + print {$temp_file} "some code\n"; + # Just to flush the buffer. + close $temp_file or confess "Couldn't close $temp_file: $OS_ERROR"; + + my $doc = PPI::Document::File->new($temp_file->filename()); + + no warnings qw< deprecated >; ## no critic (TestingAndDebugging::ProhibitNoWarnings) + ok(is_script($doc), 'is_script, false for .PL files'); + + return; +} + +#----------------------------------------------------------------------------- + +sub test_is_perl_builtin { + ok( is_perl_builtin('print'), 'Is perl builtin function' ); + ok( !is_perl_builtin('foobar'), 'Is not perl builtin function' ); + + my $code = 'sub print {}'; + my $doc = make_doc( $code ); + my $sub = $doc->find_first('Statement::Sub'); + ok( is_perl_builtin($sub), 'Is perl builtin function (PPI)' ); + + $code = 'sub foobar {}'; + $doc = make_doc( $code ); + $sub = $doc->find_first('Statement::Sub'); + ok( !is_perl_builtin($sub), 'Is not perl builtin function (PPI)' ); + + return; +} + +#----------------------------------------------------------------------------- + +sub test_is_perl_global { + ok( is_perl_global('$OSNAME'), '$OSNAME is a perl global var' ); + ok( is_perl_global('*STDOUT'), '*STDOUT is a perl global var' ); + ok( !is_perl_global('%FOOBAR'), '%FOOBAR is a not perl global var' ); + + my $code = '$OSNAME'; + my $doc = make_doc($code); + my $var = $doc->find_first('Token::Symbol'); + ok( is_perl_global($var), '$OSNAME is perl a global var (PPI)' ); + + $code = '*STDOUT'; + $doc = make_doc($code); + $var = $doc->find_first('Token::Symbol'); + ok( is_perl_global($var), '*STDOUT is perl a global var (PPI)' ); + + $code = '%FOOBAR'; + $doc = make_doc($code); + $var = $doc->find_first('Token::Symbol'); + ok( !is_perl_global($var), '%FOOBAR is not a perl global var (PPI)' ); + + $code = q[$\\]; + $doc = make_doc($code); + $var = $doc->find_first('Token::Symbol'); + ok( is_perl_global($var), "$code is a perl global var (PPI)" ); + + return; +} + +#----------------------------------------------------------------------------- + +sub test_precedence_of { + cmp_ok( precedence_of(q<*>), q[<], precedence_of(q<+>), 'Precedence' ); + + my $code1 = '8 + 5'; + my $doc1 = make_doc($code1); + my $op1 = $doc1->find_first('Token::Operator'); + + my $code2 = '7 * 5'; + my $doc2 = make_doc($code2); + my $op2 = $doc2->find_first('Token::Operator'); + + cmp_ok( precedence_of($op2), '<', precedence_of($op1), 'Precedence (PPI)' ); + + return; +} + +#----------------------------------------------------------------------------- + +sub test_is_subroutine_name { + my $code = 'sub foo {}'; + my $doc = make_doc( $code ); + my $word = $doc->find_first( sub { $_[1] eq 'foo' } ); + ok( is_subroutine_name( $word ), 'Is a subroutine name'); + + $code = '$bar = foo()'; + $doc = make_doc( $code ); + $word = $doc->find_first( sub { $_[1] eq 'foo' } ); + ok( !is_subroutine_name( $word ), 'Is not a subroutine name'); + + return; +} + +#----------------------------------------------------------------------------- + +sub test_policy_long_name_and_policy_short_name { + my $short_name = 'Baz::Nuts'; + my $long_name = "${POLICY_NAMESPACE}::$short_name"; + is( policy_long_name( $short_name ), $long_name, 'policy_long_name' ); + is( policy_long_name( $long_name ), $long_name, 'policy_long_name' ); + is( policy_short_name( $short_name ), $short_name, 'policy_short_name' ); + is( policy_short_name( $long_name ), $short_name, 'policy_short_name' ); + + return; +} + +#----------------------------------------------------------------------------- + +sub test_interpolate { + is( interpolate( '\r%l\t%c\n' ), "\r%l\t%c\n", 'Interpolation' ); + is( interpolate( 'literal' ), 'literal', 'Interpolation' ); + + return; +} + +#----------------------------------------------------------------------------- + +sub test_is_perl_and_shebang_line { + for ( qw(foo.t foo.pm foo.pl foo.PL foo.psgi) ) { + ok( Perl::Critic::Utils::_is_perl($_), qq{Is perl: '$_'} ); + } + + for ( qw(foo.doc foo.txt foo.conf foo foo.pl.exe foo_pl) ) { + ok( ! Perl::Critic::Utils::_is_perl($_), qq{Is not perl: '$_'} ); + } + + my @perl_shebangs = ( + '#!perl', + '#!/usr/local/bin/perl', + '#!/usr/local/bin/perl-5.8', + '#!/bin/env perl', + '#!perl ## no critic', + '#!perl ## no critic (foo)', + ); + + for my $shebang (@perl_shebangs) { + my $temp_file = + File::Temp->new( TEMPLATE => 'Perl-Critic.05_utils.t.XXXXX' ); + my $filename = $temp_file->filename(); + print {$temp_file} "$shebang\n"; + # Must close to flush buffer + close $temp_file or confess "Couldn't close $temp_file: $OS_ERROR"; + + ok( Perl::Critic::Utils::_is_perl($filename), qq{Is perl: '$shebang'} ); + + my $document = PPI::Document->new(\$shebang); + is( + Perl::Critic::Utils::shebang_line($document), + $shebang, + qq, + ); + } + + my @not_perl_shebangs = ( + 'shazbot', + '#!/usr/bin/ruby', + '#!/bin/env python', + ); + + for my $shebang (@not_perl_shebangs) { + my $temp_file = + File::Temp->new( TEMPLATE => 'Perl-Critic.05_utils.t.XXXXX' ); + my $filename = $temp_file->filename(); + print {$temp_file} "$shebang\n"; + # Must close to flush buffer + close $temp_file or confess "Couldn't close $temp_file: $OS_ERROR"; + + ok( ! Perl::Critic::Utils::_is_perl($filename), qq{Is not perl: '$shebang'} ); + + my $document = PPI::Document->new(\$shebang); + is( + Perl::Critic::Utils::shebang_line($document), + ($shebang eq 'shazbot' ? undef : $shebang), + qq, + ); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub test_is_backup { + for ( qw( foo.swp foo.bak foo~ ), '#foo#' ) { + ok( Perl::Critic::Utils::_is_backup($_), qq{Is backup: '$_'} ); + } + + for ( qw( swp.pm Bak ~foo ) ) { + ok( ! Perl::Critic::Utils::_is_backup($_), qq{Is not backup: '$_'} ); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub test_first_arg { + my @tests = ( + q{eval { some_code() };} => q{{ some_code() }}, + q{eval( {some_code() } );} => q{{some_code() }}, + q{eval();} => undef, + ); + + for (my $i = 0; $i < @tests; $i += 2) { ## no critic (ProhibitCStyleForLoops) + my $code = $tests[$i]; + my $expect = $tests[$i+1]; + my $doc = PPI::Document->new(\$code); + my $got = first_arg($doc->first_token()); + is($got ? "$got" : undef, $expect, 'first_arg - '.$code); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub test_parse_arg_list { + my @tests = ( + [ q/foo($bar, 'baz', 1)/ => [ [ q<$bar> ], [ q<'baz'> ], [ q<1> ], ] ], + [ + q/foo( { bar => 1 }, { bar => 1 }, 'blah' )/ + => [ + [ '{ bar => 1 }' ], + [ '{ bar => 1 }' ], + [ q<'blah'> ], + ], + ], + [ + q/foo( { bar() }, {}, 'blah' )/ + => [ + [ '{ bar() }' ], + [ qw< {} > ], + [ q<'blah'> ], + ], + ], + ); + + foreach my $test (@tests) { + my ($code, $expected) = @{ $test }; + + my $document = PPI::Document->new( \$code ); + my @got = parse_arg_list( $document->first_token() ); + is_deeply( \@got, $expected, "parse_arg_list: $code" ); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub test_is_function_call { + my $code = 'sub foo{}'; + my $doc = PPI::Document->new( \$code ); + my $words = $doc->find('PPI::Token::Word'); + is(scalar @{$words}, 2, 'count PPI::Token::Words'); + is((scalar grep {is_function_call($_)} @{$words}), 0, 'is_function_call'); + + return; +} + +#----------------------------------------------------------------------------- + +sub test_find_bundled_policies { + Perl::Critic::TestUtils::block_perlcriticrc(); + + my @native_policies = bundled_policy_names(); + my $policy_dir = File::Spec->catfile( qw(lib Perl Critic Policy) ); + my @found_policies = all_perl_files( $policy_dir ); + is( scalar @found_policies, scalar @native_policies, 'Find all perl code'); + + return; +} + +#----------------------------------------------------------------------------- +sub test_is_unchecked_call { + my @trials = ( + # just an obvious failure to check the return value + { + code => q[ open( $fh, $mode, $filename ); ], + pass => 1, + }, + # check the value with a trailing conditional + { + code => q[ open( $fh, $mode, $filename ) or confess 'unable to open'; ], + pass => 0, + }, + # assign the return value to a variable (and assume that it's checked later) + { + code => q[ my $error = open( $fh, $mode, $filename ); ], + pass => 0, + }, + # the system call is in a conditional + { + code => q[ return $EMPTY if not open my $fh, '<', $file; ], + pass => 0, + }, + # open call in list context, checked with 'not' + { + code => q[ return $EMPTY if not ( open my $fh, '<', $file ); ], + pass => 0, + }, + # just putting the system call in a list context doesn't mean the return value is checked + { + code => q[ ( open my $fh, '<', $file ); ], + pass => 1, + }, + + # Check Fatal. + { + code => q[ use Fatal qw< open >; open( $fh, $mode, $filename ); ], + pass => 0, + }, + { + code => q[ use Fatal qw< open >; ( open my $fh, '<', $file ); ], + pass => 0, + }, + + # Check Fatal::Exception. + { + code => q[ use Fatal::Exception 'Exception::System' => qw< open close >; open( $fh, $mode, $filename ); ], + pass => 0, + }, + { + code => q[ use Fatal::Exception 'Exception::System' => qw< open close >; ( open my $fh, '<', $file ); ], + pass => 0, + }, + + # Check autodie. + { + code => q[ use autodie; open( $fh, $mode, $filename ); ], + pass => 0, + }, + { + code => q[ use autodie qw< :io >; open( $fh, $mode, $filename ); ], + pass => 0, + }, + { + code => q[ use autodie qw< :system >; ( open my $fh, '<', $file ); ], + pass => 1, + }, + { + code => q[ use autodie qw< :system :file >; ( open my $fh, '<', $file ); ], + pass => 0, + }, + ); + + foreach my $trial ( @trials ) { + my $code = $trial->{'code'}; + my $doc = make_doc( $code ); + my $statement = $doc->find_first( sub { $_[1] eq 'open' } ); + if ( $trial->{'pass'} ) { + ok( is_unchecked_call( $statement ), qq ); + } else { + ok( ! is_unchecked_call( $statement ), qq ); + } + } + + return; +} + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/05_utils_perl.t b/t/05_utils_perl.t new file mode 100644 index 0000000..2dc0156 --- /dev/null +++ b/t/05_utils_perl.t @@ -0,0 +1,42 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::Utils::Perl qw< :all >; + +use Test::More tests => 7; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +#----------------------------------------------------------------------------- +# export tests + +can_ok('main', 'symbol_without_sigil'); + +#----------------------------------------------------------------------------- +# name_without_sigil tests + +{ + foreach my $sigil ( q<>, qw< $ @ % * & > ) { + my $symbol = "${sigil}foo"; + is( + symbol_without_sigil($symbol), + 'foo', + "symbol_without_sigil($symbol)", + ); + } +} + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/05_utils_pod.t b/t/05_utils_pod.t new file mode 100644 index 0000000..0425183 --- /dev/null +++ b/t/05_utils_pod.t @@ -0,0 +1,690 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use English qw< -no_match_vars >; +use Readonly; +use Carp qw< confess >; + + +use Perl::Critic::Utils::POD qw< :all >; + + +use Test::More tests => 61; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +Readonly::Scalar my $EXCEPTION_MESSAGE_REGEX => + qrxmsi; + + +can_ok('main', 'get_pod_file_for_module'); +can_ok('main', 'get_raw_pod_section_from_file'); +can_ok('main', 'get_raw_pod_section_from_filehandle'); +can_ok('main', 'get_raw_pod_section_from_string'); +can_ok('main', 'get_raw_pod_section_for_module'); +can_ok('main', 'get_pod_section_from_file'); +can_ok('main', 'get_pod_section_from_filehandle'); +can_ok('main', 'get_pod_section_from_string'); +can_ok('main', 'get_pod_section_for_module'); +can_ok('main', 'trim_raw_pod_section'); +can_ok('main', 'trim_pod_section'); +can_ok('main', 'get_raw_module_abstract_from_file'); +can_ok('main', 'get_raw_module_abstract_from_filehandle'); +can_ok('main', 'get_raw_module_abstract_from_string'); +can_ok('main', 'get_raw_module_abstract_for_module'); +can_ok('main', 'get_module_abstract_from_file'); +can_ok('main', 'get_module_abstract_from_filehandle'); +can_ok('main', 'get_module_abstract_from_string'); +can_ok('main', 'get_module_abstract_for_module'); + + +{ + my $code = q; ## no critic (RequireInterpolationOfMetachars) + + my $pod = get_raw_pod_section_from_string( $code, 'SYNOPSIS' ); + + is( + $pod, + undef, + qq, + ); + + $pod = get_pod_section_from_string( $code, 'SYNOPSIS' ); + + is( + $pod, + undef, + qq, + ); +} + + +{ + my $code = <<'END_CODE'; +=pod +END_CODE + + my $pod = get_raw_pod_section_from_string( $code, 'SYNOPSIS' ); + + is( + $pod, + undef, + q, + ); + + $pod = get_pod_section_from_string( $code, 'SYNOPSIS' ); + + is( + $pod, + undef, + q, + ); +} + + +{ + my $code = <<'END_CODE'; +=pod + +=head1 FOO + +Some plain text. + +=cut +END_CODE + + my $pod = get_raw_pod_section_from_string( $code, 'FOO' ); + + my $expected = <<'END_EXPECTED'; +=head1 FOO + +Some plain text. + +END_EXPECTED + is( + $pod, + $expected, + q, + ); + + $pod = get_pod_section_from_string( $code, 'FOO' ); + + $expected = <<'END_EXPECTED'; +FOO + Some plain text. + +END_EXPECTED + is( + $pod, + $expected, + q, + ); +} + + +{ + my $code = <<'END_CODE'; +=pod + +=head1 FOO + +Some C text. + +=cut +END_CODE + + my $pod = get_raw_pod_section_from_string( $code, 'FOO' ); + + my $expected = <<'END_EXPECTED'; +=head1 FOO + +Some C text. + +END_EXPECTED + is( + $pod, + $expected, + q/get_raw_pod_section_from_string('=head1 FOO Some C text.', 'FOO')/, + ); + + $pod = get_pod_section_from_string( $code, 'FOO' ); + + $expected = <<'END_EXPECTED'; +FOO + Some `escaped' text. + +END_EXPECTED + is( + $pod, + $expected, + q/get_pod_section_from_string('=head1 FOO Some C text.', 'FOO')/, + ); +} + + +{ + my $code = <<'END_CODE'; +=pod + +=head1 FOO + +Some plain text. + +=head1 BAR + +=cut +END_CODE + + my $pod = get_raw_pod_section_from_string( $code, 'FOO' ); + + my $expected = <<'END_EXPECTED'; +=head1 FOO + +Some plain text. + +END_EXPECTED + is( + $pod, + $expected, + q, + ); + + $pod = get_pod_section_from_string( $code, 'FOO' ); + + $expected = <<'END_EXPECTED'; +FOO + Some plain text. + +END_EXPECTED + is( + $pod, + $expected, + q, + ); +} + + +{ + my $code = <<'END_CODE'; +=pod + +=head1 FOO + +Some plain text. + +=head2 BAR + +=cut +END_CODE + + my $pod = get_raw_pod_section_from_string( $code, 'FOO' ); + + my $expected = <<'END_EXPECTED'; +=head1 FOO + +Some plain text. + +=head2 BAR + +END_EXPECTED + is( + $pod, + $expected, + q, + ); + + $pod = get_pod_section_from_string( $code, 'FOO' ); + + # Pod::Parser v1.36 changed what it did with trailing whitespace, so we + # use a regex with an ending \s* so that we can deal with whatever version + # of Pod::Parser the user has installed. This until we can figure out + # what to replace Pod::Select with. + $expected = qr< + \A + FOO \n + [ ]{4} Some [ ] plain [ ] text.\n + \n + [ ]{2} BAR\n + \s* + \z + >xms; + + like( + $pod, + $expected, + q, + ); +} + +{ + my $code = <<'END_CODE'; +=pod + +=head2 FOO + +Some plain text. + +=cut +END_CODE + + my $pod = get_raw_pod_section_from_string( $code, 'FOO' ); + + is( + $pod, + undef, + q, + ); + + $pod = get_pod_section_from_string( $code, 'FOO' ); + + is( + $pod, + undef, + q, + ); +} + +#----------------------------------------------------------------------------- + +{ + my $original = <<'END_POD'; +=head1 LYRICS + +We like talking dirty. We smoke and we drink. We're KMFDM and all other bands +stink. + +END_POD + + my $trimmed = trim_raw_pod_section( $original ); + + my $expected = + q + . qq + . q; + + is( + $trimmed, + $expected, + 'trim_raw_pod_section() with section header', + ); + + $trimmed = trim_pod_section( $original ); + + is( + $trimmed, + $expected, + 'trim_pod_section() with section header', + ); +} + + +{ + my $original = <<'END_VOCAL_SAMPLE'; + +You see, I believe in the noble, aristocratic art of doin' absolutely nothin'. +And I hope someday to be in a position where I can do even less. + +END_VOCAL_SAMPLE + + my $trimmed = trim_raw_pod_section( $original ); + + my $expected = + q + . qq + . q + . q; + + is( + $trimmed, + $expected, + 'trim_raw_pod_section() without section header', + ); + + $trimmed = trim_pod_section( $original ); + + is( + $trimmed, + $expected, + 'trim_pod_section() without section header', + ); +} + + +{ + my $original = <<'END_INDENTATION'; + + Some indented text. + +END_INDENTATION + + my $trimmed = trim_raw_pod_section( $original ); + + my $expected = q; + + is( + $trimmed, + $expected, + 'trim_raw_pod_section() indented', + ); + + $trimmed = trim_pod_section( $original ); + + $expected = q< > . $expected; + + is( + $trimmed, + $expected, + 'trim_pod_section() indented', + ); +} + +#----------------------------------------------------------------------------- + +{ + my $source = <<'END_MODULE'; + +=head1 NAME + +A::Stupendous::Module - An abstract. + +END_MODULE + + my $expected = q; + + my $result = get_raw_module_abstract_from_string( $source ); + + is( + $result, + $expected, + q, + ); + + $result = get_module_abstract_from_string( $source ); + + is( + $result, + $expected, + q, + ); +} + + +{ + my $source = <<'END_MODULE'; + +=head1 NAME + +A::Stupendous::Code::Module - An abstract involving C<$code>. + +END_MODULE + + my $expected = q.>; ## no critic (RequireInterpolationOfMetachars) + + my $result = get_raw_module_abstract_from_string( $source ); + + is( + $result, + $expected, + q, + ); + + $expected = q; ## no critic (RequireInterpolationOfMetachars) + + $result = get_module_abstract_from_string( $source ); + + is( + $result, + $expected, + q, + ); +} + + +{ + my $source = <<'END_MODULE'; + +=head1 NOT NAME + +There's nobody home. + +END_MODULE + + my $result = get_raw_module_abstract_from_string( $source ); + + is( + $result, + undef, + q, + ); + + $result = get_module_abstract_from_string( $source ); + + is( + $result, + undef, + q, + ); +} + + +{ + my $source = <<'END_MODULE'; + +=head1 NAME + +=head1 DESCRIPTION + +END_MODULE + + my $result = get_raw_module_abstract_from_string( $source ); + + is( + $result, + undef, + q, + ); + + $result = get_module_abstract_from_string( $source ); + + is( + $result, + undef, + q, + ); +} + + +{ + my $source = <<'END_MODULE'; + +=head1 NAME + +A::Not::So::Stupendous::Module + +END_MODULE + + my $result = get_raw_module_abstract_from_string( $source ); + + is( + $result, + undef, + q, + ); + + $result = get_module_abstract_from_string( $source ); + + is( + $result, + undef, + q, + ); +} + + +{ + my $source = <<'END_MODULE'; + +=head1 NAME + +A::Not::So::Stupendous::Module - + +END_MODULE + + my $result = get_raw_module_abstract_from_string( $source ); + + is( + $result, + undef, + q, + ); + + $result = get_module_abstract_from_string( $source ); + + is( + $result, + undef, + q, + ); +} + + +{ + my $source = <<'END_MODULE'; + +=head1 NAME + +A::Not::So::Stupendous::Module No hyphen. + +END_MODULE + + test_exception_from_get_raw_module_abstract_from_string( + $source, q, + ); + + test_exception_from_get_module_abstract_from_string( + $source, q, + ); +} + + +{ + my $source = <<'END_MODULE'; + +=head1 NAME + +A::Not::So::Stupendous::Module -- Double hyphen. + +END_MODULE + + test_exception_from_get_raw_module_abstract_from_string( + $source, q, + ); + + test_exception_from_get_module_abstract_from_string( + $source, q, + ); +} + + +{ + my $source = <<'END_MODULE'; + +=head1 NAME + +A::Not::So::Stupendous::Module - Abstract goes across +multiple lines. + +END_MODULE + + test_exception_from_get_raw_module_abstract_from_string( + $source, q, + ); + +# Cannot do this test: Pod::PlainText merges the lines. +# test_exception_from_get_module_abstract_from_string( +# $source, q, +# ); +} + +#----------------------------------------------------------------------------- + +sub test_exception_from_get_raw_module_abstract_from_string { + my ($source, $name) = @_; + + my $result; + my $message_like_name = + qq; + + local $EVAL_ERROR = undef; + eval { + $result = get_raw_module_abstract_from_string( $source ); + }; + _test_exception_from_get_module_abstract_from_string( + $source, $name, $result, $message_like_name, + ); + + return; +} + +sub test_exception_from_get_module_abstract_from_string { + my ($source, $name) = @_; + + my $result; + my $message_like_name = + qq; + + local $EVAL_ERROR = undef; + eval { + $result = get_module_abstract_from_string( $source ); + }; + _test_exception_from_get_module_abstract_from_string( + $source, $name, $result, $message_like_name, + ); + + return; +} + +sub _test_exception_from_get_module_abstract_from_string { + my ($source, $name, $result, $message_like_name) = @_; + + my $eval_error = $EVAL_ERROR; + my $exception = Perl::Critic::Exception::Fatal::Generic->caught(); + + if ( + ok( + ref $exception, + qq, + ) + ) { + like( $exception->message(), $EXCEPTION_MESSAGE_REGEX, $message_like_name ); + } + else { + diag( 'Result: ', (defined $result ? ">$result<" : '') ); + if ($eval_error) { + diag( + qq, + ); + like( $eval_error, $EXCEPTION_MESSAGE_REGEX, $message_like_name ); + } + else { + fail($message_like_name); + } + } + + return; +} + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/05_utils_ppi.t b/t/05_utils_ppi.t new file mode 100644 index 0000000..322cc0b --- /dev/null +++ b/t/05_utils_ppi.t @@ -0,0 +1,379 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use PPI::Document qw< >; +use PPI::Statement::Break qw< >; +use PPI::Statement::Compound qw< >; +use PPI::Statement::Data qw< >; +use PPI::Statement::End qw< >; +use PPI::Statement::Expression qw< >; +use PPI::Statement::Include qw< >; +use PPI::Statement::Null qw< >; +use PPI::Statement::Package qw< >; +use PPI::Statement::Scheduled qw< >; +use PPI::Statement::Sub qw< >; +use PPI::Statement::Unknown qw< >; +use PPI::Statement::UnmatchedBrace qw< >; +use PPI::Statement::Variable qw< >; +use PPI::Statement qw< >; +use PPI::Token::Word qw< >; + +use Perl::Critic::Utils::PPI qw< :all >; + +use Test::More tests => 64; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +my @ppi_statement_classes = qw{ + PPI::Statement + PPI::Statement::Package + PPI::Statement::Include + PPI::Statement::Sub + PPI::Statement::Scheduled + PPI::Statement::Compound + PPI::Statement::Break + PPI::Statement::Data + PPI::Statement::End + PPI::Statement::Expression + PPI::Statement::Variable + PPI::Statement::Null + PPI::Statement::UnmatchedBrace + PPI::Statement::Unknown +}; + +my %instances = map { $_ => $_->new() } @ppi_statement_classes; +$instances{'PPI::Token::Word'} = PPI::Token::Word->new('foo'); + +#----------------------------------------------------------------------------- +# export tests + +can_ok('main', 'is_ppi_expression_or_generic_statement'); +can_ok('main', 'is_ppi_generic_statement'); +can_ok('main', 'is_ppi_statement_subclass'); +can_ok('main', 'is_subroutine_declaration'); +can_ok('main', 'is_in_subroutine'); + +#----------------------------------------------------------------------------- +# is_ppi_expression_or_generic_statement tests + +{ + ok( + ! is_ppi_expression_or_generic_statement( undef ), + 'is_ppi_expression_or_generic_statement( undef )', + ); + ok( + ! is_ppi_expression_or_generic_statement( $instances{'PPI::Token::Word'} ), + 'is_ppi_expression_or_generic_statement( PPI::Token::Word )', + ); + ok( + is_ppi_expression_or_generic_statement( $instances{'PPI::Statement'} ), + 'is_ppi_expression_or_generic_statement( PPI::Statement )', + ); + ok( + ! is_ppi_expression_or_generic_statement( $instances{'PPI::Statement::Package'} ), + 'is_ppi_expression_or_generic_statement( PPI::Statement::Package )', + ); + ok( + ! is_ppi_expression_or_generic_statement( $instances{'PPI::Statement::Include'} ), + 'is_ppi_expression_or_generic_statement( PPI::Statement::Include )', + ); + ok( + ! is_ppi_expression_or_generic_statement( $instances{'PPI::Statement::Sub'} ), + 'is_ppi_expression_or_generic_statement( PPI::Statement::Sub )', + ); + ok( + ! is_ppi_expression_or_generic_statement( $instances{'PPI::Statement::Scheduled'} ), + 'is_ppi_expression_or_generic_statement( PPI::Statement::Scheduled )', + ); + ok( + ! is_ppi_expression_or_generic_statement( $instances{'PPI::Statement::Compound'} ), + 'is_ppi_expression_or_generic_statement( PPI::Statement::Compound )', + ); + ok( + ! is_ppi_expression_or_generic_statement( $instances{'PPI::Statement::Break'} ), + 'is_ppi_expression_or_generic_statement( PPI::Statement::Break )', + ); + ok( + ! is_ppi_expression_or_generic_statement( $instances{'PPI::Statement::Data'} ), + 'is_ppi_expression_or_generic_statement( PPI::Statement::Data )', + ); + ok( + ! is_ppi_expression_or_generic_statement( $instances{'PPI::Statement::End'} ), + 'is_ppi_expression_or_generic_statement( PPI::Statement::End )', + ); + ok( + is_ppi_expression_or_generic_statement( $instances{'PPI::Statement::Expression'} ), + 'is_ppi_expression_or_generic_statement( PPI::Statement::Expression )', + ); + ok( + is_ppi_expression_or_generic_statement( $instances{'PPI::Statement::Variable'} ), + 'is_ppi_expression_or_generic_statement( PPI::Statement::Variable )', + ); + ok( + ! is_ppi_expression_or_generic_statement( $instances{'PPI::Statement::Null'} ), + 'is_ppi_expression_or_generic_statement( PPI::Statement::Null )', + ); + ok( + ! is_ppi_expression_or_generic_statement( $instances{'PPI::Statement::UnmatchedBrace'} ), + 'is_ppi_expression_or_generic_statement( PPI::Statement::UnmatchedBrace )', + ); + ok( + ! is_ppi_expression_or_generic_statement( $instances{'PPI::Statement::Unknown'} ), + 'is_ppi_expression_or_generic_statement( PPI::Statement::Unknown )', + ); +} + +#----------------------------------------------------------------------------- +# is_ppi_generic_statement tests + +{ + ok( + ! is_ppi_generic_statement( undef ), + 'is_ppi_generic_statement( undef )', + ); + ok( + ! is_ppi_generic_statement( $instances{'PPI::Token::Word'} ), + 'is_ppi_generic_statement( PPI::Token::Word )', + ); + ok( + is_ppi_generic_statement( $instances{'PPI::Statement'} ), + 'is_ppi_generic_statement( PPI::Statement )', + ); + ok( + ! is_ppi_generic_statement( $instances{'PPI::Statement::Package'} ), + 'is_ppi_generic_statement( PPI::Statement::Package )', + ); + ok( + ! is_ppi_generic_statement( $instances{'PPI::Statement::Include'} ), + 'is_ppi_generic_statement( PPI::Statement::Include )', + ); + ok( + ! is_ppi_generic_statement( $instances{'PPI::Statement::Sub'} ), + 'is_ppi_generic_statement( PPI::Statement::Sub )', + ); + ok( + ! is_ppi_generic_statement( $instances{'PPI::Statement::Scheduled'} ), + 'is_ppi_generic_statement( PPI::Statement::Scheduled )', + ); + ok( + ! is_ppi_generic_statement( $instances{'PPI::Statement::Compound'} ), + 'is_ppi_generic_statement( PPI::Statement::Compound )', + ); + ok( + ! is_ppi_generic_statement( $instances{'PPI::Statement::Break'} ), + 'is_ppi_generic_statement( PPI::Statement::Break )', + ); + ok( + ! is_ppi_generic_statement( $instances{'PPI::Statement::Data'} ), + 'is_ppi_generic_statement( PPI::Statement::Data )', + ); + ok( + ! is_ppi_generic_statement( $instances{'PPI::Statement::End'} ), + 'is_ppi_generic_statement( PPI::Statement::End )', + ); + ok( + ! is_ppi_generic_statement( $instances{'PPI::Statement::Expression'} ), + 'is_ppi_generic_statement( PPI::Statement::Expression )', + ); + ok( + ! is_ppi_generic_statement( $instances{'PPI::Statement::Variable'} ), + 'is_ppi_generic_statement( PPI::Statement::Variable )', + ); + ok( + ! is_ppi_generic_statement( $instances{'PPI::Statement::Null'} ), + 'is_ppi_generic_statement( PPI::Statement::Null )', + ); + ok( + ! is_ppi_generic_statement( $instances{'PPI::Statement::UnmatchedBrace'} ), + 'is_ppi_generic_statement( PPI::Statement::UnmatchedBrace )', + ); + ok( + ! is_ppi_generic_statement( $instances{'PPI::Statement::Unknown'} ), + 'is_ppi_generic_statement( PPI::Statement::Unknown )', + ); +} + +#----------------------------------------------------------------------------- +# is_ppi_statement_subclass tests + +{ + ok( + ! is_ppi_statement_subclass( undef ), + 'is_ppi_statement_subclass( undef )', + ); + ok( + ! is_ppi_statement_subclass( $instances{'PPI::Token::Word'} ), + 'is_ppi_statement_subclass( PPI::Token::Word )', + ); + ok( + ! is_ppi_statement_subclass( $instances{'PPI::Statement'} ), + 'is_ppi_statement_subclass( PPI::Statement )', + ); + ok( + is_ppi_statement_subclass( $instances{'PPI::Statement::Package'} ), + 'is_ppi_statement_subclass( PPI::Statement::Package )', + ); + ok( + is_ppi_statement_subclass( $instances{'PPI::Statement::Include'} ), + 'is_ppi_statement_subclass( PPI::Statement::Include )', + ); + ok( + is_ppi_statement_subclass( $instances{'PPI::Statement::Sub'} ), + 'is_ppi_statement_subclass( PPI::Statement::Sub )', + ); + ok( + is_ppi_statement_subclass( $instances{'PPI::Statement::Scheduled'} ), + 'is_ppi_statement_subclass( PPI::Statement::Scheduled )', + ); + ok( + is_ppi_statement_subclass( $instances{'PPI::Statement::Compound'} ), + 'is_ppi_statement_subclass( PPI::Statement::Compound )', + ); + ok( + is_ppi_statement_subclass( $instances{'PPI::Statement::Break'} ), + 'is_ppi_statement_subclass( PPI::Statement::Break )', + ); + ok( + is_ppi_statement_subclass( $instances{'PPI::Statement::Data'} ), + 'is_ppi_statement_subclass( PPI::Statement::Data )', + ); + ok( + is_ppi_statement_subclass( $instances{'PPI::Statement::End'} ), + 'is_ppi_statement_subclass( PPI::Statement::End )', + ); + ok( + is_ppi_statement_subclass( $instances{'PPI::Statement::Expression'} ), + 'is_ppi_statement_subclass( PPI::Statement::Expression )', + ); + ok( + is_ppi_statement_subclass( $instances{'PPI::Statement::Variable'} ), + 'is_ppi_statement_subclass( PPI::Statement::Variable )', + ); + ok( + is_ppi_statement_subclass( $instances{'PPI::Statement::Null'} ), + 'is_ppi_statement_subclass( PPI::Statement::Null )', + ); + ok( + is_ppi_statement_subclass( $instances{'PPI::Statement::UnmatchedBrace'} ), + 'is_ppi_statement_subclass( PPI::Statement::UnmatchedBrace )', + ); + ok( + is_ppi_statement_subclass( $instances{'PPI::Statement::Unknown'} ), + 'is_ppi_statement_subclass( PPI::Statement::Unknown )', + ); +} + +#----------------------------------------------------------------------------- +# is_subroutine_declaration() tests + +{ + my $test = sub { + my ($code, $result) = @_; + + my $doc; + my $input; + + if (defined $code) { + $doc = PPI::Document->new(\$code, readonly => 1); + } + if (defined $doc) { + $input = $doc->first_element(); + } + + my $name = defined $code ? $code : ''; + + local $Test::Builder::Level = $Test::Builder::Level + 1; ## no critic (Variables::ProhibitPackageVars) + is( + ! ! is_subroutine_declaration( $input ), + ! ! $result, + "is_subroutine_declaration(): $name" + ); + + return; + }; + + $test->('sub {};' => 1); + $test->('sub {}' => 1); + $test->('{}' => 0); + $test->(undef, 0); + $test->('{ sub foo {} }' => 0); + $test->('sub foo;' => 1); +} + +#----------------------------------------------------------------------------- +# is_in_subroutine() tests + +{ + my $test = sub { + my ($code, $transform, $result) = @_; + + my $doc; + my $input; + + if (defined $code) { + $doc = PPI::Document->new(\$code, readonly => 1); + } + if (defined $doc) { + $input = $transform->($doc); + } + + my $name = defined $code ? $code : ''; + + local $Test::Builder::Level = $Test::Builder::Level + 1; ## no critic (Variables::ProhibitPackageVars) + is( + ! ! is_in_subroutine( $input ), + ! ! $result, + "is_in_subroutine(): $name" + ); + + return; + }; + + $test->(undef, sub {}, 0); + + ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars) + $test->('my $foo = 42', sub {}, 0); + + $test->( + 'sub foo { my $foo = 42 }', + sub { + my ($doc) = @_; + $doc->find_first('PPI::Statement::Variable'); + }, + 1, + ); + + $test->( + 'sub { my $foo = 42 };', + sub { + my ($doc) = @_; + $doc->find_first('PPI::Statement::Variable'); + }, + 1, + ); + + $test->( + '{ my $foo = 42 };', + sub { + my ($doc) = @_; + $doc->find_first('PPI::Statement::Variable'); + }, + 0, + ); + ## use critic +} + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/06_violation.d/lib/Perl/Critic/Policy/Test.pm b/t/06_violation.d/lib/Perl/Critic/Policy/Test.pm new file mode 100644 index 0000000..2d65c7d --- /dev/null +++ b/t/06_violation.d/lib/Perl/Critic/Policy/Test.pm @@ -0,0 +1,34 @@ +package Perl::Critic::Policy::Test; + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::Utils qw{ :severities }; +use base 'Perl::Critic::Policy'; + +sub default_severity { return $SEVERITY_LOWEST } +sub applies_to { return 'PPI::Token::Word' } + +sub violates { + my ( $self, $elem, undef ) = @_; + return $self->violation( 'desc', 'expl', $elem ); +} + +1; +__END__ + +=head1 DESCRIPTION + +diagnostic + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/06_violation.d/lib/ViolationTest.pm b/t/06_violation.d/lib/ViolationTest.pm new file mode 100644 index 0000000..00518e6 --- /dev/null +++ b/t/06_violation.d/lib/ViolationTest.pm @@ -0,0 +1,35 @@ +package ViolationTest; + +use 5.006001; +use strict; +use warnings; + +use PPI::Document; +use Perl::Critic::Violation; +use Perl::Critic::Violation; # this is duplicated for test coverage of repeated calls to import() + +# This file exists solely to test Perl::Critic::Violation::import() + +=head1 DESCRIPTION + +This is a test diagnostic. + +=cut + +sub get_violation { + + my $code = 'Hello World;'; + my $doc = PPI::Document->new(\$code); + return Perl::Critic::Violation->new('', '', $doc, 0); +} + +1; + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/06_violation.d/lib/ViolationTest2.pm b/t/06_violation.d/lib/ViolationTest2.pm new file mode 100644 index 0000000..24d9730 --- /dev/null +++ b/t/06_violation.d/lib/ViolationTest2.pm @@ -0,0 +1,28 @@ +package ViolationTest2; + +use 5.006001; +use strict; +use warnings; + +use PPI::Document; +use Perl::Critic::Violation; + +# This file exists solely to test Perl::Critic::Violation::import() + +sub get_violation { + + my $code = 'Hello World;'; + my $doc = PPI::Document->new(\$code); + return Perl::Critic::Violation->new('', '', [0,0], 0); +} + +1; + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/06_violation.d/source/Line.pm b/t/06_violation.d/source/Line.pm new file mode 100644 index 0000000..1c17178 --- /dev/null +++ b/t/06_violation.d/source/Line.pm @@ -0,0 +1,3 @@ +foo +#line 57 Thingy.pm +bar diff --git a/t/06_violation.t b/t/06_violation.t new file mode 100644 index 0000000..058eff6 --- /dev/null +++ b/t/06_violation.t @@ -0,0 +1,290 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use English qw< -no_match_vars >; + +use File::Basename qw< basename >; +use File::Spec::Functions qw< catdir catfile >; +use PPI::Document q< >; +use PPI::Document::File q< >; + +use Perl::Critic::Utils qw< :characters >; +use Perl::Critic::Violation q< >; + +use Test::More tests => 69; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +use lib catdir( qw< t 06_violation.d lib > ); + +use ViolationTest; # this is solely to test the import() method; has diagnostics +use ViolationTest2; # this is solely to test the import() method; no diagnostics +use Perl::Critic::Policy::Test; # this is to test violation formatting + +#----------------------------------------------------------------------------- +# method tests + +{ + can_ok('Perl::Critic::Violation', 'sort_by_location'); + can_ok('Perl::Critic::Violation', 'sort_by_severity'); + can_ok('Perl::Critic::Violation', 'new'); + can_ok('Perl::Critic::Violation', 'location'); + can_ok('Perl::Critic::Violation', 'diagnostics'); + can_ok('Perl::Critic::Violation', 'description'); + can_ok('Perl::Critic::Violation', 'explanation'); + can_ok('Perl::Critic::Violation', 'filename'); + can_ok('Perl::Critic::Violation', 'source'); + can_ok('Perl::Critic::Violation', 'policy'); + can_ok('Perl::Critic::Violation', 'get_format'); + can_ok('Perl::Critic::Violation', 'set_format'); + can_ok('Perl::Critic::Violation', 'to_string'); +} # end scope block + +#----------------------------------------------------------------------------- +# Constructor Failures: +{ + eval { Perl::Critic::Violation->new('desc', 'expl'); }; + ok($EVAL_ERROR, 'new, wrong number of args'); + eval { Perl::Critic::Violation->new('desc', 'expl', {}, 'severity'); }; + ok($EVAL_ERROR, 'new, bad arg'); +} # end scope block + +#----------------------------------------------------------------------------- +# Accessor tests + +{ + my $pkg = __PACKAGE__; + my $code = 'Hello World;'; + my $document = PPI::Document->new(\$code); + my $no_diagnostics_msg = qr/ \s* No [ ] diagnostics [ ] available \s* /xms; + my $viol = Perl::Critic::Violation->new( 'Foo', 'Bar', $document, 99, ); + + is( $viol->description(), 'Foo', 'description'); + is( $viol->explanation(), 'Bar', 'explanation'); + is( $viol->line_number(), 1, 'line_number'); + is( $viol->logical_line_number(), 1, 'logical_line_number'); + is( $viol->column_number(), 1, 'column_number'); + is( $viol->visual_column_number(), 1, 'visual_column_number'); + is( $viol->severity(), 99, 'severity'); + is( $viol->source(), $code, 'source'); + is( $viol->policy(), $pkg, 'policy'); + is( $viol->element_class(), 'PPI::Document', 'element class'); + like( $viol->diagnostics(), qr/ \A $no_diagnostics_msg \z /xms, 'diagnostics'); + + { + my $old_format = Perl::Critic::Violation::get_format(); + Perl::Critic::Violation::set_format('%l,%c,%m,%e,%p,%d,%r'); + my $expect = qr/\A 1,1,Foo,Bar,$pkg,$no_diagnostics_msg,\Q$code\E \z/xms; + + like($viol->to_string(), $expect, 'to_string'); + like("$viol", $expect, 'stringify'); + + Perl::Critic::Violation::set_format($old_format); + } + + $viol = Perl::Critic::Violation->new('Foo', [28], $document, 99); + is($viol->explanation(), 'See page 28 of PBP', 'explanation'); + + $viol = Perl::Critic::Violation->new('Foo', [28,30], $document, 99); + is($viol->explanation(), 'See pages 28,30 of PBP', 'explanation'); +} # end scope block + +{ + my $pkg = __PACKAGE__; + my $code = 'Say goodbye to the document;'; + my $document = PPI::Document->new(\$code); + + my $words = $document->find('PPI::Token::Word'); + my $word = $words->[0]; + + my $no_diagnostics_msg = qr/ \s* No [ ] diagnostics [ ] available \s* /xms; + my $viol = Perl::Critic::Violation->new( 'Foo', 'Bar', $word, 99, ); + + # Make bye-bye with the document. This will end up stripping the guts out + # of the PPI::Token::Word instance, so it is useless to us after the + # document is gone. We need to make sure that we've copied the data out + # that we'll need. + undef $document; + undef $words; + undef $word; + + is( $viol->description(), 'Foo', 'description after dropping document'); + is( $viol->explanation(), 'Bar', 'explanation after dropping document'); + is( $viol->line_number(), 1, 'line_number after dropping document'); + is( $viol->logical_line_number(), 1, 'logical_line_number after dropping document'); + is( $viol->column_number(), 1, 'column_number after dropping document'); + is( $viol->visual_column_number(), 1, 'visual_column_number after dropping document'); + is( $viol->severity(), 99, 'severity after dropping document'); + is( $viol->source(), $code, 'source after dropping document'); + is( $viol->policy(), $pkg, 'policy after dropping document'); + is( $viol->element_class(), 'PPI::Token::Word', 'element class after dropping document'); + like( + $viol->diagnostics(), + qr/ \A $no_diagnostics_msg \z /xms, + 'diagnostics after dropping document', + ); +} # end scope block + + +#----------------------------------------------------------------------------- +# Import tests +{ + like( + ViolationTest->get_violation()->diagnostics(), + qr/ \A \s* This [ ] is [ ] a [ ] test [ ] diagnostic [.] \s*\z /xms, + 'import diagnostics', + ); +} # end scope block + +#----------------------------------------------------------------------------- +# Violation sorting + +SKIP: { + my $code = <<'END_PERL'; +my $foo = 1; my $bar = 2; +my $baz = 3; +END_PERL + + my $document = PPI::Document->new(\$code); + my @children = $document->schildren(); + my @violations = + map { Perl::Critic::Violation->new($EMPTY, $EMPTY, $_, 0) } + $document, @children; + my @sorted = Perl::Critic::Violation->sort_by_location( reverse @violations); + is_deeply(\@sorted, \@violations, 'sort_by_location'); + + my @severities = (5, 3, 4, 0, 2, 1); + @violations = + map { Perl::Critic::Violation->new($EMPTY, $EMPTY, $document, $_) } + @severities; + @sorted = Perl::Critic::Violation->sort_by_severity( @violations ); + is_deeply( [map {$_->severity()} @sorted], [sort @severities], 'sort_by_severity'); +} + +#----------------------------------------------------------------------------- +# Violation formatting + +{ + my $format = '%l; %c; %m; %e; %s; %r; %P; %p; %d'; + my $expected = join q{; }, ( + 1, 1, # line, col + 'desc', 'expl', + 1, # severity + 'print;', # source near token[0] + 'Perl::Critic::Policy::Test', 'Test', # long, short + ' diagnostic', + ); + + Perl::Critic::Violation::set_format($format); + is(Perl::Critic::Violation::get_format(), $format, 'set/get_format'); + my $code = "print;\n"; + my $document = PPI::Document->new(\$code); + $document->index_locations(); + my $p = Perl::Critic::Policy::Test->new(); + my @t = $document->tokens(); + my $v = $p->violates($t[0]); + ok($v, 'got a violation'); + + is($v->to_string(), $expected, 'to_string()'); +} + +#----------------------------------------------------------------------------- +# More formatting + +{ + # Alias subroutines, because I'm lazy + my $get_format = *Perl::Critic::Violation::get_format; + my $set_format = *Perl::Critic::Violation::set_format; + + my $fmt_literal = 'Found %m in file %f on line %l\n'; ## no critic (RequireInterpolationOfMetachars) + my $fmt_interp = "Found %m in file %f on line %l\n"; #Same, but double-quotes + is($set_format->($fmt_literal), $fmt_interp, 'set_format by spec'); + is($get_format->(), $fmt_interp, 'get_format by spec'); + + my $fmt_predefined = "%m at %f line %l\n"; + is($set_format->(3), $fmt_predefined, 'set_format by number'); + is($get_format->(), $fmt_predefined, 'get_format by number'); + + my $fmt_default = "%m at line %l, column %c. %e. (Severity: %s)\n"; + is($set_format->(999), $fmt_default, 'set_format by invalid number'); + is($get_format->(), $fmt_default, 'get_format by invalid number'); + is($set_format->(undef), $fmt_default, 'set_format with undef'); + is($get_format->(), $fmt_default, 'get_format with undef'); + +} + +#----------------------------------------------------------------------------- + +{ + my @given = ( qw(foo bar. .baz.. nuts!), [], {} ); + my @want = ( qw(foo bar .baz nuts!), [], {} ); + my @have = Perl::Critic::Violation::_chomp_periods(@given); + + is_deeply(\@have, \@want, 'Chomping periods'); +} # end scope block + +#----------------------------------------------------------------------------- + +{ + my $filename = catfile( qw< t 06_violation.d source Line.pm > ); + my $document = PPI::Document::File->new($filename); + + my @words = @{ $document->find('PPI::Token::Word') }; + + is( + (scalar @words), + 2, + 'Got the expected number of words in the line directive example document.', + ); + + + my %expected = ( + '%F' => basename($filename), + '%f' => $filename, + '%G' => basename($filename), + '%g' => $filename, + '%l' => '1', + '%L' => '1', + ); + + _test_file_and_line_formats($words[0], \%expected); + + + @expected{ qw< %F %f > } = ('Thingy.pm') x 2; + $expected{'%l'} = 57; + $expected{'%L'} = 3; + + _test_file_and_line_formats($words[1], \%expected); +} + +sub _test_file_and_line_formats { + my ($word, $expected) = @_; + + my $violation = Perl::Critic::Violation->new($EMPTY, $EMPTY, $word, 0); + + foreach my $format ( sort keys %{$expected} ) { + Perl::Critic::Violation::set_format($format); + is( + $violation->to_string(), + $expected->{$format}, + "Got expected value for $format for " . $word->content(), + ); + } + + return; +} + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/07_command.t b/t/07_command.t new file mode 100644 index 0000000..b35031b --- /dev/null +++ b/t/07_command.t @@ -0,0 +1,280 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); +use Carp qw< confess >; + +use File::Spec; + +use Perl::Critic::Command qw< run >; +use Perl::Critic::Utils qw< :characters >; + +use Test::More tests => 57; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +local @ARGV = (); +my $message; +my %options = (); + +#----------------------------------------------------------------------------- + +local @ARGV = qw(-1 -2 -3 -4 -5); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-severity}, 1, $message); + +local @ARGV = qw(-5 -3 -4 -1 -2); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-severity}, 1, $message); + +local @ARGV = qw(); +%options = Perl::Critic::Command::_get_options(); +is( $options{-severity}, undef, 'no arguments'); + +local @ARGV = qw(-2 -3 -severity 4); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-severity}, 4, $message); + +local @ARGV = qw(-severity 2 -3 -4); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-severity}, 2, $message); + +local @ARGV = qw(--severity=2 -3 -4); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-severity}, 2, $message); + +local @ARGV = qw(-cruel); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-severity}, 'cruel', $message); + +local @ARGV = qw(-cruel --severity=1 ); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-severity}, 1, $message); + +local @ARGV = qw(-stern --severity=1 -2); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-severity}, 1, $message); + +local @ARGV = qw(-stern -severity 1 -2); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-severity}, 1, $message); + +#----------------------------------------------------------------------------- + +local @ARGV = qw(-top); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-severity}, 1, $message); +is( $options{-top}, 20, $message); + +local @ARGV = qw(-top 10); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-severity}, 1, $message); +is( $options{-top}, 10, $message); + +local @ARGV = qw(-severity 4 -top); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-severity}, 4, $message); +is( $options{-top}, 20, $message); + +local @ARGV = qw(-severity 4 -top 10); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-severity}, 4, $message); +is( $options{-top}, 10, $message); + +local @ARGV = qw(-severity 5 -2 -top 5); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-severity}, 5, $message); +is( $options{-top}, 5, $message); + +#----------------------------------------------------------------------------- + +local @ARGV = qw(-noprofile); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-profile}, q{}, $message); + +local @ARGV = qw(-profile foo); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-profile}, 'foo', $message); + +#----------------------------------------------------------------------------- + +local @ARGV = qw(-single-policy nowarnings); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{'-single-policy'}, 'nowarnings', $message); + +#----------------------------------------------------------------------------- + +local @ARGV = qw(-verbose 2); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-verbose}, 2, $message); + +local @ARGV = qw(-verbose %l:%c:%m); +%options = Perl::Critic::Command::_get_options(); +is( $options{-verbose}, '%l:%c:%m', $message); + +#----------------------------------------------------------------------------- + +local @ARGV = qw(-statistics); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-statistics}, 1, $message); + +#----------------------------------------------------------------------------- + +local @ARGV = qw(-statistics-only); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{'-statistics-only'}, 1, $message); + +#----------------------------------------------------------------------------- + +local @ARGV = qw(-quiet); +$message = "@ARGV"; +%options = Perl::Critic::Command::_get_options(); +is( $options{-quiet}, 1, $message); + + +#----------------------------------------------------------------------------- + +local @ARGV = qw(-pager foo); +$message = "@ARGV"; +%options = eval { Perl::Critic::Command::_get_options() }; +is( $options{-pager}, 'foo', $message ); + + +#----------------------------------------------------------------------------- + +foreach my $severity ([qw{ + -color-severity-highest + -colour-severity-highest + -color-severity-5 + -colour-severity-5 + }], + [qw{ + -color-severity-high + -colour-severity-high + -color-severity-4 + -colour-severity-4 + }], + [qw{ + -color-severity-medium + -colour-severity-medium + -color-severity-3 + -colour-severity-3 + }], + [qw{ + -color-severity-low + -colour-severity-low + -color-severity-2 + -colour-severity-2 + }], + [qw{ + -color-severity-lowest + -colour-severity-lowest + -color-severity-1 + -colour-severity-1 + }], +) { + my $canonical = $severity->[0]; + foreach my $opt (@{ $severity }) { + local @ARGV = ($opt => 'cyan'); + $message = "@ARGV"; + %options = eval { Perl::Critic::Command::_get_options() }; + is( $options{$canonical}, 'cyan', $message ); + } +} + + +#----------------------------------------------------------------------------- +# Intercept pod2usage so we can test invalid options and special switches + +{ + no warnings qw(redefine once); ## no critic (ProhibitNoWarnings) + local *Perl::Critic::Command::pod2usage = + sub { my %args = @_; confess $args{-message} || q{} }; + + local @ARGV = qw( -help ); + eval { Perl::Critic::Command::_get_options() }; + ok( $EVAL_ERROR, '-help option' ); + + local @ARGV = qw( -options ); + eval { Perl::Critic::Command::_get_options() }; + ok( $EVAL_ERROR, '-options option' ); + + local @ARGV = qw( -man ); + eval { Perl::Critic::Command::_get_options() }; + ok( $EVAL_ERROR, '-man option' ); + + local @ARGV = qw( -noprofile -profile foo ); + eval { Perl::Critic::Command::_get_options() }; + like( + $EVAL_ERROR, + qr/-noprofile [ ] with [ ] -profile/xms, + '-noprofile with -profile', + ); + + local @ARGV = qw( -verbose bogus ); + eval { Perl::Critic::Command::_get_options() }; + like( + $EVAL_ERROR, + qr/looks [ ] odd/xms, + 'Invalid -verbose option', + ); + + local @ARGV = qw( -top -9 ); + eval { Perl::Critic::Command::_get_options() }; + like( + $EVAL_ERROR, + qr/is [ ] negative/xms, + 'Negative -verbose option', + ); + + local @ARGV = qw( -severity 0 ); + eval { Perl::Critic::Command::_get_options() }; + like( + $EVAL_ERROR, + qr/out [ ] of [ ] range/xms, + '-severity too small', + ); + + local @ARGV = qw( -severity 6 ); + eval { Perl::Critic::Command::_get_options() }; + like( + $EVAL_ERROR, + qr/out [ ] of [ ] range/xms, + '-severity too large', + ); +} + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/07_perlcritic.t b/t/07_perlcritic.t new file mode 100644 index 0000000..341bd99 --- /dev/null +++ b/t/07_perlcritic.t @@ -0,0 +1,32 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use File::Spec; + +use Test::More tests => 1; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +my $perlcritic = File::Spec->rel2abs( File::Spec->catfile( qw( blib script perlcritic ) ) ); +if (not -e $perlcritic) { + $perlcritic = File::Spec->rel2abs( File::Spec->catfile( qw( bin perlcritic ) ) ); +} + +require_ok($perlcritic); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/08_document.t b/t/08_document.t new file mode 100644 index 0000000..166aaca --- /dev/null +++ b/t/08_document.t @@ -0,0 +1,199 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Carp qw< carp >; + +use version; + + +use Perl::Critic::Document qw< >; +use Perl::Critic::Utils qw< $EMPTY >; +use Perl::Critic::Utils::DataConversion qw< dor >; + + +use Test::Deep; +use Test::More tests => 43; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +can_ok('Perl::Critic::Document', 'new'); +can_ok('Perl::Critic::Document', 'filename'); +can_ok('Perl::Critic::Document', 'find'); +can_ok('Perl::Critic::Document', 'find_first'); +can_ok('Perl::Critic::Document', 'find_any'); +can_ok('Perl::Critic::Document', 'namespaces'); +can_ok('Perl::Critic::Document', 'subdocuments_for_namespace'); +can_ok('Perl::Critic::Document', 'highest_explicit_perl_version'); +can_ok('Perl::Critic::Document', 'uses_module'); +can_ok('Perl::Critic::Document', 'ppi_document'); +can_ok('Perl::Critic::Document', 'is_program'); +can_ok('Perl::Critic::Document', 'is_module'); + +{ + my $code = q{'print 'Hello World';}; #Has 6 PPI::Element + my $ppi_doc = PPI::Document->new( \$code ); + my $pc_doc = Perl::Critic::Document->new( '-source' => $ppi_doc ); + isa_ok($pc_doc, 'Perl::Critic::Document'); + isa_ok($pc_doc, 'PPI::Document'); + isa_ok($pc_doc, 'PPI::Node'); + isa_ok($pc_doc, 'PPI::Element'); + + + my $nodes_ref = $pc_doc->find('PPI::Element'); + is( scalar @{ $nodes_ref }, 6, 'find by class name'); + + $nodes_ref = $pc_doc->find( sub{ return 1 } ); + is( scalar @{ $nodes_ref }, 6, 'find by wanted() handler'); + + $nodes_ref = $pc_doc->find( q{Element} ); + is( scalar @{ $nodes_ref }, 6, 'find by shortened class name'); + + #--------------------------- + + my $node = $pc_doc->find_first('PPI::Element'); + is( ref $node, 'PPI::Statement', 'find_first by class name'); + + $node = $pc_doc->find_first( sub{ return 1 } ); + is( ref $node, 'PPI::Statement', 'find_first by wanted() handler'); + + $node = $pc_doc->find_first( q{Element} ); + is( ref $node, 'PPI::Statement', 'find_first by shortened class name'); + + #--------------------------- + + my $found = $pc_doc->find_any('PPI::Element'); + is( $found, 1, 'find_any by class name'); + + $found = $pc_doc->find_any( sub{ return 1 } ); + is( $found, 1, 'find_any by wanted() handler'); + + $found = $pc_doc->find_any( q{Element} ); + is( $found, 1, 'find_any by shortened class name'); + + #------------------------------------------------------------------------- + + { + # Ignore "Cannot create search condition for 'PPI::': Not a PPI::Element" + local $SIG{__WARN__} = sub { + $_[0] =~ m/\QCannot create search condition for\E/xms || carp @_ + }; + $nodes_ref = $pc_doc->find( q{} ); + is( $nodes_ref, undef, 'find by empty class name'); + + $node = $pc_doc->find_first( q{} ); + is( $node, undef, 'find_first by empty class name'); + + $found = $pc_doc->find_any( q{} ); + is( $found, undef, 'find_any by empty class name'); + + } + + #------------------------------------------------------------------------- + + cmp_deeply( + [ $pc_doc->namespaces() ], + ['main'], + q, + ); + + ok( $pc_doc->is_module(), q{document type 'module' is a module}); + ok( ! $pc_doc->is_program(), q{document type 'module' is not a program}); + +} + +#----------------------------------------------------------------------------- + +{ + my $ppi_document = PPI::Document->new(\'foo(); package Foo; package Bar'); + my $critic_document = + Perl::Critic::Document->new(-source => $ppi_document); + + cmp_deeply( + [ $critic_document->namespaces() ], + bag( qw< main Foo Bar > ), + 'Got expected namespaces', + ); +} + +#----------------------------------------------------------------------------- + +{ + my $ppi_document = PPI::Document->new(\'use Moose'); + my $critic_document = + Perl::Critic::Document->new(-source => $ppi_document); + + ok(!! $critic_document->uses_module('Moose'), 'Moose is used.'); + ok( ! $critic_document->uses_module('Moose::Role'), 'Moose::Role is not used.'); + + $ppi_document = PPI::Document->new( \q{ } ); + $critic_document = + Perl::Critic::Document->new(-source => $ppi_document); + + ok( + ! $critic_document->uses_module('Blah'), + q, + ); +} + +#----------------------------------------------------------------------------- + + +{ + test_version( 'sub { 1 }', undef ); + test_version( 'use 5.006', version->new('5.006') ); + test_version( 'use 5.8.3', version->new('5.8.3') ); + test_version( + 'use 5.006; use 5.8.3; use 5.005005', + version->new('5.8.3'), + ); + test_version( 'use 5.005_05; use 5.005_03', version->new('5.005_05') ); + test_version( 'use 5.005_03; use 5.005_05', version->new('5.005_05') ); +} + +sub test_version { + my ($code, $expected_version) = @_; + + my $description_version = dor( $expected_version, '' ); + + my $document = + Perl::Critic::Document->new( + '-source' => PPI::Document->new( \$code ) + ); + + is( + $document->highest_explicit_perl_version(), + $expected_version, + qq, + ); + + return; +} + +#----------------------------------------------------------------------------- + +my $nameless_code = 'use strict'; +my $nameless_doc = Perl::Critic::Document->new( + '-source' => \$nameless_code, + '-filename-override' => 'Build.PL' +); + +is($nameless_doc->filename(), 'Build.PL', 'Got filename override.'); +ok( + ! $nameless_doc->is_module(), + 'Overridden file name affects module determination.' +); + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/09_theme.t b/t/09_theme.t new file mode 100644 index 0000000..9f1d964 --- /dev/null +++ b/t/09_theme.t @@ -0,0 +1,318 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); + +use List::MoreUtils qw(any all none); + +use Perl::Critic::TestUtils; +use Perl::Critic::PolicyFactory; +use Perl::Critic::UserProfile; +use Perl::Critic::Theme; + +use Test::More tests => 66; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +ILLEGAL_RULES: { + + my @invalid_rules = ( + '$cosmetic', ## no critic (RequireInterpolationOfMetachars) + '"cosmetic"', + '#cosmetic > bugs', + 'cosmetic / bugs', + 'cosmetic % bugs', + 'cosmetic + [bugs - pbp]', + 'cosmetic + {bugs - pbp}', + 'cosmetic @ bugs ^ pbp', + ); + + for my $invalid ( @invalid_rules ) { + eval { Perl::Critic::Theme::->new( -rule => $invalid ) }; + like( + $EVAL_ERROR, + qr/invalid [ ] character/xms, + qq{Invalid rule: "$invalid"}, + ); + } +} + +#----------------------------------------------------------------------------- + +VALID_RULES: { + + my @valid_rules = ( + 'cosmetic', + '!cosmetic', + '-cosmetic', + 'not cosmetic', + + 'cosmetic + bugs', + 'cosmetic - bugs', + 'cosmetic + (bugs - pbp)', + 'cosmetic+(bugs-pbp)', + + 'cosmetic || bugs', + 'cosmetic && bugs', + 'cosmetic || (bugs - pbp)', + 'cosmetic||(bugs-pbp)', + + 'cosmetic or bugs', + 'cosmetic and bugs', + 'cosmetic or (bugs not pbp)', + ); + + for my $valid ( @valid_rules ) { + my $theme = Perl::Critic::Theme->new( -rule => $valid ); + ok( $theme, qq{Valid expression: "$valid"} ); + } +} + +#----------------------------------------------------------------------------- + +TRANSLATIONS: { + my %expressions = ( + 'cosmetic' => 'cosmetic', + '!cosmetic' => '!cosmetic', + '-cosmetic' => '!cosmetic', + 'not cosmetic' => '! cosmetic', + 'cosmetic + bugs', => 'cosmetic || bugs', + 'cosmetic - bugs', => 'cosmetic && ! bugs', + 'cosmetic + (bugs - pbp)' => 'cosmetic || (bugs && ! pbp)', + 'cosmetic+(bugs-pbp)' => 'cosmetic||(bugs&& !pbp)', + 'cosmetic or bugs' => 'cosmetic || bugs', + 'cosmetic and bugs' => 'cosmetic && bugs', + 'cosmetic and (bugs or pbp)' => 'cosmetic && (bugs || pbp)', + 'cosmetic + bugs' => 'cosmetic || bugs', + 'cosmetic * bugs' => 'cosmetic && bugs', + 'cosmetic * (bugs + pbp)' => 'cosmetic && (bugs || pbp)', + 'cosmetic || bugs', => 'cosmetic || bugs', + '!cosmetic && bugs', => '!cosmetic && bugs', + 'cosmetic && not (bugs or pbp)'=> 'cosmetic && ! (bugs || pbp)', + ); + + while ( my ($raw, $expected) = each %expressions ) { + my $cooked = Perl::Critic::Theme::cook_rule( $raw ); + is( $cooked, $expected, qq{Theme cooking: '$raw' -> '$cooked'}); + } +} + + +#----------------------------------------------------------------------------- + +Perl::Critic::TestUtils::block_perlcriticrc(); + +{ + my $profile = Perl::Critic::UserProfile->new( -profile => q{} ); + my $factory = Perl::Critic::PolicyFactory->new( -profile => $profile ); + my @policy_names = Perl::Critic::PolicyFactory::site_policy_names(); + my @pols = map { $factory->create_policy( -name => $_ ) } @policy_names; + + #-------------- + + my $rule = 'cosmetic'; + my $theme = Perl::Critic::Theme->new( -rule => $rule ); + my @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + ok( + ( all { has_theme( $_, 'cosmetic' ) } @members ), + 'theme rule: "cosmetic"', + ); + + #-------------- + + $rule = 'cosmetic - pbp'; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + ok( + ( all { has_theme( $_, 'cosmetic' ) } @members ), + 'theme rule: "cosmetic - pbp", all has_theme(cosmetic)', + ); + ok( + ( none { has_theme( $_, 'pbp') } @members ), + 'theme rule: "cosmetic - pbp", none has_theme(pbp)', + ); + + $rule = 'cosmetic and not pbp'; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + ok( + ( all { has_theme( $_, 'cosmetic' ) } @members ), + 'theme rule: "cosmetic and not pbp", all has_theme(cosmetic)', + ); + ok( + ( none { has_theme( $_, 'pbp') } @members ), + 'theme rule: "cosmetic and not pbp", none has_theme(pbp)', + ); + + $rule = 'cosmetic && ! pbp'; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + ok( + ( all { has_theme( $_, 'cosmetic' ) } @members ), + 'theme rule: "cosmetic && ! pbp", all has_theme(cosmetic)', + ); + ok( + ( none { has_theme( $_, 'pbp') } @members ), + 'theme rule: "cosmetic && ! pbp", none has_theme(pbp)', + ); + + #-------------- + + $rule = 'cosmetic + pbp'; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + ok( + ( all { has_theme($_, 'cosmetic') || has_theme($_, 'pbp') } @members ), + 'theme rule: "cosmetic + pbp"', + ); + + $rule = 'cosmetic || pbp'; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + ok( + ( all { has_theme($_, 'cosmetic') || has_theme($_, 'pbp') } @members ), + 'theme rule: "cosmetic || pbp"', + ); + + $rule = 'cosmetic or pbp'; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + ok( + ( all { has_theme($_, 'cosmetic') || has_theme($_, 'pbp') } @members), + 'theme rule: "cosmetic or pbp"', + ); + + #-------------- + + $rule = 'bugs * pbp'; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + ok( + ( all { has_theme($_, 'bugs') } @members ), + 'theme rule: "bugs * pbp", all has_theme(bugs)', + ); + ok( + ( all { has_theme($_, 'pbp') } @members ), + 'theme rule: "bugs * pbp", all has_theme(pbp)', + ); + + $rule = 'bugs and pbp'; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + ok( + ( all { has_theme($_, 'bugs') } @members ), + 'theme rule: "bugs and pbp", all has_theme(bugs)', + ); + ok( + ( all { has_theme($_, 'pbp') } @members ), + 'theme rule: "bugs and pbp", all has_theme(pbp)', + ); + + $rule = 'bugs && pbp'; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + ok( + ( all { has_theme($_, 'bugs') } @members ), + 'theme rule: "bugs && pbp", all has_theme(bugs)', + ); + ok( + ( all { has_theme($_, 'pbp') } @members ), + 'theme rule: "bugs && pbp", all has_theme(pbp)', + ); + + #------------- + + $rule = 'pbp - (danger * security)'; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + ok( + ( all { has_theme($_, 'pbp') } @members ), + 'theme rule: "pbp - (danger * security)", all has_theme(pbp)', + ); + ok( + ( none { has_theme($_, 'danger') && has_theme($_, 'security') } @members ), + 'theme rule: "pbp - (danger * security)", none has_theme(danger && security)', + ); + + $rule = 'pbp and ! (danger and security)'; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + ok( + ( all { has_theme($_, 'pbp') } @members ), + 'theme rule: "pbp and not (danger and security)", all has_theme(pbp)', + ); + ok( + ( none { has_theme($_, 'danger') && has_theme($_, 'security') } @members ), + 'theme rule: "pbp and not (danger and security)", none has_theme(danger && security)', + ); + + $rule = 'pbp && not (danger && security)'; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + ok( + ( all { has_theme($_, 'pbp') } @members ), + 'theme rule: "pbp && not (danger && security)", all has_theme(pbp)', + ); + ok( + ( none { has_theme($_, 'danger') && has_theme($_, 'security') } @members ), + 'theme rule: "pbp && not (danger && security)", none has_theme(danger && security)', + ); + + #-------------- + + $rule = 'bogus'; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + is( scalar @members, 0, 'bogus theme' ); + + $rule = 'bogus - pbp'; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + is( scalar @members, 0, 'bogus theme' ); + + $rule = q{}; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + is( scalar @members, scalar @pols, 'empty theme' ); + + $rule = q{}; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols; + is( scalar @members, scalar @pols, 'undef theme' ); + + #-------------- + # Exceptions + + $rule = 'cosmetic *('; + $theme = Perl::Critic::Theme->new( -rule => $rule ); + eval{ $theme->policy_is_thematic( -policy => $pols[0] ) }; + like( + $EVAL_ERROR, + qr/syntax [ ] error/xms, + 'invalid theme expression', + ); + +} + +#----------------------------------------------------------------------------- + +sub has_theme { + my ($policy, $theme) = @_; + return any { $_ eq $theme } $policy->get_themes(); +} + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/10_user_profile.t b/t/10_user_profile.t new file mode 100644 index 0000000..4c7f7f2 --- /dev/null +++ b/t/10_user_profile.t @@ -0,0 +1,327 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); + +use Perl::Critic::UserProfile; + +use Test::More tests => 41; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +# Create profile from hash + +{ + my %policy_params = (min_elements => 4); + my %profile_hash = ( '-NamingConventions::Capitalization' => {}, + 'CodeLayout::ProhibitQuotedWordLists' => \%policy_params ); + + my $up = Perl::Critic::UserProfile->new( -profile => \%profile_hash ); + + # Using short policy names + is( + $up->policy_is_enabled('CodeLayout::ProhibitQuotedWordLists'), + 1, + 'CodeLayout::ProhibitQuotedWordLists is enabled.', + ); + is( + $up->policy_is_disabled('NamingConventions::Capitalization'), + 1, + 'NamingConventions::Capitalization is disabled.', + ); + is_deeply( + $up->raw_policy_params('CodeLayout::ProhibitQuotedWordLists'), + \%policy_params, + 'CodeLayout::ProhibitQuotedWordLists got the correct configuration.', + ); + + # Now using long policy names + is( + $up->policy_is_enabled('Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists'), + 1, + 'Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists is enabled.', + ); + is( + $up->policy_is_disabled('Perl::Critic::Policy::NamingConventions::Capitalization'), + 1, + 'Perl::Critic::Policy::NamingConventions::Capitalization is disabled.', + ); + is_deeply( + $up->raw_policy_params('Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists'), + \%policy_params, + 'Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists got the correct configuration.', + ); + + # Using bogus policy names + is( + $up->policy_is_enabled('Perl::Critic::Policy::Bogus'), + q{}, + q, + ); + is( + $up->policy_is_disabled('Perl::Critic::Policy::Bogus'), + q{}, + q, + ); + is_deeply( + $up->raw_policy_params('Perl::Critic::Policy::Bogus'), + {}, + q, + ); +} + +#----------------------------------------------------------------------------- +# Create profile from array + +{ + my %policy_params = (min_elements => 4); + my @profile_array = ( q{ [-NamingConventions::Capitalization] }, + q{ [CodeLayout::ProhibitQuotedWordLists] }, + q{ min_elements = 4 }, + ); + + + my $up = Perl::Critic::UserProfile->new( -profile => \@profile_array ); + + # Now using long policy names + is( + $up->policy_is_enabled('CodeLayout::ProhibitQuotedWordLists'), + 1, + 'CodeLayout::ProhibitQuotedWordLists is enabled.', + ); + is( + $up->policy_is_disabled('NamingConventions::Capitalization'), + 1, + 'NamingConventions::Capitalization is disabled.', + ); + is_deeply( + $up->raw_policy_params('CodeLayout::ProhibitQuotedWordLists'), + \%policy_params, + 'CodeLayout::ProhibitQuotedWordLists got the correct configuration.', + ); + + # Now using long policy names + is( + $up->policy_is_enabled('Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists'), + 1, + 'Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists is enabled.', + ); + is( + $up->policy_is_disabled('Perl::Critic::Policy::NamingConventions::Capitalization'), + 1, + 'Perl::Critic::Policy::NamingConventions::Capitalization is disabled.', + ); + is_deeply( + $up->raw_policy_params('Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists'), + \%policy_params, + 'Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists got the correct configuration.', + ); + + # Using bogus policy names + is( + $up->policy_is_enabled('Perl::Critic::Policy::Bogus'), + q{}, + q, + ); + is( + $up->policy_is_disabled('Perl::Critic::Policy::Bogus'), + q{}, + q, + ); + is_deeply( + $up->raw_policy_params('Perl::Critic::Policy::Bogus'), + {}, + q, + ); +} + +#----------------------------------------------------------------------------- +# Create profile from string + +{ + my %policy_params = (min_elements => 4); + my $profile_string = <<'END_PROFILE'; +[-NamingConventions::Capitalization] +[CodeLayout::ProhibitQuotedWordLists] +min_elements = 4 +END_PROFILE + + my $up = Perl::Critic::UserProfile->new( -profile => \$profile_string ); + + # Now using long policy names + is( + $up->policy_is_enabled('CodeLayout::ProhibitQuotedWordLists'), + 1, + 'CodeLayout::ProhibitQuotedWordLists is enabled.', + ); + is( + $up->policy_is_disabled('NamingConventions::Capitalization'), + 1, + 'NamingConventions::Capitalization is disabled.', + ); + is_deeply( + $up->raw_policy_params('CodeLayout::ProhibitQuotedWordLists'), + \%policy_params, + 'CodeLayout::ProhibitQuotedWordLists got the correct configuration.', + ); + + # Now using long policy names + is( + $up->policy_is_enabled('Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists'), + 1, + 'Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists is enabled.', + ); + is( + $up->policy_is_disabled('Perl::Critic::Policy::NamingConventions::Capitalization'), + 1, + 'Perl::Critic::Policy::NamingConventions::Capitalization is disabled.', + ); + is_deeply( + $up->raw_policy_params('Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists'), + \%policy_params, + 'Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists got the correct configuration.', + ); + + # Using bogus policy names + is( + $up->policy_is_enabled('Perl::Critic::Policy::Bogus'), + q{}, + q, + ); + is( + $up->policy_is_disabled('Perl::Critic::Policy::Bogus'), + q{}, + q, + ); + is_deeply( + $up->raw_policy_params('Perl::Critic::Policy::Bogus'), + {}, + q, + ); +} + +#----------------------------------------------------------------------------- +# Test long policy names + +{ + my %policy_params = (min_elements => 4); + my $long_profile_string = <<'END_PROFILE'; +[-Perl::Critic::Policy::NamingConventions::Capitalization] +[Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists] +min_elements = 4 +END_PROFILE + + my $up = Perl::Critic::UserProfile->new( -profile => \$long_profile_string ); + + # Now using long policy names + is( + $up->policy_is_enabled('CodeLayout::ProhibitQuotedWordLists'), + 1, + 'CodeLayout::ProhibitQuotedWordLists is enabled.', + ); + is( + $up->policy_is_disabled('NamingConventions::Capitalization'), + 1, + 'NamingConventions::Capitalization is disabled.', + ); + is_deeply( + $up->raw_policy_params('CodeLayout::ProhibitQuotedWordLists'), + \%policy_params, + 'CodeLayout::ProhibitQuotedWordLists got the correct configuration.', + ); + + # Now using long policy names + is( + $up->policy_is_enabled('Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists'), + 1, + 'Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists is enabled.', + ); + is( + $up->policy_is_disabled('Perl::Critic::Policy::NamingConventions::Capitalization'), + 1, + 'Perl::Critic::Policy::NamingConventions::Capitalization is disabled.', + ); + is_deeply( + $up->raw_policy_params('Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists'), + \%policy_params, + 'Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists got the correct configuration.', + ); + + # Using bogus policy names + is( + $up->policy_is_enabled('Perl::Critic::Policy::Bogus'), + q{}, + q, + ); + is( + $up->policy_is_disabled('Perl::Critic::Policy::Bogus'), + q{}, + q, + ); + is_deeply( + $up->raw_policy_params('Perl::Critic::Policy::Bogus'), + {}, + q, + ); +} + +#----------------------------------------------------------------------------- +# Test exception handling + +{ + my $code_ref = sub { return }; + eval { Perl::Critic::UserProfile->new( -profile => $code_ref ) }; + like( + $EVAL_ERROR, + qr/Can't [ ] load [ ] UserProfile/xms, + 'Invalid profile type', + ); + + eval { Perl::Critic::UserProfile->new( -profile => 'bogus' ) }; + like( + $EVAL_ERROR, + qr/Could [ ] not [ ] parse [ ] profile [ ] "bogus"/xms, + 'Invalid profile path', + ); + + my $invalid_syntax = '[Foo::Bar'; # Missing "]" + eval { Perl::Critic::UserProfile->new( -profile => \$invalid_syntax ) }; + like( + $EVAL_ERROR, + qr/Syntax [ ] error [ ] at [ ] line/xms, + 'Invalid profile syntax', + ); + + $invalid_syntax = 'severity 2'; # Missing "=" + eval { Perl::Critic::UserProfile->new( -profile => \$invalid_syntax ) }; + like( + $EVAL_ERROR, + qr/Syntax [ ] error [ ] at [ ] line/xms, + 'Invalid profile syntax', + ); + +} + +#----------------------------------------------------------------------------- +# Test profile finding + +{ + my $expected = local $ENV{PERLCRITIC} = 'foo'; + my $got = Perl::Critic::UserProfile::_find_profile_path(); + is( $got, $expected, 'PERLCRITIC environment variable'); +} + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/11_policy_factory.t b/t/11_policy_factory.t new file mode 100644 index 0000000..bc1bd72 --- /dev/null +++ b/t/11_policy_factory.t @@ -0,0 +1,130 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); + +use Perl::Critic::UserProfile; +use Perl::Critic::PolicyFactory (-test => 1); +use Perl::Critic::TestUtils qw(); + +use Test::More tests => 10; + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); +Perl::Critic::TestUtils::block_perlcriticrc(); + +#----------------------------------------------------------------------------- + +{ + my $policy_name = 'Perl::Critic::Policy::Modules::ProhibitEvilModules'; + my $params = {severity => 2, set_themes => 'betty', add_themes => 'wilma'}; + + my $userprof = Perl::Critic::UserProfile->new( -profile => 'NONE' ); + my $pf = Perl::Critic::PolicyFactory->new( -profile => $userprof ); + + + # Now test... + my $policy = $pf->create_policy( -name => $policy_name, -params => $params ); + is( ref $policy, $policy_name, 'Created correct type of policy'); + + my $severity = $policy->get_severity(); + is( $severity, 2, 'Set the severity'); + + my @themes = $policy->get_themes(); + is_deeply( \@themes, [ qw(betty wilma) ], 'Set the theme'); +} + +#----------------------------------------------------------------------------- +# Using short module name. +{ + my $policy_name = 'Variables::ProhibitPunctuationVars'; + my $params = {set_themes => 'betty', add_themes => 'wilma'}; + + my $userprof = Perl::Critic::UserProfile->new( -profile => 'NONE' ); + my $pf = Perl::Critic::PolicyFactory->new( -profile => $userprof ); + + + # Now test... + my $policy = $pf->create_policy( -name => $policy_name, -params => $params ); + my $policy_name_long = 'Perl::Critic::Policy::' . $policy_name; + is( ref $policy, $policy_name_long, 'Created correct type of policy'); + + my @themes = $policy->get_themes(); + is_deeply( \@themes, [ qw(betty wilma) ], 'Set the theme'); +} + +#----------------------------------------------------------------------------- +# Test exception handling + +{ + my $userprof = Perl::Critic::UserProfile->new( -profile => 'NONE' ); + my $pf = Perl::Critic::PolicyFactory->new( -profile => $userprof ); + + # Try missing arguments + eval{ $pf->create_policy() }; + like( + $EVAL_ERROR, + qr/The [ ] -name [ ] argument/xms, + 'create without -name arg', + ); + + # Try creating bogus policy + eval{ $pf->create_policy( -name => 'Perl::Critic::Foo' ) }; + like( + $EVAL_ERROR, + qr/Can't [ ] locate [ ] object [ ] method/xms, + 'create bogus policy', + ); + + # Try using a bogus severity level + my $policy_name = 'Modules::RequireVersionVar'; + my $policy_params = {severity => 'bogus'}; + eval{ $pf->create_policy( -name => $policy_name, -params => $policy_params)}; + like( + $EVAL_ERROR, + qr/Invalid [ ] severity: [ ] "bogus"/xms, + 'create policy w/ bogus severity', + ); +} + +#----------------------------------------------------------------------------- +# Test warnings about bogus policies + +{ + my $last_warning = q{}; #Trap warning messages here + local $SIG{__WARN__} = sub { $last_warning = shift }; + + my $profile = { 'Perl::Critic::Bogus' => {} }; + my $userprof = Perl::Critic::UserProfile->new( -profile => $profile ); + my $pf = Perl::Critic::PolicyFactory->new( -profile => $userprof ); + like( + $last_warning, + qr/^Policy [ ] ".*Bogus" [ ] is [ ] not [ ] installed/xms, + 'Got expected warning for positive configuration of Policy.', + ); + $last_warning = q{}; + + $profile = { '-Perl::Critic::Shizzle' => {} }; + $userprof = Perl::Critic::UserProfile->new( -profile => $profile ); + $pf = Perl::Critic::PolicyFactory->new( -profile => $userprof ); + like( + $last_warning, + qr/^Policy [ ] ".*Shizzle" [ ] is [ ] not [ ] installed/xms, + 'Got expected warning for negative configuration of Policy.', + ); + $last_warning = q{}; +} + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/12_policy_listing.t b/t/12_policy_listing.t new file mode 100644 index 0000000..039edcc --- /dev/null +++ b/t/12_policy_listing.t @@ -0,0 +1,51 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::UserProfile; +use Perl::Critic::PolicyFactory (-test => 1); +use Perl::Critic::PolicyListing; + +use Test::More; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +my $profile = Perl::Critic::UserProfile->new( -profile => 'NONE' ); +my @policy_names = Perl::Critic::PolicyFactory::site_policy_names(); +my $factory = Perl::Critic::PolicyFactory->new( -profile => $profile ); +my @policies = map { $factory->create_policy( -name => $_ ) } @policy_names; +my $listing = Perl::Critic::PolicyListing->new( -policies => \@policies ); +my $policy_count = scalar @policies; + +plan( tests => $policy_count + 1); + +#----------------------------------------------------------------------------- +# These tests verify that the listing has the right number of lines (one per +# policy) and that each line matches the expected pattern. This indirectly +# verifies that each core policy declares at least one theme. + +my $listing_as_string = "$listing"; +my @listing_lines = split m/ \n /xms, $listing_as_string; +my $line_count = scalar @listing_lines; +is( $line_count, $policy_count, qq{Listing has all $policy_count policies} ); + + +my $listing_pattern = qr< \A \d [ ] [\w:]+ [ ] \[ [\w\s]+ \] \z >xms; +for my $line ( @listing_lines ) { + like($line, $listing_pattern, 'Listing format matches expected pattern'); +} + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/12_theme_listing.t b/t/12_theme_listing.t new file mode 100644 index 0000000..5f6c1fc --- /dev/null +++ b/t/12_theme_listing.t @@ -0,0 +1,51 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::UserProfile; +use Perl::Critic::PolicyFactory (-test => 1); +use Perl::Critic::ThemeListing; + +use Test::More tests => 1; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +my $profile = Perl::Critic::UserProfile->new( -profile => 'NONE' ); +my @policy_names = Perl::Critic::PolicyFactory::site_policy_names(); +my $factory = Perl::Critic::PolicyFactory->new( -profile => $profile ); +my @policies = map { $factory->create_policy( -name => $_ ) } @policy_names; +my $listing = Perl::Critic::ThemeListing->new( -policies => \@policies ); + +my $expected = <<'END_EXPECTED'; +bugs +certrec +certrule +complexity +core +cosmetic +maintenance +pbp +performance +portability +readability +security +tests +unicode +END_EXPECTED + +my $listing_as_string = "$listing"; +is( $listing_as_string, $expected, 'Theme list matched.' ); + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/13_bundled_policies.t b/t/13_bundled_policies.t new file mode 100644 index 0000000..8be8c6e --- /dev/null +++ b/t/13_bundled_policies.t @@ -0,0 +1,33 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::UserProfile; +use Perl::Critic::PolicyFactory (-test => 1); +use Perl::Critic::TestUtils qw(bundled_policy_names); + +use Test::More tests => 1; + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); +Perl::Critic::TestUtils::block_perlcriticrc(); + + +my $profile = Perl::Critic::UserProfile->new(); +my $factory = Perl::Critic::PolicyFactory->new( -profile => $profile ); +my @found_policies = sort map { ref } $factory->create_all_policies(); +my $test_label = 'successfully loaded policies matches MANIFEST'; +is_deeply( \@found_policies, [bundled_policy_names()], $test_label ); + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/14_policy_parameter_behavior_boolean.t b/t/14_policy_parameter_behavior_boolean.t new file mode 100644 index 0000000..5a0b2f9 --- /dev/null +++ b/t/14_policy_parameter_behavior_boolean.t @@ -0,0 +1,100 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); + +use Perl::Critic::Policy; +use Perl::Critic::PolicyParameter; +use Perl::Critic::Utils qw{ :booleans }; + +use Test::More tests => 9; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +my $specification; +my $parameter; +my %config; +my $policy; + +$specification = + { + name => 'test', + description => 'A boolean parameter for testing', + behavior => 'boolean', + }; + + +$parameter = Perl::Critic::PolicyParameter->new($specification); +TODO: { + local $TODO = + 'Need to restore tri-state functionality to Behavior::Boolean.'; + + $policy = Perl::Critic::Policy->new(); + $parameter->parse_and_validate_config_value($policy, \%config); + is($policy->{_test}, undef, q{no value, no default}); +} + +$policy = Perl::Critic::Policy->new(); +$config{test} = '1'; +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, $TRUE, q{'1', no default}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '0'; +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, $FALSE, q{'0', no default}); + + +$specification->{default_string} = '1'; +delete $config{test}; + +$parameter = Perl::Critic::PolicyParameter->new($specification); +$policy = Perl::Critic::Policy->new(); +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, $TRUE, q{no value, default '1'}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '1'; +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, $TRUE, q{'1', default '1'}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '0'; +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, $FALSE, q{'0', default '1'}); + + +$specification->{default_string} = '0'; +delete $config{test}; + +$parameter = Perl::Critic::PolicyParameter->new($specification); +$policy = Perl::Critic::Policy->new(); +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, $FALSE, q{no value, default '0'}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '1'; +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, $TRUE, q{'1', default '0'}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '0'; +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, $FALSE, q{'0', default '0'}); + + +############################################################################### +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/14_policy_parameter_behavior_enumeration.t b/t/14_policy_parameter_behavior_enumeration.t new file mode 100644 index 0000000..61bef4a --- /dev/null +++ b/t/14_policy_parameter_behavior_enumeration.t @@ -0,0 +1,162 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); + +use Perl::Critic::Policy; +use Perl::Critic::PolicyParameter; + +use Test::More tests => 24; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +my $specification; +my $parameter; +my %config; +my $policy; + +$specification = + { + name => 'test', + description => 'An enumeration parameter for testing', + behavior => 'enumeration', + }; + + +eval { $parameter = Perl::Critic::PolicyParameter->new($specification); }; +like( + $EVAL_ERROR, + qr/\b enumeration_values \b/xms, + 'exception thrown for missing enumeration_values' +); + +$specification->{enumeration_values} = 'cranberries'; +eval { $parameter = Perl::Critic::PolicyParameter->new($specification); }; +like( + $EVAL_ERROR, + qr/\b enumeration_values \b/xms, + 'exception thrown for enumeration_values not being an array reference' +); + +$specification->{enumeration_values} = [ ]; +eval { $parameter = Perl::Critic::PolicyParameter->new($specification); }; +like( + $EVAL_ERROR, + qr/\b enumeration_values \b/xms, + 'exception thrown for enumeration_values not having at least two elements' +); + +$specification->{enumeration_values} = [ qw{ cranberries } ]; +eval { $parameter = Perl::Critic::PolicyParameter->new($specification); }; +like( + $EVAL_ERROR, + qr/\b enumeration_values \b/xms, + 'exception thrown for enumeration_values not having at least two elements' +); + + +$specification->{enumeration_values} = [ qw{ mercury gemini apollo } ]; + +$parameter = Perl::Critic::PolicyParameter->new($specification); +$policy = Perl::Critic::Policy->new(); +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, undef, q{no value, no default}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = 'gemini'; +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, 'gemini', q{'gemini', no default}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = 'easter_bunny'; +eval {$parameter->parse_and_validate_config_value($policy, \%config); }; +ok($EVAL_ERROR, q{invalid value}); + +$specification->{default_string} = 'apollo'; +delete $config{test}; + +$parameter = Perl::Critic::PolicyParameter->new($specification); +$policy = Perl::Critic::Policy->new(); +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, 'apollo', q{no value, default 'apollo'}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = 'gemini'; +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, 'gemini', q{'gemini', default 'apollo'}); + + +delete $specification->{default_string}; +$specification->{enumeration_values} = [ qw{ moore gaiman ellis miller } ]; +$specification->{enumeration_allow_multiple_values} = 1; +delete $config{test}; + +my $values; + +$parameter = Perl::Critic::PolicyParameter->new($specification); +$policy = Perl::Critic::Policy->new(); +$parameter->parse_and_validate_config_value($policy, \%config); +$values = $policy->{_test}; +is( scalar( keys %{$values} ), 0, q{no value, no default} ); + +$policy = Perl::Critic::Policy->new(); +$config{test} = 'moore'; +$parameter->parse_and_validate_config_value($policy, \%config); +$values = $policy->{_test}; +is( scalar( keys %{$values} ), 1, q{'moore', no default} ); +ok( $values->{moore}, q{'moore', no default} ); + +$policy = Perl::Critic::Policy->new(); +$config{test} = 'gaiman miller'; +$parameter->parse_and_validate_config_value($policy, \%config); +$values = $policy->{_test}; +is( scalar( keys %{$values} ), 2, q{'gaiman miller', no default} ); +ok( $values->{gaiman}, q{'gaiman miller', no default} ); +ok( $values->{miller}, q{'gaiman miller', no default} ); + +$policy = Perl::Critic::Policy->new(); +$config{test} = 'leeb'; +eval {$parameter->parse_and_validate_config_value($policy, \%config); }; +ok($EVAL_ERROR, q{invalid value}); + +$specification->{default_string} = 'ellis miller'; +delete $config{test}; + +$parameter = Perl::Critic::PolicyParameter->new($specification); +$policy = Perl::Critic::Policy->new(); +$parameter->parse_and_validate_config_value($policy, \%config); +$values = $policy->{_test}; +is( scalar( keys %{$values} ), 2, q{no value, default 'ellis miller'} ); +ok( $values->{ellis}, q{no value, default 'ellis miller'} ); +ok( $values->{miller}, q{no value, default 'ellis miller'} ); + +$policy = Perl::Critic::Policy->new(); +$config{test} = 'moore'; +$parameter->parse_and_validate_config_value($policy, \%config); +$values = $policy->{_test}; +is( scalar( keys %{$values} ), 1, q{'moore', default 'ellis miller'} ); +ok( $values->{moore}, q{'moore', default 'ellis miller'} ); + +$policy = Perl::Critic::Policy->new(); +$config{test} = 'gaiman miller'; +$parameter->parse_and_validate_config_value($policy, \%config); +$values = $policy->{_test}; +is( scalar( keys %{$values} ), 2, q{'gaiman miller', default 'ellis miller'} ); +ok( $values->{gaiman}, q{'gaiman miller', default 'ellis miller'} ); +ok( $values->{miller}, q{'gaiman miller', default 'ellis miller'} ); + +############################################################################### +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/14_policy_parameter_behavior_integer.t b/t/14_policy_parameter_behavior_integer.t new file mode 100644 index 0000000..ac62f4b --- /dev/null +++ b/t/14_policy_parameter_behavior_integer.t @@ -0,0 +1,169 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); + +use Perl::Critic::Policy; +use Perl::Critic::PolicyParameter; +use Perl::Critic::Utils qw{ :booleans }; + +use Test::More tests => 22; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +my $specification; +my $parameter; +my %config; +my $policy; + +$specification = + { + name => 'test', + description => 'An integer parameter for testing', + behavior => 'integer', + }; + + +$parameter = Perl::Critic::PolicyParameter->new($specification); +$policy = Perl::Critic::Policy->new(); +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, undef, q{no value, no default}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '2943'; +$parameter->parse_and_validate_config_value($policy, \%config); +cmp_ok($policy->{_test}, q<==>, 2943, q{2943, no default}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '+2943'; +$parameter->parse_and_validate_config_value($policy, \%config); +cmp_ok($policy->{_test}, q<==>, 2943, q{+2943, no default}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '-2943'; +$parameter->parse_and_validate_config_value($policy, \%config); +cmp_ok($policy->{_test}, q<==>, -2943, q{-2943, no default}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '29_43'; +$parameter->parse_and_validate_config_value($policy, \%config); +cmp_ok($policy->{_test}, q<==>, 2943, q{29_43, no default}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '+29_43'; +$parameter->parse_and_validate_config_value($policy, \%config); +cmp_ok($policy->{_test}, q<==>, 2943, q{+29_43, no default}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '-29_43'; +$parameter->parse_and_validate_config_value($policy, \%config); +cmp_ok($policy->{_test}, q<==>, -2943, q{-29_43, no default}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '0'; +$parameter->parse_and_validate_config_value($policy, \%config); +cmp_ok($policy->{_test}, q<==>, 0, q{0, no default}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '1.5'; +eval { $parameter->parse_and_validate_config_value($policy, \%config); }; +ok($EVAL_ERROR, q{not an integer}); + + +$specification->{default_string} = '0'; +delete $config{test}; + +$parameter = Perl::Critic::PolicyParameter->new($specification); +$policy = Perl::Critic::Policy->new(); +$parameter->parse_and_validate_config_value($policy, \%config); +cmp_ok($policy->{_test}, q<==>, 0, q{no value, default 0}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '5'; +$parameter->parse_and_validate_config_value($policy, \%config); +cmp_ok($policy->{_test}, q<==>, 5, q{5, default 0}); + + +$specification->{integer_minimum} = 0; + +$parameter = Perl::Critic::PolicyParameter->new($specification); +$policy = Perl::Critic::Policy->new(); +$config{test} = '5'; +$parameter->parse_and_validate_config_value($policy, \%config); +cmp_ok($policy->{_test}, q<==>, 5, q{5, minimum 0}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '0'; +$parameter->parse_and_validate_config_value($policy, \%config); +cmp_ok($policy->{_test}, q<==>, 0, q{0, minimum 0}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '-5'; +eval { $parameter->parse_and_validate_config_value($policy, \%config); }; +ok($EVAL_ERROR, q{below minimum}); + + +delete $specification->{integer_minimum}; +$specification->{integer_maximum} = 0; + +$parameter = Perl::Critic::PolicyParameter->new($specification); +$policy = Perl::Critic::Policy->new(); +$config{test} = '-5'; +$parameter->parse_and_validate_config_value($policy, \%config); +cmp_ok($policy->{_test}, q<==>, -5, q{-5, maximum 0}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '0'; +$parameter->parse_and_validate_config_value($policy, \%config); +cmp_ok($policy->{_test}, q<==>, 0, q{0, maximum 0}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '5'; +eval { $parameter->parse_and_validate_config_value($policy, \%config); }; +ok($EVAL_ERROR, q{above maximum}); + + +$specification->{integer_minimum} = 0; +$specification->{integer_maximum} = 5; + +$parameter = Perl::Critic::PolicyParameter->new($specification); +$policy = Perl::Critic::Policy->new(); +$config{test} = '-5'; +eval { $parameter->parse_and_validate_config_value($policy, \%config); }; +ok($EVAL_ERROR, q{below minimum of range}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '0'; +$parameter->parse_and_validate_config_value($policy, \%config); +cmp_ok($policy->{_test}, q<==>, 0, q{0, minimum 0, maximum 5}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '3'; +$parameter->parse_and_validate_config_value($policy, \%config); +cmp_ok($policy->{_test}, q<==>, 3, q{3, minimum 0, maximum 5}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '5'; +$parameter->parse_and_validate_config_value($policy, \%config); +cmp_ok($policy->{_test}, q<==>, 5, q{5, minimum 0, maximum 5}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = '10'; +eval { $parameter->parse_and_validate_config_value($policy, \%config); }; +ok($EVAL_ERROR, q{above maximum of range}); + +############################################################################### +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/14_policy_parameter_behavior_list_string.t b/t/14_policy_parameter_behavior_list_string.t new file mode 100644 index 0000000..969e8b8 --- /dev/null +++ b/t/14_policy_parameter_behavior_list_string.t @@ -0,0 +1,167 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::Policy; +use Perl::Critic::PolicyParameter; + +use Test::More tests => 28; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +my $specification; +my $parameter; +my %config; +my $policy; +my $values; + +$specification = + { + name => 'test', + description => 'A string list parameter for testing', + behavior => 'string list', + }; + + +$parameter = Perl::Critic::PolicyParameter->new($specification); +$policy = Perl::Critic::Policy->new(); +$parameter->parse_and_validate_config_value($policy, \%config); +$values = $policy->{_test}; +is( scalar( keys %{$values} ), 0, q{no value, no default} ); + +$policy = Perl::Critic::Policy->new(); +$config{test} = 'koyaanisqatsi'; +$parameter->parse_and_validate_config_value($policy, \%config); +$values = $policy->{_test}; +is( scalar( keys %{$values} ), 1, q{'koyaanisqatsi', no default} ); +ok( $values->{koyaanisqatsi}, q{'koyaanisqatsi', no default} ); + +$policy = Perl::Critic::Policy->new(); +$config{test} = 'powaqqatsi naqoyqatsi'; +$parameter->parse_and_validate_config_value($policy, \%config); +$values = $policy->{_test}; +is( scalar( keys %{$values} ), 2, q{'powaqqatsi naqoyqatsi', no default} ); +ok( $values->{powaqqatsi}, q{'powaqqatsi naqoyqatsi', no default} ); +ok( $values->{naqoyqatsi}, q{'powaqqatsi naqoyqatsi', no default} ); + + +$specification->{default_string} = 'baraka chronos'; +delete $config{test}; + +$parameter = Perl::Critic::PolicyParameter->new($specification); +$policy = Perl::Critic::Policy->new(); +$parameter->parse_and_validate_config_value($policy, \%config); +$values = $policy->{_test}; +is( scalar( keys %{$values} ), 2, q{no value, default 'baraka chronos'} ); +ok( $values->{baraka}, q{no value, default 'baraka chronos'} ); +ok( $values->{chronos}, q{no value, default 'baraka chronos'} ); + +$policy = Perl::Critic::Policy->new(); +$config{test} = 'akira'; +$parameter->parse_and_validate_config_value($policy, \%config); +$values = $policy->{_test}; +is( scalar( keys %{$values} ), 1, q{'akira', default 'baraka chronos'} ); +ok( $values->{akira}, q{'akira', default 'baraka chronos'} ); + +$policy = Perl::Critic::Policy->new(); +$config{test} = 'downfall murderball'; +$parameter->parse_and_validate_config_value($policy, \%config); +$values = $policy->{_test}; +is( scalar( keys %{$values} ), 2, q{'downfall murderball', default 'baraka chronos'} ); +ok( $values->{downfall}, q{'downfall murderball', default 'baraka chronos'} ); +ok( $values->{murderball}, q{'downfall murderball', default 'baraka chronos'} ); + + +$specification->{default_string} = 'chainsuck snog'; +$specification->{list_always_present_values} = + [ 'leaether strip', 'front line assembly' ]; +delete $config{test}; + +$parameter = Perl::Critic::PolicyParameter->new($specification); +$policy = Perl::Critic::Policy->new(); +$parameter->parse_and_validate_config_value($policy, \%config); +$values = $policy->{_test}; +is( + scalar( keys %{$values} ), + 4, + q{no value, default 'chainsuck snog', always 'leaether strip' & 'front line assembly'} +); +ok( + $values->{chainsuck}, + q{no value, default 'chainsuck snog', always 'leaether strip' & 'front line assembly'} +); +ok( + $values->{snog}, + q{no value, default 'chainsuck snog', always 'leaether strip' & 'front line assembly'} +); +ok( + $values->{'leaether strip'}, + q{no value, default 'chainsuck snog', always 'leaether strip' & 'front line assembly'} +); +ok( + $values->{'front line assembly'}, + q{no value, default 'chainsuck snog', always 'leaether strip' & 'front line assembly'} +); + +$policy = Perl::Critic::Policy->new(); +$config{test} = 'pig'; +$parameter->parse_and_validate_config_value($policy, \%config); +$values = $policy->{_test}; +is( + scalar( keys %{$values} ), + 3, + q{'pig', default 'chainsuck snog', always 'leaether strip' & 'front line assembly'} +); +ok( + $values->{pig}, + q{'pig', default 'chainsuck snog', always 'leaether strip' & 'front line assembly'} +); +ok( + $values->{'leaether strip'}, + q{'pig', default 'chainsuck snog', always 'leaether strip' & 'front line assembly'} +); +ok( + $values->{'front line assembly'}, + q{'pig', default 'chainsuck snog', always 'leaether strip' & 'front line assembly'} +); + +$policy = Perl::Critic::Policy->new(); +$config{test} = 'microdisney foetus'; +$parameter->parse_and_validate_config_value($policy, \%config); +$values = $policy->{_test}; +is( + scalar( keys %{$values} ), + 4, + q{'microdisney foetus', default 'chainsuck snog', always 'leaether strip' & 'front line assembly'} +); +ok( + $values->{microdisney}, + q{'microdisney foetus', default 'chainsuck snog', always 'leaether strip' & 'front line assembly'} +); +ok( + $values->{foetus}, + q{'microdisney foetus', default 'chainsuck snog', always 'leaether strip' & 'front line assembly'} +); +ok( + $values->{'leaether strip'}, + q{'microdisney foetus', default 'chainsuck snog', always 'leaether strip' & 'front line assembly'} +); +ok( + $values->{'front line assembly'}, + q{'microdisney foetus', default 'chainsuck snog', always 'leaether strip' & 'front line assembly'} +); + +############################################################################### +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/14_policy_parameter_behavior_string.t b/t/14_policy_parameter_behavior_string.t new file mode 100644 index 0000000..ed41077 --- /dev/null +++ b/t/14_policy_parameter_behavior_string.t @@ -0,0 +1,63 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::Policy; +use Perl::Critic::PolicyParameter; + +use Test::More tests => 4; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +my $specification; +my $parameter; +my %config; +my $policy; + +$specification = + { + name => 'test', + description => 'A string parameter for testing', + behavior => 'string', + }; + + +$parameter = Perl::Critic::PolicyParameter->new($specification); +$policy = Perl::Critic::Policy->new(); +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, undef, q{no value, no default}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = 'foobie'; +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, 'foobie', q{'foobie', no default}); + + +$specification->{default_string} = 'bletch'; +delete $config{test}; + +$parameter = Perl::Critic::PolicyParameter->new($specification); +$policy = Perl::Critic::Policy->new(); +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, 'bletch', q{no value, default 'bletch'}); + +$policy = Perl::Critic::Policy->new(); +$config{test} = 'foobie'; +$parameter->parse_and_validate_config_value($policy, \%config); +is($policy->{_test}, 'foobie', q{'foobie', default 'bletch'}); + + +############################################################################### +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/14_policy_parameters.t b/t/14_policy_parameters.t new file mode 100644 index 0000000..72e420a --- /dev/null +++ b/t/14_policy_parameters.t @@ -0,0 +1,123 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); + +use Perl::Critic::UserProfile qw(); +use Perl::Critic::PolicyFactory (-test => 1); +use Perl::Critic::PolicyParameter qw{ $NO_DESCRIPTION_AVAILABLE }; +use Perl::Critic::Utils qw( policy_short_name ); +use Perl::Critic::TestUtils qw(bundled_policy_names); + +use Test::More; #plan set below! + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); +Perl::Critic::TestUtils::block_perlcriticrc(); + +#----------------------------------------------------------------------------- +# This program proves that each policy that ships with Perl::Critic overrides +# the supported_parameters() method and, assuming that the policy is +# configurable, that each parameter can parse its own default_string. +# +# This program also verifies that Perl::Critic::PolicyFactory throws an +# exception when we try to create a policy with bogus parameters. However, it +# is your responsibility to verify that valid parameters actually work as +# expected. You can do this by using the #parms directive in the *.run files. +#----------------------------------------------------------------------------- + +# Figure out how many tests there will be... +my @all_policies = bundled_policy_names(); +my @all_params = map { $_->supported_parameters() } @all_policies; +my $ntests = @all_policies + 2 * @all_params; +plan( tests => $ntests ); + +#----------------------------------------------------------------------------- + +for my $policy ( @all_policies ) { + test_has_declared_parameters( $policy ); + test_invalid_parameters( $policy ); + test_supported_parameters( $policy ); +} + +#----------------------------------------------------------------------------- + +sub test_supported_parameters { + my $policy_name = shift; + my @supported_params = $policy_name->supported_parameters(); + my $config = Perl::Critic::Config->new( -profile => 'NONE' ); + + for my $param_specification ( @supported_params ) { + my $parameter = + Perl::Critic::PolicyParameter->new($param_specification); + my $param_name = $parameter->get_name(); + my $description = $parameter->get_description(); + + ok( + $description && $description ne $NO_DESCRIPTION_AVAILABLE, + qq{Param "$param_name" for policy "$policy_name" has a description}, + ); + + my %args = ( + -policy => $policy_name, + -params => { + $param_name => $parameter->get_default_string(), + } + ); + eval { $config->add_policy( %args ) }; + is( + $EVAL_ERROR, + q{}, + qq{Created policy "$policy_name" with param "$param_name"}, + ); + } + + return; +} + +#----------------------------------------------------------------------------- + +sub test_invalid_parameters { + my $policy = shift; + my $bogus_params = { bogus => 'shizzle' }; + my $profile = Perl::Critic::UserProfile->new( -profile => 'NONE' ); + my $factory = Perl::Critic::PolicyFactory->new( + -profile => $profile, '-profile-strictness' => 'fatal' ); + + my $policy_name = policy_short_name($policy); + my $label = qq{Created $policy_name with bogus parameters}; + + eval { $factory->create_policy(-name => $policy, -params => $bogus_params) }; + like( + $EVAL_ERROR, + qr/The [ ] $policy_name [ ] policy [ ] doesn't [ ] take [ ] a [ ] "bogus" [ ] option/xms, + $label + ); + + return; +} + +#----------------------------------------------------------------------------- + +sub test_has_declared_parameters { + my $policy = shift; + if ( not $policy->can('supported_parameters') ) { + fail( qq{I don't know if $policy supports params} ); + diag( qq{This means $policy needs a supported_parameters() method} ); + } + return; +} + +############################################################################### +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/15_statistics.t b/t/15_statistics.t new file mode 100644 index 0000000..41c1e02 --- /dev/null +++ b/t/15_statistics.t @@ -0,0 +1,95 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::PolicyFactory (-test => 1); +use Perl::Critic::Statistics; +use Perl::Critic::TestUtils; + +use Test::More tests => 24; + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); +Perl::Critic::TestUtils::block_perlcriticrc(); + +#----------------------------------------------------------------------------- + +my $package = 'Perl::Critic::Statistics'; + +my @methods = qw( + average_sub_mccabe + lines + modules + new + statements + subs + total_violations + violations_by_policy + violations_by_severity + statements_other_than_subs + violations_per_file + violations_per_statement + violations_per_line_of_code +); + +for my $method ( @methods ) { + can_ok( $package, $method ); +} + +#----------------------------------------------------------------------------- + +my $code = <<'END_PERL'; +package Foo; + +use My::Module; +$this = $that if $condition; +sub foo { return @list unless $condition }; +END_PERL + +#----------------------------------------------------------------------------- + +# Just don't get involved with Perl::Tidy. +my $profile = { '-CodeLayout::RequireTidyCode' => {} }; +my $critic = + Perl::Critic->new( + -severity => 1, + -profile => $profile, + -theme => 'core', + ); +my @violations = $critic->critique( \$code ); + +#print @violations; +#exit; + +my %expected_stats = ( + average_sub_mccabe => 2, + lines => 5, + modules => 1, + statements => 6, + statements_other_than_subs => 5, + subs => 1, + total_violations => 7, + violations_per_file => 7, + violations_per_line_of_code => 1.4, # 7 violations / 5 lines + violations_per_statement => 1.4, # 7 violations / 5 lines +); + +my $stats = $critic->statistics(); +isa_ok($stats, $package); + +while ( my($method, $expected) = each %expected_stats) { + is( $stats->$method, $expected, "Statistics: $method"); +} + +############################################################################### +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/16_roundtrip_defaults.t b/t/16_roundtrip_defaults.t new file mode 100644 index 0000000..5148007 --- /dev/null +++ b/t/16_roundtrip_defaults.t @@ -0,0 +1,275 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::PolicyFactory (-test => 1); +use Perl::Critic::Config; +use Perl::Critic::ProfilePrototype; +use Perl::Critic::Utils qw{ :characters :severities }; + +use Test::Deep; +use Test::More; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +my $default_configuration = + Perl::Critic::Config->new( + -profile => $EMPTY, + -severity => 1, + -theme => 'core', + ); +my @default_policies = $default_configuration->policies(); + +my $policy_test_count; + +$policy_test_count = 4 * @default_policies; +foreach my $policy (@default_policies) { + if ( + $policy->parameter_metadata_available() + and not $policy->isa('Perl::Critic::Policy::CodeLayout::RequireTidyCode') + ) { + $policy_test_count += scalar @{$policy->get_parameters()}; + } +} +my $test_count = 18 + $policy_test_count; +plan tests => $test_count; + +#----------------------------------------------------------------------------- + +my $profile_generator = + Perl::Critic::ProfilePrototype->new( + -policies => \@default_policies, + '-comment-out-parameters' => 0, + -config => $default_configuration, + ); +my $profile = $profile_generator->to_string(); + +my $derived_configuration = + Perl::Critic::Config->new( -profile => \$profile ); + +#----------------------------------------------------------------------------- + +my @derived_include = $derived_configuration->include(); +my @default_include = $default_configuration->include(); +cmp_deeply( + \@derived_include, + \@default_include, + 'include', +); + +#----------------------------------------------------------------------------- + +my @derived_exclude = $derived_configuration->exclude(); +my @default_exclude = $default_configuration->exclude(); +cmp_deeply( + \@derived_exclude, + \@default_exclude, + 'exclude', +); + +#----------------------------------------------------------------------------- + +my @derived_single_policy = $derived_configuration->single_policy(); +my @default_single_policy = $default_configuration->single_policy(); +cmp_deeply( + \@derived_single_policy, + \@default_single_policy, + 'single_policy', +); + +#----------------------------------------------------------------------------- + +is( + $derived_configuration->force(), + $default_configuration->force(), + 'force', +); + +#----------------------------------------------------------------------------- + +is( + $derived_configuration->only(), + $default_configuration->only(), + 'only', +); + +#----------------------------------------------------------------------------- + +is( + $derived_configuration->profile_strictness(), + $default_configuration->profile_strictness(), + 'force', +); + +#----------------------------------------------------------------------------- + +is( + $derived_configuration->color(), + $default_configuration->color(), + 'color', +); + +#----------------------------------------------------------------------------- + +cmp_ok( + $derived_configuration->severity(), + q<==>, + $default_configuration->severity(), + 'severity', +); + +#----------------------------------------------------------------------------- + +cmp_ok( + $derived_configuration->top(), + q<==>, + $default_configuration->top(), + 'top', +); + +#----------------------------------------------------------------------------- + +cmp_ok( + $derived_configuration->verbose(), + q<==>, + $default_configuration->verbose(), + 'verbose', +); + +#----------------------------------------------------------------------------- + +cmp_deeply( + $derived_configuration->theme(), + $default_configuration->theme(), + 'theme', +); + +#----------------------------------------------------------------------------- + +is( + $derived_configuration->color_severity_highest(), + $default_configuration->color_severity_highest(), + 'color_severity_highest', +); + +#----------------------------------------------------------------------------- + +is( + $derived_configuration->color_severity_high(), + $default_configuration->color_severity_high(), + 'color_severity_high', +); + +#----------------------------------------------------------------------------- + +is( + $derived_configuration->color_severity_medium(), + $default_configuration->color_severity_medium(), + 'color_severity_medium', +); + +#----------------------------------------------------------------------------- + +is( + $derived_configuration->color_severity_low(), + $default_configuration->color_severity_low(), + 'color_severity_low', +); + +#----------------------------------------------------------------------------- + +is( + $derived_configuration->color_severity_lowest(), + $default_configuration->color_severity_lowest(), + 'color_severity_lowest', +); + +#----------------------------------------------------------------------------- + +my @derived_program_extensions = $derived_configuration->program_extensions(); +my @default_program_extensions = $default_configuration->program_extensions(); +cmp_deeply( + \@derived_program_extensions, + \@default_program_extensions, + 'program_extensions', +); + +#----------------------------------------------------------------------------- + +my @derived_policies = $derived_configuration->policies(); + +my $policy_counts_match = + is( + scalar @derived_policies, + scalar @default_policies, + 'same policy count' + ); + +SKIP: { + skip + q{because there weren't the same number of policies}, + $policy_test_count + if not $policy_counts_match; + + for (my $x = 0; $x < @default_policies; $x++) { ## no critic (ProhibitCStyleForLoops) + my $derived_policy = $derived_policies[$x]; + my $default_policy = $default_policies[$x]; + + is( + $derived_policy->get_short_name(), + $default_policy->get_short_name(), + 'policy names match', + ); + is( + $derived_policy->get_maximum_violations_per_document(), + $default_policy->get_maximum_violations_per_document(), + $default_policy->get_short_name() . ' maximum violations per document match', + ); + is( + $derived_policy->get_severity(), + $default_policy->get_severity(), + $default_policy->get_short_name() . ' severities match', + ); + is( + $derived_policy->get_themes(), + $default_policy->get_themes(), + $default_policy->get_short_name() . ' themes match', + ); + + if ( + $default_policy->parameter_metadata_available() + and not $default_policy->isa('Perl::Critic::Policy::CodeLayout::RequireTidyCode') + ) { + # Encapsulation violation alert! + foreach my $parameter ( @{$default_policy->get_parameters()} ) { + my $parameter_name = + $default_policy->__get_parameter_name( $parameter ); + + cmp_deeply( + $derived_policy->{$parameter_name}, + $default_policy->{$parameter_name}, + $default_policy->get_short_name() + . $SPACE + . $parameter_name + . ' match', + ); + } + } + } +} + + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/20_policies.t b/t/20_policies.t new file mode 100644 index 0000000..f9f970f --- /dev/null +++ b/t/20_policies.t @@ -0,0 +1,29 @@ +#!perl + +use 5.006001; + +use strict; +use warnings; + +use Test::Perl::Critic::Policy qw< all_policies_ok >; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +# Notice that you can pass arguments to this test, which limit the testing to +# specific policies. The arguments must be shortened policy names. When using +# prove(1), any arguments that follow '::' will be passed to the test script. + +my %args = @ARGV ? ( -policies => [ @ARGV ] ) : (); +all_policies_ok(%args); + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/20_policy_pod_spelling.d/stop-words.txt b/t/20_policy_pod_spelling.d/stop-words.txt new file mode 100644 index 0000000..6c6c4d1 --- /dev/null +++ b/t/20_policy_pod_spelling.d/stop-words.txt @@ -0,0 +1,5 @@ +# It's a comment! + +foo +arglbargl # Some other comment. +bar diff --git a/t/20_policy_pod_spelling.t b/t/20_policy_pod_spelling.t new file mode 100644 index 0000000..3d97d80 --- /dev/null +++ b/t/20_policy_pod_spelling.t @@ -0,0 +1,156 @@ +#!perl + +=for stopwords arglbargl + +=cut + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::TestUtils qw(pcritique); +use Readonly; + +use Test::More; + +Readonly::Scalar my $NUMBER_OF_TESTS => 5; +plan( tests => $NUMBER_OF_TESTS ); + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); +Perl::Critic::TestUtils::block_perlcriticrc(); + +my $code; +my $policy = 'Documentation::PodSpelling'; +my $can_podspell = can_determine_spell_command() && can_run_spell_command(); + +sub can_determine_spell_command { + my $pol = Perl::Critic::Policy::Documentation::PodSpelling->new(); + $pol->initialize_if_enabled(); + + return $pol->_get_spell_command_line(); +} + +sub can_run_spell_command { + my $pol = Perl::Critic::Policy::Documentation::PodSpelling->new(); + $pol->initialize_if_enabled(); + + return $pol->_run_spell_command( <<'END_TEST_CODE' ); +=pod + +=head1 Test The Spell Command + +=cut +END_TEST_CODE +} + +sub can_podspell { + return $can_podspell && ! Perl::Critic::Policy::Documentation::PodSpelling->got_sigpipe(); +} + +#----------------------------------------------------------------------------- +SKIP: { + +$code = <<'END_PERL'; +=head1 Silly + +=cut +END_PERL + +# Sorry about the double negative. The idea is that if aspell fails (say, +# because it can not find the right dictionary) or pcritique returns a +# non-zero number we want to skip. We have to negate the eval to catch the +# aspell failure, and then negate pcritique because we negated the eval. +# Clearer code welcome. +if ( ! eval { ! pcritique($policy, \$code) } ) { + skip 'Test environment is not English', $NUMBER_OF_TESTS; +} + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +=head1 arglbargl + +=cut +END_PERL + +is( + eval { pcritique($policy, \$code) }, + can_podspell() ? 1 : undef, + 'Mispelled header', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +=head1 Test + +arglbargl + +=cut +END_PERL + +is( + eval { pcritique($policy, \$code) }, + can_podspell() ? 1 : undef, + 'Mispelled body', +); + +#----------------------------------------------------------------------------- + + +$code = <<'END_PERL'; +=for stopwords arglbargl + +=head1 Test + +arglbargl + +=cut +END_PERL + +is( + eval { pcritique($policy, \$code) }, + can_podspell() ? 0 : undef, + 'local stopwords', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +=head1 Test + +arglbargl + +=cut +END_PERL + +{ + my %config = (stop_words => 'foo arglbargl bar'); + is( + eval { pcritique($policy, \$code, \%config) }, + can_podspell() ? 0 : undef , + 'global stopwords', + ); +} + +{ + my %config = (stop_words_file => 't/20_policy_pod_spelling.d/stop-words.txt'); + is( + eval { pcritique($policy, \$code, \%config) }, + can_podspell() ? 0 : undef , + 'global stopwords from file', + ); +} + +} # end skip + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/20_policy_prohibit_evil_modules.t b/t/20_policy_prohibit_evil_modules.t new file mode 100644 index 0000000..1621388 --- /dev/null +++ b/t/20_policy_prohibit_evil_modules.t @@ -0,0 +1,44 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::TestUtils qw< pcritique >; +use Perl::Critic::Utils qw< $EMPTY >; + +use Test::More tests => 1; + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); +Perl::Critic::TestUtils::block_perlcriticrc(); + +# This is in addition to the regular .run file. + +my $policy = 'Modules::ProhibitEvilModules'; + +my $code = <<'END_PERL'; + +use Evil::Module qw(bad stuff); +use Super::Evil::Module; + +END_PERL + +my $result = eval { pcritique( $policy, \$code, {modules => $EMPTY} ); 1; }; +ok( + ! $result, + "$policy does not run if there are no evil modules configured.", +); + + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/20_policy_prohibit_hard_tabs.t b/t/20_policy_prohibit_hard_tabs.t new file mode 100644 index 0000000..0637833 --- /dev/null +++ b/t/20_policy_prohibit_hard_tabs.t @@ -0,0 +1,195 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +# common P::C testing tools +use Perl::Critic::TestUtils qw(pcritique fcritique); + +use Test::More tests => 10; + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); +Perl::Critic::TestUtils::block_perlcriticrc(); + +# This specific policy is being tested without run.t because the .run file +# would have to contain invisible characters. + +my $code; +my $policy = 'CodeLayout::ProhibitHardTabs'; +my %config; + +#----------------------------------------------------------------------------- + +$code = <<"END_PERL"; +#This will be interpolated! + +sub my_sub { +\tfor(1){ +\t\tdo_something(); +\t} +} + +\t\t\t; + +END_PERL + +is( pcritique($policy, \$code), 0, $policy ); + +#----------------------------------------------------------------------------- + +$code = <<"END_PERL"; +#This will be interpolated! +print "\t \t foobar \t"; +END_PERL + +is( pcritique($policy, \$code), 1, $policy ); + +#----------------------------------------------------------------------------- + +$code = <<"END_PERL"; +#This will be interpolated! + +my \@list = qw( +\tfoo +\tbar +\tbaz +); + +END_PERL + +is( pcritique($policy, \$code, \%config), 0, 'Leading tabs in qw()' ); + +#----------------------------------------------------------------------------- + +$code = <<"END_PERL"; +#This will be interpolated! + +my \@list = qw( +\tfoo\tbar +\tbaz\tnuts +); + +END_PERL + +is( pcritique($policy, \$code, \%config), 1, 'Non-leading tabs in qw()' ); + +#----------------------------------------------------------------------------- +# RT #32440 + +$code = <<"END_PERL"; +#This will be interpolated! +\$x =~ m/ +\tsome +\t(really | long) +\tpattern +/mx; + +#This will be interpolated! +\$z = qr/ +\tsome +\t(really | long) +\tpattern +/mx; + +END_PERL + +is( pcritique($policy, \$code, \%config), 0, 'Leading tabs in extended regex' ); + +#----------------------------------------------------------------------------- +# RT #32440 + +$code = <<"END_PERL"; +#This will be interpolated! +#Note that these regex does not have /x, so tabs are significant + +\$x =~ m/ +\tsome +\tugly +\tpattern +/m; + + +\$z = qr/ +\tsome +\tugly +\tpattern +/gis; + +END_PERL + +is( pcritique($policy, \$code, \%config), 2, 'Leading tabs in non-extended regex' ); + +#----------------------------------------------------------------------------- +# RT #32440 + +$code = <<"END_PERL"; +#This will be interpolated! +#Note that these regex does not have /x, so tabs are significant + +\$x =~ m/ +\tsome\tugly\tpattern +/xm; + +END_PERL + +is( pcritique($policy, \$code, \%config), 1, 'Non-leading tabs in extended regex' ); + +#----------------------------------------------------------------------------- + +$code = <<"END_PERL"; +##This will be interpolated! + +sub my_sub { +\tfor(1){ +\t\tdo_something(); +\t} +} + +END_PERL + +%config = (allow_leading_tabs => 0); +is( pcritique($policy, \$code, \%config), 3, $policy ); + +#----------------------------------------------------------------------------- + +$code = <<"END_PERL"; +##This will be interpolated! + +sub my_sub { +;\tfor(1){ +\t\tdo_something(); +;\t} +} + +END_PERL + +%config = (allow_leading_tabs => 0); +is( pcritique($policy, \$code, \%config), 3, $policy ); + +#----------------------------------------------------------------------------- + +$code = <<"END_PERL"; +#This will be interpolated! + +__DATA__ +foo\tbar\tbaz +\tfred\barney + +END_PERL + +%config = (allow_leading_tabs => 0); +is( pcritique($policy, \$code, \%config), 0, 'Tabs in __DATA__' ); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/20_policy_prohibit_trailing_whitespace.t b/t/20_policy_prohibit_trailing_whitespace.t new file mode 100644 index 0000000..71cb90a --- /dev/null +++ b/t/20_policy_prohibit_trailing_whitespace.t @@ -0,0 +1,72 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::Utils qw( :characters ); +use Perl::Critic::TestUtils qw( pcritique ); + +use Test::More tests => 3; + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); +Perl::Critic::TestUtils::block_perlcriticrc(); + +# This specific policy is being tested without 20_policies.t because the .run file +# would have to contain invisible characters. + +my $code; +my $policy = 'CodeLayout::ProhibitTrailingWhitespace'; + +#----------------------------------------------------------------------------- + +$code = <<"END_PERL"; +say${SPACE}"\tblurp\t";\t +say${SPACE}"${SPACE}blorp${SPACE}";${SPACE} +\f + + +chomp;\t${SPACE}${SPACE} +chomp;${SPACE}${SPACE}\t +END_PERL + +is( pcritique($policy, \$code), 5, 'Basic failure' ); + +#----------------------------------------------------------------------------- + +$code = <<"END_PERL"; +sub${SPACE}do_frobnication${SPACE}\{ +\tfor${SPACE}(${SPACE}is_frobnicating()${SPACE})${SPACE}\{ +${SPACE}${SPACE}${SPACE}${SPACE}frobnicate(); +\l} +} + +END_PERL + +is( pcritique($policy, \$code), 0, 'Basic passing' ); + +#----------------------------------------------------------------------------- + +$code = <<"END_PERL"; +${SPACE} +${SPACE}\$x +END_PERL + +is( + pcritique($policy, \$code), + 1, + 'Multiple lines in a single PPI::Token::Whitespace', +); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/20_policy_require_consistent_newlines.t b/t/20_policy_require_consistent_newlines.t new file mode 100644 index 0000000..2354fea --- /dev/null +++ b/t/20_policy_require_consistent_newlines.t @@ -0,0 +1,83 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use charnames ':full'; + +use Perl::Critic::TestUtils qw(pcritique fcritique); + +use Test::More tests => 29; + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); +Perl::Critic::TestUtils::block_perlcriticrc(); + +my $code; +my $policy = 'CodeLayout::RequireConsistentNewlines'; + +my $base_code = <<'END_PERL'; +package My::Pkg; +my $str = <<"HEREDOC"; +heredoc_body +heredoc_body +HEREDOC + +=head1 POD_HEADER + +pod pod pod + +=cut + +# comment_line + +1; # inline_comment + +__END__ +end_body +__DATA__ +DataLine1 +DataLine2 +END_PERL + +is( fcritique($policy, \$base_code), 0, $policy ); + +my @lines = split m/\n/xms, $base_code; +for my $keyword (qw< + Pkg; heredoc_body HEREDOC POD_HEADER pod =cut + comment_line inline_comment + __END__ end_body __DATA__ DataLine1 DataLine2 +>) { + my $is_first_line = $lines[0] =~ m/\Q$keyword\E\z/xms; + my $nfail = $is_first_line ? @lines-1 : 1; + for my $nl ( + "\N{LINE FEED}", + "\N{CARRIAGE RETURN}", + "\N{CARRIAGE RETURN}\N{LINE FEED}", + ) { + next if $nl eq "\n"; + ($code = $base_code) =~ s/ (\Q$keyword\E) \n /$1$nl/xms; + is( fcritique($policy, \$code), $nfail, $policy.' - '.$keyword ); + } +} + +for my $nl ( + "\N{LINE FEED}", + "\N{CARRIAGE RETURN}", + "\N{CARRIAGE RETURN}\N{LINE FEED}", +) { + next if $nl eq "\n"; + ($code = $base_code) =~ s/ \n /$nl/xms; + is( pcritique($policy, \$code), 0, $policy.' - no filename' ); +} + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/20_policy_require_tidy_code.t b/t/20_policy_require_tidy_code.t new file mode 100644 index 0000000..34b1ead --- /dev/null +++ b/t/20_policy_require_tidy_code.t @@ -0,0 +1,132 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::TestUtils qw(pcritique); + +use Test::More tests => 6; + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); +Perl::Critic::TestUtils::block_perlcriticrc(); + +my $code; +my $policy = 'CodeLayout::RequireTidyCode'; +my %config; + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +$foo= 42; +$bar =56; +$baz = 67; +END_PERL + +%config = (perltidyrc => q{}); +is( + pcritique($policy, \$code, \%config), + 1, + 'Untidy code', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +#Only one trailing newline +$foo = 42; +$bar = 56; +END_PERL + +%config = (perltidyrc => q{}); +is( + pcritique($policy, \$code, \%config), + 0, + 'Tidy with one trailing newline', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +#Two trailing newlines +$foo = 42; +$bar = 56; + +END_PERL + +%config = (perltidyrc => q{}); +is( + pcritique($policy, \$code, \%config), + 0, + 'Tidy with two trailing newlines', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +#Several trailing newlines +$foo = 42; +$bar = 56; + + + + + + +END_PERL + + + +%config = (perltidyrc => q{}); +is( + pcritique($policy, \$code, \%config), + 0, + 'Tidy with several trailing newlines', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +sub foo { + my $code = <<'TEST'; + foo bar baz +TEST + $code; +} +END_PERL + +%config = (perltidyrc => q{}); +is( + pcritique($policy, \$code, \%config), + 0, + 'Tidy with heredoc', +); + +#----------------------------------------------------------------------------- + +$code = <<'END_PERL'; +#!perl + +eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}' + if 0; # not running under some shell + +package main; +END_PERL + +%config = (perltidyrc => q{}); +is( + pcritique($policy, \$code, \%config), + 0, + 'Tidy with shell escape', +); + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/92_memory_leaks.t b/t/92_memory_leaks.t new file mode 100644 index 0000000..30ba906 --- /dev/null +++ b/t/92_memory_leaks.t @@ -0,0 +1,67 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Carp qw< confess >; + +use PPI::Document; + +use Perl::Critic::PolicyFactory -test => 1; +use Perl::Critic::Document; +use Perl::Critic; +use Perl::Critic::TestUtils qw(); + +use Test::More; #plan set below + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); +Perl::Critic::TestUtils::block_perlcriticrc(); + +eval 'use Test::Memory::Cycle; 1' + or plan skip_all => 'Test::Memory::Cycle required to test memory leaks'; + +#----------------------------------------------------------------------------- +{ + + # We have to create and test Perl::Critic::Document for memory leaks + # separately because it is not a persistent attribute of the Perl::Critic + # object. The current API requires us to create the P::C::Document from + # an instance of an existing PPI::Document. In the future, I hope to make + # that interface a little more opaque. But this works for now. + + # Coincidentally, I've discovered that PPI::Documents may or may not + # contain circular references, depending on the input code. On some + # level, I'm sure this makes perfect sense, but I haven't stopped to think + # about it. The particular input we use here does not seem to create + # circular references. + + my $code = q; ## no critic (RequireInterpolationOfMetachars) + my $ppi_doc = PPI::Document->new( \$code ); + my $pc_doc = Perl::Critic::Document->new( '-source' => $ppi_doc ); + my $critic = Perl::Critic->new( -severity => 1 ); + my @violations = $critic->critique( $pc_doc ); + confess 'No violations were created' if not @violations; + + # One test for each violation, plus one each for Critic and Document. + plan( tests => scalar @violations + 2 ); + + memory_cycle_ok( $pc_doc, 'Document' ); + memory_cycle_ok( $critic, 'Critic' ); + foreach my $violation (@violations) { + memory_cycle_ok($_); + } +} + + +############################################################################### +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/BuiltinFunctions/ProhibitBooleanGrep.run b/t/BuiltinFunctions/ProhibitBooleanGrep.run new file mode 100644 index 0000000..21c9ad8 --- /dev/null +++ b/t/BuiltinFunctions/ProhibitBooleanGrep.run @@ -0,0 +1,132 @@ +## name Basic passing +## failures 0 +## cut + +print grep("$foo", @list); +print ( grep "$foo", @list ); +@list = ( grep "$foo", @list ); +$aref = [ grep "$foo", @list ]; +$href = { grep "$foo", @list }; + +#----------------------------------------------------------------------------- + +## name Counting is allowed +## failures 0 +## cut + +$count = grep {m/./xms} @list + +#----------------------------------------------------------------------------- + +## name Non-boolean in conditional +## failures 0 +## cut + +if (0 == grep {m/./xms} @list) {} + +#----------------------------------------------------------------------------- + +## name For loop is not conditional +## failures 0 +## cut + +for( grep { foo($_) } @list ) {} +foreach( grep { foo($_) } @list ) {} + +#----------------------------------------------------------------------------- + +## name Control structures +## failures 4 +## cut + +if( grep { foo($_) } @list ) {} +unless( grep { foo($_) } @list ) {} +while( grep { foo($_) } @list ) {} +until( grep { foo($_) } @list ) {} + +#----------------------------------------------------------------------------- + +## name Postfix control structures +## failures 4 +## cut + +foo() if grep { bar($_) } @list; +foo() unless grep { bar($_) } @list; +foo() while grep { bar($_) } @list; +foo() until grep { bar($_) } @list; + +#----------------------------------------------------------------------------- + +## name Complex booleans +## failures 1 +## cut + +if( 1 && grep { foo($_) } @list ) {} + +#----------------------------------------------------------------------------- + +## name Complex booleans +## failures 1 +## TODO need to detect assignment +## cut + +$bar = grep({foo()} @list) && 1; + +#----------------------------------------------------------------------------- + +## name Complex booleans +## failures 0 +## cut + +1 && grep({foo()} @list) == 0; + +#----------------------------------------------------------------------------- + +## name Complex booleans +## failures 1 +## cut + +1 && grep({foo()} @list) && 0; + +#----------------------------------------------------------------------------- + +## name Complex booleans +## failures 1 +## TODO detect end of statement +## cut + +1 && grep({foo()} @list); + +#----------------------------------------------------------------------------- + +## name Complex booleans +## failures 1 +## cut + +(1 && grep({foo()} @list)) + +#----------------------------------------------------------------------------- + +## name code coverage... +## failures 1 +## cut + +(1 && grep); + +#----------------------------------------------------------------------------- + +## name code coverage... +## failures 0 +## cut + +$hash->{grep}; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/BuiltinFunctions/ProhibitComplexMappings.run b/t/BuiltinFunctions/ProhibitComplexMappings.run new file mode 100644 index 0000000..dfd9e82 --- /dev/null +++ b/t/BuiltinFunctions/ProhibitComplexMappings.run @@ -0,0 +1,63 @@ +## name Basic passing +## failures 0 +## cut + +map {$_} @list; +map {substr $_, 0, 10;} @list; +map {foo($_)} @list; +map {{$_ => 1}} @list; + +map $_, @list; +map substr($_, 0, 10), @list; +map foo($_), @list; +map {$_ => 1}, @list; + +$foo{map}; # for Devel::Cover +{map}; # for Devel::Cover +map(); + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 2 +## cut + +map {my $a = $foo{$_};$a} @list; +map {if ($_) { 1 } else { 2 }} @list; + +#----------------------------------------------------------------------------- + +## name Compound statements (false negative) +## failures 0 +## cut + +map {do {$a; $b}} @list; +map do {$a; $b}, @list; + +#----------------------------------------------------------------------------- + +## name Vary config parameters: success +## failures 0 +## parms {max_statements => 2} +## cut + +map {my $a = $foo{$_};$a} @list; + +#----------------------------------------------------------------------------- + +## name Vary config parameters: failue +## failures 1 +## parms {max_statements => 2} +## cut + +map {my $a = $foo{$_};$a;$b} @list; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/BuiltinFunctions/ProhibitLvalueSubstr.run b/t/BuiltinFunctions/ProhibitLvalueSubstr.run new file mode 100644 index 0000000..4427580 --- /dev/null +++ b/t/BuiltinFunctions/ProhibitLvalueSubstr.run @@ -0,0 +1,66 @@ +## name lvalue +## failures 1 +## cut + +substr( $foo, 2, 1 ) = 'XYZ'; + +#----------------------------------------------------------------------------- + +## name 4 arg substr +## failures 0 +## cut + +substr $foo, 2, 1, 'XYZ'; + +#----------------------------------------------------------------------------- + +## name rvalue +## failures 0 +## cut + +$bar = substr( $foo, 2, 1 ); + +#----------------------------------------------------------------------------- + +## name hash rvalue +## failures 0 +## cut + +%bar = ( foobar => substr( $foo, 2, 1 ) ); + +#----------------------------------------------------------------------------- + +## name substr as word +## failures 0 +## cut + +$foo{substr}; + +#----------------------------------------------------------------------------- + +## name low precedence boolean blocks assignment +## failures 0 +## cut + +'x' eq substr $foo, 0, 1 or $foo = 'x' . $foo; + +#----------------------------------------------------------------------------- + +## name allow under really old Perl. RT #59112 +## failures 0 +## cut + +use 5.004; + +substr( $foo, 0, 0 ) = 'bar'; + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/BuiltinFunctions/ProhibitReverseSortBlock.run b/t/BuiltinFunctions/ProhibitReverseSortBlock.run new file mode 100644 index 0000000..6cb25a5 --- /dev/null +++ b/t/BuiltinFunctions/ProhibitReverseSortBlock.run @@ -0,0 +1,51 @@ +## name Basic passing +## failures 0 +## cut + +reverse sort {$a <=> $b} @list; +reverse sort {$a->[0] <=> $b->[0] && $a->[1] <=> $b->[1]} @list; +sort {$beta{$a} <=> $alpha{$b}} @list; +reverse sort({$a <=> $b} @list); +reverse sort({$a->[0] <=> $b->[0] && $a->[1] <=> $b->[1]} @list); +sort({$beta{$a} <=> $alpha{$b}} @list); + +sort{ $isopen{$a}->[0] <=> $isopen{$b}->[0] } @list; + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 3 +## cut + +sort {$b <=> $a} @list; +sort {$alpha{$b} <=> $beta{$a}} @list; +sort {$b->[0] <=> $a->[0] && $b->[1] <=> $a->[1]} @list; + +#----------------------------------------------------------------------------- + +## name Things that might look like sorts, but aren't, and sorts not involving $a and $b. +## failures 0 +## cut + +$hash1{sort} = { $b <=> $a }; +%hash2 = (sort => { $b <=> $a }); +$foo->sort({ $b <=> $a }); +sub sort { $b <=> $a } +sort 'some_sort_func', @list; +sort('some_sort_func', @list); +sort(); + +{sort}; # for Devel::Cover + +is( pcritique($policy, \$code), 0, $policy ); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/BuiltinFunctions/ProhibitShiftRef.run b/t/BuiltinFunctions/ProhibitShiftRef.run new file mode 100644 index 0000000..84eb2fb --- /dev/null +++ b/t/BuiltinFunctions/ProhibitShiftRef.run @@ -0,0 +1,58 @@ +## name Basic passing +## failures 0 +## cut + +my $a = shift; +my ($b, $c) = (shift, shift); +my $d = shift(); +my $e = shift @ARGV; +my $f = shift(@ARGV); +my $g = shift @_; +my @h = (shift @_); +shift; +{ shift() } + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 4 +## cut + +my $a = \shift; +my $b = \ shift; +my ($c1, $c2) = (shift, \shift); +my ($d1, @d2) = (\shift, @_); + +#----------------------------------------------------------------------------- + +## name Named array failure +## failures 4 +## cut + +my $a = \shift @ARGV; +my $b = \shift(@ARGV); +my $c = \shift @_; +my $d = (\shift @_); + +#----------------------------------------------------------------------------- + +## name Structure failure +## failures 2 +## cut + +my $a = \{ shift() }; +my $b = \{shift}; + +#----------------------------------------------------------------------------- + +## name Tricksy, but passing +## failures 0 +## cut + +my $a = \(shift); +my $b = \(shift()); +my $c = \(shift @ARGV); +my $d = \(shift(@_)); +my $e = \(0, shift); + +#----------------------------------------------------------------------------- diff --git a/t/BuiltinFunctions/ProhibitSleepViaSelect.run b/t/BuiltinFunctions/ProhibitSleepViaSelect.run new file mode 100644 index 0000000..bdf4b5e --- /dev/null +++ b/t/BuiltinFunctions/ProhibitSleepViaSelect.run @@ -0,0 +1,80 @@ +## name sleep, as list +## failures 1 +## cut + +select( undef, undef, undef, 0.25 ); + +#----------------------------------------------------------------------------- + +## name sleep, as list w/var +## failures 1 +## cut + +select( undef, undef, undef, $time ); + +#----------------------------------------------------------------------------- + +## name sleep, as built-in +## failures 1 +## cut + +select undef, undef, undef, 0.25; + +#----------------------------------------------------------------------------- + +## name select on read +## failures 0 +## cut + +select $vec, undef, undef, 0.25; + +#----------------------------------------------------------------------------- + +## name select on write +## failures 0 +## cut + +select undef, $vec, undef, 0.25; + +#----------------------------------------------------------------------------- + +## name select on error +## failures 0 +## cut + +select undef, undef, $vec, 0.25; + +#----------------------------------------------------------------------------- + +## name select as word +## failures 0 +## cut + +$foo{select}; + +#----------------------------------------------------------------------------- + +## name With three undefs, none of them the timeout. RT #37416 +## failures 0 +## cut + +# Now block until the GUI passes the range back + my $rin = ''; + my $rout = ''; + vec($rin, $parent->fileno(), 1) = 1; + if (select($rout=$rin,undef,undef,undef)) { + my $line; + recv($parent, $line, 1000, 0); + ($first, $last) = split ' ', $line; + } + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/BuiltinFunctions/ProhibitStringyEval.run b/t/BuiltinFunctions/ProhibitStringyEval.run new file mode 100644 index 0000000..a765f54 --- /dev/null +++ b/t/BuiltinFunctions/ProhibitStringyEval.run @@ -0,0 +1,128 @@ +## name Basic passing +## failures 0 +## cut + +eval { some_code() }; +eval( {some_code() } ); +eval(); +{eval}; # for Devel::Cover + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 3 +## cut + +eval "$some_code"; +eval( "$some_code" ); +eval( 'sub {'.$some_code.'}' ); + +#----------------------------------------------------------------------------- + +## name Things that might look like an eval, but aren't +## failures 0 +## cut + +$hash1{eval} = 1; +%hash2 = (eval => 1); + +#----------------------------------------------------------------------------- + +## name Eval of include statement without allow_includes set +## failures 20 +## cut + +eval 'use Foo'; +eval 'require Foo'; +eval 'use Foo 1.2'; +eval 'require Foo 1.2'; +eval 'use Foo qw< blah >'; +eval 'require Foo qw< blah >'; +eval 'use Foo 1.2 qw< blah >'; +eval 'require Foo 1.2 qw< blah >'; + +eval 'use Foo; 1;'; +eval 'require Foo; 1;'; +eval 'use Foo 1.2; 1;'; +eval 'require Foo 1.2; 1;'; +eval 'use Foo qw< blah >; 1;'; +eval 'require Foo qw< blah >; 1;'; +eval 'use Foo 1.2 qw< blah >; 1;'; +eval 'require Foo 1.2 qw< blah >; 1;'; + +eval "use $thingy;"; +eval "require $thingy;"; +eval "use $thingy; 1;"; +eval "require $thingy; 1;"; + +#----------------------------------------------------------------------------- + +## name Eval of include statement with allow_includes set +## failures 0 +## parms { allow_includes => 1 } +## cut + +eval 'use Foo'; +eval 'require Foo'; +eval 'use Foo 1.2'; +eval 'require Foo 1.2'; +eval 'use Foo qw< blah >'; +eval 'require Foo qw< blah >'; +eval 'use Foo 1.2 qw< blah >'; +eval 'require Foo 1.2 qw< blah >'; + +eval 'use Foo; 1;'; +eval 'require Foo; 1;'; +eval 'use Foo 1.2; 1;'; +eval 'require Foo 1.2; 1;'; +eval 'use Foo qw< blah >; 1;'; +eval 'require Foo qw< blah >; 1;'; +eval 'use Foo 1.2 qw< blah >; 1;'; +eval 'require Foo 1.2 qw< blah >; 1;'; + +eval "use $thingy;"; +eval "require $thingy;"; +eval "use $thingy; 1;"; +eval "require $thingy; 1;"; + +#----------------------------------------------------------------------------- + +## name Eval of include statement with allow_includes set but extra stuff afterwards +## failures 3 +## parms { allow_includes => 1 } +## cut + +eval 'use Foo; blah;'; +eval 'require Foo; 2; 1;'; +eval 'use $thingy;'; + +#----------------------------------------------------------------------------- + +## name Eval of "no" include statement with allow_includes set +## failures 1 +## parms { allow_includes => 1 } +## cut + +eval 'no Foo'; + +#----------------------------------------------------------------------------- + +## name Eval a comment (RT #60179) +## failures 1 +## parms { allow_includes => 1 } +## cut + +# Note that absent the desired fix, the following is a fatal error. + +eval("#" . substr($^X, 0, 0)); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/BuiltinFunctions/ProhibitStringySplit.run b/t/BuiltinFunctions/ProhibitStringySplit.run new file mode 100644 index 0000000..cd02800 --- /dev/null +++ b/t/BuiltinFunctions/ProhibitStringySplit.run @@ -0,0 +1,93 @@ +## name Basic passing +## failures 0 +## cut + +# Scalar arg +split $pattern; +split $pattern, $string; +split $pattern, $string, 3; + +# Scalar arg, w/ parens +split($pattern); +split($pattern), $string; +split($pattern), $string, 3; + +# Regex arg +split //; +split //, $string; +split //, $string, 3; + +# Regex arg, w/ parens +split( // ); +split( // ), $string; +split( // ), $string, 3; + +$foo{split}; # for Devel::Cover +{split}; # for Devel::Cover + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 12 +## cut + +# Single quote +split 'pattern'; +split 'pattern', $string; +split 'pattern', $string, 3; + +# Double quote +split "pattern"; +split "pattern", $string; +split "pattern", $string, 3; + +# Single quote, w/ parens +split('pattern'); +split('pattern'), $string; +split('pattern'), $string, 3; + +# Double quote, w/ parens +split("pattern"); +split("pattern"), $string; +split("pattern"), $string, 3; + +#----------------------------------------------------------------------------- + +## name Special split on space +## failures 0 +## cut + +split ' '; +split ' ', $string; +split ' ', $string, 3; + +split( " " ); +split( " " ), $string; +split( " " ), $string, 3; + +split( q{ } ); +split( q{ } ), $string; +split( q{ } ), $string, 3; + +#----------------------------------------------------------------------------- + +## name Split oddities +## failures 0 +## cut + +# These might be technically legal, but they are so hard +# to understand that they might as well be outlawed. + +split @list; +split( @list ); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/BuiltinFunctions/ProhibitUniversalCan.run b/t/BuiltinFunctions/ProhibitUniversalCan.run new file mode 100644 index 0000000..22ee255 --- /dev/null +++ b/t/BuiltinFunctions/ProhibitUniversalCan.run @@ -0,0 +1,27 @@ +## name Basic passing +## failures 0 +## cut + +use UNIVERSAL::can; +require UNIVERSAL::can; +$foo->can($funcname); + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 2 +## cut + +can($foo, $funcname); +UNIVERSAL::can($foo, $funcname); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/BuiltinFunctions/ProhibitUniversalIsa.run b/t/BuiltinFunctions/ProhibitUniversalIsa.run new file mode 100644 index 0000000..1758c5f --- /dev/null +++ b/t/BuiltinFunctions/ProhibitUniversalIsa.run @@ -0,0 +1,27 @@ +## name Basic passing +## failures 0 +## cut + +use UNIVERSAL::isa; +require UNIVERSAL::isa; +$foo->isa($pkg); + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 2 +## cut + +isa($foo, $pkg); +UNIVERSAL::isa($foo, $pkg); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/BuiltinFunctions/ProhibitUselessTopic.run b/t/BuiltinFunctions/ProhibitUselessTopic.run new file mode 100644 index 0000000..0c30caa --- /dev/null +++ b/t/BuiltinFunctions/ProhibitUselessTopic.run @@ -0,0 +1,83 @@ +## name Topics in a filetest +## failures 2 +## cut + +my $x = -s $_; +if ( -f $_ ) { foo(); } + +#----------------------------------------------------------------------------- + +## name Topics in a filetest: -t $_ is not useless because -t defaults to STDIN +## failures 0 +## cut + +if ( -t $_ ) { foo(); } + +#----------------------------------------------------------------------------- + +## name Topics in a function call, with parens +## failures 5 +## cut + +my $x = length($_); +my $y = sin($_); +my $z = defined($_); +my @x = split( /\t/, $_ ); +unlink($_); +# Policy cannot handle this yet. +#my $backwards = reverse($_); + +#----------------------------------------------------------------------------- + +## name Topics in a function call, no parens +## failures 6 +## cut + +my $x = length $_; +my $y = sin $_; +my $z = defined $_; +my @x = split /\t/, $_; +unlink $_; +my $backwards = reverse $_; + +#----------------------------------------------------------------------------- + +## name Function calls with $_ but in ways that should not be flagged. +## failures 0 +## cut + +my @y = split( /\t/, $_, 3 ); +my @y = split /\t/, $_, 3; +unlink $_ . '.txt'; +my $z = sin( $_ * 4 ); +my $a = tan $_ + 5; + +#----------------------------------------------------------------------------- + +## The following two should NOT be flagged as errors. +## TODO see KNOWN BUGS in the policy documentation +## failures 0 +## cut + +my @backwards = reverse $_; +my @backwards = reverse($_); + +#----------------------------------------------------------------------------- + +## name GH #600 +## TODO User reported false positives +## failures 0 +## cut + +$self->zilla->log($_) +foo(lc, $_) + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/BuiltinFunctions/ProhibitVoidGrep.run b/t/BuiltinFunctions/ProhibitVoidGrep.run new file mode 100644 index 0000000..d13059c --- /dev/null +++ b/t/BuiltinFunctions/ProhibitVoidGrep.run @@ -0,0 +1,71 @@ +## name Basic passing +## failures 0 +## cut + +print grep("$foo", @list); +print ( grep "$foo", @list ); +@list = ( grep "$foo", @list ); +$aref = [ grep "$foo", @list ]; +$href = { grep "$foo", @list }; + +if( grep { foo($_) } @list ) {} +for( grep { foo($_) } @list ) {} + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 7 +## cut + +grep "$foo", @list; +grep("$foo", @list); +grep { foo($_) } @list; +grep({ foo($_) } @list); + +if( $condition ){ grep { foo($_) } @list } +while( $condition ){ grep { foo($_) } @list } +for( @list ){ grep { foo($_) } @list } + +#----------------------------------------------------------------------------- + +## name Comma operator +## failures 1 +## TODO not handled properly +## cut + +$baz, grep "$foo", @list; + +#----------------------------------------------------------------------------- + +## name Chained void grep +## failures 1 +## cut + +grep { spam($_) } + grep { foo($_) } + grep { bar($_) } + grep { baz($_) } @list; + +#----------------------------------------------------------------------------- + +## name Subscript grep (RT #79289) +## failures 0 +## cut + +my %hash; + +delete @hash{ grep { m/ foo /smx } keys %hash }; +delete @hash{ grep m/ foo /smx, keys %hash }; +# The following is the form that was actually failing. +delete @hash{ grep ( m/ foo /smx, keys %hash ) }; + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/BuiltinFunctions/ProhibitVoidMap.run b/t/BuiltinFunctions/ProhibitVoidMap.run new file mode 100644 index 0000000..85773aa --- /dev/null +++ b/t/BuiltinFunctions/ProhibitVoidMap.run @@ -0,0 +1,70 @@ +## name Basic passing +## failures 0 +## cut + +$baz, map "$foo", @list; +print map("$foo", @list); +print ( map "$foo", @list ); +@list = ( map $foo, @list ); +$aref = [ map $foo, @list ]; +$href = { map $foo, @list }; + +if( map { foo($_) } @list ) {} +for( map { foo($_) } @list ) {} + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 7 +## cut + +map "$foo", @list; +map("$foo", @list); +map { foo($_) } @list; +map({ foo($_) } @list); + +if( $condition ){ map { foo($_) } @list } +while( $condition ){ map { foo($_) } @list } +for( @list ){ map { foo($_) } @list } + +#----------------------------------------------------------------------------- + +## name Chained void map +## failures 1 +## cut + +map { foo($_) } + map { bar($_) } + map { baz($_) } @list; + +#----------------------------------------------------------------------------- + +## name not builtin map +## failures 0 +## cut + +$self->map('Pennsylvania Ave, Washington, DC'); + +#----------------------------------------------------------------------------- + +## name Subscript map (derived from RT #79289) +## failures 0 +## cut + +my %hash; + +delete @hash{ map { uc $_ } keys %hash }; +delete @hash{ map uc( $_ ), keys %hash }; +# This is the form analogous to what failed under RT #79289. +delete @hash{ map ( uc( $_ ), keys %hash ) }; + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/BuiltinFunctions/RequireBlockGrep.run b/t/BuiltinFunctions/RequireBlockGrep.run new file mode 100644 index 0000000..cdb0d34 --- /dev/null +++ b/t/BuiltinFunctions/RequireBlockGrep.run @@ -0,0 +1,41 @@ +## name Basic passing +## failures 0 +## cut + +grep {$_ eq 'foo'} @list; +@matches = grep {$_ eq 'foo'} @list; +grep( {$_ eq 'foo'} @list ); +@matches = grep( {$_ eq 'foo'} @list ) +grep(); +@matches = grep(); +{grep}; # for Devel::Cover +grelp $_ eq 'foo', @list; # deliberately misspell grep + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 2 +## cut + +grep $_ eq 'foo', @list; +@matches = grep $_ eq 'foo', @list; + +#----------------------------------------------------------------------------- + +## name Things that may look like a grep, but aren't +## failures 0 +## cut + +$hash1{grep} = 1; +%hash2 = (grep => 1); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/BuiltinFunctions/RequireBlockMap.run b/t/BuiltinFunctions/RequireBlockMap.run new file mode 100644 index 0000000..c3467a2 --- /dev/null +++ b/t/BuiltinFunctions/RequireBlockMap.run @@ -0,0 +1,41 @@ +## name Basic passing +## failures 0 +## cut + +map {$_++} @list; +@foo = map {$_++} @list; +map( {$_++} @list ); +@foo = map( {$_++} @list ); +map(); +@foo = map(); +{map}; # for Devel::Cover +malp $_++, @list; # deliberately misspell map + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 2 +## cut + +map $_++, @list; +@foo = map $_++, @list; + +#----------------------------------------------------------------------------- + +## name Things that may look like a map, but aren't +## failures 0 +## cut + +$hash1{map} = 1; +%hash2 = (map => 1); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/BuiltinFunctions/RequireGlobFunction.run b/t/BuiltinFunctions/RequireGlobFunction.run new file mode 100644 index 0000000..6eaa337 --- /dev/null +++ b/t/BuiltinFunctions/RequireGlobFunction.run @@ -0,0 +1,44 @@ +## name glob via <...> +## failures 1 +## cut + +@files = <*.pl>; + +#----------------------------------------------------------------------------- + +## name glob via <...> in foreach +## failures 1 +## cut + +foreach my $file (<*.pl>) { + print $file; +} + +#----------------------------------------------------------------------------- + +## name Multiple globs via <...> +## failures 2 +## cut + +@files = (<*.pl>, <*.pm>); + +#----------------------------------------------------------------------------- + +## name I/O +## failures 0 +## cut + +while (<$fh>) { + print $_; +} + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/BuiltinFunctions/RequireSimpleSortBlock.run b/t/BuiltinFunctions/RequireSimpleSortBlock.run new file mode 100644 index 0000000..a1f5610 --- /dev/null +++ b/t/BuiltinFunctions/RequireSimpleSortBlock.run @@ -0,0 +1,52 @@ +## name Basic passing +## failures 0 +## cut + +sort @list; +sort {$a cmp $b;} @list; +sort {$a->[0] <=> $b->[0] && $a->[1] <=> $b->[1]} @list; +sort {bar($a,$b)} @list; +sort 'func', @list; + +sort(@list); +sort({$a cmp $b;} @list); +sort({$a->[0] <=> $b->[0] && $a->[1] <=> $b->[1]} @list); +sort({bar($a,$b)} @list); +sort('func', @list); + +$foo{sort}; # for Devel::Cover +{sort}; # for Devel::Cover +sort(); + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 1 +## cut + +sort {my $aa = $foo{$a};my $b = $foo{$b};$a cmp $b} @list; + +#----------------------------------------------------------------------------- + +## name Potential false positives +## failures 0 +## cut + +# These are things I found in my Perl that caused some false- +# positives because they have some extra whitespace in the block. + +sort { $a->[2] cmp $b->[2] } @dl; +sort { $a->[0] <=> $b->[0] } @failed; +sort{ $isopen{$a}->[0] <=> $isopen{$b}->[0] } @list; +sort { -M $b <=> -M $a} @entries; + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ClassHierarchies/ProhibitAutoloading.run b/t/ClassHierarchies/ProhibitAutoloading.run new file mode 100644 index 0000000..66a8b62 --- /dev/null +++ b/t/ClassHierarchies/ProhibitAutoloading.run @@ -0,0 +1,37 @@ +## name Basic passing +## failures 0 +## cut + +sub autoload {} +my $AUTOLOAD = 'foo'; +our @AUTOLOAD = qw(nuts); + +#----------------------------------------------------------------------------- + +## name Empty AUTOLOAD() +## failures 1 +## cut + +sub AUTOLOAD {} + +#----------------------------------------------------------------------------- + +## name AUTOLOAD() with code +## failures 1 +## cut + +sub AUTOLOAD { + $foo, $bar = @_; + return $baz; +} + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ClassHierarchies/ProhibitExplicitISA.run b/t/ClassHierarchies/ProhibitExplicitISA.run new file mode 100644 index 0000000..00e8b90 --- /dev/null +++ b/t/ClassHierarchies/ProhibitExplicitISA.run @@ -0,0 +1,27 @@ +## name Basic passing +## failures 0 +## cut + +print @Foo::ISA; +use base 'Foo'; + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 3 +## cut + +our @ISA = qw(Foo); +push @ISA, 'Foo'; +@ISA = ('Foo'); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ClassHierarchies/ProhibitOneArgBless.run b/t/ClassHierarchies/ProhibitOneArgBless.run new file mode 100644 index 0000000..de0bcae --- /dev/null +++ b/t/ClassHierarchies/ProhibitOneArgBless.run @@ -0,0 +1,37 @@ +## name Basic passing +## failures 0 +## cut + +my $self = bless {}, 'foo'; +my $self = bless( {}, 'foo' ); +my $self = bless [], 'foo'; +my $self = bless( [], 'foo' ); +my $self = bless {} => 'foo'; + +$baz{bless}; # not a function call +$bar->bless('foo'); # method call + +$data{"attachment_$index"} = bless([ $files->[$i] ], "Attachment"); + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 4 +## cut + +my $self = bless {}; +my $self = bless []; + +my $self = bless( {} ); +my $self = bless( [] ); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/CodeLayout/ProhibitParensWithBuiltins.run b/t/CodeLayout/ProhibitParensWithBuiltins.run new file mode 100644 index 0000000..639e439 --- /dev/null +++ b/t/CodeLayout/ProhibitParensWithBuiltins.run @@ -0,0 +1,153 @@ +## name Basic failure +## failures 6 +## cut + +open ($foo, $bar); +open($foo, $bar); +uc(); +lc(); + +# These ones deliberately omit the semi-colon +sub {uc()} +sub {reverse()} + +#----------------------------------------------------------------------------- + +## name Basic passing +## failures 0 +## cut + +open $foo, $bar; +uc $foo; +lc $foo; +my $foo; +my ($foo, $bar); +our ($foo, $bar); +local ($foo $bar); +return ($foo, $bar); +return (); +my_subroutine($foo $bar); +{print}; # for Devel::Cover + +#----------------------------------------------------------------------------- + +## name Method invocation +## failures 0 +## cut + +my $obj = SomeClass->new(); +$obj->open(); +$obj->close(); +$obj->prototype(); +$obj->delete(); + +is( pcritique($policy, \$code), 0, $policy); + +#----------------------------------------------------------------------------- + +## name Unary operators with parens, followed by a high-precedence operator +## failures 0 +## cut + +$foo = int( 0.5 ) + 1.5; +$foo = int( 0.5 ) - 1.5; +$foo = int( 0.5 ) * 1.5; +$foo = int( 0.5 ) / 1.5; +$foo = int( 0.5 ) ** 1.5; + +$foo = oct( $foo ) + 1; +$foo = ord( $foo ) - 1; +$foo = sin( $foo ) * 2; +$foo = uc( $foo ) . $bar; +$foo = lc( $foo ) . $bar; + +$nanosecond = int ( ($value - $epoch) * $NANOSECONDS_PER_SECOND ); + +#----------------------------------------------------------------------------- + +## name RT #21713 +## failures 0 +## cut + +print substr($foo, 2, 3), "\n"; +if ( unpack('V', $foo) == 2 ) { } + +#----------------------------------------------------------------------------- + +## name Parentheses with greedy functions +## failures 0 +## cut + +substr join( $delim, @list), $offset, $length; +print reverse( $foo, $bar, $baz), $nuts; +sort map( {some_func($_)} @list1 ), @list2; + +#----------------------------------------------------------------------------- + +## name Test cases from RT +## failures 0 +## cut + +chomp( my $foo = ); +defined( my $child = shift @free_children ) +return ( $start_time + $elapsed_hours ) % $hours_in_day; + +#----------------------------------------------------------------------------- + +## name High-precedence operator after parentheses +## failures 0 +## cut + +grep( { do_something($_) }, @list ) + 3; +join( $delim, @list ) . "\n"; +pack( $template, $foo, $bar ) . $suffix; +chown( $file1, $file2 ) || die q{Couldn't chown}; + +#----------------------------------------------------------------------------- + +## name Low-precedence operator after parentheses +## failures 2 +## cut + +grep( { do_something($_) }, $foo, $bar) and do_something(); +chown( $file1, $file2 ) or die q{Couldn't chown}; + +#----------------------------------------------------------------------------- + +## name Named unary op with operator inside parenthesis (RT #46862) +## failures 0 +## cut + +length( $foo // $bar ); +stat( $foo || $bar ); +uc( $this & $that ); + +#----------------------------------------------------------------------------- + +## name Handling sort having subroutine name as an argument +## failures 0 +## cut + +sort(foo(@x)); +[ sort ( modules_used_in_string( $code ) ) ] + +#----------------------------------------------------------------------------- + +## name RT 52029 - Accept parens with 'state' +## failures 0 +## cut + +use 5.010; + +state ( $foo ); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/CodeLayout/ProhibitQuotedWordLists.run b/t/CodeLayout/ProhibitQuotedWordLists.run new file mode 100644 index 0000000..0f2b7a8 --- /dev/null +++ b/t/CodeLayout/ProhibitQuotedWordLists.run @@ -0,0 +1,104 @@ +## name Basic failure +## failures 2 +## cut + +@list = ('foo', 'bar', 'baz-bot'); + +@list = ('foo', + 'bar', + 'baz-bot'); + +#----------------------------------------------------------------------------- + +## name Non-word lists +## failures 0 +## cut + +@list = ('3/4', '-123', '#@$%'); + +@list = ('3/4', + '-123', + '#@$%'); + +#----------------------------------------------------------------------------- + +## name Basic passing +## failures 0 +## cut + +('foo'); +@list = (); +@list = ('foo'); +@list = ('foo', 'bar', 'bee baz'); +@list = ('foo', 'bar', q{bee baz}); +@list = ('foo', 'bar', q{}); +@list = ('foo', 'bar', 1.0); +@list = ('foo', 'bar', 'foo'.'bar'); +@list = ($foo, 'bar', 'baz'); +@list = (foo => 'bar'); +%hash = ('foo' => 'bar', 'fo' => 'fum'); +my_function('foo', 'bar', 'fudge'); +&my_function('foo', 'bar', 'fudge'); +$an_object->a_method('foo', 'bar', 'fudge'); +$a_sub_routine_ref->('foo', 'bar', 'fudge'); +foreach ('foo', 'bar', 'nuts'){ do_something($_) } + +#----------------------------------------------------------------------------- + +## name Three elements with minimum set to four +## failures 0 +## parms {min_elements => 4} +## cut + +@list = ('foo', 'bar', 'baz'); + +#----------------------------------------------------------------------------- + +## name Four elements with minimum set to four +## failures 1 +## parms {min_elements => 4} +## cut + +@list = ('foo', 'bar', 'baz', 'nuts'); + +#----------------------------------------------------------------------------- + +## name Failing 'use' statements +## failures 1 +## cut + +use Foo ('foo', 'bar', 'baz'); + +#----------------------------------------------------------------------------- + +## name Passing 'use' statements +## failures 0 +## cut + +use Foo (); +use Foo ('foo', 1, 'bar', '1/2'); +use Foo ('foo' => 'bar', 'baz' => 'nuts'); + +## name Non-word lists in strict mode. +## failures 3 +## parms { strict => 1 } +## cut + +use Foo ('foo', 'bar', '1/2'); + +@list = ('3/4', '-123', '#@$%'); + +@list = ('3/4', + '-123', + '#@$%'); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/CodeLayout/RequireTrailingCommas.run b/t/CodeLayout/RequireTrailingCommas.run new file mode 100644 index 0000000..e5b5be4 --- /dev/null +++ b/t/CodeLayout/RequireTrailingCommas.run @@ -0,0 +1,115 @@ +## name Basic passing +## failures 0 +## cut + +($foo, + $bar, + $baz +); +@list = ($foo, $bar, $baz); +@list = some_function($foo, $bar, $baz); +@list = ($baz); +@list = (); + +@list = ( +); + +@list = ($baz +); + +@list = ($baz + ); + +# not a straight assignment +@list = ((1,2,3),( + 1, + 2, + 3 +)); + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 3 +## cut + +@list = ($foo, + $bar, + $baz); + +@list = ($foo, + $bar, + $baz + ); + +@list = ($foo, + $bar, + $baz +); + +#----------------------------------------------------------------------------- + +## name List assignment +## failures 0 +## cut + +@list = ($foo, + $bar, + $baz,); + +@list = ($foo, + $bar, + $baz, +); + +@list = ($foo, + $bar, + $baz, + ); + +#----------------------------------------------------------------------------- + +## name Conditionals and mathematical precedence +## failures 0 +## cut + +$foo = ( 1 > 2 ? + $baz : + $nuts ); + +$bar = ( $condition1 + && ( $condition2 + || $condition3 ) + ); + + +# These were reported as false-positives. +# See http://rt.cpan.org/Ticket/Display.html?id=18297 + +$median = ( $times[ int $array_size / 2 ] + + $times[(int $array_size / 2) - 1 ]) / 2; + +$median = ( $times[ int $array_size / 2 ] + + $times[ int $array_size / 2 - 1 ]) / 2; + +#----------------------------------------------------------------------------- + +## name code coverage +## failures 1 +## cut + +@list = ($foo, + $bar, + $baz -- + ); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ControlStructures/ProhibitCStyleForLoops.run b/t/ControlStructures/ProhibitCStyleForLoops.run new file mode 100644 index 0000000..0ad253d --- /dev/null +++ b/t/ControlStructures/ProhibitCStyleForLoops.run @@ -0,0 +1,38 @@ +## name Basic passing +## failures 0 +## cut + +for(@list){ + do_something(); +} + +for my $element (@list){ + do_something(); +} + +foreach my $element (@list){ + do_something(); +} + +do_something() for @list; + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 1 +## cut + +for($i=0; $i<=$max; $i++){ + do_something(); +} + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ControlStructures/ProhibitCascadingIfElse.run b/t/ControlStructures/ProhibitCascadingIfElse.run new file mode 100644 index 0000000..48b88ae --- /dev/null +++ b/t/ControlStructures/ProhibitCascadingIfElse.run @@ -0,0 +1,84 @@ +## name Basic passing +## failures 0 +## cut + +if ($condition1){ + $foo; +} +elsif ($condition2){ + $bar; +} +elsif ($condition3){ + $bar; +} +else { + $nuts; +} + +if ($condition1){ + $foo; +} +else { + $nuts; +} + +if ($condition1){ + $foo; +} + +foreach (1,2,3){ + $foo; +} + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 1 +## cut + +if ($condition1){ + $foo; +} +elsif ($condition2){ + $bar; +} +elsif ($condition3){ + $baz; +} +elsif ($condition4){ + $barf; +} +else { + $nuts; +} + +#----------------------------------------------------------------------------- + +## name With custom max_elsif value. +## failures 1 +## parms {max_elsif => 1} +## cut + +if ($condition1){ + $foo; +} +elsif ($condition2){ + $bar; +} +elsif ($condition3){ + $baz; +} +else { + $nuts; +} + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ControlStructures/ProhibitDeepNests.run b/t/ControlStructures/ProhibitDeepNests.run new file mode 100644 index 0000000..0c1c0cf --- /dev/null +++ b/t/ControlStructures/ProhibitDeepNests.run @@ -0,0 +1,132 @@ +## name 6 for loops +## failures 1 +## cut + +for $element1 ( @list1 ) { + foreach $element2 ( @list2 ) { + for $element3 ( @list3 ) { + foreach $element4 ( @list4 ) { + for $element5 ( @list5 ) { + for $element6 ( @list6 ) { + } + } + } + } + } +} + +#----------------------------------------------------------------------------- + +## name 6 if blocks +## failures 1 +## cut + +if ($condition1) { + if ($condition2) { + if ($condition3) { + if ($condition4) { + if ($condition5) { + if ($condition6) { + } + } + } + } + } +} + +#----------------------------------------------------------------------------- + +## name 6 if blocks, not nested +## failures 0 +## cut + +if ($condition1) { + if ($condition2) {} + if ($condition3) {} + if ($condition4) {} + if ($condition5) {} + if ($condition6) {} +} + +#----------------------------------------------------------------------------- + +## name 6 for loops, not nested +## failures 0 +## cut + +for $element1 ( @list1 ) { + foreach $element2 ( @list2 ) {} + for $element3 ( @list3 ) {} + foreach $element4 ( @list4 ) {} + for $element5 ( @list5 ) {} + foreach $element6 ( @list6 ) {} +} + +#----------------------------------------------------------------------------- + +## name 6 mixed nests +## failures 1 +## cut + +if ($condition) { + foreach ( @list ) { + until ($condition) { + for (my $i=0; $<10; $i++) { + if ($condition) { + while ($condition) { + } + } + } + } + } +} + +is( pcritique($policy, \$code), 1, ''); + +#----------------------------------------------------------------------------- + +## name Configurable +## failures 0 +## parms {max_nests => 6} +## cut + +if ($condition) { + foreach ( @list ) { + until ($condition) { + for (my $i=0; $<10; $i++) { + if ($condition) { + while ($condition) { + } + } + } + } + } +} + +#----------------------------------------------------------------------------- + +## name With postfixes +## failures 0 +## cut + +if ($condition) { + s/foo/bar/ for @list; + until ($condition) { + for (my $i=0; $<10; $i++) { + die if $condition; + while ($condition) { + } + } + } +} + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ControlStructures/ProhibitLabelsWithSpecialBlockNames.run b/t/ControlStructures/ProhibitLabelsWithSpecialBlockNames.run new file mode 100644 index 0000000..6bf3327 --- /dev/null +++ b/t/ControlStructures/ProhibitLabelsWithSpecialBlockNames.run @@ -0,0 +1,44 @@ +## name Basic passing +## failures 0 +## cut + +BEGIN { $x = 1; } +END { $x = 1; } +CHECK { $x = 1; } +INIT { $x = 1; } +UNITCHECK { $x = 1; } + +#----------------------------------------------------------------------------- + +## name Failure, cuddled colon +## failures 5 +## cut + +BEGIN: { $x = 1; } +END: { $x = 1; } +CHECK: { $x = 1; } +INIT: { $x = 1; } +UNITCHECK: { $x = 1; } + +#----------------------------------------------------------------------------- + +## name Failure, uncuddled colon +## failures 5 +## cut + +BEGIN : { $x = 1; } +END : { $x = 1; } +CHECK : { $x = 1; } +INIT : { $x = 1; } +UNITCHECK : { $x = 1; } + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ControlStructures/ProhibitMutatingListFunctions.run b/t/ControlStructures/ProhibitMutatingListFunctions.run new file mode 100644 index 0000000..2ba4845 --- /dev/null +++ b/t/ControlStructures/ProhibitMutatingListFunctions.run @@ -0,0 +1,208 @@ +## name Assignment and op-assignment +## failures 4 +## cut + +# TODO: PPI as of 1.215 doesn't parse all of the augmented assignment +# operators, so we can't do exhaustive testing. +@bar = map {$_ = 1} @foo; +@bar = map {$_ *= 2} @foo; +@bar = map {$_++} @foo; +@bar = map {$_--} @foo; + +#----------------------------------------------------------------------------- + +## name ++ and -- operators +## failures 2 +## cut + +@bar = map {++$_} @foo; +@bar = map {--$_} @foo; + +#----------------------------------------------------------------------------- + +## name Explicit regexes +## failures 3 +## cut + +@bar = map {$_ =~ s/f/g/} @foo; +@bar = map {$_ =~ tr/f/g/} @foo; +@bar = map {$_ =~ y/f/g/} @foo; + +#----------------------------------------------------------------------------- + +## name Simple implicit regexps +## failures 3 +## cut + +@bar = map {s/f/g/} @foo; +@bar = map {tr/f/g/} @foo; +@bar = map {y/f/g/} @foo; + +#----------------------------------------------------------------------------- + +## name "Hidden" implicit regexps +## failures 3 +## cut + +@bar = map {my $c = s/f/g/g; $c} @foo; +@bar = map {my $c = tr/f/g/g; $c} @foo; +@bar = map {my $c = y/f/g/g; $c} @foo; + +#----------------------------------------------------------------------------- + +## name Implicit chomp-ish builtins +## failures 2 +## cut + +@bar = map {chop} @foo; +@bar = map {chomp} @foo; +@bar = map {undef} @foo; + +#----------------------------------------------------------------------------- + +## name Explicit chomp-ish builtins +## failures 3 +## cut + +@bar = map {chop $_} @foo; +@bar = map {chomp $_} @foo; +@bar = map {undef $_} @foo; + +#----------------------------------------------------------------------------- + +## name substr +## failures 1 +## cut + +@bar = map {substr $_, 0, 1, 'f'} @foo; + +#----------------------------------------------------------------------------- + +## name Non-mutators +## failures 0 +## cut + +@bar = map {$_} @foo; +@bar = map {$_ => 1} @foo; +@bar = map {m/4/} @foo; +@bar = map {my $s=$_; chomp $s; $s} @foo; + +#----------------------------------------------------------------------------- + +## name Value given for list_funcs passing +## failures 0 +## parms {list_funcs => ' foo bar '} +## cut + +@bar = map {$_=1} @foo; +@bar = foo {$_} @foo; +@bar = baz {$_=1} @foo; + +#----------------------------------------------------------------------------- + +## name Value given for list_funcs failure +## failures 1 +## parms {list_funcs => ' foo bar '} +## cut + +@bar = foo {$_=1} @foo; + +#----------------------------------------------------------------------------- + +## name Value given for add_list_funcs +## failures 2 +## parms {add_list_funcs => ' foo bar '} +## cut + +@bar = map {$_=1} @foo; +@bar = foo {$_=1} @foo; + +#----------------------------------------------------------------------------- + +## name Accept non-mutating tr/// function. RT 44515 +## failures 0 +## cut + +@bar = map {$_ =~ tr/f//} @foo; +@bar = map {$_ =~ tr/f//c} @foo; +@bar = map {$_ =~ tr/f/f/} @foo; +@bar = map {$_ =~ tr/f/f/d} @foo; +@bar = map {$_ =~ y/f//} @foo; +@bar = map {$_ =~ y/f//c} @foo; +@bar = map {$_ =~ y/f/f/} @foo; +@bar = map {$_ =~ y/f/f/d} @foo; +@bar = map {tr/f//} @foo; +@bar = map {tr/f//c} @foo; +@bar = map {tr/f/f/} @foo; +@bar = map {tr/f/f/d} @foo; +@bar = map {y/f//} @foo; +@bar = map {y/f//c} @foo; +@bar = map {y/f/f/} @foo; +@bar = map {y/f/f/d} @foo; +@bar = map {my $c = tr/f//; $c} @foo; +@bar = map {my $c = tr/f//c; $c} @foo; +@bar = map {my $c = tr/f/f/; $c} @foo; +@bar = map {my $c = tr/f/f/d; $c} @foo; +@bar = map {my $c = y/f//; $c} @foo; +@bar = map {my $c = y/f//c; $c} @foo; +@bar = map {my $c = y/f/f/; $c} @foo; +@bar = map {my $c = y/f/f/d; $c} @foo; + +#----------------------------------------------------------------------------- + +## name Recognize mutating tr/// function. RT 44515 +## failures 24 +## cut + +@bar = map {$_ =~ tr/f//d} @foo; +@bar = map {$_ =~ tr/f/f/c} @foo; +@bar = map {$_ =~ tr/f//s} @foo; +@bar = map {$_ =~ tr/f/f/s} @foo; +@bar = map {$_ =~ y/f//d} @foo; +@bar = map {$_ =~ y/f/f/c} @foo; +@bar = map {$_ =~ y/f//s} @foo; +@bar = map {$_ =~ y/f/f/s} @foo; +@bar = map {tr/f//d} @foo; +@bar = map {tr/f/f/c} @foo; +@bar = map {tr/f//s} @foo; +@bar = map {tr/f/f/s} @foo; +@bar = map {y/f//d} @foo; +@bar = map {y/f/f/c} @foo; +@bar = map {y/f//s} @foo; +@bar = map {y/f/f/s} @foo; +@bar = map {my $c = tr/f//d; $c} @foo; +@bar = map {my $c = tr/f/f/c; $c} @foo; +@bar = map {my $c = tr/f//s; $c} @foo; +@bar = map {my $c = tr/f/f/s; $c} @foo; +@bar = map {my $c = y/f//d; $c} @foo; +@bar = map {my $c = y/f/f/c; $c} @foo; +@bar = map {my $c = y/f//s; $c} @foo; +@bar = map {my $c = y/f/f/s; $c} @foo; + +#----------------------------------------------------------------------------- + +## name Recognize non-mutating s///r function introduced in 5.13.2. +## failures 0 +## cut + +@bar = map { s/cat/dog/r } @foo; + +#----------------------------------------------------------------------------- + +## name Recognize non-mutating tr///r function introduced in 5.13.7. +## failures 0 +## cut + +@bar = map { tr/cat/dog/r } @foo; +@bar = map { y/cat/dog/r } @foo; + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.run.PL b/t/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.run.PL new file mode 100644 index 0000000..56938d1 --- /dev/null +++ b/t/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.run.PL @@ -0,0 +1,305 @@ +#!/usr/bin/env perl + +use 5.006001; +use strict; +use warnings; + +use English qw< -no_match_vars >; +use Carp qw< confess >; + +use Carp qw< confess >; +use Fatal qw< open close >; + +my $this_program = __FILE__; +(my $test_file_name = $this_program) =~ s/ [.] PL \z //xms; +if ($this_program eq $test_file_name) { + confess + 'Was not able to figure out the name of the file to generate.' + . "This program: $this_program."; +} + +print "\n\nGenerating $test_file_name.\n"; + + + +open my $test_file, '>', $test_file_name ## no critic (RequireBriefOpen) + or confess "Could not open $test_file_name: $ERRNO"; + + +print {$test_file} <<"END_HEADER"; +# Do not edit!!! This test suite generated by $this_program. +END_HEADER + +foreach my $operator ( qw/ ! not / ) { + emit_not_operator_code($test_file, $operator); +} +emit_not_match_code($test_file); +foreach my $operator ( qw/ ne != < > <= >= <=> lt gt le ge cmp / ) { + emit_comparator_code($test_file, $operator); +} + + +print {$test_file} <<'END_FOOTER'; + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : +END_FOOTER + + +close $test_file; +print "Done.\n\n"; + +#----------------------------------------------------------------------------- + +sub emit_not_operator_code { + my ($test_file, $operator) = @_; + + print {$test_file} <<"END_NOT_OPERATOR_CODE"; + +## name "$operator" within positive control structures +## failures 0 +## cut + +if ($operator \$foo) { + blah(); +} + +if (\$foo) { + blah(\$foo); +} +elsif ($operator \$bar) { + blah(\$bar); +} +else { + blah(undef); +} + +while ($operator \$foo) { + blah(); +} + +foreach my \$bar ( grep { $operator \$_ } \@foo ) { + blah(\$bar); +} + +for (my \$bar = 0; $operator \$bar; \$bar++) { + blah(\$bar); +} + +#----------------------------------------------------------------------------- + +## name "$operator" within positive postfix statement modifiers +## failures 0 +## cut + +blah() if $operator \$foo; + +blah() while $operator \$foo; + +blah(\$_) for grep { $operator \$_ } \@foo; + +#----------------------------------------------------------------------------- + +## name "$operator" within negative control structures +## failures 2 +## cut + +unless ($operator \$foo) { + blah(); +} + +until ($operator \$foo) { + blah(); +} + +#----------------------------------------------------------------------------- + +## name "$operator" within negative postfix statement modifiers +## failures 2 +## cut + +blah() unless $operator \$foo; + +blah() until $operator \$foo; + +#----------------------------------------------------------------------------- +END_NOT_OPERATOR_CODE + + return; +} + +#----------------------------------------------------------------------------- + +sub emit_not_match_code { + my ($test_file) = @_; + + print {$test_file} <<'END_NOT_MATCH_CODE'; + +## name "!~" within positive control structures +## failures 0 +## cut + +if ($foo !~ m/bar/) { + blah(); +} + +if ($foo) { + blah($foo); +} +elsif ($bar !~ m/bar/) { + blah($bar); +} +else { + blah(undef); +} + +while ($foo !~ m/bar/) { + blah(); +} + +foreach my $bar ( grep { $_ !~ m/baz/ } @foo ) { + blah($bar); +} + +for (my $bar = 0; $bar =~ m/baz/; $bar++) { + blah($bar); +} + +#----------------------------------------------------------------------------- + +## name "!~" within positive postfix statement modifiers +## failures 0 +## cut + +blah() if $foo !~ m/bar/; + +blah() while $foo !~ m/bar/; + +blah($_) for grep { $_ !~ m/bar/ } @foo; + +#----------------------------------------------------------------------------- + +## name "!~" within negative control structures +## failures 2 +## cut + +unless ($foo !~ m/bar/) { + blah(); +} + +until ($foo !~ m/bar/) { + blah(); +} + +#----------------------------------------------------------------------------- + +## name "!~" within negative postfix statement modifiers +## failures 2 +## cut + +blah() unless $foo !~ m/bar/; + +blah() until $foo !~ m/bar/; + +#----------------------------------------------------------------------------- +END_NOT_MATCH_CODE + + return; +} + +#----------------------------------------------------------------------------- + +sub emit_comparator_code { + my ($test_file, $operator) = @_; + + print {$test_file} <<"END_COMPARATOR_CODE"; + +## name "$operator" within positive control structures +## failures 0 +## cut + +if (\$foo $operator \$bar) { + blah(); +} + +if (\$foo $operator \$bar) { + blah(\$foo); +} +elsif (\$bar $operator \$baz) { + blah(\$bar); +} +else { + blah(undef); +} + +while (\$foo $operator \$bar) { + blah(); +} + +foreach my \$bar ( grep { \$_ $operator \$baz } \@foo ) { + blah(\$bar); +} + +for (my \$bar = 0; \$bar $operator \$baz; \$bar++) { + blah(\$bar); +} + +#----------------------------------------------------------------------------- + +## name "$operator" within positive postfix statement modifiers +## failures 0 +## cut + +blah() if \$foo $operator \$bar; + +blah() while \$foo $operator \$bar; + +blah(\$_) for grep { \$_ $operator \$bar } \@foo; + +#----------------------------------------------------------------------------- + +## name "$operator" within negative control structures +## failures 2 +## cut + +unless (\$foo $operator \$bar) { + blah(); +} + +until (\$foo $operator \$bar) { + blah(); +} + +#----------------------------------------------------------------------------- + +## name "$operator" within negative postfix statement modifiers +## failures 2 +## cut + +blah() unless \$foo $operator \$bar; + +blah() until \$foo $operator \$bar; + +#----------------------------------------------------------------------------- +END_COMPARATOR_CODE + + return; +} + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ControlStructures/ProhibitPostfixControls.run b/t/ControlStructures/ProhibitPostfixControls.run new file mode 100644 index 0000000..c137e6f --- /dev/null +++ b/t/ControlStructures/ProhibitPostfixControls.run @@ -0,0 +1,221 @@ +## name Basic failure +## failures 7 +## cut + +do_something() if $condition; +do_something() while $condition; +do_something() until $condition; +do_something() unless $condition; +do_something() for @list; +do_something() foreach @list; +do_something() when @list; + +#----------------------------------------------------------------------------- + +## name Configured to allow all +## failures 0 +## parms {allow => 'if while until unless for foreach when'} +## cut + +do_something() if $condition; +do_something() while $condition; +do_something() until $condition; +do_something() unless $condition; +do_something() for @list; +do_something() foreach @list; +do_something() when @list; + +#----------------------------------------------------------------------------- + +## name Configured to allow all, all regular control structures +## failures 0 +## parms {allow => 'if unless until while when'} +## cut + +if($condition){ do_something() } +while($condition){ do_something() } +until($condition){ do_something() } +unless($condition){ do_something() } +when($smart_match){ do_something() } + +#----------------------------------------------------------------------------- + +## name Regular for loops +## failures 0 +## cut + +# PPI versions < 1.03 had problems with this +for my $element (@list){ do_something() } +for (@list){ do_something_else() } +foreach my $element (@list){ do_something() } +foreach (@list){ do_something_else() } + +#----------------------------------------------------------------------------- + +## name Regular given/when +## failures 0 +## cut + +given ($foo) { + when ($bar) { + $thingy = $blah; + } +} + +#----------------------------------------------------------------------------- + +## name Legal postfix if usage +## failures 0 +## cut + +use Carp; + +while ($condition) { + next if $condition; + last if $condition; + redo if $condition; + return if $condition; + goto HELL if $condition; + exit if $condition; +} + +die 'message' if $condition; +die if $condition; + +warn 'message' if $condition; +warn if $condition; + +carp 'message' if $condition; +carp if $condition; + +croak 'message' if $condition; +croak if $condition; + +cluck 'message' if $condition; +cluck if $condition; + +confess 'message' if $condition; +confess if $condition; + +exit 0 if $condition; +exit if $condition; + +#----------------------------------------------------------------------------- + +## name Legal postfix when usage +## failures 0 +## cut + +use Carp; + +while ($condition) { + next when $smart_match; + last when $smart_match; + redo when $smart_match; + return when $smart_match; + goto HELL when $smart_match; + exit when $smart_match; +} + +die 'message' when $smart_match; +die when $smart_match; + +warn 'message' when $smart_match; +warn when $smart_match; + +carp 'message' when $smart_match; +carp when $smart_match; + +croak 'message' when $smart_match; +croak when $smart_match; + +cluck 'message' when $smart_match; +cluck when $smart_match; + +confess 'message' when $smart_match; +confess when $smart_match; + +exit 0 when $smart_match; +exit when $smart_match; + +#----------------------------------------------------------------------------- + +## name override exempt flowcontrols +## failures 0 +## parms {flowcontrol => 'assert'} +## cut + +use Carp::Assert; + +assert $something if $condition; + + +#----------------------------------------------------------------------------- + +## name overriding exempt flowcontrols restores the defaults +## failures 8 +## parms {flowcontrol => 'assert'} +## cut + +use Carp::Assert; + +warn $something if $condition; +die $something if $condition; +carp $something if $condition; +croak $something if $condition; +cluck $something if $condition; +confess $something if $condition; +exit $something if $condition; +do_something() if $condition; + +#----------------------------------------------------------------------------- + +## name Individual "keyword" hash assignment +## failures 0 +## cut + +my %hash; +$hash{if} = 1; +$hash{unless} = 1; +$hash{until} = 1; +$hash{while} = 1; +$hash{for} = 1; +$hash{foreach} = 1; +$hash{when} = 1; + +#----------------------------------------------------------------------------- + +## name "Keyword"-list hash assignment +## failures 0 +## cut + +my %hash = ( + if => 1, + unless => 1, + until => 1, + while => 1, + for => 1, + foreach => 1, + when => 1, +); + +#----------------------------------------------------------------------------- + +## name RT #48422: Allow flow control method calls +## TODO exemption for method calls not implimented yet +## failures 0 +## cut + +Exception::Class->throw('an expression') if $error; +Exception::Class->throw($arg1, $arg2) unless not $error; + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ControlStructures/ProhibitUnlessBlocks.run b/t/ControlStructures/ProhibitUnlessBlocks.run new file mode 100644 index 0000000..ad0c004 --- /dev/null +++ b/t/ControlStructures/ProhibitUnlessBlocks.run @@ -0,0 +1,30 @@ +## name Basic passing +## failures 0 +## cut + +if(! $condition){ + do_something(); +} + +do_something() unless $condition + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 1 +## cut + +unless($condition){ + do_something(); +} + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ControlStructures/ProhibitUnreachableCode.run b/t/ControlStructures/ProhibitUnreachableCode.run new file mode 100644 index 0000000..961c8ef --- /dev/null +++ b/t/ControlStructures/ProhibitUnreachableCode.run @@ -0,0 +1,205 @@ +## name Basic passing +## failures 0 +## cut + +sub a { + return 123 if $a == 1; + do_something(); +} + +sub b { + croak 'error' unless $b; + do_something(); +} + +sub c { + confess 'error' if $c != $d; + do_something(); +} + +for (1..2) { + next if $_ == 1; + do_something(); +} + +for (1..2) { + last if $_ == 2; + do_something(); +} + +for (1..2) { + redo if do_this($_); + do_something(); +} + +{ + exit; + FOO: + do_something(); +} + +{ + die; + BAR: + do_something(); +} + +{ + exit; + sub d {} + BAZ: + print 123; +} + +{ + die; + JAPH: + sub e {} + print 456; +} + +{ + exit; + BEGIN { + print 123; + } +} + +{ + $foo || die; + print 123; +} + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 12 +## cut + +{ + exit; + require Foo; +} + +sub a { + return 123; + do_something(); +} + +sub b { + croak 'error'; + do_something(); +} + +sub c { + confess 'error'; + do_something(); +} + +for (1..2) { + next; + do_something(); +} + +for (1..2) { + last; + do_something(); +} + +for (1..2) { + redo; + do_something(); +} + +{ + exit; + do_something(); +} + + +{ + die; + do_something(); +} + + +{ + exit; + sub d {} + print 123; +} + +{ + $foo, die; + print 123; +} + +die; +print 456; +FOO: print $baz; + +#----------------------------------------------------------------------------- + +## name Compile-time code +## failures 0 +## cut + +exit; + +no warnings; +use Memoize; +our %memoization; + +#----------------------------------------------------------------------------- + +## name __DATA__ section +## failures 0 +## cut + +exit; + +__DATA__ +... + +#----------------------------------------------------------------------------- + +## name __END__ section +## failures 0 +## cut + +exit; + +__END__ +... + +#----------------------------------------------------------------------------- + +## name RT #36080 +## failures 0 +## cut + +my $home = $ENV{HOME} // die "HOME not set"; +say 'hello'; + +#----------------------------------------------------------------------------- + +## name RT #41734 +## failures 0 +## cut + +Foo::foo(); +exit 0; + +package Foo; +sub foo { print "hello\n"; } + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ControlStructures/ProhibitUntilBlocks.run b/t/ControlStructures/ProhibitUntilBlocks.run new file mode 100644 index 0000000..6746db9 --- /dev/null +++ b/t/ControlStructures/ProhibitUntilBlocks.run @@ -0,0 +1,30 @@ +## name Basic passing +## failures 0 +## cut + +while(! $condition){ + do_something(); +} + +do_something() until $condition + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 1 +## cut + +until($condition){ + do_something(); +} + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ControlStructures/ProhibitYadaOperator.run b/t/ControlStructures/ProhibitYadaOperator.run new file mode 100644 index 0000000..bbfe74d --- /dev/null +++ b/t/ControlStructures/ProhibitYadaOperator.run @@ -0,0 +1,49 @@ +## name Basic passing +## failures 0 +## cut + +for (1 ... 3) { + do_something(); +} + +for ('a' ... 'b') { + do_something(); +} + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 1 +## cut + +do_something(); + +... + +do_something(); + +#----------------------------------------------------------------------------- + +## name Excessive yadaing +## failures 1 +## cut + +do_something(); + +... +... +... +... + +do_something(); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Documentation/RequirePackageMatchesPodName.run b/t/Documentation/RequirePackageMatchesPodName.run new file mode 100644 index 0000000..c97815d --- /dev/null +++ b/t/Documentation/RequirePackageMatchesPodName.run @@ -0,0 +1,295 @@ +## name No POD +## failures 0 +## cut +print 'Hello World'; + +#----------------------------------------------------------------------------- + +## name Program +## failures 0 +## cut +#!/usr/bin/perl +print 'Hello World'; + +=pod + +=head1 NAME + +helloworld.pl - Greetings! + +=cut + +#----------------------------------------------------------------------------- + +## name No name +## failures 0 +## cut +=pod + +=head1 DESCRIPTION + +=cut + +#----------------------------------------------------------------------------- + +## name Empty name +## failures 1 +## cut +package Foo; + +=pod + +=head1 NAME + +=head1 DESCRIPTION + +Blah... + +=cut + +#----------------------------------------------------------------------------- + +## name Name without package +## failures 1 +## cut + +=pod + +=head1 NAME + +Foo - A module that does stuff + +=head1 DESCRIPTION + +Blah... + +=cut + +#----------------------------------------------------------------------------- + +## name Name doesn't match package +## failures 1 +## cut +package Foo; + +=pod + +=head1 NAME + +Bar - a module that does something else + +=head1 DESCRIPTION + +Blah... + +=cut + +#----------------------------------------------------------------------------- + +## name A good match +## failures 0 +## cut +package Foo; + +=pod + +=head1 NAME + +Foo - A module that does stuff + +=head1 DESCRIPTION + +Blah... + +=cut + +#----------------------------------------------------------------------------- + +## name Almost a match +## failures 1 +## cut +package Foo; + +=pod + +=head1 NAME + +Foo! - A module that does stuff + +=head1 DESCRIPTION + +Blah... + +=cut + +#----------------------------------------------------------------------------- + +## name A good match with C<> +## failures 0 +## cut +package Foo; + +=pod + +=head1 NAME + +C - A module that does stuff + +=head1 DESCRIPTION + +Blah... + +=cut + +#----------------------------------------------------------------------------- + +## name A good match with L<> +## failures 0 +## cut +package Foo; + +=pod + +=head1 NAME + +L - A module that does stuff + +=head1 DESCRIPTION + +Blah... + +=cut + +#----------------------------------------------------------------------------- + +## name A good match with B<> +## failures 0 +## cut +package Foo; + +=pod + +=head1 NAME + +B - A module that does stuff + +=head1 DESCRIPTION + +Blah... + +=cut + + +#----------------------------------------------------------------------------- + +## name A good match with I<> +## failures 0 +## cut +package Foo; + +=pod + +=head1 NAME + +I - A module that does stuff + +=head1 DESCRIPTION + +Blah... + +=cut + + +#----------------------------------------------------------------------------- + +## name Multiple packages +## failures 0 +## cut +package Foo; +package Bar; +package main; + +=pod + +=head1 NAME + +Foo - A module that does stuff + +=head1 DESCRIPTION + +Blah... + +=cut + +#----------------------------------------------------------------------------- + +## name Multiple packages and not first (RT #49501) +## failures 0 +## cut +package Foo; +package Bar; +package main; + +=pod + +=head1 NAME + +Bar - A module that does stuff + +=head1 DESCRIPTION + +Blah... + +=cut + +#----------------------------------------------------------------------------- + +## name Perl 4 +## failures 0 +## cut +package Foo'Bar; + +=pod + +=head1 NAME + +Foo::Bar - A module that does stuff + +=head1 DESCRIPTION + +Blah... + +=cut + +#----------------------------------------------------------------------------- + +## name Whitespace +## failures 0 +## cut +package Foo; + +=pod + +=head1 NAME + + + + + + +Foo - A module that does stuff + +=head1 DESCRIPTION + +Blah... + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Documentation/RequirePodAtEnd.run b/t/Documentation/RequirePodAtEnd.run new file mode 100644 index 0000000..61bb19b --- /dev/null +++ b/t/Documentation/RequirePodAtEnd.run @@ -0,0 +1,122 @@ +## name No code at all +## failures 0 +## cut + +#Nothing! No code! + +#----------------------------------------------------------------------------- + +## name Just an END section +## failures 0 +## cut +__END__ +#Nothing! + +#----------------------------------------------------------------------------- + +## name only one pod section +## failures 1 +## cut +=head1 Foo + +=cut + +#----------------------------------------------------------------------------- + +## name only one pod section, at the end +## failures 0 +## cut +__END__ + +=head1 Foo + +=cut +#----------------------------------------------------------------------------- + +## name some pod sections OK not at the end +## failures 0 +## cut + +=for comment +This POD is ok +=cut + +__END__ + +=head1 Foo + +=cut + +#----------------------------------------------------------------------------- + +## name but main pod still has to be at the end +## failures 1 +## cut + +=for comment +This POD is ok +=cut + +=head1 Foo + +This POD is illegal + +=cut + +=begin comment + +This POD is ok + +This POD is also ok + +=end comment + +=cut + +__END__ + +=head1 Bar + +=cut + +#----------------------------------------------------------------------------- + +## name more =for exceptions +## failures 0 +## cut + +=for comment +This is a one-line comment + +=cut + +my $baz = 'nuts'; + +__END__ + + +#----------------------------------------------------------------------------- + +## name =begin exceptions +## failures 0 +## cut + +=begin comment + +Multi-paragraph comment + +Mutli-paragrapm comment + +=end comment + +=cut + +__END__ +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Documentation/RequirePodSections.run b/t/Documentation/RequirePodSections.run new file mode 100644 index 0000000..3d62254 --- /dev/null +++ b/t/Documentation/RequirePodSections.run @@ -0,0 +1,181 @@ +## name No code +## failures 0 +## cut +=pod + +=head1 NO CODE IN HERE + +=cut + +#----------------------------------------------------------------------------- + +## name No POD +## failures 0 +## cut +#!/usr/bin/perl +print 'Hello World'; + +#----------------------------------------------------------------------------- + +## name Missing many sections +## failures 10 +## cut +#!/usr/bin/perl + +print 'Hello World'; + +__END__ + +=head1 NAME + +Blah... + +=head1 DESCRIPTION + +Blah... + +=head1 USAGE + +Blah... + +#----------------------------------------------------------------------------- + +## name No shebang, this is a library +## failures 8 +## cut +#No shebang, this is a library +#POD is inline with code too + +=head1 NAME + +Blah... + +=head1 DESCRIPTION + +Blah... + +=cut + +print 'Hello World'; + +=head1 SUBROUTINES/METHODS + +Blah... + +=cut + +sub foobar {} + +=head1 AUTHOR + +Santa Claus + +=cut + +#----------------------------------------------------------------------------- + +## name Passing parms, for a library +## failures 0 +## parms {lib_sections => 'mi nombre | el descripcion'} +## cut + +print 'Hello World'; + +__END__ + +=head1 MI NOMBRE + +Blah... + +=head1 EL DESCRIPCION + +Blah... + +=cut + +#----------------------------------------------------------------------------- + +## name Passing parms, for a program +## failures 0 +## parms {script_sections => 'mi nombre | el descripcion'} +## cut +#!/usr/bin/perl + +__END__ + +=head1 MI NOMBRE + +Blah... + +=head1 EL DESCRIPCION + +Blah... + +=cut + +#----------------------------------------------------------------------------- + +## name Disable with annotation, for a library (RT #59268) +## failures 0 +## cut + +print 'Hello World'; + +## no critic (RequirePodSections) + +__END__ + +=head1 MI NOMBRE + +Blah... + +=head1 EL DESCRIPCION + +Blah... + +=cut + +#----------------------------------------------------------------------------- + +## name Disable with annotation, for a program (RT #59268) +## failures 0 +## cut +#!/usr/bin/perl + +## no critic (RequirePodSections) + +__END__ + +=head1 MI NOMBRE + +Blah... + +=head1 EL DESCRIPCION + +Blah... + +=cut + +#----------------------------------------------------------------------------- + +## name Don't die if we don't have a head1 to report against. RT #67231 +## failures 1 +## parms { lib_sections => 'NAME' } +## cut + +warn "Trouble ahead"; # Needed because we ignore files without code + +=pod + +Fubar + +=cut + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ErrorHandling/RequireCarping.run b/t/ErrorHandling/RequireCarping.run new file mode 100644 index 0000000..3c037b3 --- /dev/null +++ b/t/ErrorHandling/RequireCarping.run @@ -0,0 +1,418 @@ +## name Unspectacular die +## failures 3 +## cut + +die 'A horrible death' if $condtion; + +if ($condition) { + die 'A horrible death'; +} + +open my $fh, '<', $path or + die "Can't open file $path"; + +#----------------------------------------------------------------------------- + +## name Unspectacular warn +## failures 3 +## cut + +warn 'A horrible warning' if $condtion; + +if ($condition) { + warn 'A horrible warning'; +} + +open my $fh, '<', $path or + warn "Can't open file $path"; + +#----------------------------------------------------------------------------- + +## name Carping +## failures 0 +## cut + +carp 'A horrible death' if $condtion; + +if ($condition) { + carp 'A horrible death'; +} + +open my $fh, '<', $path or + carp "Can't open file $path"; + +#----------------------------------------------------------------------------- + +## name No croaking +## failures 1 +## cut + +die 'A horrible death'; + +#----------------------------------------------------------------------------- + +## name Complain about cases without arguments. +## failures 2 +## cut + +die; +die + +#----------------------------------------------------------------------------- + +## name Complain about cases with empty list arguments. +## failures 2 +## cut + +die ( ); +die ( ) + +#----------------------------------------------------------------------------- + +## name Complain about cases with non-string arguments. +## failures 7 +## cut + +die $error; +die @errors; +die %errors_by_id; +die $errors[0]; +die $errors_by_id{"Cheese fondue overflow"}; +die $marvin_gaye->whats_goin_on(); +die $george_washington->cross("Delaware River\n"); + +#----------------------------------------------------------------------------- + +## name Don't complain about obvious uses of references because they're likely being used as exception objects. +## TODO not yet implemented +## failures 0 +## cut + +die \$frobnication_exception; +die \@accumulated_warnings; +die \%problem_data; + +die + [ + 'process.html: missing standard section separator comments', + 'green.css: uses non-standard font "Broken 15"', + 'cat.jpg: missing copyright information in Exif metadata', + ]; + +die + { + message => 'Found duplicate entries', + file => $current_file, + parser => $self, + occurrences => $occurrences, + duplicated => $entry_content, + }; + +die Blrfl::Exception->new('Too many croutons', $salad); + + +#----------------------------------------------------------------------------- + +## name Don't complain if message ends with "\n" in double quotes. +## failures 0 +## cut + +die "A horrible death\n" ; +die "A horrible death\n" # last statement doesn't need a terminator + +#----------------------------------------------------------------------------- + +## name Don't complain if message ends with literal "\n" (RT #25046) +## failures 0 +## cut + +die "A horrible death +" ; +die 'A horrible death +' ; +die q{A horrible death +} ; +die qq{A horrible death +} ; + +#----------------------------------------------------------------------------- + +## name Don't complain if message is a heredoc, which must end in "\n" +## failures 0 +## cut + +die <<'eod' ; +A horrible death +eod + +die <<'eod' # last statement doesn't need a terminator +A horrible death +eod + +#----------------------------------------------------------------------------- + +## name Complain if message ends with "\n" in single quotes. +## failures 2 +## cut + +die 'A horrible death\n' ; +die 'A horrible death\n' # last statement doesn't need a terminator + +#----------------------------------------------------------------------------- + +## name Don't complain if message ends with "\n" in interpolated quotelike operator. +## failures 0 +## cut + +die qq{A horrible death\n} ; +die qq#A horrible death\n# ; +die qq/A horrible death\n/ # last statement doesn't need a terminator + +#----------------------------------------------------------------------------- + +## name Complain if message ends with "\n" in non-interpolated quotelike operator. +## failures 3 +## cut + +die q{A horrible death\n} ; +die q#A horrible death\n# ; +die q/A horrible death\n/ # last statement doesn't need a terminator + +#----------------------------------------------------------------------------- + +## name Don't complain if message is a list with a last element that ends with "\n" +## failures 0 +## cut + +die q{Don't }, $die, " a horrible death\n" ; +die qq{Don't }, $die, qq/ a horrible death\n/ ; +die q{Don't }, $die, " a horrible death\n" , ; +die q{Don't }, $die, " a horrible death\n" , # last statement doesn't need a terminator + +#----------------------------------------------------------------------------- + +## name Don't complain if message is a parenthesised list with a last element that ends with "\n" +## failures 0 +## cut + +die ( q{Don't }, $die, " a horrible death\n" ) ; +die ( qq{Don't }, $die, qq/ a horrible death\n/ ) ; +die ( qq{Don't }, $die, qq/ a horrible death\n/ ) , ; +die ( q{Don't }, $die, " a horrible death\n" , ) # last statement doesn't need a terminator + +#----------------------------------------------------------------------------- + +## name Don't complain if message is a list with "sub" lists with a last (flattened list) element that ends with "\n" +## failures 0 +## cut + +# all these tests are necessary (different PPI trees) + +# one element in a sub list +die q{Don't } , ( $die ) , " a horrible death\n" ; +die q{Don't } , $die , ( " a horrible death\n" ) ; + +# sub list and a bare element +die q{Don't } , ( $die , " a horrible death\n" ) ; + +# two sub lists +die q{Don't } , ( $die ) , ( " a horrible death\n" ) ; + + +# sub sub lists +die ( ( q{Don't } ) , $die , " a horrible death\n" ) ; +die ( q{Don't } , $die , ( " a horrible death\n" ) ) ; +die ( q{Don't } , ( $die , ( " a horrible death\n" ) ) ) ; +die ( ( q{Don't } , ( $die , ( " a horrible death\n" ) ) ) ) ; + +# play with extra commas +die ( ( q{Don't } , ( $die , ( " a horrible death\n" , ) , ) , ) , ) , ; +die ( ( q{Don't } , ( $die , ( " a horrible death\n" , ) , ) , ) , ) , + +#----------------------------------------------------------------------------- + +## name Complain if message is a list with "sub" lists with a last (flattened list) element that doesn't end with "\n" +## failures 10 +## cut + +# all these tests are necessary: make sure that the policy knows when to +# stop looking. + +# one element in a sub list +die q{Don't } , ( $die ) , @a_horrible_death ; +die q{Don't } , $die , ( @a_horrible_death ) ; + +# sub list and a bare element +die q{Don't } , ( $die , @a_horrible_death ) ; + +# two sub lists +die q{Don't } , ( $die ) , ( @a_horrible_death ) ; + + +# sub sub lists +die ( ( q{Don't } ) , $die , @a_horrible_death ) ; +die ( q{Don't } , $die , ( @a_horrible_death ) ) ; +die ( q{Don't } , ( $die , ( @a_horrible_death ) ) ) ; +die ( ( q{Don't } , ( $die , ( @a_horrible_death ) ) ) ) ; + +# play with extra commas +die ( ( q{Don't } , ( $die , ( @a_horrible_death , ) , ) , ) , ) , ; +die ( ( q{Don't } , ( $die , ( @a_horrible_death , ) , ) , ) , ) , + +#----------------------------------------------------------------------------- + +## name Don't complain if message is a concatenation with a last element that ends with "\n" +## failures 0 +## cut + +die q{Don't } . $die . " a horrible death\n" ; +die ( q{Don't } . $die . " a horrible death\n" ) ; + +##----------------------------------------------------------------------------- + +## name Complain if message has a last element that ends with "\n" but has an operation in front +## failures 2 +## cut + +die q{Don't } . $die . length " a horrible death\n" ; +die ( q{Don't } . $die . length " a horrible death\n" ) ; + +#----------------------------------------------------------------------------- + +## name Don't complain if followed by postfix operator and otherwise valid. +## failures 0 +## cut + +die "A horrible death\n" if $self->is_a_bad_guy(); +die "A horrible death\n" unless $self->rescued_from_the_sinking_ship(); +die "A horrible death\n" while $deep_sense_of_guilt; +die "A horrible death\n" until $clear_conscience; +die "A horrible death\n" for @your_crimes; +die "A horrible death\n" foreach @{ $songs_sung_off_key }; + +die 'A horrible ', "death\n" if $self->is_a_bad_guy(); +die 'A horrible ', "death\n" unless $self->rescued_from_the_sinking_ship(); +die 'A horrible ', "death\n" while $deep_sense_of_guilt; +die 'A horrible ', "death\n" until $clear_conscience; +die 'A horrible ', "death\n" for @your_crimes; +die 'A horrible ', "death\n" foreach @{ $songs_sung_off_key }; + +die ( 'A horrible ', "death\n" ) if $self->is_a_bad_guy(); +die ( 'A horrible ', "death\n" ) unless $self->rescued_from_the_sinking_ship(); +die ( 'A horrible ', "death\n" ) while $deep_sense_of_guilt; +die ( 'A horrible ', "death\n" ) until $clear_conscience; +die ( 'A horrible ', "death\n" ) for @your_crimes; +die ( 'A horrible ', "death\n" ) foreach @{ $songs_sung_off_key }; + +die ( 'A horrible ' . "death\n" ) if $self->is_a_bad_guy(); +die ( 'A horrible ' . "death\n" ) unless $self->rescued_from_the_sinking_ship(); +die ( 'A horrible ' . "death\n" ) while $deep_sense_of_guilt; +die ( 'A horrible ' . "death\n" ) until $clear_conscience; +die ( 'A horrible ' . "death\n" ) for @your_crimes; +die ( 'A horrible ' . "death\n" ) foreach @{ $songs_sung_off_key }; + +#----------------------------------------------------------------------------- + +## name Complain if followed by postfix operator with "\n" ending last operand and otherwise invalid. +## failures 24 +## cut + +die "A horrible death" if "Matagami\n"; +die "A horrible death" unless "Enniscorthy\n"; +die "A horrible death" while "Htargcm\n"; +die "A horrible death" until "Akhalataki\n"; +die "A horrible death" for "Fleac\n"; +die "A horrible death" foreach "Uist\n"; + +die 'A horrible ', "death" if "Matagami\n"; +die 'A horrible ', "death" unless "Enniscorthy\n"; +die 'A horrible ', "death" while "Htargcm\n"; +die 'A horrible ', "death" until "Akhalataki\n"; +die 'A horrible ', "death" for "Fleac\n"; +die 'A horrible ', "death" foreach "Uist\n"; + +die ( 'A horrible ', "death" ) if "Matagami\n"; +die ( 'A horrible ', "death" ) unless "Enniscorthy\n"; +die ( 'A horrible ', "death" ) while "Htargcm\n"; +die ( 'A horrible ', "death" ) until "Akhalataki\n"; +die ( 'A horrible ', "death" ) for "Fleac\n"; +die ( 'A horrible ', "death" ) foreach "Uist\n"; + +die ( 'A horrible ' . "death" ) if "Matagami\n"; +die ( 'A horrible ' . "death" ) unless "Enniscorthy\n"; +die ( 'A horrible ' . "death" ) while "Htargcm\n"; +die ( 'A horrible ' . "death" ) until "Akhalataki\n"; +die ( 'A horrible ' . "death" ) for "Fleac\n"; +die ( 'A horrible ' . "death" ) foreach "Uist\n"; + +#----------------------------------------------------------------------------- + +## name Complain if config doesn't allow newlines. +## failures 1 +## parms { allow_messages_ending_with_newlines => 0 } +## cut + +die "A horrible death\n" ; + +#----------------------------------------------------------------------------- + +## name Complain if in main:: and option not set (RT #56619) +## failures 1 +## cut + +package main; + +die "A horrible death"; + +#----------------------------------------------------------------------------- + +## name Don't complain if in main:: and option set (RT #56619) +## failures 0 +## parms { allow_in_main_unless_in_subroutine => 1 } +## cut + +package main; + +die "A horrible death"; + +#----------------------------------------------------------------------------- + +## name Don't complain if implicitly in main:: and option set (RT #56619) +## failures 0 +## parms { allow_in_main_unless_in_subroutine => 1 } +## cut + +die "A horrible death"; + +#----------------------------------------------------------------------------- + +## name Complain if in main:: but in subroutine (RT #56619) +## parms { allow_in_main_unless_in_subroutine => 1 } +## failures 1 +## cut + +sub foo { + die "Goodbye, cruel world!"; +} + +#----------------------------------------------------------------------------- + +## name Complain if in main:: but in anonymous subroutine (RT #56619) +## parms { allow_in_main_unless_in_subroutine => 1 } +## failures 1 +## cut + +my $foo = sub { + die "Goodbye, cruel world!"; +}; + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ErrorHandling/RequireCheckingReturnValueOfEval.run b/t/ErrorHandling/RequireCheckingReturnValueOfEval.run new file mode 100644 index 0000000..b89ae5d --- /dev/null +++ b/t/ErrorHandling/RequireCheckingReturnValueOfEval.run @@ -0,0 +1,428 @@ +## name Basic failure +## failures 9 +## cut + +eval { foo; }; +{ eval { baz; } }; +[ eval { buz; } ]; +( eval { blrfl; } ); + +eval 'foo;'; +{ eval 'baz;' }; +[ eval 'buz;' ]; +( eval 'blrfl;' ); + +eval { something }; +if ($@) { + blahblah +} + +#----------------------------------------------------------------------------- + +## name Assignment +## failures 0 +## cut + +$result = eval { foo; }; +@result = eval { bar; }; +$result = { eval { baz; } }; +$result = [ eval { buz; } ]; +@result = ( 0, eval { blrfl; } ); +@result = [ qw< one two >, { thrpt => ( eval { frlbfrnk; } ) } ]; + +$result = eval 'foo;'; +@result = eval 'bar;'; +$result = { eval 'baz;' }; +$result = [ eval 'buz;' ]; +@result = ( 0, eval 'blrfl;' ); +@result = [ qw< one two >, { thrpt => ( eval 'frlbfrnk;' ) } ]; + +#----------------------------------------------------------------------------- + +## name Assignment with comma separated statements. +## failures 12 +## cut + +$result = 1, eval { foo; }; +@result = 1, eval { bar; }; +$result = 1, { eval { baz; } }; +$result = 1, [ eval { buz; } ]; +@result = 1, ( eval { blrfl; } ); +@result = 1, [ qw< one two >, { thrpt => ( eval { frlbfrnk; } ) } ]; + +$result = 1, eval 'foo;'; +@result = 1, eval 'bar;'; +$result = 1, { eval 'baz;' }; +$result = 1, [ eval 'buz;' ]; +@result = 1, ( eval 'blrfl;' ); +@result = 1, [ qw< one two >, { thrpt => ( eval 'frlbfrnk;' ) } ]; + +#----------------------------------------------------------------------------- + +## name if +## failures 0 +## cut + +if ( eval { bar; } ) { + something +} + +if ( ( eval { blrfl; } ) ) { + something +} + +if ( 5 == eval { bar; } ) { + something +} + +if ( scalar ( eval { blrfl; } ) ) { + something +} + +if ( not eval { whatever; } ) { + something +} + + + +if ( eval 'bar;' ) { + something +} + +if ( ( eval 'blrfl;' ) ) { + something +} + +if ( 5 == eval 'bar;' ) { + something +} + +if ( scalar ( eval 'blrfl;' ) ) { + something +} + +if ( ! eval 'whatever;' ) { + something +} + +#----------------------------------------------------------------------------- + +## name foreach +## failures 0 +## cut + +foreach my $thingy ( eval { bar; } ) { + something +} + +foreach my $thingy ( ( eval { blrfl; } ) ) { + something +} + +foreach my $thingy ( qw< one two >, eval { bar; } ) { + something +} + + +foreach my $thingy ( eval 'bar;' ) { + something +} + +foreach my $thingy ( ( eval 'blrfl;' ) ) { + something +} + +foreach my $thingy ( qw< one two >, eval 'bar;' ) { + something +} + +#----------------------------------------------------------------------------- + +## name C-style for with eval in condition or assignment +## failures 0 +## cut + +for (blah; eval { bar; }; blah ) { + something +} + +for (blah; ( eval { blrfl; } ); blah ) { + something +} + +for (blah; eval { bar; } eq 'bing bang bong'; blah ) { + something +} + +for (my $x = eval { thrp; }; $x < 1587; $x = eval { thrp; } ) { + something +} + + +for (blah; eval 'bar;'; blah ) { + something +} + +for (blah; ( eval 'blrfl;' ); blah ) { + something +} + +for (blah; eval 'bar;' eq 'bing bang bong'; blah ) { + something +} + +for (my $x = eval 'thrp;'; $x < 1587; $x = eval 'thrp;' ) { + something +} + +#----------------------------------------------------------------------------- + +## name C-style for with eval in initialization or increment with no assignment +## failures 4 +## cut + +for (eval { bar; }; blah; blah) { + something +} + +for ( blah; blah; ( eval { blrfl; } ) ) { + something +} + + +for (eval 'bar;'; blah; blah) { + something +} + +for ( blah; blah; ( eval 'blrfl;' ) ) { + something +} + +#----------------------------------------------------------------------------- + +## name while +## failures 0 +## cut + +while ( eval { bar; } ) { + something +} + +while ( ( ( eval { blrfl; } ) ) ) { + something +} + + +while ( eval 'bar;' ) { + something +} + +while ( ( ( eval 'blrfl;' ) ) ) { + something +} + +#----------------------------------------------------------------------------- + +## name Postfix if +## failures 0 +## cut + +bleah if eval { yadda; }; +bleah if ( eval { yadda; } ); +bleah if 5 == eval { yadda; }; +bleah if eval { yadda; } == 5; + +bleah if eval 'yadda;'; +bleah if ( eval 'yadda;' ); +bleah if 5 == eval 'yadda;'; +bleah if eval 'yadda;' == 5; + +#----------------------------------------------------------------------------- + +## name Ternary +## failures 0 +## cut + +eval { yadda; } ? 1 : 2; +eval 'yadda;' ? 1 : 2; + +#----------------------------------------------------------------------------- + +## name Postfix foreach +## failures 0 +## cut + +blargh($_) foreach eval { bar; }; +blargh($_) foreach ( eval { blrfl; } ); +blargh($_) foreach qw< one two >, eval { bar; }; +blargh($_) foreach eval { bar; }, qw< one two >; + +blargh($_) foreach eval 'bar;'; +blargh($_) foreach ( eval 'blrfl;' ); +blargh($_) foreach eval 'bar;', qw< one two >; + +#----------------------------------------------------------------------------- + +## name First value in comma-separated list in condition +## failures 4 +## cut + +if ( eval { 1 }, 0 ) { + blah blah blah +} + +if ( ( eval { 1 }, 0 ) ) { + blah blah blah +} + +if ( eval '1', 0 ) { + blah blah blah +} + +if ( ( eval '1', 0 ) ) { + blah blah blah +} + +#----------------------------------------------------------------------------- + +## name Last value in comma-separated list in condition +## failures 0 +## cut + +if ( 0, eval { 1 }, ) { + blah blah blah +} + +# Comma outside inner parentheses. +if ( ( 0, eval { 1 } ), , ) { + blah blah blah +} + +if ( 0, eval '1', ) { + blah blah blah +} + +# Comma inside inner parentheses. +if ( ( 0, eval '1', , ) ) { + blah blah blah +} + +#----------------------------------------------------------------------------- + +## name Last value in comma-separated list that isn't the last element in another list in condition +## failures 4 +## cut + +if ( ( 0, eval { 1 } ), 0 ) { + blah blah blah +} + +if ( ( ( 0, eval { 1 } ) ), 0 ) { + blah blah blah +} + +if ( ( 0, eval '1' ), 0 ) { + blah blah blah +} + +if ( ( ( 0, eval '1' ) ), 0 ) { + blah blah blah +} + +#----------------------------------------------------------------------------- + +## name "Proper" handling of return value +## failures 0 +## cut + +eval { + something +} + or do { + if ($EVAL_ERROR) { + yadda + } + else { + blahdda + }; + +eval "something_else" or die; + +# eval gets the thing following it before || does. +eval { + something +} + || do { + if ($EVAL_ERROR) { + yadda + } + else { + blahdda + } + }; + +eval "something_else" || die; + + +eval { + something +} + and do { + yadda + }; + +eval "something_else" and thingy; + +# eval gets the thing following it before && does. +eval { + something +} + && do { + yadda + }; + +eval "something_else" && die; + +#----------------------------------------------------------------------------- + +## name A grep is a check -- RT #69489 +## failures 0 +## cut + +foreach ( grep { eval $_ } @bar ) { say } +foreach ( grep { ! eval $_ } @bar ) { say } +foreach ( grep eval $_, @bar ) { say } +foreach ( grep ! eval $_, @bar ) { say } + +# grep $_, map eval $_, @foo; # Should this be accepted? +grep { $_ } map { eval $_ } @foo; # Should this be rejected? + +#----------------------------------------------------------------------------- + +## name ||= eval{} (https://github.com/adamkennedy/PPI/issues/74) +## failures 0 +## cut + +$foo ||= eval { something }; +$foo &&= eval { something }; + +#----------------------------------------------------------------------------- + +## name return eval{} (https://github.com/Perl-Critic/Perl-Critic/issues/324) +## failures 0 +## cut + +return eval { something }; +return eval "something"; +# TODO return ( eval { something } ) + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/InputOutput/ProhibitBacktickOperators.run b/t/InputOutput/ProhibitBacktickOperators.run new file mode 100644 index 0000000..4ec978c --- /dev/null +++ b/t/InputOutput/ProhibitBacktickOperators.run @@ -0,0 +1,84 @@ +## name Basic failures +## failures 18 +## cut + +$string = `date`; +@array = `date`; +@array = ( `date` ); +@array = ( $foo, `date`, 'bar' ); +$array_ref = [ $foo, `date`, 'bar' ]; + +print `date`; +print ( `date` ); + +if ( `date` ) {} + +for ( `date` ) {} + +$string = qx/date/; +@array = qx/date/; +@array = ( qx/date/ ); +@array = ( $foo, qx/date/, 'bar' ); +$array_ref = [ $foo, qx/date/, 'bar' ]; + +print qx/date/; +print ( qx/date/ ); + +if ( qx/date/ ) {} + +for ( qx/date/ ) {} + +#----------------------------------------------------------------------------- + +## name Passing with only_in_void_context +## failures 0 +## parms { only_in_void_context => 1 } +## cut + +$string = `date`; +@array = `date`; +@array = ( `date` ); +@array = ( $foo, `date`, 'bar' ); +$array_ref = [ $foo, `date`, 'bar' ]; + +print `date`; +print ( `date` ); + +if ( `date` ) {} + +for ( `date` ) {} + +$string = qx/date/; +@array = qx/date/; +@array = ( qx/date/ ); +@array = ( $foo, qx/date/, 'bar' ); +$array_ref = [ $foo, qx/date/, 'bar' ]; + +print qx/date/; +print ( qx/date/ ); + +if ( qx/date/ ) {} + +for ( qx/date/ ) {} + +#----------------------------------------------------------------------------- + +## name Failure with only_in_void_context +## failures 4 +## parms { only_in_void_context => 1 } +## cut + +`date`; +qx/date/; + +if ( $blah ) { `date` } +if ( $blah ) { qx/date/ } + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/InputOutput/ProhibitBarewordFileHandles.run b/t/InputOutput/ProhibitBarewordFileHandles.run new file mode 100644 index 0000000..8f90e9c --- /dev/null +++ b/t/InputOutput/ProhibitBarewordFileHandles.run @@ -0,0 +1,48 @@ +## name standard filehandles are OK +## failures 0 +## cut + +open(STDIN, '<', '/dev/null') or die; +open(STDOUT, '>', '/dev/null') or die; +open(STDERR, '>', '/dev/null') or die; + +#----------------------------------------------------------------------------- + +## name basic failures +## failures 5 +## cut + +open FH, '>', $some_file; +open FH, '>', $some_file or die; +open(FH, '>', $some_file); +open(FH, '>', $some_file) or die; +open(STDERROR, '>', '/dev/null') or die; + +#----------------------------------------------------------------------------- + +## name basic passes +## failures 0 +## cut +open $fh, '>', $some_file; +open $fh, '>', $some_file or die; +open($fh, '>', $some_file); +open($fh, '>', $some_file) or die; + +open my $fh, '>', $some_file; +open my $fh, '>', $some_file or die; +open(my $fh, '>', $some_file); +open(my $fh, '>', $some_file) or die; + +$foo{open}; # not a function call +{open}; # zero args, for Devel::Cover + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/InputOutput/ProhibitExplicitStdin.run b/t/InputOutput/ProhibitExplicitStdin.run new file mode 100644 index 0000000..f2d1eda --- /dev/null +++ b/t/InputOutput/ProhibitExplicitStdin.run @@ -0,0 +1,52 @@ +## name basic passes +## failures 0 +## cut + +$foo = 'STDIN'; +my $STDIN = 1; +close STDIN; +while (<>) { + print; +} +while () { + print; +} +while (<$fh>) { + print; +} + +#----------------------------------------------------------------------------- + +## name basic failures +## failures 3 +## cut + +$answer = ; +while () { + print; +} +if ( =~ /y/) { + remove 'tmp.txt'; +} + +#----------------------------------------------------------------------------- + +## name ppi failures +## failures 4 +## cut + +$content = join '', ; +$content = join('', ); +$content = join $var, ; +$content = join($var, ); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/InputOutput/ProhibitInteractiveTest.run b/t/InputOutput/ProhibitInteractiveTest.run new file mode 100644 index 0000000..ed613c9 --- /dev/null +++ b/t/InputOutput/ProhibitInteractiveTest.run @@ -0,0 +1,25 @@ +## name basic failures +## failures 2 +## cut + +-t; +if (-t) { } + +#----------------------------------------------------------------------------- + +## name basic passes +## failures 0 +## cut +-toomany; +-f _; + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/InputOutput/ProhibitJoinedReadline.run b/t/InputOutput/ProhibitJoinedReadline.run new file mode 100644 index 0000000..529b1a3 --- /dev/null +++ b/t/InputOutput/ProhibitJoinedReadline.run @@ -0,0 +1,55 @@ +## name basic passes +## failures 0 +## cut + +$content = do {local $/ = undef; <>}; +@content = <>; +$content = do {local $/ = undef; <$fh>}; +@content = <$fh>; +$content = do {local $/ = undef; }; +@content = ; + +#----------------------------------------------------------------------------- + +## name basic failures +## failures 4 +## cut + +$content = join '', <>; +$content = join('', <>); +$content = join $var, <>; +$content = join($var, <>); + +#----------------------------------------------------------------------------- + +## name ppi failures +## failures 8 +## cut + +$content = join '', <$fh>; +$content = join '', ; +$content = join('', <$fh>); +$content = join('', ); +$content = join $var, <$fh>; +$content = join $var, ; +$content = join($var, <$fh>); +$content = join($var, ); + +#----------------------------------------------------------------------------- + +## name code coverage +## failures 0 +## cut + +$self->join($chain_link_1, $chain_link_2); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/InputOutput/ProhibitOneArgSelect.run b/t/InputOutput/ProhibitOneArgSelect.run new file mode 100644 index 0000000..b78b6f4 --- /dev/null +++ b/t/InputOutput/ProhibitOneArgSelect.run @@ -0,0 +1,56 @@ +## name 1 arg; variable w/parens +## failures 1 +## cut + +select( $fh ); + +#----------------------------------------------------------------------------- + +## name 1 arg; variable, as built-in +## failures 1 +## cut + +select $fh; + +#----------------------------------------------------------------------------- + +## name 1 arg; fh, w/parens +## failures 1 +## cut + +select( STDERR ); + +#----------------------------------------------------------------------------- + +## name 1 arg; fh, as built-in +## failures 1 +## cut + +select STDERR; + +#----------------------------------------------------------------------------- + +## name 4 args +## failures 0 +## cut + +select( undef, undef, undef, 0.25 ); + +#----------------------------------------------------------------------------- + +## name RT Bug #15653 +## failures 0 +## cut + +sub select { } + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/InputOutput/ProhibitReadlineInForLoop.run b/t/InputOutput/ProhibitReadlineInForLoop.run new file mode 100644 index 0000000..8c61350 --- /dev/null +++ b/t/InputOutput/ProhibitReadlineInForLoop.run @@ -0,0 +1,31 @@ +## name basic failures +## failures 6 +## cut +for my $foo () {} +for $foo (<$fh>) {} +for (<>) {} + +foreach my $foo () {} +foreach $foo (<$fh>) {} +foreach (<>) {} + +#----------------------------------------------------------------------------- + +## name basic passes +## failures 0 +## cut +for my $foo (@lines) {} +while( my $foo = <> ){} +while( $foo = <> ){} +while( <> ){} + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/InputOutput/ProhibitTwoArgOpen.run b/t/InputOutput/ProhibitTwoArgOpen.run new file mode 100644 index 0000000..3476d95 --- /dev/null +++ b/t/InputOutput/ProhibitTwoArgOpen.run @@ -0,0 +1,113 @@ +## name basic failures +## failures 12 +## cut + +open $fh, ">$output"; +open($fh, ">$output"); +open($fh, ">$output") or die; + +open my $fh, ">$output"; +open(my $fh, ">$output"); +open(my $fh, ">$output") or die; + +open FH, ">$output"; +open(FH, ">$output"); +open(FH, ">$output") or die; + +#This are tricky because the Critic can't +#tell where the expression really ends +open FH, ">$output" or die; +open $fh, ">$output" or die; +open my $fh, ">$output" or die; + +#----------------------------------------------------------------------------- + +## name basic passes +## failures 0 +## cut + +open $fh, '>', $output; +open($fh, '>', $output); +open($fh, '>', $output) or die; + +open my $fh, '>', $output; +open(my $fh, '>', $output); +open(my $fh, '>', $output) or die; + +open FH, '>', $output; +open(FH, '>', $output); +open(FH, '>', $output) or die; + +#This are tricky because the Critic can't +#tell where the expression really ends +open $fh, '>', $output or die; +open my $fh, '>', $output or die; +open FH, '>', $output or die; + +$foo{open}; # not a function call + +#----------------------------------------------------------------------------- + +## name no three-arg equivalent passes +## failures 0 +## cut + +open( STDOUT, '>&STDOUT' ); +open( STDIN, '>&STDIN' ); +open( STDERR, '>&STDERR' ); + +open( \*STDOUT, '>&STDERR' ); +open( *STDOUT, '>&STDERR' ); +open( STDOUT, '>&STDERR' ); + +# These are actually forks +open FH, '-|'; +open FH, '|-'; + +open FH, q{-|}; +open FH, qq{-|}; +open FH, "-|"; + +# Other file modes. +open( \*STDOUT, '>>&STDERR' ); +open( \*STDOUT, '<&STDERR' ); +open( \*STDOUT, '+>&STDERR' ); +open( \*STDOUT, '+>>&STDERR' ); +open( \*STDOUT, '+<&STDERR' ); + +#----------------------------------------------------------------------------- + +## name pass with "use 5.005" +## failures 0 +## cut + +open $fh, ">$output"; +use 5.005; + +#----------------------------------------------------------------------------- + +## name fail with "use 5.006" +## failures 1 +## cut + +open $fh, ">$output"; +use 5.006; + +#----------------------------------------------------------------------------- + +## name rt44554 two arg open should fail +## failures 1 +## cut + +open my $a, 'testing' or die 'error: ', $!; + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/InputOutput/RequireBracedFileHandleWithPrint.run b/t/InputOutput/RequireBracedFileHandleWithPrint.run new file mode 100644 index 0000000..2185d21 --- /dev/null +++ b/t/InputOutput/RequireBracedFileHandleWithPrint.run @@ -0,0 +1,238 @@ +## name basic failures (print) +## failures 7 +## cut + +#print $fh; #Punt on this +#print $fh if 1; +print $fh "something" . "something else"; +print $fh generate_report(); +print $fh "something" if $DEBUG; +print $fh @list; +print $fh $foo, $bar; +print( $fh @list ); +print( $fh $foo, $bar ); + +#----------------------------------------------------------------------------- + +## name basic failures (printf) +## failures 7 +## cut + +#printf $fh; #Punt on this +#printf $fh if 1; +printf $fh "something" . "something else"; +printf $fh generate_report(); +printf $fh "something" if $DEBUG; +printf $fh @list; +printf $fh $foo, $bar; +printf( $fh @list ); +printf( $fh $foo, $bar ); + +#----------------------------------------------------------------------------- + +## name more arcane passes (print) +## failures 0 +## cut +print "something" . "something else"; +print "something" . "something else" + or die; +print {FH} "something" . "something else"; +print {FH} "something" . "something else" + or die; + +print generate_report(); +print generate_report() + or die; +print {FH} generate_report(); +print {FH} generate_report() + or die; + +print rand 10; +print rand 10 + or die; + +print {FH}; +print {FH} + or die; +print {FH} @list; +print {FH} @list + or die; +print {FH} $foo, $bar; +print {FH} $foo, $bar + or die; + +print @list; +print @list + or die; +print $foo, $bar; +print $foo, $bar + or die; +print $foo , $bar; +print $foo , $bar + or die; +print foo => 1; +print foo => 1 + or die; + +print( {FH} @list ); +print( {FH} @list ) + or die; +print( {FH} $foo, $bar ); +print( {FH} $foo, $bar ) + or die; + +print(); +print() + or die; +print( ); +print( ) + or die; +print( @list ); +print( @list ) + or die; +print( $foo, $bar ); +print( $foo, $bar ) + or die; + +print if 1; +print or die if 1; + +print 1 2; # syntax error, but not a policy violation +$foo{print}; # not a function call +{print}; # no siblings + +#----------------------------------------------------------------------------- + +## name more arcane passes (printf) +## failures 0 +## cut +printf "something" . "something else"; +printf "something" . "something else" + or die; +printf {FH} "something" . "something else"; +printf {FH} "something" . "something else" + or die; + +printf generate_report(); +printf generate_report() + or die; +printf {FH} generate_report(); +printf {FH} generate_report() + or die; + +printf rand 10; +printf rand 10 + or die; + +printf {FH}; +printf {FH} + or die; +printf {FH} @list; +printf {FH} @list + or die; +printf {FH} $foo, $bar; +printf {FH} $foo, $bar + or die; + +printf @list; +printf @list + or die; +printf $foo, $bar; +printf $foo, $bar + or die; +printf $foo , $bar; +printf $foo , $bar + or die; +printf foo => 1; +printf foo => 1 + or die; + +printf( {FH} @list ); +printf( {FH} @list ) + or die; +printf( {FH} $foo, $bar ); +printf( {FH} $foo, $bar ) + or die; + +printf(); +printf() + or die; +printf( ); +printf( ) + or die; +printf( @list ); +printf( @list ) + or die; +printf( $foo, $bar ); +printf( $foo, $bar ) + or die; + +printf if 1; +printf or die if 1; + +printf 1 2; # syntax error, but not a policy violation +$foo{printf}; # not a function call +{printf}; # no siblings + +#----------------------------------------------------------------------------- + +## name more bracing arcana (print) +## failures 0 +## cut + +print {$fh}; +print {$fh} @list; +print {$fh} $foo, $bar; +print( {$fh} @list ); +print( {$fh} $foo, $bar ); + +#----------------------------------------------------------------------------- + +## name more bracing arcana (printf) +## failures 0 +## cut + +printf {$fh}; +printf {$fh} @list; +printf {$fh} $foo, $bar; +printf( {$fh} @list ); +printf( {$fh} $foo, $bar ); + +#----------------------------------------------------------------------------- + +## name RT #49500: say violations +## failures 6 +## cut + +say FH "foo"; +# say $fh; #Punt on this +say $fh "foo"; +say $fh @list; +say $fh print_report(); +say $fh "foo" or die; +say( $fh "foo" ); + +#----------------------------------------------------------------------------- + +## name RT #49500: say compliances +## failures 0 +## cut + +say { FH } "foo"; +say { $fh }; +say { $fh } "foo"; +say { $fh } @list; +say { $fh } print_report(); +say { $fh } "foo" or die; +say( { $fh } "foo" ); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/InputOutput/RequireBriefOpen.run b/t/InputOutput/RequireBriefOpen.run new file mode 100644 index 0000000..1e46d93 --- /dev/null +++ b/t/InputOutput/RequireBriefOpen.run @@ -0,0 +1,393 @@ +## name open .. close +## failures 0 +## cut + +open my $fh1, '<', $filename or die; +close $fh1; +open my $fh2, '<', $filename or die; +close $fh2; +if (open my $fh3, '<', $filename) { + close $fh3; +} + +my $fh4; +open $fh4, '<', $filename or die; +close $fh4; + +#----------------------------------------------------------------------------- + +## name OO +## failures 0 +## cut + +open my $fh1, '<', $filename or die; +$fh1->close; + +#----------------------------------------------------------------------------- + +## name else +## failures 0 +## cut + +if (!open my $fh3, '<', $filename) { + croak; +} else { + close $fh3; +} + +#----------------------------------------------------------------------------- + +## name while .. print +## failures 0 +## cut + +open my $fh1, '<', $filename or die; +while (<$fh1>) { + print; +} +close $fh1; + +if (open my $fh2, '<', $filename) { + while (<$fh2>) { + print; + } + close $fh2; +} + +#----------------------------------------------------------------------------- + +## name basic failures +## failures 2 +## cut + +open my $fh1, '<', $filename or die; +close $fh0; +if (open my $fh2, '<', $filename) { + while (<$fh2>) { + print; + } +} + +#----------------------------------------------------------------------------- + +## name lexical wrong name failure +## failures 2 +## cut + +open my $fh1, '<', $filename or die; +close $fh2; +open my $fh3, '<', $filename or die; +$fh4->close; + +#----------------------------------------------------------------------------- + +## name scope failure +## failures 1 +## cut + +{ + open my $fh1, '<', $filename; +} +close $fh1; + +#----------------------------------------------------------------------------- + +## name glob scope failure; no longer fails w/ RT #64437 applied. +## failures 0 +## cut + +{ + open FH1, '<', $filename; +} +close FH1; + +#----------------------------------------------------------------------------- + +## name glob filehandle +## failures 0 +## cut + +local (*FH1); +open FH1, '<', $filename or die; +close FH1; + +#----------------------------------------------------------------------------- + +## name glob failure +## failures 2 +## cut + +local (*FH2); +open FH2, '<', $filename or die; +open *FH3, '<', $filename or die; + +#----------------------------------------------------------------------------- + +## name glob wrong name failure +## failures 1 +## cut + +local (*FH1); +open FH1, '<', $filename or die; +close FH2; + +#----------------------------------------------------------------------------- + +## name we do not flag non-uppercase globs -- maybe it is a sub call +## failures 0 +## cut + +local (*fh1); +open fh1, '<', $filename or die; + +#----------------------------------------------------------------------------- + +## name fail blocks +## failures 2 +## cut + +my $foo; +open {$foo}, '<', $filename or die; + +open {*BAR}, '<', $filename or die; + +#----------------------------------------------------------------------------- + +## name allow std handles +## failures 0 +## cut + +open STDIN, '<', $filename or die; +open STDOUT, '>', $filename or die; +open STDERR, '>', $filename or die; + +#----------------------------------------------------------------------------- + +## name allow std globs in blocks +## failures 0 +## cut + +open {*STDIN}, '<', $filename or die; +open {*STDOUT}, '>', $filename or die; +open {*STDERR}, '>', $filename or die; + +#----------------------------------------------------------------------------- + +## name config - pass at default +## failures 0 +## cut + +open my $fh1, '<', $filename; +# 1 +# 2 +# 3 +# 4 +# 5 +# 6 +# 7 +# 8 +close $fh1; + +#----------------------------------------------------------------------------- + +## name config - fail at one after default +## failures 1 +## cut + +open my $fh1, '<', $filename; +# 1 +# 2 +# 3 +# 4 +# 5 +# 6 +# 7 +# 8 +# 9 +close $fh1; + +#----------------------------------------------------------------------------- + +## name config - set lines to 2 +## failures 1 +## parms {lines => '2'} +## cut + +open my $fh1, '<', $filename; +# 1 +close $fh1; + +open my $fh2, '<', $filename; +# 1 +# 2 +close $fh2; + +#----------------------------------------------------------------------------- + +## name nested sub +## failures 1 +## cut + +open my $fh1, '<', $filename; +sub not_a_recommended_idiom { + close $fh1; +} + +#----------------------------------------------------------------------------- + +## name opener sub +## failures 0 +## cut + +sub my_open { + my ($filename) = @_; + open my $fh1, '<', $filename or return; + return $fh1; +} + +#----------------------------------------------------------------------------- + +## name long opener sub failure +## failures 1 +## cut + +sub my_open { + my ($filename) = @_; + open my $fh1, '<', $filename or return; + # 1 + # 2 + # 3 + # 4 + # 5 + # 6 + # 7 + # 8 + # 9 + return $fh1; +} + +#----------------------------------------------------------------------------- + +## name opener sub failure +## failures 1 +## cut + +sub my_open { + my ($filename) = @_; + open my $fh1, '<', $filename or return; + return $fh2; +} + +#----------------------------------------------------------------------------- + +## name unusual lexical syntax +## failures 1 +## TODO we do not recognize parenthesized lexical declarations +## cut + +open my ($fh1), '<', $filename; + +#----------------------------------------------------------------------------- + +## name code coverage - unsupported open() calls +## failures 0 +## cut + +$self->open($door); +open($fh); # erroneous call +open(get_fh(), '<', $filename); # first arg returns a filehandle -- bad form +open(1 + 1, '<', $filename); # nonsense + +#----------------------------------------------------------------------------- + +## name code coverage - glob topic for method call +## failures 1 +## cut + +open FH1, '<', $filename; +FH1->close; # invalid code + +#----------------------------------------------------------------------------- + +## name code coverage - close is not a function or method call +## failures 1 +## cut + +open my $fh, '<', $filename; +$hash->{close}; + +#----------------------------------------------------------------------------- + +## name code coverage - FH is not a glob or scalar +## failures 0 +## cut + +open @foo, '<', $filename; # nonsense +open @$foo, '<', $filename; # nonsense +open my @bar, '<', $filename; # nonsense + +#----------------------------------------------------------------------------- + +## name CORE::close() - RT #52391 +## failures 0 +## cut + +open( my $fh, '<', $filename ); +my $value = <$fh>; +CORE::close($fh); + +#----------------------------------------------------------------------------- + +## name CORE::GLOBAL::close() +## failures 0 +## cut + +open my $fh, '<', $filename; +my $value = <$fh>; +CORE::GLOBAL::close($fh); + +#----------------------------------------------------------------------------- + +## name CORE::open() +## failures 1 +## cut + +CORE::open my $fh, '<', $filename; + +#----------------------------------------------------------------------------- + +## name CORE::GLOBAL::open() +## failures 1 +## cut + +CORE::GLOBAL::open(my $fh, '<', $filename); + +#----------------------------------------------------------------------------- + +## name Handle declared in outer scope RT #64437 +## failures 0 +## cut + +#!/usr/bin/perl + +my $file = 'fubar'; +my ($fh, @lines); + +if (! open $fh, '<', $file) { + croak "Error opening $file for reading: $!"; +} +@lines = <$fh>; +if (! close $fh) { + croak "Error closing $file after reading: $!"; +} + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/InputOutput/RequireCheckedClose.run b/t/InputOutput/RequireCheckedClose.run new file mode 100644 index 0000000..d198272 --- /dev/null +++ b/t/InputOutput/RequireCheckedClose.run @@ -0,0 +1,178 @@ +## name passes by assigning error variable +## failures 0 +## cut + +my $error = close( $filehandle ); +my $error = close $filehandle; +my $error = close CLOSE; +my $error = close OR; + +#----------------------------------------------------------------------------- + +## name passes by "or die" +## failures 0 +## cut + +close $filehandle or die 'could not close'; +close ($filehandle) or die 'could not close'; +close ($filehandle) or croak 'could not close'; + +#----------------------------------------------------------------------------- + +## name passes by "|| die" +## failures 0 +## cut + +close $filehandle || die 'could not close'; +close ($filehandle) || die 'could not close'; +close ($filehandle) || croak 'could not close'; + +#----------------------------------------------------------------------------- + +## name passes by "unless" +## failures 0 +## cut + +die unless close ( $filehandle ); +die unless close $filehandle; + +croak unless close ( $filehandle ); +croak unless close $filehandle; + +#----------------------------------------------------------------------------- + +## name passes by "if not" +## failures 0 +## cut + +die if not close ( $filehandle ); +die if not close $filehandle; + +croak if not close ( $filehandle ); +croak if not close $filehandle; + +die if !close ( $filehandle ); +die if !close $filehandle; + +croak if !close ( $filehandle ); +croak if !close $filehandle; + +#----------------------------------------------------------------------------- + +## name passes with "if" statement +## failures 0 +## cut + +if ( close $filehandle ) { dosomething(); }; + +#----------------------------------------------------------------------------- + +## name Basic failure with parens +## failures 1 +## cut + +close( $filehandle ); + +#----------------------------------------------------------------------------- + +## name Basic failure no parens +## failures 1 +## cut + +close $filehandle; + +#----------------------------------------------------------------------------- + +## name Fatal.pm on +## failures 0 +## cut + +use Fatal qw(close); +close $filehandle; + +#----------------------------------------------------------------------------- + +## name Fatal.pm on +## failures 0 +## cut + +use Fatal 'close'; +close $filehandle; + +#----------------------------------------------------------------------------- + +## name Fatal.pm on +## failures 0 +## cut + +use Fatal ('close'); +close $filehandle; + +#----------------------------------------------------------------------------- + +## name Fatal::Exception on +## failures 0 +## cut + +use Fatal::Exception 'Exception' => qw(close); +close $filehandle; + +#----------------------------------------------------------------------------- + +## name Fatal.pm off +## failures 1 +## cut + +use Fatal qw(open); +close $filehandle; + +#----------------------------------------------------------------------------- + +## name autodie on via no parameters +## failures 0 +## cut + +use autodie; +close $filehandle; + +#----------------------------------------------------------------------------- + +## name autodie on via :io +## failures 0 +## cut + +use autodie qw< :io >; +close $filehandle; + +#----------------------------------------------------------------------------- + +## name autodie off +## failures 1 +## cut + +use autodie qw< :system >; +close $filehandle; + +#----------------------------------------------------------------------------- + +## name autodie on and off +## failures 1 +## TODO need to handle autodie lexically. +## cut + +use autodie; +{ + no autodie; + + close $filehandle; +} + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/InputOutput/RequireCheckedOpen.run b/t/InputOutput/RequireCheckedOpen.run new file mode 100644 index 0000000..e5e7341 --- /dev/null +++ b/t/InputOutput/RequireCheckedOpen.run @@ -0,0 +1,197 @@ +## name passes by assigning error variable +## failures 0 +## cut + +my $error = open( $filehandle, $mode, $filename ); +my $error = open $filehandle, $mode, $filename; +my $error = open OPEN, $open, 'open'; +my $error = open OR, $or, 'or'; + +#----------------------------------------------------------------------------- + +## name passes by "or die" +## failures 0 +## cut + +open $filehandle, $mode, $filename or die 'could not open'; +open( $filehandle, $mode, $filename ) or die 'could not open'; +open( $filehandle, $mode, $filename ) or croak 'could not open'; + +#----------------------------------------------------------------------------- + +## name passes by "|| die" +## failures 0 +## cut + +open $filehandle, $mode, $filename or die 'could not open'; +open( $filehandle, $mode, $filename ) || die 'could not open'; +open( $filehandle, $mode, $filename ) || croak 'could not open'; + +#----------------------------------------------------------------------------- + +## name passes by "unless" +## failures 0 +## cut + +die unless open( $filehandle, $mode, $filename ); +die unless open $filehandle, $mode, $filename; + +croak unless open( $filehandle, $mode, $filename ); +croak unless open $filehandle, $mode, $filename; + +#----------------------------------------------------------------------------- + +## name passes by "if not" +## failures 0 +## cut + +die if not open( $filehandle, $mode, $filename ); +die if not open $filehandle, $mode, $filename; + +croak if not open( $filehandle, $mode, $filename ); +croak if not open $filehandle, $mode, $filename; + +die if !open( $filehandle, $mode, $filename ); +die if !open $filehandle, $mode, $filename; + +croak if !open( $filehandle, $mode, $filename ); +croak if !open $filehandle, $mode, $filename; + +#----------------------------------------------------------------------------- + +## name passes with "if" statement +## failures 0 +## cut + +if ( open( $filehandle, $mode, $filename ) ) { dosomething(); }; + +#----------------------------------------------------------------------------- + +## name Basic failure with parens +## failures 2 +## cut + +open( $filehandle, $mode, $filename ); +open( $filehandle, $filename ); + +#----------------------------------------------------------------------------- + +## name Basic failure no parens +## failures 2 +## cut + +open $filehandle, $mode, $filename; +open $filehandle, $filename; + +#----------------------------------------------------------------------------- + +## name Fatal.pm on +## failures 0 +## cut + +use Fatal qw(open); +open $filehandle, $filename; + +#----------------------------------------------------------------------------- + +## name Fatal.pm on +## failures 0 +## cut + +use Fatal 'open'; +open $filehandle, $filename; + +#----------------------------------------------------------------------------- + +## name Fatal.pm on +## failures 0 +## cut + +use Fatal ('open'); +open $filehandle, $filename; + +#----------------------------------------------------------------------------- + +## name Fatal::Exception on +## failures 0 +## cut + +use Fatal::Exception 'Exception' => qw(open); +open $filehandle, $filename; + +#----------------------------------------------------------------------------- + +## name Fatal.pm off +## failures 1 +## cut + +use Fatal qw(close); +open $filehandle, $filename; + +#----------------------------------------------------------------------------- + +## name autodie on via no parameters +## failures 0 +## cut + +use autodie; +open $filehandle; + +#----------------------------------------------------------------------------- + +## name autodie on via pragma with numeric version number (GH #612) +## failures 0 +## cut + +use autodie 2.14; +open $filehandle; + +#----------------------------------------------------------------------------- + +## name autodie on via pragma with vstring version (GH #612) +## failures 0 +## cut + +use autodie v2.14.8; +open $filehandle; + +#----------------------------------------------------------------------------- + +## name autodie on via :io +## failures 0 +## cut + +use autodie qw< :io >; +open $filehandle; + +#----------------------------------------------------------------------------- + +## name autodie off +## failures 1 +## cut + +use autodie qw< :system >; +open $filehandle; + +#----------------------------------------------------------------------------- + +## name autodie on and off +## failures 1 +## TODO need to handle autodie lexically. +## cut + +use autodie; +{ + no autodie; + + open $filehandle; +} + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/InputOutput/RequireCheckedSyscalls.run b/t/InputOutput/RequireCheckedSyscalls.run new file mode 100644 index 0000000..0be54ed --- /dev/null +++ b/t/InputOutput/RequireCheckedSyscalls.run @@ -0,0 +1,405 @@ +## name passes by assigning error variable +## failures 0 +## cut + +my $error = open( $filehandle, $mode, $filename ); +my $error = open $filehandle, $mode, $filename; +my $error = open OPEN, $open, 'open'; +my $error = open OR, $or, 'or'; + +#----------------------------------------------------------------------------- + +## name passes by "or die" +## failures 0 +## cut + +open $filehandle, $mode, $filename or die 'could not open'; +open( $filehandle, $mode, $filename ) or die 'could not open'; +open( $filehandle, $mode, $filename ) or croak 'could not open'; + +#----------------------------------------------------------------------------- + +## name passes by "|| die" +## failures 0 +## cut + +open $filehandle, $mode, $filename or die 'could not open'; +open( $filehandle, $mode, $filename ) || die 'could not open'; +open( $filehandle, $mode, $filename ) || croak 'could not open'; + +#----------------------------------------------------------------------------- + +## name passes by "unless" +## failures 0 +## cut + +die unless open( $filehandle, $mode, $filename ); +die unless open $filehandle, $mode, $filename; + +croak unless open( $filehandle, $mode, $filename ); +croak unless open $filehandle, $mode, $filename; + +#----------------------------------------------------------------------------- + +## name passes by "if not" +## failures 0 +## cut + +die if not open( $filehandle, $mode, $filename ); +die if not open $filehandle, $mode, $filename; + +croak if not open( $filehandle, $mode, $filename ); +croak if not open $filehandle, $mode, $filename; + +die if !open( $filehandle, $mode, $filename ); +die if !open $filehandle, $mode, $filename; + +croak if !open( $filehandle, $mode, $filename ); +croak if !open $filehandle, $mode, $filename; + +#----------------------------------------------------------------------------- + +## name passes with "if" statement +## failures 0 +## cut + +if ( open( $filehandle, $mode, $filename ) ) { dosomething(); }; + +#----------------------------------------------------------------------------- + +## name Basic failure with parens +## failures 2 +## cut + +open( $filehandle, $mode, $filename ); +open( $filehandle, $filename ); + +#----------------------------------------------------------------------------- + +## name Basic failure no parens +## failures 2 +## cut + +open $filehandle, $mode, $filename; +open $filehandle, $filename; + +#----------------------------------------------------------------------------- + +## name Fatal.pm on +## failures 0 +## cut + +use Fatal qw(open); +open $filehandle, $filename; + +#----------------------------------------------------------------------------- + +## name Fatal.pm on +## failures 0 +## cut + +use Fatal 'open'; +open $filehandle, $filename; + +#----------------------------------------------------------------------------- + +## name Fatal.pm on +## failures 0 +## cut + +use Fatal ('open'); +open $filehandle, $filename; + +#----------------------------------------------------------------------------- + +## name Fatal::Exception on +## failures 0 +## cut + +use Fatal::Exception 'Exception' => qw(open); +open $filehandle, $filename; + +#----------------------------------------------------------------------------- + +## name Fatal.pm off +## failures 1 +## cut + +use Fatal qw(close); +open $filehandle, $filename; + +#----------------------------------------------------------------------------- + +## name passes by assigning error variable +## failures 0 +## cut + +my $error = close( $filehandle ); +my $error = close $filehandle; +my $error = close CLOSE; +my $error = close OR; + +#----------------------------------------------------------------------------- + +## name passes by "or die" +## failures 0 +## cut + +close $filehandle or die 'could not close'; +close ($filehandle) or die 'could not close'; +close ($filehandle) or croak 'could not close'; + +#----------------------------------------------------------------------------- + +## name passes by "|| die" +## failures 0 +## cut + +close $filehandle || die 'could not close'; +close ($filehandle) || die 'could not close'; +close ($filehandle) || croak 'could not close'; + +#----------------------------------------------------------------------------- + +## name passes by "unless" +## failures 0 +## cut + +die unless close ( $filehandle ); +die unless close $filehandle; + +croak unless close ( $filehandle ); +croak unless close $filehandle; + +#----------------------------------------------------------------------------- + +## name passes by "if not" +## failures 0 +## cut + +die if not close ( $filehandle ); +die if not close $filehandle; + +croak if not close ( $filehandle ); +croak if not close $filehandle; + +die if !close ( $filehandle ); +die if !close $filehandle; + +croak if !close ( $filehandle ); +croak if !close $filehandle; + +#----------------------------------------------------------------------------- + +## name passes with "if" statement +## failures 0 +## cut + +if ( close $filehandle ) { dosomething(); }; + +#----------------------------------------------------------------------------- + +## name Basic failure with parens +## failures 1 +## cut + +close( $filehandle ); + +#----------------------------------------------------------------------------- + +## name Basic failure no parens +## failures 1 +## cut + +close $filehandle; + +#----------------------------------------------------------------------------- + +## name Fatal.pm on +## failures 0 +## cut + +use Fatal qw(close); +close $filehandle; + +#----------------------------------------------------------------------------- + +## name Fatal.pm on +## failures 0 +## cut + +use Fatal 'close'; +close $filehandle; + +#----------------------------------------------------------------------------- + +## name Fatal.pm on +## failures 0 +## cut + +use Fatal ('close'); +close $filehandle; + +#----------------------------------------------------------------------------- + +## name Fatal::Exception on +## failures 0 +## cut + +use Fatal::Exception 'Exception' => qw(close); +close $filehandle; + +#----------------------------------------------------------------------------- + +## name Fatal.pm off +## failures 1 +## cut + +use Fatal qw(open); +close $filehandle; + +#----------------------------------------------------------------------------- + +## name autodie on via no parameters +## failures 0 +## cut + +use autodie; +close $filehandle; + +#----------------------------------------------------------------------------- + +## name autodie on via :io +## failures 0 +## cut + +use autodie qw< :io >; +close $filehandle; + +#----------------------------------------------------------------------------- + +## name autodie off +## failures 1 +## cut + +use autodie qw< :system >; +close $filehandle; + +#----------------------------------------------------------------------------- + +## name autodie on and off +## failures 1 +## TODO need to handle autodie lexically. +## cut + +use autodie; +{ + no autodie; + + close $filehandle; +} + +#----------------------------------------------------------------------------- + +## name no config +## failures 0 +## cut + +accept NEWSOCK, SOCKET; + +#----------------------------------------------------------------------------- + +## name config with single function +## parms {functions => 'accept'} +## failures 1 +## cut + +accept NEWSOCK, SOCKET; + +#----------------------------------------------------------------------------- + +## name config with :builtins +## parms {functions => ':builtins'} +## failures 1 +## cut + +accept NEWSOCK, SOCKET; + +#----------------------------------------------------------------------------- + +## name config with :builtins except print with failure +## parms {functions => ':builtins', exclude_functions => 'print'} +## failures 1 +## cut + +accept NEWSOCK, SOCKET; + +#----------------------------------------------------------------------------- + +## name config with :builtins except print with failure +## parms {functions => ':builtins', exclude_functions => 'print'} +## failures 0 +## cut + +print 'Foo!'; + +#----------------------------------------------------------------------------- + +## name insane config with failures +## parms {functions => ':all'} +## failures 2 +## cut + +sub foo { + return 1; +} +foo(); + +#----------------------------------------------------------------------------- + +## name insane config without failures +## parms {functions => ':all'} +## failures 0 +## cut + +sub foo { + return 1 or die; +} +foo() or die; + +#----------------------------------------------------------------------------- + +## name insane config with excluded function +## parms {functions => ':all', exclude_functions => 'foo'} +## failures 0 +## cut + +foo(); + +#----------------------------------------------------------------------------- + +## name RT #37487 - complain about use of say +## failures 1 +## cut + +say 'The sun is a mass of incandessent gas'; + +#----------------------------------------------------------------------------- + +## name allow alternative autodie modules +## parms {autodie_modules => 'custom::autodier'} +## failures 0 +## cut + +use custom::autodier; +open my $fh, '>', 'foo'; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/InputOutput/RequireEncodingWithUTF8Layer.run b/t/InputOutput/RequireEncodingWithUTF8Layer.run new file mode 100644 index 0000000..2308cf7 --- /dev/null +++ b/t/InputOutput/RequireEncodingWithUTF8Layer.run @@ -0,0 +1,156 @@ +## name basic failures +## failures 33 +## cut + +open $fh, ">:utf8", $output; +open($fh, ">:utf8", $output); +open($fh, ">:utf8", $output) or die; + +open my $fh, ">:utf8", $output; +open(my $fh, ">:utf8", $output); +open(my $fh, ">:utf8", $output) or die; + +open FH, ">:utf8", $output; +open(FH, ">:utf8", $output); +open(FH, ">:utf8", $output) or die; + +#This are tricky because the Critic can't +#tell where the expression really ends +open FH, ">:utf8", $output or die; +open $fh, ">:utf8", $output or die; +open my $fh, ">:utf8", $output or die; + +# Other file modes +open $fh, "<:utf8", $output; +open $fh, ">>:utf8", $output; +open $fh, "+>:utf8", $output; +open $fh, "+<:utf8", $output; +open $fh, "+>>:utf8", $output; + +# binmode() + +binmode $fh, ":utf8"; +binmode($fh, ":utf8"); +binmode($fh, ":utf8") or die; + +binmode FH, ":utf8"; +binmode(FH, ":utf8"); +binmode(FH, ":utf8") or die; + +#This are tricky because the Critic can't +#tell where the expression really ends +binmode FH, ":utf8" or die; +binmode $fh, ":utf8" or die; + +binmode $fh, "utf8"; +binmode($fh, "utf8"); +binmode($fh, "utf8") or die; + +binmode FH, "utf8"; +binmode(FH, "utf8"); +binmode(FH, "utf8") or die; + +#This are tricky because the Critic can't +#tell where the expression really ends +binmode FH, "utf8" or die; +binmode $fh, "utf8" or die; + +#----------------------------------------------------------------------------- + +## name basic passes +## failures 0 +## cut + +open $fh, ">$output"; +open($fh, ">$output"); +open($fh, ">$output") or die; + +open my $fh, ">$output"; +open(my $fh, ">$output"); +open(my $fh, ">$output") or die; + +open FH, ">$output"; +open(FH, ">$output"); +open(FH, ">$output") or die; + +#This are tricky because the Critic can't +#tell where the expression really ends +open $fh, ">$output" or die; +open my $fh, ">$output" or die; +open FH, ">$output" or die; + +open $fh, '>', $output; +open($fh, '>', $output); +open($fh, '>', $output) or die; + +open my $fh, '>', $output; +open(my $fh, '>', $output); +open(my $fh, '>', $output) or die; + +open FH, '>', $output; +open(FH, '>', $output); +open(FH, '>', $output) or die; + +#This are tricky because the Critic can't +#tell where the expression really ends +open $fh, '>', $output or die; +open my $fh, '>', $output or die; +open FH, '>', $output or die; + +open $fh, '>:encoding(utf8)', $output; +open($fh, '>:encoding(utf8)', $output); +open($fh, '>:encoding(utf8)', $output) or die; + +open my $fh, '>:encoding(utf8)', $output; +open(my $fh, '>:encoding(utf8)', $output); +open(my $fh, '>:encoding(utf8)', $output) or die; + +open FH, '>:encoding(utf8)', $output; +open(FH, '>:encoding(utf8)', $output); +open(FH, '>:encoding(utf8)', $output) or die; + +#This are tricky because the Critic can't +#tell where the expression really ends +open $fh, '>:encoding(utf8)', $output or die; +open my $fh, '>:encoding(utf8)', $output or die; +open FH, '>:encoding(utf8)', $output or die; + +# binmode + +binmode $fh; +binmode($fh); +binmode($fh) or die; + +binmode FH; +binmode(FH); +binmode(FH) or die; + +#This are tricky because the Critic can't +#tell where the expression really ends +binmode $fh or die; +binmode FH or die; + +binmode $fh, ':encoding(utf8)'; +binmode($fh, ':encoding(utf8)'); +binmode($fh, ':encoding(utf8)') or die; + +binmode FH, ':encoding(utf8)'; +binmode(FH, ':encoding(utf8)'); +binmode(FH, ':encoding(utf8)') or die; + +#This are tricky because the Critic can't +#tell where the expression really ends +binmode $fh, ':encoding(utf8)' or die; +binmode FH, ':encoding(utf8)' or die; + +$foo{open}; # not a function call + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Miscellanea/ProhibitFormats.run b/t/Miscellanea/ProhibitFormats.run new file mode 100644 index 0000000..ca975a8 --- /dev/null +++ b/t/Miscellanea/ProhibitFormats.run @@ -0,0 +1,41 @@ +## name standard failures +## failures 4 +## cut +format STDOUT = +@<<<<<< @|||||| @>>>>>> +"left", "middle", "right" +. + +format = +@<<<<<< @|||||| @>>>>>> +"foo", "bar", "baz" +. + +format REPORT_TOP = + Passwd File +Name Login Office Uid Gid Home +------------------------------------------------------------------ +. +format REPORT = +@<<<<<<<<<<<<<<<<<< @||||||| @<<<<<<@>>>> @>>>> @<<<<<<<<<<<<<<<<< +$name, $login, $office,$uid,$gid, $home +. + +#----------------------------------------------------------------------------- + +## name basic passes +## failures 0 +## cut +$hash{format} = 'foo'; +%hash = ( format => 'baz' ); +$object->format(); + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Miscellanea/ProhibitTies.run b/t/Miscellanea/ProhibitTies.run new file mode 100644 index 0000000..5184d73 --- /dev/null +++ b/t/Miscellanea/ProhibitTies.run @@ -0,0 +1,37 @@ +## name basic failures +## failures 12 +## cut +tie $scalar, 'Some::Class'; +tie @array, 'Some::Class'; +tie %hash, 'Some::Class'; + +tie ($scalar, 'Some::Class'); +tie (@array, 'Some::Class'); +tie (%hash, 'Some::Class'); + +tie $scalar, 'Some::Class', @args; +tie @array, 'Some::Class', @args; +tie %hash, 'Some::Class' @args; + +tie ($scalar, 'Some::Class', @args); +tie (@array, 'Some::Class', @args); +tie (%hash, 'Some::Class', @args); + +#----------------------------------------------------------------------------- + +## name basic passes +## failures 0 +## cut +$hash{tie} = 'foo'; +%hash = ( tie => 'knot' ); +$object->tie(); + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Miscellanea/ProhibitUnrestrictedNoCritic.run b/t/Miscellanea/ProhibitUnrestrictedNoCritic.run new file mode 100644 index 0000000..68c83d2 --- /dev/null +++ b/t/Miscellanea/ProhibitUnrestrictedNoCritic.run @@ -0,0 +1,90 @@ +##---------------------------------------------------------------------------- +## name standard failures +## failures 4 +## cut + +##no critic +## no critic +## no critic; +## no critic #blah,blah + +##---------------------------------------------------------------------------- +## name slightly more complicated failures +## failures 4 +## cut + +# just some spacing variations here... +$foo = $bar; ## no critic +$foo = $bar; ##no critic + +$foo = $bar; ## no critic () +#$foo = $bar; ## no critic '' +#$foo = $bar; ## no critic "" +$foo = $bar; ## no critic qw() + +#---------------------------------------------------------------------------- +## name unrestricted "no critic" on a sub block +## failures 5 +## cut + +sub frobulate { ##no critic + return $frob; +} + +sub frobulate { ## no critic #blah,blah + return $frob; +} + +sub frobulate { ## no critic '' + return $frob; +} + +sub frobulate { ## no critic "" + return $frob; +} + +sub frobulate { ## no critic () + return $frob; +} + +##---------------------------------------------------------------------------- +## name standard passes +## failures 0 +## cut + +## no critic (shizzle) +## no critic 'shizzle' +## no critic "shizzle" +## no critic qw(shizzle) #blah,blah + +$foo = $bar; ## no critic 'shizzle'; +$foo = $bar; ## no critic "shizzle"; +$foo = $bar; ## no critic (shizzle); +$foo = $bar; ## no critic qw(shizzle); + + +sub frobulate { ## no critic 'shizzle' + return $frob; +} + +sub frobulate { ## no critic "shizzle" + return $frob; +} + +sub frobulate { ## no critic (shizzle) + return $frob; +} + +sub fornicate { ## no critic qw(shizzle) + return $forn; +} + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Modules/ProhibitAutomaticExportation.run b/t/Modules/ProhibitAutomaticExportation.run new file mode 100644 index 0000000..2c5ae63 --- /dev/null +++ b/t/Modules/ProhibitAutomaticExportation.run @@ -0,0 +1,90 @@ +## name Basic failure, "our @EXPORT;" +## failures 1 +## cut + +require Exporter; +our @EXPORT = qw(foo bar); + +#----------------------------------------------------------------------------- + +## name Basic failure, "use vars @EXPORT;" +## failures 1 +## cut + +use Exporter; +use vars '@EXPORT'; +@EXPORT = qw(foo bar); + +#----------------------------------------------------------------------------- + +## name Basic failure, "@PACKAGE::EXPORT;" +## failures 1 +## cut + +use base 'Exporter'; +@Foo::EXPORT = qw(foo bar); + +#----------------------------------------------------------------------------- + +## name Basic pass, "our @EXPORT_OK;" +## failures 0 +## cut + +require Exporter; +our @EXPORT_OK = ( '$foo', '$bar' ); + +#----------------------------------------------------------------------------- + +## name Basic pass, "use vars %EXPORT_TAGS;" +## failures 0 +## cut + +use Exporter; +use vars '%EXPORT_TAGS'; +%EXPORT_TAGS = (); + +#----------------------------------------------------------------------------- + +## name Basic pass, "@PACKAGE::EXPORT_OK;" +## failures 0 +## cut + +use base 'Exporter'; +@Foo::EXPORT_OK = qw(foo bar); + +#----------------------------------------------------------------------------- + +## name Basic pass, "use vars '@EXPORT_OK';" +## failures 0 +## cut + +use base 'Exporter'; +use vars qw(@EXPORT_OK); +@EXPORT_OK = qw(foo bar); + +#----------------------------------------------------------------------------- + +## name Basic pass, "use vars '%EXPORT_TAGS';" +## failures 0 +## cut + +use base 'Exporter'; +use vars qw(%EXPORT_TAGS); +%EXPORT_TAGS = ( foo => [ qw(baz bar) ] ); + +#----------------------------------------------------------------------------- + +## name No exporting at all +## failures 0 +## cut + +print 123; # no exporting at all; for test coverage + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Modules/ProhibitConditionalUseStatements.run b/t/Modules/ProhibitConditionalUseStatements.run new file mode 100644 index 0000000..f0032e6 --- /dev/null +++ b/t/Modules/ProhibitConditionalUseStatements.run @@ -0,0 +1,905 @@ +## name pass, simple use +## failures 0 +## cut + +use Foo::Bar; + +#----------------------------------------------------------------------------- + +## name pass, enclosing bare block +## failures 0 +## cut + +{ +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, enclosing labeled bare block +## failures 0 +## cut + +FOO: { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, enclosing subroutine +## failures 0 +## cut + +sub foo { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, enclosing begin block +## failures 0 +## cut + +BEGIN { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, enclosing do block +## failures 0 +## cut + +do { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, enclosing string eval block +## failures 0 +## cut + +eval "use Foo::Bar"; + +#----------------------------------------------------------------------------- + +## name pass, enclosing if statement in string eval +## failures 0 +## cut + +eval "if ($a == 1) { use Foo::Bar; }"; + +#----------------------------------------------------------------------------- + +## name pass, enclosing string eval in if statement +## failures 0 +## cut + +if ($a == 1) { +eval "use Foo::Bar;"; +} + +#----------------------------------------------------------------------------- + +## name pass, simple require +## failures 0 +## cut + +require Foo::Bar; + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing bare block +## failures 0 +## cut + +{ +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing labeled bare block +## failures 0 +## cut + +FOO: { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing subroutine +## failures 0 +## cut + +sub foo { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing begin block +## failures 0 +## cut + +BEGIN { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing do block +## failures 0 +## cut + +do { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing do following logical or +## failures 0 +## cut + +$a == 1 || do { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing do following logical and +## failures 0 +## cut + +$a && 1 || do { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing do following binary or +## failures 0 +## cut + +$a == 1 or do { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing do following binary and +## failures 0 +## cut + +$a == 1 and do { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require enclosing string eval block +## failures 0 +## cut + +eval "require Foo::Bar"; + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing if statement in string eval +## failures 0 +## cut + +eval "if ($a == 1) { require Foo::Bar; }"; + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing string eval in if statement +## failures 0 +## cut + +if ($a == 1) { +eval "require Foo::Bar;"; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing else statement +## failures 0 +## cut + +if ($a == 1) { +print 1; +} else { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing elsif statement +## failures 0 +## cut + +if ($a == 1) { +print 1; +} elsif ($a == 2) { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing while statement +## failures 0 +## cut + +while ($a == 1) { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing continue statement +## failures 0 +## cut + +while ($a == 1) { +print 1; +} continue { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing unless statement +## failures 0 +## cut + +unless ($a == 1) { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing until statement +## failures 0 +## cut + +until ($a == 1) { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing c-style for statement +## failures 0 +## cut + +for ($a = 1; $a < $b; $a++) { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing for statement +## failures 0 +## cut + +for $a (1..$b) { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing foreach statement +## failures 0 +## cut + +foreach $a (@b) { +require Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing if statement in begin block +## failures 0 +## cut + +BEGIN { +if ($a == 1) { +require Foo::Bar; +} +} + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing do-while block +## failures 0 +## cut + +do { +require Foo::Bar; +} while ($a == 1); + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing do-until block +## failures 0 +## cut + +do { +require Foo::Bar; +} until ($a == 1); + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing do-unless block +## failures 0 +## cut + +do { +require Foo::Bar; +} unless ($a == 1); + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing do-for block +## failures 0 +## cut + +do { +require Foo::Bar; +} for (1..2); + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing do-foreach block +## failures 0 +## cut + +do { +require Foo::Bar; +} foreach (@a); + +#----------------------------------------------------------------------------- + +## name pass, require in enclosing do-if block +## failures 0 +## cut + +do { +require Foo::Bar; +} if ($a == 1); + +#----------------------------------------------------------------------------- + +## name pass, simple pragma +## failures 0 +## cut + +use strict; + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing bare block +## failures 0 +## cut + +{ +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing labeled bare block +## failures 0 +## cut + +FOO: { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing subroutine +## failures 0 +## cut + +sub foo { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing begin block +## failures 0 +## cut + +BEGIN { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing do block +## failures 0 +## cut + +do { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing do following logical or +## failures 0 +## cut + +$a == 1 || do { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing do following logical and +## failures 0 +## cut + +$a && 1 || do { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing do following binary or +## failures 0 +## cut + +$a == 1 or do { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing do following binary and +## failures 0 +## cut + +$a == 1 and do { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma enclosing string eval block +## failures 0 +## cut + +eval "use strict"; + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing if statement in string eval +## failures 0 +## cut + +eval "if ($a == 1) { use strict; }"; + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing string eval in if statement +## failures 0 +## cut + +if ($a == 1) { +eval "use strict;"; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing else statement +## failures 0 +## cut + +if ($a == 1) { +print 1; +} else { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing elsif statement +## failures 0 +## cut + +if ($a == 1) { +print 1; +} elsif ($a == 2) { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing while statement +## failures 0 +## cut + +while ($a == 1) { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing continue statement +## failures 0 +## cut + +while ($a == 1) { +print 1; +} continue { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing unless statement +## failures 0 +## cut + +unless ($a == 1) { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing until statement +## failures 0 +## cut + +until ($a == 1) { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing c-style for statement +## failures 0 +## cut + +for ($a = 1; $a < $b; $a++) { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing for statement +## failures 0 +## cut + +for $a (1..$b) { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing foreach statement +## failures 0 +## cut + +foreach $a (@b) { +use strict; +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing if statement in begin block +## failures 0 +## cut + +BEGIN { +if ($a == 1) { +use strict; +} +} + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing do-while block +## failures 0 +## cut + +do { +use strict; +} while ($a == 1); + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing do-until block +## failures 0 +## cut + +do { +use strict; +} until ($a == 1); + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing do-unless block +## failures 0 +## cut + +do { +use strict; +} unless ($a == 1); + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing do-for block +## failures 0 +## cut + +do { +use strict; +} for (1..2); + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing do-foreach block +## failures 0 +## cut + +do { +use strict; +} foreach (@a); + +#----------------------------------------------------------------------------- + +## name pass, pragma in enclosing do-if block +## failures 0 +## cut + +do { +use strict; +} if ($a == 1); + +#----------------------------------------------------------------------------- + +## name failure, enclosing else statement +## failures 1 +## cut + +if ($a == 1) { +print 1; +} else { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name failure, enclosing elsif statement +## failures 1 +## cut + +if ($a == 1) { +print 1; +} elsif ($a == 2) { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name failure, enclosing while statement +## failures 1 +## cut + +while ($a == 1) { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name failure, enclosing continue statement +## failures 1 +## cut + +while ($a == 1) { +print 1; +} continue { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name failure, enclosing unless statement +## failures 1 +## cut + +unless ($a == 1) { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name failure, enclosing until statement +## failures 1 +## cut + +until ($a == 1) { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name failure, enclosing c-style for statement +## failures 1 +## cut + +for ($a = 1; $a < $b; $a++) { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name failure, enclosing for statement +## failures 1 +## cut + +for $a (1..$b) { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name failure, enclosing foreach statement +## failures 1 +## cut + +foreach $a (@b) { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name failure, enclosing if statement in begin block +## failures 1 +## cut + +BEGIN { +if ($a == 1) { +use Foo::Bar; +} +} + +#----------------------------------------------------------------------------- + +## name failure, enclosing eval statement +## failures 1 +## cut + +eval { +use Foo::Bar; +}; + +#----------------------------------------------------------------------------- + +## name failure, enclosing if statement in eval +## failures 1 +## cut + +eval { +if ($a == 1) { +use Foo::Bar; +} +}; + +#----------------------------------------------------------------------------- + +## name failure, enclosing do following logical or +## failures 1 +## cut + +$a == 1 || do { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name failure, enclosing do following logical and +## failures 1 +## cut + +$a && 1 || do { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name failure, enclosing do following binary or +## failures 1 +## cut + +$a == 1 or do { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name failure, enclosing do following binary and +## failures 1 +## cut + +$a == 1 and do { +use Foo::Bar; +} + +#----------------------------------------------------------------------------- + +## name failure, enclosing do-while block +## failures 1 +## cut + +do { +use Foo::Bar; +} while ($a == 1); + +#----------------------------------------------------------------------------- + +## name failure, enclosing do-until block +## failures 1 +## cut + +do { +use Foo::Bar; +} until ($a == 1); + +#----------------------------------------------------------------------------- + +## name failure, enclosing do-unless block +## failures 1 +## cut + +do { +use Foo::Bar; +} unless ($a == 1); + +#----------------------------------------------------------------------------- + +## name failure, enclosing do-for block +## failures 1 +## cut + +do { +use Foo::Bar; +} for (1..2); + +#----------------------------------------------------------------------------- + +## name failure, enclosing do-foreach block +## failures 1 +## cut + +do { +use Foo::Bar; +} foreach (@a); + +#----------------------------------------------------------------------------- + +## name failure, enclosing do-if block +## failures 1 +## cut + +do { +use Foo::Bar; +} if ($a == 1); + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Modules/ProhibitEvilModules.d/modules-no-regular-expressions.txt b/t/Modules/ProhibitEvilModules.d/modules-no-regular-expressions.txt new file mode 100644 index 0000000..15007ce --- /dev/null +++ b/t/Modules/ProhibitEvilModules.d/modules-no-regular-expressions.txt @@ -0,0 +1,6 @@ +Evil # Comment on same line as meaningful content. + +Fatal Found use of Fatal. Use autodie instead. + +# Extra leading and trailing whitespace here is intentional. + Getopt::Std Found use of Getopt::Std. Use Getopt::Long instead. diff --git a/t/Modules/ProhibitEvilModules.d/modules-regular-expressions.txt b/t/Modules/ProhibitEvilModules.d/modules-regular-expressions.txt new file mode 100644 index 0000000..d045d6d --- /dev/null +++ b/t/Modules/ProhibitEvilModules.d/modules-regular-expressions.txt @@ -0,0 +1,7 @@ +/\AEvil\z/ # Comment on same line as meaningful content. + +# Lack of whitespace between regex and message intentional. +/Fatal/Found use of Fatal. Use autodie instead. + +# Extra leading and trailing whitespace here is intentional. + /Getopt::Std/ Found use of Getopt::Std. Use Getopt::Long instead. diff --git a/t/Modules/ProhibitEvilModules.run b/t/Modules/ProhibitEvilModules.run new file mode 100644 index 0000000..72d5e95 --- /dev/null +++ b/t/Modules/ProhibitEvilModules.run @@ -0,0 +1,144 @@ +## name Deprecated Class::ISA +## failures 1 +## cut + +use Class::ISA; + +#----------------------------------------------------------------------------- + +## name Deprecated Pod::Plainer +## failures 1 +## cut + +use Pod::Plainer; + +#----------------------------------------------------------------------------- + +## name Deprecated Shell +## failures 1 +## cut + +use Shell; + +#----------------------------------------------------------------------------- + +## name Deprecated Switch +## failures 1 +## cut + +use Switch; + +#----------------------------------------------------------------------------- + +## name 2 evil modules +## parms {modules => 'Evil::Module Super::Evil::Module'} +## failures 2 +## cut + +use Evil::Module qw(bad stuff); +use Super::Evil::Module; + +#----------------------------------------------------------------------------- + +## name No evil modules +## parms {modules => ' Evil::Module Super::Evil::Module'} +## failures 0 +## cut + +use Good::Module; + +#----------------------------------------------------------------------------- + +## name 2 evil modules, with pattern matching +## parms { modules => '/Evil::/ /Demonic/ ' } +## failures 2 +## cut + +use Evil::Module qw(bad stuff); +use Demonic::Module + +#----------------------------------------------------------------------------- + +## name More evil modules, with mixed config +## parms { modules => ' /Evil::/ Demonic::Module /Acme/' } +## failures 4 +## cut + +use Evil::Module qw(bad stuff); +use Super::Evil::Module; +use Demonic::Module; +use Acme::Foo; + +#----------------------------------------------------------------------------- + +## name More evil modules, with more pattern matching +## parms { modules => '/Evil::|Demonic::Module|Acme/ ' } +## failures 4 +## cut + +use Evil::Module qw(bad stuff); +use Super::Evil::Module; +use Demonic::Module; +use Acme::Foo; + +#----------------------------------------------------------------------------- + +## name Pattern matching exceptions +## parms { modules => '/(/' } +## failures 0 +## error /invalid regular expression/ +## cut + +print 'Hello World'; + +#----------------------------------------------------------------------------- + +## name Providing the description for modules, no regular expressions. +## parms { modules => q' Fatal{Found use of Fatal. Use autodie instead} Getopt::Std {Found use of Getopt::Std. Use Getopt::Long instead} ' } +## failures 2 +## cut + +use Fatal qw< open close >; +use Getopt::Std; + +#----------------------------------------------------------------------------- + +## name Providing the description for modules, regular expressions. +## parms { modules => q' /Fatal/{Found use of Fatal. Use autodie instead} /Getopt::Std/ {Found use of Getopt::Std. Use Getopt::Long instead} ' } +## failures 2 +## cut + +use Fatal qw< open close >; +use Getopt::Std; + +#----------------------------------------------------------------------------- + +## name Providing the description for modules, no regular expressions. +## parms { modules_file => 't/Modules/ProhibitEvilModules.d/modules-no-regular-expressions.txt' } +## failures 3 +## cut + +use Evil; +use Fatal qw< open close >; +use Getopt::Std; + +#----------------------------------------------------------------------------- + +## name Providing the description for modules, regular expressions. +## parms { modules_file => 't/Modules/ProhibitEvilModules.d/modules-regular-expressions.txt' } +## failures 3 +## cut + +use Evil; +use Fatal qw< open close >; +use Getopt::Std; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Modules/ProhibitExcessMainComplexity.run b/t/Modules/ProhibitExcessMainComplexity.run new file mode 100644 index 0000000..c1d3f27 --- /dev/null +++ b/t/Modules/ProhibitExcessMainComplexity.run @@ -0,0 +1,93 @@ +## name param-based failure +## failures 0 +## parms { max_mccabe => 100 } +## cut + +if ( $foo && $bar || $baz ) { + open my $fh, '<', $file or die $!; +} +elsif ( $blah >>= some_function() ) { + return if $barf; +} +else { + $results = $condition ? 1 : 0; +} +croak unless $result; + +while( $condition ){ frobulate() } +until( $foo > $baz ){ blech() } + +#----------------------------------------------------------------------------- + +## name parm-based failure +## failures 1 +## parms { max_mccabe => 1 } +## cut + + +if ( $foo && $bar || $baz ) { + open my $fh, '<', $file or die $!; +} +elsif ( $blah >>= some_function() ) { + return if $barf; +} +else { + $results = $condition ? 1 : 0; +} + +croak unless $result; + +#----------------------------------------------------------------------------- + +## name exclude code inside subroutines +## failures 0 +## parms { max_mccabe => 2 } +## cut + +sub foo { + if ( $foo && $bar || $baz ) { + open my $fh, '<', $file or die $!; + } + elsif ( $blah >>= some_function() ) { + return if $barf; + } + else { + $results = $condition ? 1 : 0; + } + + croak unless $result; +} + +#main code here! +die if $condition; + +sub bar { + if ( $foo && $bar || $baz ) { + open my $fh, '<', $file or die $!; + } + elsif ( $blah >>= some_function() ) { + return if $barf; + } + else { + $results = $condition ? 1 : 0; + } + + croak unless $result; +} + +#----------------------------------------------------------------------------- + +## name empty module +## failures 0 +## cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : + diff --git a/t/Modules/ProhibitMultiplePackages.run b/t/Modules/ProhibitMultiplePackages.run new file mode 100644 index 0000000..36db792 --- /dev/null +++ b/t/Modules/ProhibitMultiplePackages.run @@ -0,0 +1,33 @@ +## name basic pass, no package +## failures 0 +## cut + +#no package +$some_code = $foo; + +#----------------------------------------------------------------------------- + +## name basic failure +## failures 2 +## cut +package foo; +package bar; +package nuts; +$some_code = undef; + +#----------------------------------------------------------------------------- + +## name basic pass, with code +## failures 0 +## cut +package foo; +$some_code = undef; + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Modules/RequireBarewordIncludes.run b/t/Modules/RequireBarewordIncludes.run new file mode 100644 index 0000000..077db33 --- /dev/null +++ b/t/Modules/RequireBarewordIncludes.run @@ -0,0 +1,44 @@ +## name basic pass, incomplete statements +## failures 0 +## cut + +require; #incomplete statement +use; #incomplete statement +no; #incomplete statement +{require}; # for Devel::Cover +END_PERL + +$policy = 'Modules::RequireBarewordIncludes'; +is( pcritique($policy, \$code), 0, $policy); + +#----------------------------------------------------------------------------- + +## name basic failures +## failures 5 +## cut +require 'Exporter'; +require 'My/Module.pl'; +use 'SomeModule'; +no "Module"; +no "Module.pm"; + +#----------------------------------------------------------------------------- + +## name basic passes with module names +## failures 0 +## cut +use 5.008; +require MyModule; +use MyModule; +no MyModule; +use strict; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Modules/RequireEndWithOne.run b/t/Modules/RequireEndWithOne.run new file mode 100644 index 0000000..701352f --- /dev/null +++ b/t/Modules/RequireEndWithOne.run @@ -0,0 +1,155 @@ +## name no code, no need for a one +## failures 0 +## cut +=pod + +=head1 NO CODE IN HERE + +=cut + +#----------------------------------------------------------------------------- + +## name basic pass +## failures 0 +## cut +1; + +#----------------------------------------------------------------------------- + +## name pass with __END__ +## failures 0 +## cut +1; +__END__ + +#----------------------------------------------------------------------------- + +## name pass with __DATA__ +## failures 0 +## cut +1; +__DATA__ + +#----------------------------------------------------------------------------- + +## name pass with comments at the end +## failures 0 +## cut +1; +# The end + +#----------------------------------------------------------------------------- + +## name pass with comment on the same line +## failures 0 +## cut +1; # final true value + +#----------------------------------------------------------------------------- + +## name pass with extra space +## failures 0 +## cut +1 ; #With extra space. + +#----------------------------------------------------------------------------- + +## name pass with more spacing +## failures 0 +## cut + 1 ; #With extra space. + +#----------------------------------------------------------------------------- + +## name pass with 1 on last line, but not last statement +## failures 0 +## cut +$foo = 2; 1; #On same line.. + +#----------------------------------------------------------------------------- + +## name fails with 0 +## failures 1 +## cut +0; + +#----------------------------------------------------------------------------- + +## name fail with closing sub +## failures 1 +## cut +1; +sub foo {} + +#----------------------------------------------------------------------------- + +## name fail with END block +## failures 1 +## cut +1; +END {} + +#----------------------------------------------------------------------------- + +## name fail with a non-zero true value +## failures 1 +## cut +'Larry'; + +#----------------------------------------------------------------------------- + +## name programs are exempt +## failures 0 +## parms +## cut +#!/usr/bin/perl +my $foo = 42; + +#----------------------------------------------------------------------------- + +## name DESTROY sub hides the 1; (RT #27364) +## failures 0 +## cut + +DESTROY { warn 'DEAD'; } + +1; + +#----------------------------------------------------------------------------- + +## name PPI parsing problem saw this as not ending with 1 (GH #696) +## failures 0 +## cut + +package UQ::Net::AddressSpace; +use warnings; +use strict; +sub v4_block { my ($self, $id) = @_; return $self->_sub_hash(['id', $id, 'v4-block']); } +1; + +#----------------------------------------------------------------------------- + +## name Second PPI parsing problem (GH #607) +## failures 0 +## cut + +package Fail; + +use strict; +use warnings; + +sub x64_flag { + my $self = shift; + return $self->{param}{perl_64b}; +} + +1; +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Modules/RequireExplicitPackage.run b/t/Modules/RequireExplicitPackage.run new file mode 100644 index 0000000..ac86486 --- /dev/null +++ b/t/Modules/RequireExplicitPackage.run @@ -0,0 +1,129 @@ +## name one statement before package +## failures 1 +## cut +$foo = $bar; +package foo; +END_PERL + +$policy = 'Modules::RequireExplicitPackage'; +is( pcritique($policy, \$code), 1, $policy.' 1 stmnt before package'); + +#----------------------------------------------------------------------------- + +## name BEGIN block before package +## failures 1 +## cut +BEGIN{ + print 'Hello'; #this violation will be squelched + print 'Beginning'; #this violation will be squelched +} + +package foo; + +#----------------------------------------------------------------------------- + +## name inclusion before package +## failures 1 +## cut +use Some::Module; +package foo; + +#----------------------------------------------------------------------------- + +## name two statements before package +## failures 1 +## cut +$baz = $nuts; +print 'whatever'; #this violation will be squelched +package foo; + +#----------------------------------------------------------------------------- + +## name no package at all +## failures 1 +## cut +print 'whatever'; + +#----------------------------------------------------------------------------- + +## name no statements at all +## failures 0 +## cut + +# no statements + +#----------------------------------------------------------------------------- + +## name just a package, no statements +## failures 0 +## cut +package foo; + +#----------------------------------------------------------------------------- + +## name package OK +## failures 0 +## cut +package foo; +use strict; +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name programs can be exempt +## failures 0 +## parms {exempt_scripts => 1} +## cut +#!/usr/bin/perl +$foo = $bar; +package foo; + +#----------------------------------------------------------------------------- + +## name programs not exempted +## failures 1 +## parms {exempt_scripts => 0} +## cut +#!/usr/bin/perl +use strict; +use warnings; #this violation will be squelched +my $foo = 42; #this violation will be squelched + +#----------------------------------------------------------------------------- + +## name programs not exempted, but we have a package +## failures 0 +## parms {exempt_scripts => 0} +## cut +#!/usr/bin/perl +package foo; +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name Work around a PPI bug that doesn't return a location for C<({})>. +## failures 1 +## cut + +({}) + +#----------------------------------------------------------------------------- + +## name Allow exception for specific module loads. RT #72660 +## failures 0 +## parms { allow_import_of => 'utf8' } +## cut + +use utf8; + +package Foo::Bar; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Modules/RequireFilenameMatchesPackage.run b/t/Modules/RequireFilenameMatchesPackage.run new file mode 100644 index 0000000..694f231 --- /dev/null +++ b/t/Modules/RequireFilenameMatchesPackage.run @@ -0,0 +1,320 @@ +## name Basic passes. +## filename OK.pm +## failures 0 +## cut + +package Filename::OK; +1; + +#------------------------------------------------------------------------------ + +## name Basic passes. +## filename Filename/OK.pm +## failures 0 +## cut + +package Filename::OK; +1; + +#------------------------------------------------------------------------------ + +## name Basic passes. +## filename lib/Filename/OK.pm +## failures 0 +## cut + +package Filename::OK; +1; + +#------------------------------------------------------------------------------ + +## name Basic passes. +## filename blib/lib/Filename/OK.pm +## failures 0 +## cut + +package Filename::OK; +1; + +#------------------------------------------------------------------------------ + +## name Basic passes. +## filename OK.pl +## failures 0 +## cut + +package Filename::OK; +1; + +#------------------------------------------------------------------------------ + +## name Basic passes. +## filename Filename-OK-1.00/OK.pm +## failures 0 +## cut + +package Filename::OK; +1; + +#------------------------------------------------------------------------------ + +## name Basic passes. +## filename Filename-OK/OK.pm +## failures 0 +## cut + +package Filename::OK; +1; + +#------------------------------------------------------------------------------ + +## name Basic passes. +## filename Foobar-1.00/OK.pm +## failures 0 +## cut + +package Filename::OK; +1; + +#------------------------------------------------------------------------------ + +## name Basic Failure. +## filename Bad.pm +## failures 1 +## cut + +package Filename::OK; +1; + +#------------------------------------------------------------------------------ + +## name Basic Failure. +## filename Filename/Bad.pm +## failures 1 +## cut + +package Filename::OK; +1; + +#------------------------------------------------------------------------------ + +## name Basic Failure. +## filename lib/Filename/BadOK.pm +## failures 1 +## cut + +package Filename::OK; +1; + +#------------------------------------------------------------------------------ + +## name Basic Failure. +## filename ok.pm +## failures 1 +## cut + +package Filename::OK; +1; + +#------------------------------------------------------------------------------ + +## name Basic Failure. +## filename filename/OK.pm +## failures 1 +## cut + +package Filename::OK; +1; + +#------------------------------------------------------------------------------ + +## name Basic Failure. +## filename Foobar/OK.pm +## failures 1 +## cut + +package Filename::OK; +1; + +#------------------------------------------------------------------------------ + +## name first package is main, with inner package +## filename some_script +## failures 0 +## cut + +package main; + +Inner::frobulate( @ARGV ); + +package Inner; + +sub frobulate{}; + +1; + +#------------------------------------------------------------------------------ + +## name second package is main, with inner package +## filename some_script +## failures 1 +## cut + +package Inner; + +sub frobulate{}; + +package main; + +Inner::frobulate( @ARGV ); + +1; + +#------------------------------------------------------------------------------ + +## name Pass with apostrophe. +## filename Oh.pm +## failures 0 +## cut + +package D'Oh; +1; + +#------------------------------------------------------------------------------ + +## name Pass with apostrophe. +## filename D/Oh.pm +## failures 0 +## cut + +package D'Oh; +1; + +#------------------------------------------------------------------------------ + +## name Failure with apostrophe. +## filename oh.pm +## failures 1 +## cut + +package D'Oh; +1; + +#------------------------------------------------------------------------------ + +## name Failure with apostrophe. +## filename d/Oh.pm +## failures 1 +## cut + +package D'Oh; +1; + +#----------------------------------------------------------------------------- + +## name programs are exempt +## failures 0 +## filename foo.plx +## cut +#!/usr/bin/perl +package Wibble; + +#----------------------------------------------------------------------------- + +## name using #line directive with double-quoted filename +## filename Foo.pm +## failures 0 +## cut + +#line 99 "Bar.pm" +package Bar; + +#----------------------------------------------------------------------------- + +## name using #line directive with bareword filename +## filename Foo.pm +## failures 0 +## cut + +#line 99 Bar.pm +package Bar; + +#----------------------------------------------------------------------------- + +## name #line directive appears after package declaration +## filename Foo.pm +## failures 1 +## cut + +package Bar; +#line 99 Bar.pm + +#----------------------------------------------------------------------------- + +## name multiple #line directives +## filename Foo.pm +## failures 1 +## cut + +#line 99 Bar.pm +#line 999 Baz.pm +package Bar; + +#----------------------------------------------------------------------------- + +## name #line directive with multi-part path +## filename Wrong.pm +## failures 0 +## cut + +#line 99 Foo/Bar/Baz.pm +package Foo::Bar::Baz; + +#----------------------------------------------------------------------------- + +## name #line directive with multi-part path in lib/ dir +## filename lib/Wrong.pm +## failures 0 +## cut + +#line 99 lib/Foo/Bar/Baz.pm +package Foo::Bar::Baz; + +#----------------------------------------------------------------------------- + +## name #line directive with partially matching multi-part path +## filename Wrong.pm +## failures 0 +## cut + +#line 99 Foo/Bar/Baz.pm +package Baz; + +#----------------------------------------------------------------------------- + +## name no package declaration at all +## filename Foo.pm +## failures 0 +## cut + +1; + +#----------------------------------------------------------------------------- + +## name #line directive with no package declaration at all +## filename Foo.pm +## failures 0 +## cut + +#line 1 Baz.pm +1; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Modules/RequireNoMatchVarsWithUseEnglish.run b/t/Modules/RequireNoMatchVarsWithUseEnglish.run new file mode 100644 index 0000000..04bb9da --- /dev/null +++ b/t/Modules/RequireNoMatchVarsWithUseEnglish.run @@ -0,0 +1,224 @@ +## name Passing with no "use English". +## failures 0 +## cut + +use strict; +use warnings; + +my $doodle_doodle_dee = 'wubba wubba wubba'; + +#----------------------------------------------------------------------------- + +## name Passing single quotes. +## failures 0 +## cut + +use English '-no_match_vars'; + +#----------------------------------------------------------------------------- + +## name Passing double quotes +## failures 0 +## cut + +use English "-no_match_vars"; + +#----------------------------------------------------------------------------- + +## name Passing literal quotes. +## failures 0 +## cut + +use English q/-no_match_vars/; +use English q{-no_match_vars}; +use English q(-no_match_vars); +use English q[-no_match_vars]; +use English q<-no_match_vars>; +use English q!-no_match_vars!; +use English q#-no_match_vars#; +use English q'-no_match_vars'; +use English q"-no_match_vars"; + +#----------------------------------------------------------------------------- + +## name Passing literal quotes with whitespace before delimiter. +## failures 0 +## cut + +use English q /-no_match_vars/; +use English q {-no_match_vars}; +use English q (-no_match_vars); +use English q [-no_match_vars]; +use English q <-no_match_vars>; +use English q !-no_match_vars!; +use English q '-no_match_vars'; +use English q "-no_match_vars"; + +#----------------------------------------------------------------------------- + +## name Passing interpolating quotes. +## failures 0 +## cut + +use English qq/-no_match_vars/; +use English qq{-no_match_vars}; +use English qq(-no_match_vars); +use English qq[-no_match_vars]; +use English qq<-no_match_vars>; +use English qq!-no_match_vars!; +use English qq#-no_match_vars#; +use English qq'-no_match_vars'; +use English qq"-no_match_vars"; + +#----------------------------------------------------------------------------- + +## name Passing interpolating quotes with whitespace before delimiter. +## failures 0 +## cut + +use English qq /-no_match_vars/; +use English qq {-no_match_vars}; +use English qq (-no_match_vars); +use English qq [-no_match_vars]; +use English qq <-no_match_vars>; +use English qq !-no_match_vars!; +use English qq '-no_match_vars'; +use English qq "-no_match_vars"; + +#----------------------------------------------------------------------------- + +## name Passing quotelike words. +## failures 0 +## cut + +use English qw/ -no_match_vars /; +use English qw{ -no_match_vars }; +use English qw( -no_match_vars ); +use English qw[ -no_match_vars ]; +use English qw< -no_match_vars >; +use English qw! -no_match_vars !; +use English qw# -no_match_vars #; +use English qw' -no_match_vars '; +use English qw" -no_match_vars "; + +#----------------------------------------------------------------------------- + +## name Passing quotelike words with whitespace before delimiter. +## failures 0 +## cut + +use English qw / -no_match_vars /; +use English qw { -no_match_vars }; +use English qw ( -no_match_vars ); +use English qw [ -no_match_vars ]; +use English qw < -no_match_vars >; +use English qw ! -no_match_vars !; +use English qw ' -no_match_vars '; +use English qw " -no_match_vars "; + +#----------------------------------------------------------------------------- + +## name Passing quotelike words with things in addition to -no_match_vars. +## failures 0 +## cut + +use English qw/ $ERRNO -no_match_vars $EVAL_ERROR /; + +#----------------------------------------------------------------------------- + +## name Passing parenthesized list. +## failures 0 +## cut + +use English ( '-no_match_vars' ); + +#----------------------------------------------------------------------------- + +## name Passing parenthesized list with things in addition to -no_match_vars. +## failures 0 +## cut + +use English ( '$ERRNO', "-no_match_vars", "$EVAL_ERROR" ); + +#----------------------------------------------------------------------------- + +## name Passing unparenthesized list with things in addition to -no_match_vars. +## failures 0 +## cut + +use English '$ERRNO', "-no_match_vars", "$EVAL_ERROR"; + +#----------------------------------------------------------------------------- + +## name Passing version. +## failures 0 +## cut + +use English 1.02 '-no_match_vars'; + +#----------------------------------------------------------------------------- + +## name Passing v-string version. +## failures 0 +## cut + +use English v1.02 '-no_match_vars'; + +#----------------------------------------------------------------------------- + +## name Passing parenthesized list and version. +## failures 0 +## cut + +use English 1.02 ('-no_match_vars'); + +#----------------------------------------------------------------------------- + +## name Basic failure. +## failures 1 +## cut + +use English; + +#----------------------------------------------------------------------------- + +## name Failure with version. +## failures 1 +## cut + +use English 1.02; + +#----------------------------------------------------------------------------- + +## name Failure with v-string. +## failures 1 +## cut + +use English v1.02; + +#----------------------------------------------------------------------------- + +## name Failure with random garbage. +## failures 2 +## cut + +use English 'oink oink'; +use English qw< blah blah blah >; + +#----------------------------------------------------------------------------- + +## name Failure with typo that Ovid noticed. +## failures 1 +## cut + +use English qw(-no_mactch_vars); + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Modules/RequireVersionVar.run b/t/Modules/RequireVersionVar.run new file mode 100644 index 0000000..5bd7e1c --- /dev/null +++ b/t/Modules/RequireVersionVar.run @@ -0,0 +1,110 @@ +## name No code +## failures 1 +## cut +#Nothing! + +#----------------------------------------------------------------------------- + +## name basic pass +## failures 0 +## cut +our $VERSION = 1.0; + +#----------------------------------------------------------------------------- + +## name basic pass #2 +## failures 0 +## cut +our ($VERSION) = 1.0; + +#----------------------------------------------------------------------------- + +## name basic pass #3 +## failures 0 +## cut +$Package::VERSION = 1.0; + +#----------------------------------------------------------------------------- + +## name basic pass #4 +## failures 0 +## cut +use vars '$VERSION'; + +#----------------------------------------------------------------------------- + +## name basic pass #5 +## failures 0 +## cut +use vars qw($VERSION); + +#----------------------------------------------------------------------------- + +## name fail with lexical +## failures 1 +## cut +my $VERSION; + +#----------------------------------------------------------------------------- + +## name fail with wrong variable +## failures 1 +## cut +our $Version; + +#----------------------------------------------------------------------------- + +## name pass with "no critic" on +## failures 0 +## cut +#!anything ## no critic (RequireVersionVar) + +#----------------------------------------------------------------------------- + +## name Readonly VERSION +## failures 0 +## cut + +Readonly our $VERSION = 1.0; + +#----------------------------------------------------------------------------- + +## name Readonly::Scalar VERSION +## failures 0 +## cut + +Readonly::Scalar our $VERSION = 1.0; + +#----------------------------------------------------------------------------- + +## name Readonly::Scalar VERSION +## failures 1 +## cut + +Readonly::Scalar my $VERSION = 1.0; #Note this is lexical + +#----------------------------------------------------------------------------- + +## name Version as argument to package. RT #67159 +## failures 0 +## cut + +package Foo 0.001; + +#----------------------------------------------------------------------------- + +## name Package without version should still be violation. RT #67159 +## failures 1 +## cut + +package Foo; + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/NamingConventions/Capitalization.run.PL b/t/NamingConventions/Capitalization.run.PL new file mode 100644 index 0000000..16ccd32 --- /dev/null +++ b/t/NamingConventions/Capitalization.run.PL @@ -0,0 +1,847 @@ +#!/usr/bin/env perl + +use 5.006001; +use strict; +use warnings; + +use English qw< -no_match_vars >; +use Carp qw< confess >; + +use Carp qw< confess >; +use Fatal qw< open close >; + +my $this_program = __FILE__; +(my $test_file_name = $this_program) =~ s/ [.] PL \z //xms; +if ($this_program eq $test_file_name) { + confess + 'Was not able to figure out the name of the file to generate.' + . "This program: $this_program."; +} + +print "\n\nGenerating $test_file_name.\n"; + + + +open my $test_file, '>', $test_file_name ## no critic (RequireBriefOpen) + or confess "Could not open $test_file_name: $ERRNO"; + + +print {$test_file} <<"END_HEADER"; +# Do not edit!!! This test suite generated by $this_program. +END_HEADER + +emit_simple_tests($test_file); +emit_primary_tests($test_file); +emit_footer($test_file); + +close $test_file; +print "Done.\n\n"; + +#----------------------------------------------------------------------------- + +sub emit_simple_tests { + my ($test_file) = @_; + + print {$test_file} <<'END_SIMPLE_TESTS'; +#----------------------------------------------------------------------------- + +## name Basic Passes +## failures 0 +## cut + +my $foo; +our $bar; +my($foo, $bar) = ("BLEH", "BLEH"); +my @foo; +my %bar; +sub foo {} + +my $foo123; +my $foo123bar; +sub foo123 {} +sub foo123bar {} + +package This::SomeThing; +package This; +package This::Thing; +package Acme::12345; +package YYZ; + +#----------------------------------------------------------------------------- + +## name Basic Failures +## failures 14 +## cut + +my $Foo; +our $Bar; +my @Foo; +my %Bar; +sub Foo {} + +my $foo_Bar; +sub foo_Bar {} + +my $FooBar; +sub FooBar {} + +my $foo123Bar; +sub foo123Bar {} + +package pragma; +package Foo::baz; +package baz::FooBar; + +#----------------------------------------------------------------------------- + +## name Special case: main +## failures 0 +## cut + +package main; + +#----------------------------------------------------------------------------- + +## name Combined passes and fails +## failures 2 +## cut + +my($foo, $Bar); +our($Bar, $foo); + +#----------------------------------------------------------------------------- + +## name Variables from other packages should pass +## failures 0 +## cut + +local $Other::Package::Foo; +$Other::Package::Foo; + +#----------------------------------------------------------------------------- + +## name Only cares about declarations +## failures 0 +## cut +Foo(); +$Foo = 42; + +#----------------------------------------------------------------------------- + +## name Constants must be all caps, passes +## failures 0 +## cut + +Readonly::Scalar my $CONSTANT = 23; +const my $CONSTANT = 23; +use constant FOO => 42; +use constant { BAR => 3, BAZ => 7 }; +use constant 1.16 FOO => 42; +use constant 1.16 { BAR => 3, BAZ => 7 }; + +#----------------------------------------------------------------------------- + +## name Constants must be all caps, failures +## failures 3 +## cut + +Readonly::Scalar my $Foo = 23; +Readonly::Scalar my $foo = 23; +const my $fooBAR = 23; + +#----------------------------------------------------------------------------- + +## name PPI misparses part of ternary as a label (RT #41170) +## failures 0 +## cut + +my $foo = $condition ? $objection->method : $alternative; +my $foo = $condition ? undef : 1; + +END_SIMPLE_TESTS + + return; +} + + +sub emit_primary_tests { + my ($test_file) = @_; + + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'all_lower_case', 'guaranteed_to_pass', ':single_case', 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'ALL_UPPER_CASE', 'guaranteed_to_pass', ':single_case', 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'mixedCase', 'guaranteed_to_pass', ':single_case', 1, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'a11_lower_case_with_digits', 'guaranteed_to_pass', ':single_case', 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'A11_UPPER_CASE_WITH_DIGITS', 'guaranteed_to_pass', ':single_case', 0, + ); + + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'all_lower_case', 'guaranteed_to_pass', ':all_lower', 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'ALL_UPPER_CASE', 'guaranteed_to_pass', ':all_lower', 1, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'mixedCase', 'guaranteed_to_pass', ':all_lower', 1, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'a11_lower_case_with_digits', 'guaranteed_to_pass', ':all_lower', 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'A11_UPPER_CASE_WITH_DIGITS', 'guaranteed_to_pass', ':all_lower', 1, + ); + + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'all_lower_case', 'GUARANTEED_TO_PASS', ':all_upper', 1, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'ALL_UPPER_CASE', 'GUARANTEED_TO_PASS', ':all_upper', 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'mixedCase', 'GUARANTEED_TO_PASS', ':all_upper', 1, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'a11_lower_case_with_digits', 'GUARANTEED_TO_PASS', ':all_upper', 1, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'A11_UPPER_CASE_WITH_DIGITS', 'GUARANTEED_TO_PASS', ':all_upper', 0, + ); + + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'all_lower_case', 'guaranteed_to_pass', ':starts_with_lower', 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'ALL_UPPER_CASE', 'guaranteed_to_pass', ':starts_with_lower', 1, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, + '________all_lower_case_with_leading_underscores', + 'guaranteed_to_pass', + ':starts_with_lower', + 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'a11_lower_case_with_digits', 'guaranteed_to_pass', ':starts_with_lower', 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'A11_UPPER_CASE_WITH_DIGITS', 'guaranteed_to_pass', ':starts_with_lower', 1, + ); + + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'all_lower_case', 'GUARANTEED_TO_PASS', ':starts_with_upper', 1, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'ALL_UPPER_CASE', 'GUARANTEED_TO_PASS', ':starts_with_upper', 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, + '________ALL_UPPER_CASE_WITH_LEADING_UNDERSCORES', + 'GUARANTEED_TO_PASS', + ':starts_with_upper', + 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'a11_lower_case_with_digits', 'GUARANTEED_TO_PASS', ':starts_with_upper', 1, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'A11_UPPER_CASE_WITH_DIGITS', 'GUARANTEED_TO_PASS', ':starts_with_upper', 0, + ); + + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'all_lower_case', 'guaranteed_to_pass', ':no_restriction', 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'ALL_UPPER_CASE', 'guaranteed_to_pass', ':no_restriction', 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'mixedCase', 'guaranteed_to_pass', ':no_restriction', 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, + '________ALL_UPPER_CASE_WITH_LEADING_UNDERSCORES', + 'guaranteed_to_pass', + ':no_restriction', + 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'a11_lower_case_with_digits', 'guaranteed_to_pass', ':no_restriction', 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'A11_UPPER_CASE_WITH_DIGITS', 'guaranteed_to_pass', ':no_restriction', 0, + ); + + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'foobar', 'foo_guaranteed_to_pass_bar', 'foo.*bar', 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'fooXYZZYbar', 'foo_guaranteed_to_pass_bar', 'foo.*bar', 0, + ); + emit_all_tests_for_name_and_capitalization_scheme( + $test_file, 'xyzzy', 'foo_guaranteed_to_pass_bar', 'foo.*bar', 1, + ); + + return; +} + + +sub emit_all_tests_for_name_and_capitalization_scheme { + my ($test_file, $name, $guaranteed_to_pass, $capitalization_scheme, $failures) + = @_; + + emit_package_test( + $test_file, + $name, + $guaranteed_to_pass, + $capitalization_scheme, + $failures + ); + emit_subroutine_test( + $test_file, $name, $capitalization_scheme, $failures, + ); + emit_local_lexical_variable_in_subroutine_test( + $test_file, $name, $capitalization_scheme, $failures, + ); + emit_local_lexical_variable_in_scheduled_subroutine_test( + $test_file, $name, $capitalization_scheme, $failures, + ); + emit_scoped_lexical_variable_test( + $test_file, $name, $capitalization_scheme, $failures, + ); + emit_file_lexical_variable_test( + $test_file, $name, $capitalization_scheme, $failures, + ); + emit_global_variable_test( + $test_file, $name, $capitalization_scheme, $failures, + ); + emit_foreach_loop_variable_tests( + $test_file, $name, $capitalization_scheme, $failures, + ); + emit_c_style_for_loop_variable_tests( + $test_file, $name, $capitalization_scheme, $failures, + ); + emit_local_lexical_variable_in_io_assignment_in_while_loop_test( + $test_file, $name, $capitalization_scheme, $failures, + ); + emit_label_test($test_file, $name, $capitalization_scheme, $failures); + + return; +} + + +sub emit_package_test { + my ($test_file, $package_name, $good_package_component, $capitalization_scheme, $failures) = @_; + + print {$test_file} <<"END_PACKAGE_TEST"; + +#----------------------------------------------------------------------------- + +## name Package named "$package_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { packages => '$capitalization_scheme' } +## cut + +package $package_name; + +#----------------------------------------------------------------------------- + +## name Exempted package named "bLaHlAhLaH" vs the "$capitalization_scheme" capitalization scheme. +## failures 0 +## parms { packages => '$capitalization_scheme', package_exemptions => 'bLa.*LaH' } +## cut + +package bLaHlAhLaH; + +#----------------------------------------------------------------------------- + +## name Package named "${good_package_component}::$package_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { packages => '$capitalization_scheme' } +## cut + +package ${good_package_component}::$package_name; +END_PACKAGE_TEST + + return; +} + + +sub emit_subroutine_test { + my ($test_file, $subroutine_name, $capitalization_scheme, $failures) = @_; + + print {$test_file} <<"END_SUBROUTINE_TEST"; + +#----------------------------------------------------------------------------- + +## name Subroutine named "$subroutine_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { subroutines => '$capitalization_scheme' } +## cut + +sub $subroutine_name { + # Blah blah blah +} + +#----------------------------------------------------------------------------- + +## name Exempted subroutine named "bLaHlAhLaH" vs the "$capitalization_scheme" capitalization scheme. +## failures 0 +## parms { subroutines => '$capitalization_scheme', subroutine_exemptions => 'bLa.*LaH' } +## cut + +sub bLaHlAhLaH { + # Blah blah blah +} + +#----------------------------------------------------------------------------- + +## name Subroutine named "Foo::Bar::$subroutine_name" vs the "$capitalization_scheme" capitalization scheme. +## parms { subroutines => '$capitalization_scheme' } +## failures $failures +## cut + +sub Foo::Bar::$subroutine_name; + +END_SUBROUTINE_TEST + + return; +} + + +sub emit_local_lexical_variable_in_subroutine_test { + my ($test_file, $variable_name, $capitalization_scheme, $failures) = @_; + + print {$test_file} <<"END_LOCAL_LEXICAL_VARIABLE_TEST"; + +#----------------------------------------------------------------------------- + +## name Local lexical variable in subroutine named "$variable_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { subroutines => ':all_lower', local_lexical_variables => '$capitalization_scheme' } +## cut + +sub some_subroutine { + my \$$variable_name; +} + +#----------------------------------------------------------------------------- + +## name Exempted local lexical variable in subroutine named "bLaHlAhLaH" vs the "$capitalization_scheme" capitalization scheme. +## failures 0 +## parms { subroutines => ':all_lower', local_lexical_variables => '$capitalization_scheme', local_lexical_variable_exemptions => 'bLa.*LaH' } +## cut + +sub some_subroutine { + my \$bLaHlAhLaH; +} +END_LOCAL_LEXICAL_VARIABLE_TEST + + return; +} + + +sub emit_local_lexical_variable_in_scheduled_subroutine_test { + my ($test_file, $variable_name, $capitalization_scheme, $failures) = @_; + + print {$test_file} <<"END_LOCAL_LEXICAL_VARIABLE_TEST"; + +#----------------------------------------------------------------------------- + +## name Local lexical variable in subroutine named "$variable_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { local_lexical_variables => '$capitalization_scheme' } +## cut + +CHECK { + my \$$variable_name; +} +END_LOCAL_LEXICAL_VARIABLE_TEST + + return; +} + + +sub emit_scoped_lexical_variable_test { + my ($test_file, $variable_name, $capitalization_scheme, $failures) = @_; + + print {$test_file} <<"END_SCOPED_LEXICAL_VARIABLE_TEST"; + +#----------------------------------------------------------------------------- + +## name Scoped lexical variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { scoped_lexical_variables => '$capitalization_scheme' } +## cut + +{ + my \$$variable_name; +} + +#----------------------------------------------------------------------------- + +## name Exempted scoped lexical variable named "bLaHlAhLaH" vs the "$capitalization_scheme" capitalization scheme. +## failures 0 +## parms { scoped_lexical_variables => '$capitalization_scheme', scoped_lexical_variable_exemptions => 'bLa.*LaH' } +## cut + +{ + my \$bLaHlAhLaH; +} +END_SCOPED_LEXICAL_VARIABLE_TEST + + return; +} + + +sub emit_file_lexical_variable_test { + my ($test_file, $variable_name, $capitalization_scheme, $failures) = @_; + + print {$test_file} <<"END_FILE_LEXICAL_VARIABLE_TEST"; + +#----------------------------------------------------------------------------- + +## name File lexical variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { file_lexical_variables => '$capitalization_scheme' } +## cut + +my \$$variable_name; + +#----------------------------------------------------------------------------- + +## name Exempted file lexical variable named "bLaHlAhLaH" vs the "$capitalization_scheme" capitalization scheme. +## failures 0 +## parms { file_lexical_variables => '$capitalization_scheme', file_lexical_variable_exemptions => 'bLa.*LaH' } +## cut + +my \$bLaHlAhLaH; +END_FILE_LEXICAL_VARIABLE_TEST + + return; +} + + +sub emit_global_variable_test { + my ($test_file, $variable_name, $capitalization_scheme, $failures) = @_; + + foreach my $variable_type ( qw< our local > ) { + print {$test_file} <<"END_FILE_LEXICAL_VARIABLE_TEST"; + +#----------------------------------------------------------------------------- + +## name "$variable_type" variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { global_variables => '$capitalization_scheme' } +## cut + +$variable_type \$$variable_name; + +#----------------------------------------------------------------------------- + +## name Exempted "$variable_type" variable named "bLaHlAhLaH" vs the "$capitalization_scheme" capitalization scheme. +## failures 0 +## parms { global_variables => '$capitalization_scheme', global_variable_exemptions => 'bLa.*LaH' } +## cut + +$variable_type \$bLaHlAhLaH; +END_FILE_LEXICAL_VARIABLE_TEST + } + + return; +} + + +sub emit_foreach_loop_variable_tests { + my ($test_file, $variable_name, $capitalization_scheme, $failures) = @_; + + print {$test_file} <<"END_FOREACH_LOOP_VARIABLE_TESTS"; + +#----------------------------------------------------------------------------- + +## name Local lexical variable as foreach loop variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { local_lexical_variables => '$capitalization_scheme' } +## cut + +foreach my \$$variable_name (\@_) { + say \$$variable_name; +} + +#----------------------------------------------------------------------------- + +## name State variable as foreach loop variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { local_lexical_variables => '$capitalization_scheme' } +## cut + +foreach state \$$variable_name (\@_) { + say \$$variable_name; +} + +#----------------------------------------------------------------------------- + +## name Implied local lexical variable as foreach loop variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { local_lexical_variables => '$capitalization_scheme' } +## cut + +foreach \$$variable_name (\@_) { + say \$$variable_name; +} + +#----------------------------------------------------------------------------- + +## name Global variable as foreach loop variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { global_variables => '$capitalization_scheme' } +## cut + +foreach our \$$variable_name (\@_) { + say \$$variable_name; +} + +#----------------------------------------------------------------------------- + +## name Localized builtin variable +## failures 0 +## cut + +local \$\@; + +#----------------------------------------------------------------------------- + +## name Localized \$\\ +## failures 0 +## cut + +# \$\\ was missing from the built in global exceptions +local \$\\; +END_FOREACH_LOOP_VARIABLE_TESTS + + return; +} + + +sub emit_c_style_for_loop_variable_tests { + my ($test_file, $variable_name, $capitalization_scheme, $failures) = @_; + + print {$test_file} <<"END_C_STYLE_FOR_LOOP_VARIABLE_TESTS"; + +#----------------------------------------------------------------------------- + +## name Local lexical variable as C-style for loop variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { local_lexical_variables => '$capitalization_scheme' } +## cut + +for (my \$$variable_name = -7; \$$variable_name <= 17; \$$variable_name += 3) { + say \$$variable_name; +} + +#----------------------------------------------------------------------------- + +## name State variable as C-style for loop variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { local_lexical_variables => '$capitalization_scheme' } +## cut + +# Declare the same variable twice in order to catch the case where the +# variable is the second one in the loop definition. +for (state \$$variable_name = -7; \$$variable_name <= 17; \$$variable_name += 3) { + say \$$variable_name; +} + +#----------------------------------------------------------------------------- + +## name Global variable as C-style for loop variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { global_variables => '$capitalization_scheme' } +## cut + +# Declare the same variable twice in order to catch the case where the +# variable is the second one in the loop definition. +for (our \$$variable_name = -7; \$$variable_name <= 17; \$$variable_name += 3) { + say \$$variable_name; +} + +#----------------------------------------------------------------------------- + +## name Localized variable as C-style for loop variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { global_variables => '$capitalization_scheme' } +## cut + +# Localize the same variable twice in order to catch the case where the +# variable is the second one in the loop definition. +for (local \$$variable_name = -7; \$$variable_name <= 17; \$$variable_name += 3) { + say \$$variable_name; +} + +#----------------------------------------------------------------------------- + +## name Localized builtin variable as C-style for loop variable vs the "$capitalization_scheme" capitalization scheme. +## failures 0 +## parms { global_variables => '$capitalization_scheme' } +## cut + +for (local \$EVAL_ERROR = -23; \$EVAL_ERROR <= 17; \$EVAL_ERROR += 3) { + say \$EVAL_ERROR; +} + +#----------------------------------------------------------------------------- + +## name Localized variable in another package as C-style for loop variable vs the "$capitalization_scheme" capitalization scheme. +## failures 0 +## parms { global_variables => '$capitalization_scheme' } +## cut + +for (local \$Foo::Baz = -23; \$Foo::Baz <= 17; \$Foo::Baz += 3) { + say \$Foo::Baz +} +END_C_STYLE_FOR_LOOP_VARIABLE_TESTS + + return; +} + + +sub emit_local_lexical_variable_in_io_assignment_in_while_loop_test { + my ($test_file, $variable_name, $capitalization_scheme, $failures) = @_; + + print {$test_file} <<"END_LOCAL_LEXICAL_VARIABLE_TEST"; + +#----------------------------------------------------------------------------- + +## name Local lexical variable, in I/O assignment in while loop, named "$variable_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { subroutines => ':all_lower', local_lexical_variables => '$capitalization_scheme' } +## cut + +sub some_subroutine { + while (my \$$variable_name = <>) { + say \$$variable_name; + } +} +END_LOCAL_LEXICAL_VARIABLE_TEST + + return; +} + + +sub emit_label_test { + my ($test_file, $label_name, $capitalization_scheme, $failures) = @_; + + print {$test_file} <<"END_LABEL_TEST"; + +#----------------------------------------------------------------------------- + +## name Label named "$label_name" vs the "$capitalization_scheme" capitalization scheme. +## failures $failures +## parms { labels => '$capitalization_scheme' } +## cut + +$label_name: +while ( foo() ) { + next $label_name; +} + +#----------------------------------------------------------------------------- + +## name Exempted label named "bLaHlAhLaH" vs the "$capitalization_scheme" capitalization scheme. +## failures 0 +## parms { labels => '$capitalization_scheme', label_exemptions => 'bLa.*LaH' } +## cut + +bLaHlAhLaH: +while ( foo() ) { + next bLaHlAhLaH; +} +END_LABEL_TEST + + return; +} + + +sub emit_footer { + my ($test_file) = @_; + + print {$test_file} <<'END_FOOTER'; + +#----------------------------------------------------------------------------- + +## name Variable in continue block gets handled as a local lexical and not a scoped lexical. +## failures 1 +## parms { local_lexical_variables => ':all_upper', scoped_lexical_variables => ':all_lower' } +## cut + +while (blah) { + blah; +} +continue { + my $this_should_be_local_and_not_scoped; +} + +#----------------------------------------------------------------------------- + +## name Builtin variables and variables in other packages are exempt. +## failures 0 +## parms { global_variables => ':all_lower' } +## cut + +local $EVAL_ERROR +local @ARGV; +local %INC; +local $Foo::Bar; + +#----------------------------------------------------------------------------- + +## name Test customization example in the Capitalization POD passing. +## failures 0 +## parms { global_variables => 'G_(?:(?!_)\w)+', global_variable_exemptions => '.*THINGY.*' } +## cut + +our $G_FooBar; +our $THINGY; +our @otherTHINGY; + +#----------------------------------------------------------------------------- + +## name Test customization example in the Capitalization POD failing. +## failures 4 +## parms { global_variables => 'G_(?:(?!_)\w)+', global_variable_exemptions => '.*THINGY.*' } +## cut + +our $FooBar; +our $G_; +our $G_foo_bar; +our @THING; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : +END_FOOTER + + return; +} + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/NamingConventions/ProhibitAmbiguousNames.run b/t/NamingConventions/ProhibitAmbiguousNames.run new file mode 100644 index 0000000..9bfd32f --- /dev/null +++ b/t/NamingConventions/ProhibitAmbiguousNames.run @@ -0,0 +1,110 @@ +## name Basic failures. +## failures 11 +## cut + +my $left = 1; # scalar +my @right = ('foo'); # array +our $no = undef; # our +my %abstract; # hash +local *main::contract; # pkg prefix on var +sub record {} # sub +my ($second, $close); # catch both of these +sub pkg::bases {} # pkg prefix on sub +my ($last, $set); + +#----------------------------------------------------------------------------- + +## name Ambiguous word in compound name. +## TODO False negative: Ambiguous words in compound names should be forbidden +## failures 2 +## cut + +my $last_record; +my $first_record; + +#----------------------------------------------------------------------------- + +## name Basic passes. +## failures 0 +## cut + +for my $bases () {} +print $main::contract; +my %hash = (left => 1, center => 'right'); +sub no_left_turn {} +local $\; # for Devel::Cover; an example of a var declaration without \w + +#----------------------------------------------------------------------------- + +## name Ambiguous name on rhs. +## TODO False positive: Need to distinguish rhs in variable statements +## failures 0 +## cut + +my ($foo) = ($left); + +#----------------------------------------------------------------------------- + +## name Ambiguous, but exempt by convention +## failures 0 +## cut + +no warnings; +close $fh; + +#----------------------------------------------------------------------------- + +## name Custom null configuration +## parms { forbid => q{} } +## failures 0 +## cut + +my $left; +my $close; +END_PERL + +#----------------------------------------------------------------------------- + +## name Custom configuration: "foo bar baz quux" +## parms { forbid => 'foo bar baz quux' } +## failures 2 +## cut + +my $left; +my $close; +my $foo; +my $bar; + +#----------------------------------------------------------------------------- + +## name Custom configuration: "foo bar baz quux" +## parms { forbid => 'foo bar left close' } +## failures 4 +## cut + +my $left; +my $close; +my $foo; +my $bar; + +#%config = ( forbid => join q{ }, qw(foo bar baz quux), @default ); + +#----------------------------------------------------------------------------- + +## name Custom null configuration +## parms { forbid => undef } +## failures 2 +## cut + +my $left; +my $close; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Objects/ProhibitIndirectSyntax.run b/t/Objects/ProhibitIndirectSyntax.run new file mode 100644 index 0000000..10c5e2a --- /dev/null +++ b/t/Objects/ProhibitIndirectSyntax.run @@ -0,0 +1,64 @@ +## name basic passes +## failures 0 +## cut + +Foo->new; +Foo->new(); +Foo->new( bar => 'baz' ); + +$foo->new; + +{$foo}->new; + +#----------------------------------------------------------------------------- + +## name basic failures +## failures 5 +## cut + +new Foo; +new Foo(); +new Foo( bar => 'baz' ); + +new $foo; + +new {$foo}; + +#----------------------------------------------------------------------------- + +## name unchecked indirect objects +## failures 0 +## cut + +create Foo; +create Foo(); +create Foo( bar => 'baz' ); + +create $foo; + +create {$foo}; + +#----------------------------------------------------------------------------- + +## name checked indirect objects +## parms { forbid => 'create' } +## failures 5 +## cut + +create Foo; +create Foo(); +create Foo( bar => 'baz' ); + +create $foo; + +create {$foo}; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/References/ProhibitDoubleSigils.run b/t/References/ProhibitDoubleSigils.run new file mode 100644 index 0000000..bf3abf3 --- /dev/null +++ b/t/References/ProhibitDoubleSigils.run @@ -0,0 +1,46 @@ +## name Basic passes +## failures 0 +## cut + +%hash = %{ $some_ref }; +@array = @{ $some_ref }; +$scalar = ${ $some_ref }; + +$some_ref = \%hash; +$some_ref = \@array; +$some_ref = \$scalar; +$some_ref = \&code; + +#----------------------------------------------------------------------------- + +## name Basic failures +## failures 6 +## cut + +%hash = %$some_ref; +%array = @$some_ref; +%scalar = $$some_ref; + +%hash = ( %$some_ref ); +%array = ( @$some_ref ); +%scalar = ( $$some_ref ); + +#----------------------------------------------------------------------------- + +## name Multiplication is not a glob +# old PPI bug (fixed as of PPI v1.112): multiplication is mistakenly +# interpreted as a glob. +## failures 0 +## cut + +$value = $one*$two; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/RegularExpressions/ProhibitCaptureWithoutTest.run b/t/RegularExpressions/ProhibitCaptureWithoutTest.run new file mode 100644 index 0000000..d583d20 --- /dev/null +++ b/t/RegularExpressions/ProhibitCaptureWithoutTest.run @@ -0,0 +1,333 @@ +## name use without regex +## failures 3 +## cut +my $foo = $1; +my @matches = ($1, $2); + +#----------------------------------------------------------------------------- + +## name void use without regex +## failures 1 +## cut +$1 + +#----------------------------------------------------------------------------- + +## name regex but no check on success +## failures 1 +## cut +'some string' =~ m/(s)/; +my $s = $1; + +#----------------------------------------------------------------------------- + +## name inside a checkblock, but another regex overrides +## failures 1 +## cut +if (m/(.)/) { + 'some string' =~ m/(s)/; + my $s = $1; +} + +#----------------------------------------------------------------------------- + +## name good passes +## failures 0 +## cut +if ($str =~ m/(.)/) { + return $1; +} +elsif ($foo =~ s/(b)//) { + $bar = $1; +} + +if ($str =~ m/(.)/) { + while (1) { + return $1; + } +} + +while ($str =~ m/\G(.)/cg) { + print $1; +} + +print $0; # not affected by policy +print $_; # not affected by policy +print $f1; # not affected by policy + +my $result = $str =~ m/(.)/; +if ($result) { + return $1; +} + +#----------------------------------------------------------------------------- + +## name ternary passes +## failures 0 +## cut +print m/(.)/ ? $1 : 'undef'; +print !m/(.)/ ? 'undef' : $1; +print s/(.)// ? $1 : 'undef'; +print !s/(.)// ? 'undef' : $1; +$foo = m/(.)/ && $1; +$foo = !m/(.)/ || $1; +$foo = s/(.)// && $1; +$foo = !s/(.)// || $1; + +#----------------------------------------------------------------------------- + +## name Regression for PPI::Statement::Expressions +## failures 0 +## cut + +if (m/(\d+)/xms) { + $foo = ($1); +} + +#----------------------------------------------------------------------------- + +## name Regression for ternaries with structures +## failures 0 +## cut + +$str =~ m/(.)/xms ? foo($1) : die; +$str =~ m/(.)/xms ? [$1] : die; +$str =~ m/(.)/xms ? { match => $1 } : die; + +#----------------------------------------------------------------------------- + +## name Failure to match throws exception - RT 36081. +## failures 0 +## cut + +m/(foo)/ or die; +print $1, "\n"; +m/(foo)/ or croak; +print $1, "\n"; +m/(foo)/ or confess; +print $1, "\n"; +m/(foo)/ || die; +print $1, "\n"; +m/(foo)/ || croak; +print $1, "\n"; +m/(foo)/ || confess; +print $1, "\n"; + +#----------------------------------------------------------------------------- + +## name Failure to match throws exception (regex in outer block) - RT 36081. +## failures 0 +## cut + +m/(foo)/ or die; +{ + print $1, "\n"; +} + +#----------------------------------------------------------------------------- + +## name Failure to match throws exception (regex in inner block) - RT 36081. +## failures 1 +## cut + +{ + m/(foo)/ or die; +} +print $1, "\n"; + +#----------------------------------------------------------------------------- + +## name Boolean 'or' without known exception source is an error - RT 36081 +## failures 1 +## cut + +m/(foo)/ or my_exception_source( 'bar' ); +print $1, "\n"; + +#----------------------------------------------------------------------------- + +## name Recognize alternate exception sources if told about them - RT 36081 +## parms { exception_source => 'my_exception_source' } +## failures 0 +## cut + +m/(foo)/ or my_exception_source( 'bar' ); +print $1, "\n"; +m/(foo)/ or $self->my_exception_source( 'bar' ); +print $1, "\n"; + +#----------------------------------------------------------------------------- + +## name Failure to match causes transfer of control - RT 36081. +## failures 0 +## cut + +m/(foo)/ or next; +print $1, "\n"; +m/(foo)/ or last; +print $1, "\n"; +m/(foo)/ or redo; +print $1, "\n"; +m/(foo)/ or goto FOO; +print $1, "\n"; +m/(foo)/ or return; +print $1, "\n"; +m/(foo)/ || next; +print $1, "\n"; +m/(foo)/ || last; +print $1, "\n"; +m/(foo)/ || redo; +print $1, "\n"; +m/(foo)/ || goto FOO; +print $1, "\n"; +m/(foo)/ || return; +print $1, "\n"; + +#----------------------------------------------------------------------------- + +## name Failure to match causes transfer of control (regex in outer block) - RT 36081. +## failures 0 +## cut + +m/(foo)/ or return; +{ + print $1, "\n"; +} + +#----------------------------------------------------------------------------- + +## name Failure to match causes transfer of control (regex in inner block) - RT 36081. +## failures 1 +## cut + +{ + m/(foo)/ or return; +} +print $1, "\n"; + +#----------------------------------------------------------------------------- + +## name Failure to match does not cause transfer of control (regex in inner block) - RT 36081. +## failures 1 +## cut + +{ + m/(foo)/; +} +print $1, "\n"; + +#----------------------------------------------------------------------------- + +## name goto that transfers around capture - RT 36081. +## failures 0 +## cut + +{ + m/(foo)/ or goto BAR; + print $1, "\n"; + BAR: + print "Baz\n"; +} + +{ +BAR: m/(foo)/ or goto BAR; + print $1, "\n"; +} + +{ + m/(foo)/ or goto &bar; + print $1, "\n"; +} + +#----------------------------------------------------------------------------- + +## name goto that does not transfer around capture - RT 36081. +## failures 1 +## cut + +{ + m/(foo)/ or goto BAR; +BAR : print $1, "\n"; +} + +#----------------------------------------------------------------------------- + +## name goto that can not be disambiguated - RT 36081. +## failures 1 +## cut + +{ +FOO: m/(foo)/ or goto (qw{FOO BAR BAZ})[$i]; +BAR: print $1, "\n"; +BAZ: +} + +#----------------------------------------------------------------------------- + +## name regex in suffix control +## failures 0 +## cut + +die unless m/(foo)/; +print $1, "\n"; +last unless m/(foo)/; +print $1, "\n"; +die "Arrrgh" unless m/(foo)/; +print $1, "\n"; + +#----------------------------------------------------------------------------- + +## name regex in loop with capture in nested if +## failures 0 +## cut + +foreach (qw{foo bar baz}) { + next unless m/(foo)/; + if ($1) { + print "Foo!\n"; + } +} + +#----------------------------------------------------------------------------- + +## name regex in while, capture in loop +## failures 0 +## cut + +while (m/(foo)/) { + print $1, "\n"; +} + +#----------------------------------------------------------------------------- + +## name Regex followed by "and do {...}" RT #50910 +## failures 0 +## cut + +m/^commit (.*)/xsm and do { + $commit = $1; + next; +}; + +#----------------------------------------------------------------------------- + +## name regex inside when(){} RT #36081 +## failures 0 +## cut + +use 5.010; + +given ( 'abc' ) { + when ( m/(a)/ ) { + say $1; + } +} + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/RegularExpressions/ProhibitComplexRegexes.run b/t/RegularExpressions/ProhibitComplexRegexes.run new file mode 100644 index 0000000..cc064fe --- /dev/null +++ b/t/RegularExpressions/ProhibitComplexRegexes.run @@ -0,0 +1,98 @@ +## name basic passes +## failures 0 +## cut + +m/foo/; +m/foo foo foo foo foo foo foo foo foo foo foo foo/; +m/foo + foo/; + +m/foo # this is a foo + bar # this is a bar + baz # this is a baz + more # more more more more more + /x; + +m/ + + + + + +/; + +#----------------------------------------------------------------------------- + +## name basic failures +## failures 1 +## cut + +m/ foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo/; + +## name basic failures, m//x +## failures 1 +## cut + +m/foo # this is a foo + bar # this is a bar + baz # this is a baz + 1234567890 1234567890 1234567890 1234567890 1234567890 1234567890 # this is too long + /x; + +#----------------------------------------------------------------------------- + +## name config +## failures 1 +## parms {max_characters => 2} +## cut + +m/ foo /; + +#----------------------------------------------------------------------------- + +## name failing regexp with syntax error +## failures 0 +## cut + +m/foofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoofoo(/x; + +#----------------------------------------------------------------------------- + +## name RT 36098 forgive long (and presumably descriptive) variable names +## failures 0 +## parms {max_characters => 20} +## cut + +m/ $now_is_the_time_for_all_good_men_to_come_to /; +m/ \\$now_is_the_time_for_all_good_men_to_come_to /; +m/ $now::is::the::time::for::all::good::men::to::come::to /; +m/ ${^_now_is_the_time_for_all_good_men_to_come_to} /; +m/ ${now_is_the_time_for_all_good_men_to_come_to} /; +m/ ${now::is::the::time::for::all::good::men::to::come::to} /; +m/ @now_is_the_time_for_all_good_men_to_come_to /; +m/ @{^_now_is_the_time_for_all_good_men_to_come_to} /; +m/ @{now_is_the_time_for_all_good_men_to_come_to} /; +m/ @{now::is::the::time::for::all::good::men::to::come::to} /; +m/ $#now_is_the_time_for_all_good_men_to_come_to /; +m/ $#{^_now_is_the_time_for_all_good_men_to_come_to} /; + +#----------------------------------------------------------------------------- + +## name RT 36098 things that look like interpolation but are not +## failures 3 +## parms {max_characters => 20} +## cut + +m/ \$now_is_the_time_for_all_good_men_to_come_to /; +m/ \\\$now_is_the_time_for_all_good_men_to_come_to /; +m' $now_is_the_time_for_all_good_men_to_come_to '; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/RegularExpressions/ProhibitEnumeratedClasses.run b/t/RegularExpressions/ProhibitEnumeratedClasses.run new file mode 100644 index 0000000..608b950 --- /dev/null +++ b/t/RegularExpressions/ProhibitEnumeratedClasses.run @@ -0,0 +1,82 @@ +## name basic passes +## failures 0 +## cut + +m/\w\d\p{Uppercase}/; +m/[\w\s]/; + +#----------------------------------------------------------------------------- + +## name allowed classes +## failures 0 +## cut + +m/[B-Y]/; +m/[0-8]/; +m/[\x{ffef}]/; # for code coverage + +#----------------------------------------------------------------------------- + +## name basic failures +## failures 8 +## cut + +m/[A-Z]/; # \p{Uppercase} +m/[a-z]/; # \p{Lowercase} +m/[0-9]/; # \d +m/[A-Za-z0-9_]/; # \w +m/[0-9a-z_A-Z]/; # \w +m/[a-zA-Z]/; # \p{Alphabetic} +m/[ \t\r\n\f]/;# \s +m/[\ \t\r\n]/; # \s + +#----------------------------------------------------------------------------- + +## name alterate representations of line endings +## failures 3 +## cut + +m/[\ \t\012\015]/; # \s +m/[\ \t\x0a\x0d]/; # \s +m/[\ \t\x{0a}\x{0d}]/; # \s + +#----------------------------------------------------------------------------- + +## name negative failures +## failures 8 +## cut + +m/[^\w]/; # \W +m/[^\s]/; # \S +m/[^0-9]/; # \D +m/[^A-Za-z0-9_]/; # \W +m/[^0-9a-z_A-Z]/; # \W +m/[^a-zA-Z]/; # \P{Alphabetic} +m/[^ \t\r\n\f]/;# \S +m/[^\ \t\r\n]/; # \S + +#----------------------------------------------------------------------------- + +## name special negative successes +## failures 0 +## cut + +m/[^\s\w]/; + +#----------------------------------------------------------------------------- + +## name failing regexp with syntax error +## failures 0 +## cut + +m/[^\w] (/; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/RegularExpressions/ProhibitEscapedMetacharacters.run b/t/RegularExpressions/ProhibitEscapedMetacharacters.run new file mode 100644 index 0000000..0d120f9 --- /dev/null +++ b/t/RegularExpressions/ProhibitEscapedMetacharacters.run @@ -0,0 +1,62 @@ +## name basic passes +## failures 0 +## cut + +m/ [{] . [.] \d{2} [}] /xms; +$name =~ m{ harry [ ] s [ ] truman + | harry [ ] j [ ] potter + }ixms; + +## name basic failures +## failures 2 +## cut + +m/ \{ . \. \d{2} \} /xms; +$name =~ m{ harry \ s \ truman + | harry \ j \ potter + }ixms; + +## name allow comment character in //x mode -- http://rt.perl.org/rt3/Public/Bug/Display.html?id=45667 +## failures 0 +## cut + +m/\#/x; +m/\#/; + +## name allowed escapes +## failures 0 +## cut + +# omit \N{}, \p{}, \P{}, \xfe \cx +m/\Q\E \L\U \l\u /; # matched pairs of specials +m/\A\B\C\D \F\G\H\I\J\K \M \O \R\S\T \V\W\X\Y\Z /; +m/\a\b \d\e\f\g\h\i\j\k \m\n\o \q\r\s\t \v\w \y\z /; +m/(.)(.)(.)(.)(.)(.)(.)(.)(.) + \1\2\3\4\5\6\7\8\9 /; +m/\!\@\%\&\-\_\= /; +m/\\ \'\"\` \~\,\<\> \/ /; +m/ \[\] /x; + +## name unexpected failures +## failures 0 +## cut + +s{\%[fF]}{STDIN}mx; + +## name escaped characters in character classes +## failures 2 +## cut + +m/ ([\)]) /xms; +m/ [\.] /xms; + + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/RegularExpressions/ProhibitFixedStringMatches.run b/t/RegularExpressions/ProhibitFixedStringMatches.run new file mode 100644 index 0000000..c59ccfb --- /dev/null +++ b/t/RegularExpressions/ProhibitFixedStringMatches.run @@ -0,0 +1,105 @@ +## name basic passes +## failures 0 +## cut + +/foo/; +/foo/s; +/ bar /; +/(bar)/; +/(foo|bar)/; + +s/foo//; +qr/ bar /; + +## name failures mentioned in perldoc +## failures 7 +## cut + + m/^foo$/; + m/\A foo \z/x; + m/\A foo \z/xm; + m/\A(foo)\z/; + m/\A(?:foo)\z/; + m/\A(foo|bar)\z/; + m/\A(?:foo|bar)\z/; + +## name anchored passes +## failures 0 +## cut + +/\A \s* \z/sx; +/ \A \s* \z /sx; +/^ \w+ $/x; +/^ foo $/mx; + +s/\A \s* \z//sx; +s/^ \w+ $//x; +s/^ foo $//m; + +qr/\A \s* \z/s; +qr/^ \w+ $/x; +qr/^ foo $/m; + +## name escapes +## failures 0 +## cut + +/\\A foo \\z/s; +/\^ foo \$/; + +## name alternating passes +## failures 0 +## cut + +/\A (foo|\w+) \z/x; +/^ (foo|bar) \z/mx; + +## name basic failures, m// +## failures 5 +## cut + +/\A foo \z/x; +/\A foo \z/s; +/\A foo \z/xs; +/^ foo $/sx; +/\A foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo \z/; + +## name basic failures, s/// +## failures 5 +## cut + +s/\A foo \z//; +s/\A foo \z//s; +s/\A foo \z//xs; +s/^ foo $//s; +s/\A foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo \z//; + +## name basic failures, qr// +## failures 5 +## cut + +qr/\A foo \z/; +qr/\A foo \z/s; +qr/\A foo \z/xs; +qr/^ foo $/s; +qr/\A foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo foo \z/; + +## name alternating failures +## failures 5 +## cut + +qr/\A(foo|bar)\z/; +qr/\A(foo|)\z/; +qr/\A(?:foo|bar)\z/; +/^(?:foo|bar)$/; +/^(?:foo|bar|baz|spam|splunge)$/; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/RegularExpressions/ProhibitSingleCharAlternation.run b/t/RegularExpressions/ProhibitSingleCharAlternation.run new file mode 100644 index 0000000..8d26232 --- /dev/null +++ b/t/RegularExpressions/ProhibitSingleCharAlternation.run @@ -0,0 +1,52 @@ +## name basic passes +## failures 0 +## cut + +m/\A [adiqrwx] \z/xms; +m/\A (?: qq | qr | qx | [qsy] | tr ) \z/xms; +m/\A (?: q[qrx] | [qsy] | tr ) \z/xms; + +m/\A (?: a ) \z/xms; # bad form, but not a violation of this policy +m/\A (?: [a] ) \z/xms; # bad form, but not a violation of this policy + +## name warnings reported by users (App::Ack) +## failures 1 +## cut + +return ('shell',TEXT) if $header =~ /\b(?:ba|c|k|z)?sh\b/; + +## name metacharacters +## failures 0 +## cut + +m/(?: ^ | . | \d | $ )/xms; + +## name allowed to have one single character alternation +## failures 0 +## cut + +m/\A (?: a | do | in | queue | rue | woe | xray ) \z/xms; +return 1 if $file =~ m/ [.] (?: p (?: l x? | m ) | t | PL ) \z /xms; + +## name basic failures +## failures 2 +## cut + +m/\A (?: a | d | i | q | r | w | x ) \z/xms; +m/\A (?: qq| qr | qx | q | s | y | tr ) \z/xms; + +## name failing regexp with syntax error +## failures 0 +## cut + +m/\A (?: a | d | i | q | r | w | x ) ( \z/xms; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/RegularExpressions/ProhibitUnusedCapture.run b/t/RegularExpressions/ProhibitUnusedCapture.run new file mode 100644 index 0000000..b2d1eff --- /dev/null +++ b/t/RegularExpressions/ProhibitUnusedCapture.run @@ -0,0 +1,582 @@ +## name non-captures +## failures 0 +## cut + +m/foo/; +m/(?:foo)/; + +if (m/foo/) { + print "bar"; +} + +#----------------------------------------------------------------------------- + +## name assignment captures +## failures 0 +## cut + +my ($foo) = m/(foo)/; +my ($foo) = m/(foo|bar)/; +my ($foo) = m/(foo)(?:bar)/; +my @foo = m/(foo)/; +my @foo = m/(foo)/g; +my %foo = m/(foo)(bar)/g; + +my ($foo, $bar) = m/(foo)(bar)/; +my @foo = m/(foo)(bar)/; +my ($foo, @bar) = m/(foo)(bar)/; +my ($foo, @bar) = m/(foo)(bar)(baz)/; + +#----------------------------------------------------------------------------- + +## name undef array captures +## failures 0 +## cut + +() = m/(foo)/; +(undef) = m/(foo)/; +my ($foo) =()= m/(foo)/g; + +#----------------------------------------------------------------------------- + +## name complex array assignment captures +## failures 0 +## cut + +@$foo = m/(foo)(bar)/; +@{$foo} = m/(foo)(bar)/; +%$foo = m/(foo)(bar)/; +%{$foo} = m/(foo)(bar)/; + +($foo,@$foo) = m/(foo)(bar)/; +($foo,@{$foo}) = m/(foo)(bar)/; + +#----------------------------------------------------------------------------- + +## name conditional captures +## failures 0 +## cut + +if (m/(foo)/) { + my $foo = $1; + print $foo; +} +if (m/(foo)(bar)/) { + my $foo = $1; + my $bar = $2; + print $foo, $bar; +} +if (m/(foo)(bar)/) { + my ($foo, $bar) = ($1, $2); + print $foo, $bar; +} +if (m/(foo)(bar)/) { + my (@foo) = ($1, $2); + print @foo; +} + +if (m/(foo)/) { + # bug, but not a violation of THIS policy + my (@foo) = ($1, $2); + print @foo; +} + +#----------------------------------------------------------------------------- + +## name RT #38942 +## failures 0 +## cut + +while ( pos() < length ) { + m{\G(a)(b)(c)}gcxs or die; + my ($a, $b, $c) = ($1, $2, $3); +} + +#----------------------------------------------------------------------------- + +## name boolean and ternary captures +## failures 0 +## cut + +m/(foo)/ && print $1; +m/(foo)/ ? print $1 : die; +m/(foo)/ && ($1 == 'foo') ? print 1 : die; + +#----------------------------------------------------------------------------- + +## name loop captures +## failures 0 +## cut + +for (m/(foo)/) { + my $foo = $1; + print $foo; +} + +#----------------------------------------------------------------------------- + +## name slurpy array loop captures +## failures 0 +## cut + +map {print} m/(foo)/; +foo(m/(foo)/); +foo('bar', m/(foo)/); +foo(m/(foo)/, 'bar'); +foo m/(foo)/; +foo 'bar', m/(foo)/; +foo m/(foo)/, 'bar'; + +## name slurpy with assignment +## failures 0 +## cut + +my ($foo) = grep {$b++ == 2} m/(foo)/g; +my ($foo) = grep {$b++ == 2} $str =~ m/(foo)/g; + +#----------------------------------------------------------------------------- + +## name slurpy with array assignment +## failures 0 +## cut + +my @foo = grep {$b++ > 2} m/(foo)/g; +my @foo = grep {$b++ > 2} $str =~ m/(foo)/g; + +#----------------------------------------------------------------------------- + +## name assignment captures on string +## failures 0 +## cut + +my ($foo) = $str =~ m/(foo)/; +my ($foo) = $str =~ m/(foo|bar)/; +my ($foo) = $str =~ m/(foo)(?:bar)/; +my @foo = $str =~ m/(foo)/; +my @foo = $str =~ m/(foo)/g; + +my ($foo, $bar) = $str =~ m/(foo)(bar)/; +my @foo = $str =~ m/(foo)(bar)/; +my ($foo, @bar) = $str =~ m/(foo)(bar)/; +my (@bar) = $str =~ m/(foo)(bar)/; +my ($foo, @bar) = $str =~ m/(foo)(bar)(baz)/; + +#----------------------------------------------------------------------------- + +## name slurpy captures on string +## failures 0 +## cut + +map {print} $str =~ m/(foo)/g; + +#----------------------------------------------------------------------------- + +## name self captures +## failures 0 +## cut + +m/(foo)\1/; +s/(foo)/$1/; +s/(foo)/\1/; +s<\A t[\\/] (\w+) [\\/] (\w+) [.]run \z><$1\::$2>xms + +#----------------------------------------------------------------------------- + +## name basic failures +## failures 5 +## cut + +m/(foo)/; +my ($foo) = m/(foo)/g; + +if (m/(foo)/) { + print "bar"; +} +if (m/(foo)(bar)/) { + my $foo = $1; + print $foo; +} + +for (m/(foo)/) { + print "bar"; +} + +#----------------------------------------------------------------------------- + +## name negated regexp failures +## failures 1 +## cut + +my ($foo) = $str !~ m/(foo)/; + +#----------------------------------------------------------------------------- + +## name statement failures +## failures 1 +## cut + +m/(foo)/ && m/(bar)/ && print $1; + +#----------------------------------------------------------------------------- + +## name sub failures +## failures 1 +## cut + +sub foo { + m/(foo)/; + return; +} +print $1; + +#----------------------------------------------------------------------------- + +## name anon sub failures +## failures 1 +## TODO PPI v1.118 doesn't recognize anonymous subroutines +## cut + +my $sub = sub foo { + m/(foo)/; + return; +}; +print $1; + +#----------------------------------------------------------------------------- + +## name ref constructors +## failures 0 +## cut + +$f = { m/(\w+)=(\w+)/g }; +$f = [ m/(\w+)/g ]; + +#----------------------------------------------------------------------------- + +## name sub returns +## failures 0 +## cut + +sub foo { + m/(foo)/; +} +sub foo { + return m/(foo)/; +} +map { m/(foo)/ } (1, 2, 3); + +#----------------------------------------------------------------------------- + +## name failing regexp with syntax error +## failures 0 +## cut + +m/(foo)(/; + +#----------------------------------------------------------------------------- + +## name lvalue sub assigment pass +## failures 0 +## cut + +(substr $str, 0, 1) = m/(\w+)/; + +#----------------------------------------------------------------------------- + +## name lvalue sub assigment failure +## failures 1 +## TODO lvalue subs are too complex to support +## cut + +(substr $str, 0, 1) = m/(\w+)(\d+)/; + +#----------------------------------------------------------------------------- + +## name code coverage +## failures 1 +## cut + +m/(foo)/; +print $0; +print @ARGV; +print $_; + +#----------------------------------------------------------------------------- + +## name while loop with /g +## failures 0 +## cut + +while (m/(\d+)/g) { + print $1, "\n"; +} + +#----------------------------------------------------------------------------- + +## name conditional named captures +## failures 0 +## cut + +if ( m/(?bar)/ ) { + print $+{foo}, "\n"; +} + +while ( m/(?'foo'\d+)/g ) { + print $-{foo}[0], "\n"; +} + +m/(?P\w+)|(?\W+)/ and print $+{foo}, "\n"; + +#----------------------------------------------------------------------------- + +## name named capture in array context is unused +## failures 2 +## cut + +my @foo = m/(?\w+)/; +sub foo { + return m/(?\W+)/; +} + +#----------------------------------------------------------------------------- + +## name named capture in array context with siblings is OK +## failures 0 +## cut + +my @foo = m/(?\w+)/; +print $+{foo}, "\n"; + +#----------------------------------------------------------------------------- + +## name named capture not used in replacement +## failures 1 +## cut + +s/(?\w+)/foo$1/g; + +#----------------------------------------------------------------------------- + +## name named capture used in replacement +## failures 0 +## cut + +s/(?\w+)/foo$+{foo}/g; + +#----------------------------------------------------------------------------- + +## name subscripted capture +## failures 0 +## cut + +s/(foo)/$+[ 1 ]/; +s/(foo)/$-[ 1 ]/; +s/(foo)/$+[ -1 ]/; +s/(foo)/$-[ -1 ]/; +m/(\w+)/ and print substr( $_, $-[ 1 ], $+[ 1 ] - $-[ 1 ] ); +m/(\w+)/ and print substr( $_, $-[ -1 ], $+[ -1 ] - $-[ -1 ] ); + +#----------------------------------------------------------------------------- + +## name named capture English name in replacement RT #60002 +## failures 1 +## cut + +s/(?\w+)/foo$LAST_PAREN_MATCH{foo}/g; + +#----------------------------------------------------------------------------- + +## name named capture English name in code RT #60002 +## failures 1 +## cut + + +m/(?P\w+)|(?\W+)/ and print $LAST_PAREN_MATCH{foo}, "\n"; + +#----------------------------------------------------------------------------- + +## name named capture English name in replacement RT #60002 +## failures 0 +## cut + +use English; + +s/(?\w+)/foo$LAST_PAREN_MATCH{foo}/g; + +#----------------------------------------------------------------------------- + +## name named capture English name in code RT #60002 +## failures 0 +## cut + +use English; + +m/(?P\w+)|(?\W+)/ and print $LAST_PAREN_MATCH{foo}, "\n"; + +#----------------------------------------------------------------------------- + +## name English subscripted capture without use English +## failures 6 +## cut + +s/(foo)/$LAST_MATCH_END[ 1 ]/; +s/(foo)/$LAST_MATCH_START[ 1 ]/; +s/(foo)/$LAST_MATCH_END[ -1 ]/; +s/(foo)/$LAST_MATCH_START[ -1 ]/; +m/(\w+)/ and print substr( + $_, $LAST_MATCH_START[ 1 ], $LAST_MATCH_END[ 1 ] - $LAST_MATCH_START[ 1 ] ); +m/(\w+)/ and print substr( + $_, $LAST_MATCH_START[ -1 ], + $LAST_MATCH_END[ -1 ] - $LAST_MATCH_START[ -1 ] ); + +#----------------------------------------------------------------------------- + +## name English subscripted capture with use English +## failures 0 +## cut + +use English; + +s/(foo)/$LAST_MATCH_END[ 1 ]/; +s/(foo)/$LAST_MATCH_START[ 1 ]/; +s/(foo)/$LAST_MATCH_END[ -1 ]/; +s/(foo)/$LAST_MATCH_START[ -1 ]/; +m/(\w+)/ and print substr( + $_, $LAST_MATCH_START[ 1 ], $LAST_MATCH_END[ 1 ] - $LAST_MATCH_START[ 1 ] ); +m/(\w+)/ and print substr( + $_, $LAST_MATCH_START[ -1 ], + $LAST_MATCH_END[ -1 ] - $LAST_MATCH_START[ -1 ] ); + +#----------------------------------------------------------------------------- + +## name Capture used in substitution portion of s/.../.../e +## failures 0 +## cut + +s/(\w+)/$replace{$1} || "<$1>"/ge; + +#----------------------------------------------------------------------------- + +## name Capture used in double-quotish string. RT #38942 redux +## failures 0 +## cut + +m/(\w+)(\W+)/; +print "$+[2] $1"; + +m/(?(\w+)/; +print "$+{foo}"; + +m/(\d+)/; +print "${1}234"; + +#----------------------------------------------------------------------------- + +## name Capture used in a here document. RT #38942 redux +## failures 0 +## cut + +m/(\w+)(\W+)/; +print <; +m(foo); +m'foo'; +m"foo"; +m;foo;; +m,foo,; + +s#foo##; +s|foo||; +s<>; +s//; +s(foo)(); +s'foo''; +s"foo""; +s;foo;;; +s,foo,,; + +qr#foo#; +qr|foo|; +qr; +qr(foo); +qr'foo'; +qr"foo"; +qr;foo;; +qr,foo,; + +## name allow_all_brackets +## failures 0 +## parms { allow_all_brackets => 1 } +## cut + +m{foo}; +m(foo); +m[foo]; +m; + +s{foo}{}; +s(foo){}; +s[foo]{}; +s{}; + +s{foo}(); +s(foo)(); +s[foo](); +s(); + +s{foo}[]; +s(foo)[]; +s[foo][]; +s[]; + +s{foo}<>; +s(foo)<>; +s[foo]<>; +s<>; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/RegularExpressions/ProhibitUselessTopic.run b/t/RegularExpressions/ProhibitUselessTopic.run new file mode 100644 index 0000000..90b2b33 --- /dev/null +++ b/t/RegularExpressions/ProhibitUselessTopic.run @@ -0,0 +1,115 @@ +## name Non-topic explicitness +## failures 0 +## cut + +my $foo = 'Whatever'; + +$foo =~ /foo/; +$foo =~ m/foo/; +$foo =~ s/foo/bar/; +$foo =~ tr/a-mn-z/n-za-m/; + +#----------------------------------------------------------------------------- + +## name Topical exclusion +## failures 0 +## cut + +/foo/; +m/foo/; +s/foo/bar/; +tr/a-mn-z/n-za-m/; + +#----------------------------------------------------------------------------- + +## name Useless topic +## failures 10 +## cut + +$_ =~ /foo/; +$_ =~ m/foo/; +$_ =~ s/foo/bar/; +$_ =~ tr/a-mn-z/n-za-m/; +$_ =~ y/a-mn-z/n-za-m/; + +# Plus some without spacing + +$_=~/foo/; +$_=~m/foo/; +$_=~s/foo/bar/; +$_=~tr/a-mn-z/n-za-m/; +$_=~y/a-mn-z/n-za-m/; + +#----------------------------------------------------------------------------- + +## name Useless topic in a negative match +## failures 5 +## cut + +$_ !~ /foo/; +$_ !~ m/foo/; +$_ !~ s/foo/bar/; +$_ !~ tr/a-mn-z/n-za-m/; +$_ !~ y/a-mn-z/n-za-m/; + +#----------------------------------------------------------------------------- + +## name Match against qr object +## failures 2 +## cut + +$_ =~ qr/bar/; +$_ !~ qr/bar/; + +#----------------------------------------------------------------------------- + +## name Not useless matching against a variable +## failures 0 +## cut + +my $non_useless_topic_regex = qr/foo.+bar/; +$_ =~ $non_useless_topic_regex; + +#----------------------------------------------------------------------------- + +## name More complex constructions +## failures 8 +## cut + +my $x = scalar( grep { $_ =~ m/^INFO: .*$/ } @foo ); +$x = 3 if $_ !~ s/foo/bar/; +$_ =~ s/\s+$// foreach ($name, $zip, $phone); +our @paths = grep { $_ =~ /./ } ; # get non-blank lines from the end +next if $_ =~ m/^\s*#/; +$condition_count += ($_ =~ tr/,/,/) foreach values %requirements; +my ( $v ) = grep { $_ =~ /^\s*our\s+\$VERSION\s*=\s*['"]\d/ } <$fh>; +assert( ! grep { $_ =~ m/\|/ } @$suggestions, 'no suggestion contains a pipe character (reserved for future field separator)' ); + +#----------------------------------------------------------------------------- + +## name Potential false positives, but none should fail. +## failures 0 +## cut + +$x =~ /foo/; +$_ += /foo/; +print s/x/y/; +foo(tr/x/y/); ++tr/x/y/; +# $_ =~ /foo/ +'foo' =~ $_; +$_ =~ $some_qr_var; +ok( ( grep { $_ =~ $regwarn } ( $title->warnings() ) ), 'expected warning text reported' ); +my ( $line, $dummy ) = grep { $_ =~ $stat->{regex} } @contents; +if ($_ !~ $pat) { foo(); } +=head1 $_ =~ /foo/ + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/RegularExpressions/RequireBracesForMultiline.run b/t/RegularExpressions/RequireBracesForMultiline.run new file mode 100644 index 0000000..3ec787a --- /dev/null +++ b/t/RegularExpressions/RequireBracesForMultiline.run @@ -0,0 +1,102 @@ +## name short match regexps +## failures 0 +## cut + +/foo/; +/foo\nbar/; +/ bar .* baz /m; +s/foo/ + bar + /; + +## name proper delimiters +## failures 0 +## cut + +m{ + foo + }x; +m{ + foo + }; +s{foo + bar} + {baz + fzz}; +qr{ + foo + }; + +## name basic failures +## failures 4 +## cut + +m/ + foo + /; +s/ + foo + //; +qr/ + foo + /; +m# + foo + #; + +## name allow_all_brackets +## failures 0 +## parms { allow_all_brackets => 1 } +## cut + +m( + foo + )x; +m( + foo + ); +s(foo + bar) + (baz + fzz); +qr( + foo + ); + +m[ + foo + ]x; +m[ + foo + ]; +s[foo + bar] + [baz + fzz]; +qr[ + foo + ]; + +m< + foo + >x; +m< + foo + >; +s + ; +qr< + foo + >; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/RegularExpressions/RequireDotMatchAnything.run b/t/RegularExpressions/RequireDotMatchAnything.run new file mode 100644 index 0000000..e8d4392 --- /dev/null +++ b/t/RegularExpressions/RequireDotMatchAnything.run @@ -0,0 +1,121 @@ +## name basic passes +## failures 0 +## cut + +my $string =~ m{pattern}s; +my $string =~ m{pattern}gisx; +my $string =~ m{pattern}gmis; +my $string =~ m{pattern}mgxs; + +my $string =~ m/pattern/s; +my $string =~ m/pattern/gisx; +my $string =~ m/pattern/gmis; +my $string =~ m/pattern/mgxs; + +my $string =~ /pattern/s; +my $string =~ /pattern/gisx; +my $string =~ /pattern/gmis; +my $string =~ /pattern/mgxs; + +my $string =~ s/pattern/foo/s; +my $string =~ s/pattern/foo/gisx; +my $string =~ s/pattern/foo/gmis; +my $string =~ s/pattern/foo/mgxs; + +my $re = qr/pattern/s; + +#----------------------------------------------------------------------------- + +## name basic failures +## failures 17 +## cut + +my $string =~ m{pattern}; +my $string =~ m{pattern}gix; +my $string =~ m{pattern}gim; +my $string =~ m{pattern}gxm; + +my $string =~ m/pattern/; +my $string =~ m/pattern/gix; +my $string =~ m/pattern/gim; +my $string =~ m/pattern/gxm; + +my $string =~ /pattern/; +my $string =~ /pattern/gix; +my $string =~ /pattern/gim; +my $string =~ /pattern/gxm; + +my $string =~ s/pattern/foo/; +my $string =~ s/pattern/foo/gix; +my $string =~ s/pattern/foo/gim; +my $string =~ s/pattern/foo/gxm; + +my $re = qr/pattern/; + +#----------------------------------------------------------------------------- + +## name tr and y checking +## failures 0 +## cut + +my $string =~ tr/[A-Z]/[a-z]/; +my $string =~ tr|[A-Z]|[a-z]|; +my $string =~ tr{[A-Z]}{[a-z]}; + +my $string =~ y/[A-Z]/[a-z]/; +my $string =~ y|[A-Z]|[a-z]|; +my $string =~ y{[A-Z]}{[a-z]}; + +my $string =~ tr/[A-Z]/[a-z]/cd; +my $string =~ y/[A-Z]/[a-z]/cd; + +#----------------------------------------------------------------------------- + +## name use re '/s' - RT #72151 +## failures 0 +## cut + +use re '/s'; +my $string =~ m{pattern.}; + +#----------------------------------------------------------------------------- + +## name use re qw{ /s } - RT #72151 +## failures 0 +## cut + +use re qw{ /s }; +my $string =~ m{pattern.}; + +#----------------------------------------------------------------------------- + +## name use re qw{ /s } not in scope - RT #72151 +## failures 1 +## cut + +{ + use re qw{ /s }; +} +my $string =~ m{pattern.}; + +#----------------------------------------------------------------------------- + +## name no re qw{ /s } - RT #72151 +## failures 1 +## cut + +use re qw{ /smx }; +{ + no re qw{ /s }; + my $string =~ m{pattern.}; +} + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/RegularExpressions/RequireExtendedFormatting.run b/t/RegularExpressions/RequireExtendedFormatting.run new file mode 100644 index 0000000..1f54d6b --- /dev/null +++ b/t/RegularExpressions/RequireExtendedFormatting.run @@ -0,0 +1,170 @@ +## name basic passes +## failures 0 +## cut + +my $string =~ m{pattern}; +my $string =~ m{pattern}gim; +my $string =~ m{pattern}gis; +my $string =~ m{pattern}gms; + +my $string =~ m{pattern.}x; +my $string =~ m{pattern.}gimx; +my $string =~ m{pattern.}gixs; +my $string =~ m{pattern.}xgms; + +my $string =~ m/pattern./x; +my $string =~ m/pattern./gimx; +my $string =~ m/pattern./gixs; +my $string =~ m/pattern./xgms; + +my $string =~ /pattern./x; +my $string =~ /pattern./gimx; +my $string =~ /pattern./gixs; +my $string =~ /pattern./xgms; + +my $string =~ s/pattern./foo/x; +my $string =~ s/pattern./foo/gimx; +my $string =~ s/pattern./foo/gixs; +my $string =~ s/pattern./foo/xgms; + +my $string =~ s/pattern/foo./; +my $string =~ s/pattern/foo./gim; +my $string =~ s/pattern/foo./gis; +my $string =~ s/pattern/foo./gms; + +my $re =~ qr/pattern./x; + +#----------------------------------------------------------------------------- + +## name basic failures +## failures 17 +## cut + +my $string =~ m{pattern.}; +my $string =~ m{pattern.}gim; +my $string =~ m{pattern.}gis; +my $string =~ m{pattern.}gms; + +my $string =~ m/pattern./; +my $string =~ m/pattern./gim; +my $string =~ m/pattern./gis; +my $string =~ m/pattern./gms; + +my $string =~ /pattern./; +my $string =~ /pattern./gim; +my $string =~ /pattern./gis; +my $string =~ /pattern./gms; + +my $string =~ s/pattern./foo/; +my $string =~ s/pattern./foo/gim; +my $string =~ s/pattern./foo/gis; +my $string =~ s/pattern./foo/gms; + +my $re =~ qr/pattern./; + +#----------------------------------------------------------------------------- + +## name tr and y formatting +## failures 0 +## cut + +my $string =~ tr/[A-Z]/[a-z]/; +my $string =~ tr|[A-Z]|[a-z]|; +my $string =~ tr{[A-Z]}{[a-z]}; + +my $string =~ y/[A-Z]/[a-z]/; +my $string =~ y|[A-Z]|[a-z]|; +my $string =~ y{[A-Z]}{[a-z]}; + +my $string =~ tr/[A-Z]/[a-z]/cds; +my $string =~ y/[A-Z]/[a-z]/cds; + + +#----------------------------------------------------------------------------- + +## name minimum_regex_length_to_complain_about, pass +## failures 0 +## parms { minimum_regex_length_to_complain_about => 5 } +## cut + +my $string =~ m/foo./; + +my $string =~ s/foo.//; +my $string =~ s/foo./bar/; +my $string =~ s/foo./barbarbar/; +my $string =~ s/1234.//; + + +#----------------------------------------------------------------------------- + +## name minimum_regex_length_to_complain_about, fail +## failures 2 +## parms { minimum_regex_length_to_complain_about => 5 } +## cut + +my $string =~ m/fooba./; + +my $string =~ s/fooba.//; + + +#----------------------------------------------------------------------------- + +## name strict +## failures 2 +## parms { strict => 1 } +## cut + +my $string =~ m/foobar/; + +my $string =~ s/foobar/foo bar/; + +#----------------------------------------------------------------------------- + +## name use re '/x' - RT #72151 +## failures 0 +## cut + +use re '/x'; +my $string =~ m{pattern.}; + +#----------------------------------------------------------------------------- + +## name use re qw{ /x } - RT #72151 +## failures 0 +## cut + +use re qw{ /x }; +my $string =~ m{pattern.}; + +#----------------------------------------------------------------------------- + +## name use re qw{ /x } not in scope - RT #72151 +## failures 1 +## cut + +{ + use re qw{ /x }; +} +my $string =~ m{pattern.}; + +#----------------------------------------------------------------------------- + +## name no re qw{ /x } - RT #72151 +## failures 1 +## cut + +use re qw{ /smx }; +{ + no re qw{ /x }; + my $string =~ m{pattern.}; +} + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/RegularExpressions/RequireLineBoundaryMatching.run b/t/RegularExpressions/RequireLineBoundaryMatching.run new file mode 100644 index 0000000..261476a --- /dev/null +++ b/t/RegularExpressions/RequireLineBoundaryMatching.run @@ -0,0 +1,118 @@ +## name basic passes +## failures 0 +## cut +my $string =~ m{pattern}m; +my $string =~ m{pattern}gimx; +my $string =~ m{pattern}gmis; +my $string =~ m{pattern}mgxs; + +my $string =~ m/pattern/m; +my $string =~ m/pattern/gimx; +my $string =~ m/pattern/gmis; +my $string =~ m/pattern/mgxs; + +my $string =~ /pattern/m; +my $string =~ /pattern/gimx; +my $string =~ /pattern/gmis; +my $string =~ /pattern/mgxs; + +my $string =~ s/pattern/foo/m; +my $string =~ s/pattern/foo/gimx; +my $string =~ s/pattern/foo/gmis; +my $string =~ s/pattern/foo/mgxs; + +my $re = qr/pattern/m; + +#----------------------------------------------------------------------------- + +## name basic failures +## failures 17 +## cut +my $string =~ m{pattern}; +my $string =~ m{pattern}gix; +my $string =~ m{pattern}gis; +my $string =~ m{pattern}gxs; + +my $string =~ m/pattern/; +my $string =~ m/pattern/gix; +my $string =~ m/pattern/gis; +my $string =~ m/pattern/gxs; + +my $string =~ /pattern/; +my $string =~ /pattern/gix; +my $string =~ /pattern/gis; +my $string =~ /pattern/gxs; + +my $string =~ s/pattern/foo/; +my $string =~ s/pattern/foo/gix; +my $string =~ s/pattern/foo/gis; +my $string =~ s/pattern/foo/gxs; + +my $re = qr/pattern/; + +#----------------------------------------------------------------------------- + +## name tr and y checking +## failures 0 +## cut +my $string =~ tr/[A-Z]/[a-z]/; +my $string =~ tr|[A-Z]|[a-z]|; +my $string =~ tr{[A-Z]}{[a-z]}; + +my $string =~ y/[A-Z]/[a-z]/; +my $string =~ y|[A-Z]|[a-z]|; +my $string =~ y{[A-Z]}{[a-z]}; + +my $string =~ tr/[A-Z]/[a-z]/cds; +my $string =~ y/[A-Z]/[a-z]/cds; + +#----------------------------------------------------------------------------- + +## name use re '/m' - RT #72151 +## failures 0 +## cut + +use re '/m'; +my $string =~ m{pattern.}; + +#----------------------------------------------------------------------------- + +## name use re qw{ /m } - RT #72151 +## failures 0 +## cut + +use re qw{ /m }; +my $string =~ m{pattern.}; + +#----------------------------------------------------------------------------- + +## name use re qw{ /m } not in scope - RT #72151 +## failures 1 +## cut + +{ + use re qw{ /m }; +} +my $string =~ m{pattern.}; + +#----------------------------------------------------------------------------- + +## name no re qw{ /m } - RT #72151 +## failures 1 +## cut + +use re qw{ /smx }; +{ + no re qw{ /m }; + my $string =~ m{pattern.}; +} + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Subroutines/ProhibitAmpersandSigils.run b/t/Subroutines/ProhibitAmpersandSigils.run new file mode 100644 index 0000000..9630e74 --- /dev/null +++ b/t/Subroutines/ProhibitAmpersandSigils.run @@ -0,0 +1,75 @@ +## name basic failures +## failures 7 +## cut + +&function_call(); +&my_package::function_call(); +&function_call( $args ); +&my_package::function_call( %args ); +&function_call( &other_call( @foo ), @bar ); +&::function_call(); + +#----------------------------------------------------------------------------- + +## name basic passing +## failures 0 +## cut +exists &function_call; +defined &function_call; +\ &function_call; +\&function_call; +exists &my_package::function_call; +defined &my_package::function_call; +\ &my_package::function_call; +\&my_package::function_call; +$$foo; # for Devel::Cover; skip non-backslash casts + +#----------------------------------------------------------------------------- + +## name RT #38855 passing with parens +## failures 0 +## cut + +defined( &function_call ); +exists( &function_call ); + +#----------------------------------------------------------------------------- + +## name RT #49609 recognize reference-taking distributes over parens +## failures 0 +## cut + +\( &function_call ); +\( &function_call, &another_function ); + +#----------------------------------------------------------------------------- + +## name more passing +## failures 0 +## cut +function_call(); +my_package::function_call(); +function_call( $args ); +my_package::function_call( %args ); +function_call( other_call( @foo ), @bar ); +\&my_package::function_call; +\&function_call; +goto &foo; + +#----------------------------------------------------------------------------- + +## name handle that the first bareword after "sort" is the comparator function +## failures 0 +## cut + +sort &foo($x) + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Subroutines/ProhibitBuiltinHomonyms.run b/t/Subroutines/ProhibitBuiltinHomonyms.run new file mode 100644 index 0000000..e04dfe1 --- /dev/null +++ b/t/Subroutines/ProhibitBuiltinHomonyms.run @@ -0,0 +1,45 @@ +## name Basic failures +## failures 7 +## cut + +sub open {} +sub map {} +sub eval {} +sub if {} +sub sub {} +sub foreach {} +sub while {} + +#----------------------------------------------------------------------------- + +## name Basic passing +## failures 0 +## cut + +sub my_open {} +sub my_map {} +sub eval2 {} + +#----------------------------------------------------------------------------- + +## name Acceptable homonyms +## failures 0 +## cut + +sub import { do_something(); } +sub AUTOLOAD { do_something(); } +sub DESTROY { do_something(); } +BEGIN { do_something(); } +INIT { do_something(); } +CHECK { do_something(); } +END { do_something(); } + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Subroutines/ProhibitExcessComplexity.run b/t/Subroutines/ProhibitExcessComplexity.run new file mode 100644 index 0000000..777fd91 --- /dev/null +++ b/t/Subroutines/ProhibitExcessComplexity.run @@ -0,0 +1,58 @@ +## name parm-based pass +## failures 0 +## parms { max_mccabe => 100 } +## cut + +sub test_sub { + if ( $foo && $bar || $baz ) { + open my $fh, '<', $file or die $!; + } + elsif ( $blah >>= some_function() ) { + return if $barf; + } + else { + $results = $condition ? 1 : 0; + } + croak unless $result; + + while( $condition ){ frobulate() } + until( $foo > $baz ){ blech() } +} + +#----------------------------------------------------------------------------- + +## name parm-based failure +## failures 1 +## parms { max_mccabe => 1 } +## cut + +sub test_sub { + if ( $foo && $bar || $baz ) { + open my $fh, '<', $file or die $!; + } + elsif ( $blah >>= some_function() ) { + return if $barf; + } + else { + $results = $condition ? 1 : 0; + } + croak unless $result; +} + +#----------------------------------------------------------------------------- + +## name no-op sub +## failures 0 +## cut +sub test_sub { +} + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Subroutines/ProhibitExplicitReturnUndef.run b/t/Subroutines/ProhibitExplicitReturnUndef.run new file mode 100644 index 0000000..79a0b06 --- /dev/null +++ b/t/Subroutines/ProhibitExplicitReturnUndef.run @@ -0,0 +1,48 @@ +## name simple failure +## failures 3 +## cut + +sub test_sub1 { + $foo = shift; + return undef; +} + +sub test_sub2 { + shift || return undef; +} + +sub test_sub3 { + return undef if $bar; +} + +#----------------------------------------------------------------------------- + +## name simple success +## failures 0 +## cut + +sub test_sub1 { + $foo = shift; + return; +} + +sub test_sub2 { + shift || return; +} + +sub test_sub3 { + return if $bar; +} + +$foo{return}; # hash key, not keyword +sub foo {return}; # no sibling + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Subroutines/ProhibitManyArgs.run b/t/Subroutines/ProhibitManyArgs.run new file mode 100644 index 0000000..39a9d7e --- /dev/null +++ b/t/Subroutines/ProhibitManyArgs.run @@ -0,0 +1,223 @@ +## name basic passes +## failures 0 +## cut + +sub forward; + +sub foo { + my ($self, $bar) = @_; +} + +sub fu { + my $self = shift; + my $bar = shift; +} + +sub foo($$) { + print $_[0]; + return; +} + +#----------------------------------------------------------------------------- + +## name simple failures +## failures 3 +## cut + +sub foo { + my ($self, $bar1, $bar2, $bar3, $bar4, $bar5) = @_; +} + +sub fu { + my $self = shift; + my $bar1 = shift; + my $bar2 = shift; + my $bar3 = shift; + my $bar4 = shift; + my $bar5 = shift; +} + +sub foo($$$$$$) { + print $_[0]; + return; +} + +#----------------------------------------------------------------------------- + +## name configured failures +## failures 3 +## parms {max_arguments => 3} +## cut + +sub foo { + my ($self, $bar1, $bar2, $bar3) = @_; +} + +sub fu { + my $self = shift; + my $bar1 = shift; + my $bar2 = shift; + my $bar3 = shift; +} + +sub foo($$$$) { + print $_[0]; + return; +} + +#----------------------------------------------------------------------------- + +## name configured successes +## failures 0 +## parms {max_arguments => 3} +## cut + +sub foo_ok { + my ($self, $bar1, $bar2) = @_; +} + +sub fu_ok { + my $self = shift; + my $bar1 = shift; + my $bar2 = shift; +} + +sub foo_ok($$$) { + print $_[0]; + return; +} + +#----------------------------------------------------------------------------- + +## name RT56627: prototype interpretation +## failures 0 +## parms {max_arguments => 3} +## cut + +sub foo ($;$) { return 1 } +sub bar ( $ ; $ ) { return 1 } + +#----------------------------------------------------------------------------- + +## name prototype grouping +## failures 0 +## parms {max_arguments => 3} +## cut + +sub foo (\[$@%]@) { return 1 } +sub bar ( \[$@%] $ \[$@%] ) { return 1 } + +#----------------------------------------------------------------------------- + +## name single term prototype (Perl 5.14) +## failures 0 +## parms {max_arguments => 2} +## cut + +sub foo ($+) { return 1 } + +#----------------------------------------------------------------------------- + +## name single term prototype (Perl 5.14) +## failures 1 +## parms {max_arguments => 2} +## cut + +sub foo ($$+) { return 1 } + +#----------------------------------------------------------------------------- + +## name ignore $self and $class +## failures 0 +## parms {skip_object => 1} +## cut + +sub self_foo { + my ($self, $bar1, $bar2, $bar3, $bar4, $bar5) = @_; +} + +sub self_fu { + my $self = shift; + my $bar1 = shift; + my $bar2 = shift; + my $bar3 = shift; + my $bar4 = shift; + my $bar5 = shift; +} + +sub self_bar { + my $self = shift; + my ($bar1, $bar2, $bar3, $bar4, $bar5) = @_; +} + +sub class_foo { + my ($class, $bar1, $bar2, $bar3, $bar4, $bar5) = @_; +} + +sub class_fu { + my $class = shift; + my $bar1 = shift; + my $bar2 = shift; + my $bar3 = shift; + my $bar4 = shift; + my $bar5 = shift; +} + +sub class_bar { + my $class = shift; + my ($bar1, $bar2, $bar3, $bar4, $bar5) = @_; +} + +#----------------------------------------------------------------------------- + +## name ignore $self and $class with configured max_arguments +## failures 0 +## parms {skip_object => 1, max_arguments => 2} +## cut + +sub self_foo { + my ($self, $bar1, $bar2) = @_; +} + +sub class_foo { + my ($class, $bar1, $bar2) = @_; +} + +#----------------------------------------------------------------------------- + +## name too many arguments despite ignoring $self and $class +## failures 5 +## parms {skip_object => 1, max_arguments => 2} +## cut + +sub self_foo { + my ($self, $bar1, $bar2, $bar3) = @_; +} + +sub self_fu { + my $self = shift; + my ($bar1, $bar2, $bar3) = @_; +} + +sub class_foo { + my ($class, $bar1, $bar2, $bar3) = @_; +} + +sub class_fu { + my $class = shift; + my ($bar1, $bar2, $bar3) = @_; +} + +sub classy_self { + my ($self, $class, $class, $self) = @_; +} + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Subroutines/ProhibitNestedSubs.run b/t/Subroutines/ProhibitNestedSubs.run new file mode 100644 index 0000000..a089773 --- /dev/null +++ b/t/Subroutines/ProhibitNestedSubs.run @@ -0,0 +1,65 @@ +## name Basic passing +## failures 0 +## cut + +sub foo { my $bar = sub { 1 } } +sub foo { } sub bar { } + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 2 +## cut + +sub foo { sub bar { 1 } } +sub foo { if (1) { do { sub bar { 1 } } } } + +#----------------------------------------------------------------------------- + +## name Subroutine declarations inside scheduled blocks used for lexical scope restriction. +## failures 0 +## cut + +CHECK { + my $foo = 1; + + sub bar { return $foo } +} + +#----------------------------------------------------------------------------- + +## name Scheduled blocks inside subroutine declarations. +## failures 0 +## cut + +sub quack { + state $foo; + + UNITCHECK { + $foo = 1; + } +} + +#----------------------------------------------------------------------------- + +## name Subroutine declarations inside scheduled blocks inside subroutine declarations. +## failures 1 +## cut + +sub quack { + INIT { + my $foo = 1; + + sub bar { return $foo } + } +} + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Subroutines/ProhibitReturnSort.run b/t/Subroutines/ProhibitReturnSort.run new file mode 100644 index 0000000..3444261 --- /dev/null +++ b/t/Subroutines/ProhibitReturnSort.run @@ -0,0 +1,65 @@ +## name simple failure +## failures 6 +## cut + +sub test_sub1 { + return sort @list; + return sort(@list); +} + +sub test_sub2 { + return sort { $a <=> $b } @list; + return sort({ $a <=> $b } @list); +} + +sub test_sub3 { + return sort @list if $bar; + return sort(@list) if $bar; +} + +#----------------------------------------------------------------------------- +## name simple success +## failures 0 +## cut + +sub test_sub1 { + @sorted = sort @list; + return @sorted; +} + +sub test_sub2 { + return wantarray ? sort @list : $foo; +} + +sub test_sub3 { + return map {func($_)} sort @list; +} + +#----------------------------------------------------------------------------- +## name when used in conjunction with wantarray() +## TODO False positive: used when when wantarray() has been consulted. +## failures 0 +## cut + +sub test_sub1 { + if (wantarray) { + return sort @list; + } +} + +#----------------------------------------------------------------------------- +## name "sort" used in other contexts... +## failures 0 +## cut +$foo{sort}; # hash key, not keyword +sub foo {return}; # no sibling + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Subroutines/ProhibitSubroutinePrototypes.run b/t/Subroutines/ProhibitSubroutinePrototypes.run new file mode 100644 index 0000000..796c596 --- /dev/null +++ b/t/Subroutines/ProhibitSubroutinePrototypes.run @@ -0,0 +1,25 @@ +## name simple failure +## failures 2 +## cut + +sub my_sub1 ($@) {} +sub my_sub2 (@@) {} + +#----------------------------------------------------------------------------- + +## name simple success +## failures 0 +## cut + +sub my_sub1 {} +sub my_sub1 {} + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Subroutines/ProhibitUnusedPrivateSubroutines.run b/t/Subroutines/ProhibitUnusedPrivateSubroutines.run new file mode 100644 index 0000000..e50e1f5 --- /dev/null +++ b/t/Subroutines/ProhibitUnusedPrivateSubroutines.run @@ -0,0 +1,266 @@ +## name basic failure +## failures 1 +## cut + +sub _foo {}; + +#----------------------------------------------------------------------------- + +## name basic pass +## failures 0 +## cut + +sub _foo {}; +_foo; + +#----------------------------------------------------------------------------- + +## name Method call is OK +## failures 0 +## cut + +sub _foo {}; +$self->_foo(); + +#----------------------------------------------------------------------------- + +## name Method call where invocant is "shift" +## failures 0 +## cut + +sub _foo {}; +shift->_foo; + +#----------------------------------------------------------------------------- + +## name other builtin-function followed by private method call +## failures 0 +## cut + +sub _foo {}; +pop->_foo(); + +#----------------------------------------------------------------------------- + +## name Maybe non-obvious failure +## failures 1 +## cut + +sub _foo {}; + +$self->SUPER::_foo(); + +#----------------------------------------------------------------------------- + +## name Forward references do not count +## failures 0 +## cut + +sub _foo; + +#----------------------------------------------------------------------------- + +## name User-configured exceptions. +## parms { allow => '_foo _bar _baz' } +## failures 0 +## cut + +sub _foo {}; +sub _bar ($) {}; +sub _baz : method {}; + +#----------------------------------------------------------------------------- + +## name private_name_regex passing +## failures 0 +## parms { private_name_regex => '_(?!_|parse_)\w+' } +## cut + +sub __foo {}; +sub __bar ($) {}; +sub __baz : method {}; +sub _parse_my_argument {}; + +#----------------------------------------------------------------------------- + +## name private_name_regex failure +## failures 3 +## parms { private_name_regex => '_(?!_)\w+' } +## cut + +sub _foo {}; +sub _bar ($) {}; +sub _baz : method {}; + +#----------------------------------------------------------------------------- + +## name reference to private subroutine +## failures 0 +## cut + +sub _foo {}; +my $bar = \&_foo; + +#----------------------------------------------------------------------------- + +## name goto to private subroutine +## failures 0 +## cut + +sub _foo {}; +sub bar { + goto &_foo; +} + +#----------------------------------------------------------------------------- + +## name private subroutine used in overload +## failures 0 +## cut + +use overload ( cmp => '_compare' ); +sub _compare {}; + +#----------------------------------------------------------------------------- + +## name private subroutine used in overload, the bad way +## failures 0 +## cut + +use overload ( cmp => _compare => foo => 'bar' ); +sub _compare {}; + +#----------------------------------------------------------------------------- + +## name private subroutine used in overload, by reference +## failures 0 +## cut + +use overload ( cmp => \&_compare ); +sub _compare {}; + +#----------------------------------------------------------------------------- + +## name recursive but otherwise unused subroutine +## failures 2 +## cut + +sub _foo { + my ( $arg ) = @_; + return $arg <= 1 ? $arg : $arg * _foo( $arg - 1 ); +} + +sub _bar { + --$_[0] > 0 and goto &_bar; + return $_[0]; +} + +#----------------------------------------------------------------------------- + +## name recursive subroutine called outside itself +## failures 0 +## cut + +_foo( 3 ); +sub _foo { + my ( $arg ) = @_; + return $arg <= 1 ? $arg : $arg * _foo( $arg - 1 ); +} + +_bar( 1.3 ); +sub _bar { + --$_[0] > 0 and goto &_bar; + return $_[0]; +} + +#----------------------------------------------------------------------------- + +## name subroutine declared in someone else's name space +## failures 0 +## cut + +sub _Foo::_foo {} + +#----------------------------------------------------------------------------- + +## name Subroutine called in replacement portion of s/.../.../e +## failures 0 +## cut + +s/ ( foo ) / _bar( $1 ) /smxe; + +sub _bar { + my ( $foo ) = @_; + return $foo x 3; +} + +#----------------------------------------------------------------------------- + +## name Subroutine called in regexp interpolation +## failures 0 +## cut + +s/ ( foo ) /@{[ _bar( $1 ) ]}/smx; + +sub _bar { + my ( $foo ) = @_; + return $foo x 3; +} + +#----------------------------------------------------------------------------- + +## name Subroutine called in regexp embedded code +## failures 0 +## cut + +m/ (?{ _foo() }) /smx; + +sub _foo { + return 'bar'; +} + +#----------------------------------------------------------------------------- + +## name RT 61311: dies on "&_name" call +## failures 0 +## cut + +sub first { + &_second(); +} + +sub _second { + print "A private sub\n"; +} + +#----------------------------------------------------------------------------- + +## name skip_when_using +## failures 0 +## parms { skip_when_using => 'Moose::Role' } +## cut + +use Moose::Role; + +sub _private { + print "A private sub\n"; +} + +## name allow_using_regex +## failures 0 +## parms { allow_name_regex => '_build_\w+' } +## cut + +sub _build_foo { + return 'This is foo'; +} + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Subroutines/ProtectPrivateSubs.run b/t/Subroutines/ProtectPrivateSubs.run new file mode 100644 index 0000000..f6285ec --- /dev/null +++ b/t/Subroutines/ProtectPrivateSubs.run @@ -0,0 +1,169 @@ +## name basic failure +## failures 5 +## cut + +Other::Package::_foo(); +Other::Package->_bar(); +Other::Package::_foo; +Other::Package->_bar; +$self->Other::Package::_baz(); + +#----------------------------------------------------------------------------- + +## name basic passes +## failures 0 +## cut + +package My::Self::_private; +use My::Self::_private; +require My::Self::_private; + +#----------------------------------------------------------------------------- + +## name Public methods called on non-public classes ok. +## failures 0 +## cut + +# Used for distibution-private classes. + +Foo::_Bar->baz(); + +#----------------------------------------------------------------------------- + +## name Class methods invoked via __PACKAGE__ are always OK. +## failures 0 +## cut + +__PACKAGE__->_private(); + +#----------------------------------------------------------------------------- + +## name "shift" followed by private method call +## failures 0 +## cut + +# See http://rt.cpan.org/Ticket/Display.html?id=34713 +# Also, see the test case below for a counter example. + +shift->_private_sub(); +shift->_private_sub; + +#----------------------------------------------------------------------------- + +## name other builtin-function followed by private method call +## failures 2 +## cut + +# See http://rt.cpan.org/Ticket/Display.html?id=34713 + +pop->_private_sub(); +pop->_private_sub; + +#----------------------------------------------------------------------------- + +## name Difficult-to-detect pass +## failures 0 +## cut + +# This one should be illegal, but it is too hard to distinguish from +# the next one, which is legal +$pkg->_foo(); + +$self->_bar(); +$self->SUPER::_foo(); + +#----------------------------------------------------------------------------- + +## name Exceptions from the POSIX module. +## failures 0 +## cut + +POSIX::_PC_CHOWN_RESTRICTED(); +POSIX::_PC_LINK_MAX(); +POSIX::_PC_MAX_CANON(); +POSIX::_PC_MAX_INPUT(); +POSIX::_PC_NAME_MAX(); +POSIX::_PC_NO_TRUNC(); +POSIX::_PC_PATH_MAX(); +POSIX::_PC_PIPE_BUF(); +POSIX::_PC_VDISABLE(); +POSIX::_POSIX_ARG_MAX(); +POSIX::_POSIX_CHILD_MAX(); +POSIX::_POSIX_CHOWN_RESTRICTED(); +POSIX::_POSIX_JOB_CONTROL(); +POSIX::_POSIX_LINK_MAX(); +POSIX::_POSIX_MAX_CANON(); +POSIX::_POSIX_MAX_INPUT(); +POSIX::_POSIX_NAME_MAX(); +POSIX::_POSIX_NGROUPS_MAX(); +POSIX::_POSIX_NO_TRUNC(); +POSIX::_POSIX_OPEN_MAX(); +POSIX::_POSIX_PATH_MAX(); +POSIX::_POSIX_PIPE_BUF(); +POSIX::_POSIX_SAVED_IDS(); +POSIX::_POSIX_SSIZE_MAX(); +POSIX::_POSIX_STREAM_MAX(); +POSIX::_POSIX_TZNAME_MAX(); +POSIX::_POSIX_VDISABLE(); +POSIX::_POSIX_VERSION(); +POSIX::_SC_ARG_MAX(); +POSIX::_SC_CHILD_MAX(); +POSIX::_SC_CLK_TCK(); +POSIX::_SC_JOB_CONTROL(); +POSIX::_SC_NGROUPS_MAX(); +POSIX::_SC_OPEN_MAX(); +POSIX::_SC_PAGESIZE(); +POSIX::_SC_SAVED_IDS(); +POSIX::_SC_STREAM_MAX(); +POSIX::_SC_TZNAME_MAX(); +POSIX::_SC_VERSION(); +POSIX::_exit(); + +#----------------------------------------------------------------------------- + +## name User-configured exceptions. +## parms { allow => 'Other::Package::_foo Other::Package::_bar Other::Package::_baz' } +## failures 0 +## cut + +Other::Package::_foo(); +Other::Package->_bar(); +Other::Package::_foo; +Other::Package->_bar; +$self->Other::Package::_baz(); + +#----------------------------------------------------------------------------- + +## name private_name_regex passing +## failures 0 +## parms { private_name_regex => '_(?!_)\w+' } +## cut + +Other::Package::__foo(); +Other::Package->__bar(); +Other::Package::__foo; +Other::Package->__bar; +$self->Other::Package::__baz(); + +#----------------------------------------------------------------------------- + +## name private_name_regex failure +## failures 5 +## parms { private_name_regex => '_(?!_)\w+' } +## cut + +Other::Package::_foo(); +Other::Package->_bar(); +Other::Package::_foo; +Other::Package->_bar; +$self->Other::Package::_baz(); + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Subroutines/RequireArgUnpacking.run b/t/Subroutines/RequireArgUnpacking.run new file mode 100644 index 0000000..5468c3a --- /dev/null +++ b/t/Subroutines/RequireArgUnpacking.run @@ -0,0 +1,443 @@ +## name basic passes +## failures 0 +## cut + +sub forward; + +sub foo { + my ($self, $bar) = @_; + print $bar; + return; +} + +sub fu { + my $self = shift; + my $bar = shift; + print $bar; + return; +} + +#----------------------------------------------------------------------------- + +## name prototype passes +## failures 0 +## cut + +sub foo() { + print $bar; + return; +} + +#----------------------------------------------------------------------------- + +## name scheduled subs +## failures 0 +## cut + +BEGIN { + print 1; + print 2; + print 3; +} + +INIT { + print 1; + print 2; + print 3; +} + +CHECK { + print 1; + print 2; + print 3; +} + +END { + print 1; + print 2; + print 3; +} + +#----------------------------------------------------------------------------- + +## name passes - no arguments +## failures 0 +## cut + +sub few { } +sub phu { 1; } +sub phoo { return; } + +#----------------------------------------------------------------------------- + +## name failure - not idiomatic enough +## failures 2 +## cut + +sub quux { + my $self = shift @_; + print $self; +} + +sub cwux { + my ($self) = ($_[0]); + print $self; +} + +#----------------------------------------------------------------------------- + +## name basic failures +## failures 2 +## cut + +sub bar { + print $_[0]; + print $_[1]; + print $_[2]; + print $_[3]; +} + +sub barr { + print $_[1]; +} + +#----------------------------------------------------------------------------- + +## name failure in an anonymous sub +## failures 1 +## TODO PPI v1.118 doesn't recognize anonymous subroutines +## cut + +my $x = sub { + print $_[0]; + print $_[1]; + print $_[2]; + print $_[3]; +} + +#----------------------------------------------------------------------------- + +## name basic failures, set config higher +## failures 1 +## parms {short_subroutine_statements => 1} +## cut + +sub bar { + print $_[0]; + print $_[1]; + print $_[2]; + print $_[3]; +} + +sub barr { + print $_[1]; +} + +#----------------------------------------------------------------------------- + +## name mixed failures +## failures 2 +## cut + +sub baz { + my $self = shift; + print $_[0]; + print $_[1]; + print $_[2]; + print $_[3]; +} + +sub baaz { + my ($self) = @_; + print $_[0]; + print $_[1]; + print $_[2]; + print $_[3]; +} + +#----------------------------------------------------------------------------- + +## name nested anon sub +## failures 0 +## cut + +sub baz { + print "here\n"; + return sub { + my ($self) = @_; + print $self->{bar}; + }; +} + +#----------------------------------------------------------------------------- + +## name nested name sub +## failures 0 +## cut + +sub baz { + print "here\n"; + sub bar { + my ($self) = @_; + print $self->{bar}; + } + $x->bar(); +} + +#----------------------------------------------------------------------------- + +## name array slice (POE convention), default behavior +## failures 1 +## cut + +sub foo { + my ( $kernel, $heap, $input ) = @_[ KERNEL, HEAP, ARG0 ]; +} + +#----------------------------------------------------------------------------- + +## name array slice (POE convention) with indices allowed +## parms { allow_subscripts => '1' } +## failures 0 +## cut + +sub foo { + my ( $kernel, $heap, $input ) = @_[ KERNEL, HEAP, ARG0 ]; +} + +sub bar { + my $kernel = $_[ KERNEL ]; + my $heap = $_[ HEAP ]; + my $input = $_[ ARG0 ]; +} + + +#----------------------------------------------------------------------------- + +## name exclude foreach rt#39601 +## failures 0 +## cut + +sub my_sub { + + my @a = ( [ 1, 2 ], [ 3, 4 ] ); + print @$_[0] foreach @a; + + my @b = ( [ 1, 2 ], [ 3, 4 ] ); + print @$_[0] for @b; + +} + +#----------------------------------------------------------------------------- + +## name and still catch unrolling args in a postfix for +## failures 1 +## cut + +sub my_sub { + + my @a = ( [ 1, 2 ], [ 3, 4 ] ); + print $_[0] for @a; +} + +#----------------------------------------------------------------------------- + +## name Allow the usual delegation idioms. +## failures 0 +## cut + +sub foo { + my $self = shift; + return $self->SUPER::foo(@_); +} + +sub bar { + my $self = shift; + return $self->NEXT::bar(@_); +} + +#----------------------------------------------------------------------------- + +## name Don't allow delegation to unknown places. +## failures 2 +## cut + +sub foo { + my $self = shift; + # No, Class::C3 doesn't really work this way. + return $self->Class::C3::foo(@_); +} + +sub bar { + my $self = shift; + return $self->_unpacker(@_); +} + +#----------------------------------------------------------------------------- + +## name Allow delegation to places we have been told about. +## failures 0 +## parms { allow_delegation_to => 'Class::C3:: _unpacker' } +## cut + +sub foo { + my $self = shift; + # No, Class::C3 doesn't really work this way. + return $self->Class::C3::foo(@_); +} + +sub bar { + my $self = shift; + return $self->_unpacker(@_); +} + +#----------------------------------------------------------------------------- + +## name Recognize $$_[0] as a use of $_, not @_ (rt #37713) +## failures 0 +## cut + +sub foo { + my %hash = ( a => 1, b => 2 ); + my @data = ( [ 10, 'a' ], [ 20, 'b' ], [ 30, 'c' ] ); + # $$_[1] is a funky way to say $_->[1]. + return [ grep { $hash{ $$_[1] } } @data ]; +} + +#----------------------------------------------------------------------------- + +## name Allow tests (rt #79138) +## failures 0 +## cut + +sub foo { + my ( $self, $arg ) = @_; + + if ( @_ ) { + say 'Some arguments'; + } + unless ( ! @_ ) { + say 'Some arguments'; + } + unless ( not @_ ) { + say 'Some arguments'; + } + say 'Some arguments' + if @_; + say 'Some arguments' + if ( @_ ); + say 'Some arguments' + unless ! @_; + say 'Some arguments' + unless ( ! @_ ); + say 'Some arguments' + unless not @_; + say 'Some arguments' + unless ( not @_ ); + @_ + and say 'Some arguments'; + ! @_ + or say 'Some arguments'; + not @_ + or say 'Some arguments'; + + unless ( @_ ) { + say 'No arguments'; + } + if ( ! @_ ) { + say 'No arguments'; + } + if ( not @_ ) { + say 'No arguments'; + } + say 'No arguments' + unless @_; + say 'No arguments' + unless ( @_ ); + say 'No arguments' + if ! @_; + say 'No arguments' + if ( ! @_ ); + say 'No arguments' + if not @_; + say 'No arguments' + if ( not @_ ); + @_ + or say 'No arguments'; + ! @_ + and say 'No arguments'; + not @_ + and say 'No arguments'; + + if ( @_ == 2 ) { + say 'Two arguments'; + } + if ( 2 == @_ ) { + say 'Two arguments'; + } + @_ == 2 + and say 'Two arguments'; + 2 == @_ + and say 'Two arguments'; + say 'Two arguments' + if @_ == 2; + say 'Two arguments' + if ( @_ == 2 ); + unless ( @_ != 2 ) { + say 'Two arguments'; + } + unless ( 2 != @_ ) { + say 'Two arguments'; + } + say 'Two arguments' + unless @_ != 2; + say 'Two arguments' + unless ( @_ != 2 ); + + if ( @_ != 2 ) { + say 'Not two arguments'; + } + if ( 2 != @_ ) { + say 'Not two arguments'; + } + @_ != 2 + and say 'Not two arguments'; + 2 != @_ + and say 'Not two arguments'; + say 'Not two arguments' + if @_ != 2; + say 'Not two arguments' + if ( @_ != 2 ); + unless ( @_ == 2 ) { + say 'Not two arguments'; + } + unless ( 2 == @_ ) { + say 'Not two arguments'; + } + say 'Not two arguments' + unless @_ == 2; + say 'Not two arguments' + unless ( @_ == 2 ); + +} + +#----------------------------------------------------------------------------- + +## name MOOSE idiom (https://github.com/adamkennedy/PPI/issues/74) +## failures 0 +## cut + +sub BUILD { + my ($class, $options_ref) = @_; + $options_ref ||= @_; +} + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Subroutines/RequireFinalReturn.run b/t/Subroutines/RequireFinalReturn.run new file mode 100644 index 0000000..da13965 --- /dev/null +++ b/t/Subroutines/RequireFinalReturn.run @@ -0,0 +1,294 @@ +## name basic passes +## failures 0 +## cut + +sub foo { } +sub bar; +sub baz { return; } +sub quux { return {some => [qw(complicated data)], q{ } => /structure/}; } + +#----------------------------------------------------------------------------- + +## name complex passes +## failures 0 +## cut + +sub foo { if ($bool) { return; } else { return; } } +sub bar { unless ($bool) { return; } else { return; } } +sub baz { if ($bool) { return; } elsif ($bool2) { return; } else { return; } } +sub quuz { unless ($bool) { return; } elsif ($bool2) { return; } else { return; } } + +#----------------------------------------------------------------------------- + +## name ternary returns +## failures 0 +## TODO We are not yet detecting ternaries +## cut + +sub foo { 1 ? return : 2 ? return : return; } + +#----------------------------------------------------------------------------- + +## name returning ternaries +## failures 0 +## cut + +sub foo { return 1 ? 1 : 2 ? 2 : 3; } + +#----------------------------------------------------------------------------- + +## name implicit returns fail +## failures 2 +## cut + +sub foo { 1 } +sub foo { 'Club sandwich'; } + +#----------------------------------------------------------------------------- + +## name return in a constant loop +## failures 1 +## cut + +sub foo { while (1==1) { return; } } + +#----------------------------------------------------------------------------- + +## name not all code paths returns +## failures 3 +## cut + +sub foo { if ($bool) { } else { } } +sub foo { if ($bool) { $foo = 'bar'; } else { return; } } +sub foo { unless ($bool) { $foo = 'bar'; } else { return; } } + +#----------------------------------------------------------------------------- + +## name special blocks exemption +## failures 0 +## cut + +BEGIN { + print 'this should not need a return'; +} +INIT { + print 'nor this'; +} +CHECK { + print 'nor this'; +} +END { + print 'nor this'; +} + +#----------------------------------------------------------------------------- + +## name goto is equivalent to return +## failures 0 +## cut + +sub foo { goto &bar; } +END_PERL + +#----------------------------------------------------------------------------- + +## name next and last are not equivalent to return (and are invalid Perl) +## failures 2 +## cut + +sub foo { next; } +sub bar { last; } + +#----------------------------------------------------------------------------- + +## name abnormal termination is allowed +## failures 0 +## cut + +sub foo { die; } +sub bar { croak; } +sub baz { confess; } +sub bar_C { Carp::croak; } +sub baz_C { Carp::confess; } +sub quux { exec; } +sub quux2 { exit; } +sub quux3 { throw 'nuts'; } + +#----------------------------------------------------------------------------- + +## name Final return is present, but conditional +## failures 5 +## cut + +sub foo { die if $condition } +sub bar { croak unless $condition } +sub baz { exec for @condition } +sub baz { exit for @condition } +sub quux { throw 'nuts'if not $condition } + +#----------------------------------------------------------------------------- + +## name Compound final return is present, but conditional +## failures 1 +## cut +sub foo { + + if( $condition ) { + return if $today_is_tuesday; + } + else { + exit unless $today_is_wednesday; + } +} + +#----------------------------------------------------------------------------- + +## name Custom terminal functions +## parms { terminal_funcs => 'bailout abort quit' }; +## failures 0 +## cut +sub foo { if ($condition) { return 1; }else{ abort } } +sub bar { if ($condition) { bailout }else{ return 1 } } +sub baz { quit } + + +#----------------------------------------------------------------------------- + +## name Custom terminal methods +## parms { terminal_methods => 'bailoutmeth abortmeth quitmeth' }; +## failures 0 +## cut +sub foo { if ($condition) { return 1; }else{ ONE->bailoutmeth } } +sub bar { if ($condition) { $two->abortmeth }else{ return 1 } } +sub baz { $three->quitmeth } + +#----------------------------------------------------------------------------- + +## name Custom terminal methods failing +## parms { }; +## failures 3 +## cut +sub foo { if ($condition) { return 1; }else{ ONE->bailoutmeth } } +sub bar { if ($condition) { $two->abortmeth }else{ return 1 } } +sub baz { $three->quitmeth } + +#----------------------------------------------------------------------------- + +## name ForLoop is a QuoteLike::Words +## failures 0 +## cut + +sub foo { + for my $thingy qw {} + + return; +} + +#----------------------------------------------------------------------------- + +## name RT 43309 - given/when followed by return +## failures 0 +## cut + +sub foo { + given ($bar) {} + return; +} + +#----------------------------------------------------------------------------- + +## name given/when with return on all branches +## failures 0 +## cut + +sub foo { + my ( $val ) = @_; + given ( $val ) { + when ( 'end' ) { + return 'End.'; + } + default { + return 'Not end.'; + } + } +} + +#----------------------------------------------------------------------------- + +## name given/suffix when with return on all branches +## failures 0 +## cut + +sub foo { + my ( $val ) = @_; + given ( $val ) { + return 'End.' when 'end'; + default { + return 'Not end.'; + } + } +} + +#----------------------------------------------------------------------------- + +## name given/when without return on all branches fails +## failures 1 +## cut + +sub foo { + my ( $val ) = @_; + given ( $val ) { + when ( 'end' ) { + return 'End.'; + } + default { + print "Not end.\n"; + } + } +} + +#----------------------------------------------------------------------------- + +## name given/when with return on all branches but without default fails +## failures 1 +## cut + +sub foo { + my ( $val ) = @_; + given ( $val ) { + when ( 'end' ) { + return 'End.'; + } + } +} + +#----------------------------------------------------------------------------- + +## name return without trailing whitespace (GH #451) +## failures 0 +## cut + +sub f { + return'ProposedOverdue.png'; +} + +#----------------------------------------------------------------------------- + +## name yada-yada operator is essentially terminal (GH #574) +## failures 0 +## cut + +sub f { + some_code(); + ... +} + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/TestingAndDebugging/ProhibitNoStrict.run b/t/TestingAndDebugging/ProhibitNoStrict.run new file mode 100644 index 0000000..c786b26 --- /dev/null +++ b/t/TestingAndDebugging/ProhibitNoStrict.run @@ -0,0 +1,106 @@ +## name strictures disabled +## failures 1 +## cut + +package foo; +no strict; + +#----------------------------------------------------------------------------- + +## name selective strictures disabled +## failures 1 +## cut + +package foo; +no strict 'refs', 'vars'; + +#----------------------------------------------------------------------------- + +## name selective strictures disabled +## failures 1 +## cut + +package foo; +no strict qw(vars refs subs); + +#----------------------------------------------------------------------------- + +## name allowed no strict +## failures 0 +## parms { allow => 'vars refs subs' } +## cut + +package foo; +no strict qw(vars refs subs); + +#----------------------------------------------------------------------------- + +## name allowed no strict +## failures 0 +## parms { allow => 'vars refs subs' } +## cut + +package foo; +no strict "vars", "refs", "subs"; + +#----------------------------------------------------------------------------- + +## name partially allowed no strict +## failures 1 +## parms {allow => 'VARS SUBS'} +# Note wrong case! +## cut + +package foo; +no strict "vars", "refs", 'subs'; + +#----------------------------------------------------------------------------- + +## name partially allowed no strict +## failures 1 +## parms {allow => 'VARS SUBS'} +# Note wrong case! +## cut + +package foo; +no strict qw(vars refs subs); + +#----------------------------------------------------------------------------- + +## name allow no strict, mixed case config +## parms {allow => 'RefS SuBS'} +## failures 0 +## cut + +package foo; +no strict qw(refs subs); + +#----------------------------------------------------------------------------- + +## name allow no strict, comma-delimimted config +## parms {allow => 'refs,subs'} +## failures 0 +## cut + +package foo; +no strict "refs", "subs"; + +#----------------------------------------------------------------------------- + +## name wrong case, funky config +## parms { allow => 'REfs;vArS' } +## failures 1 +## cut + +package foo; +no strict "refs", 'vars', "subs"; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/TestingAndDebugging/ProhibitNoWarnings.run b/t/TestingAndDebugging/ProhibitNoWarnings.run new file mode 100644 index 0000000..bacbc5e --- /dev/null +++ b/t/TestingAndDebugging/ProhibitNoWarnings.run @@ -0,0 +1,147 @@ +## name warnings disabled +## failures 1 +## cut + +package foo; + +no warnings; + +#----------------------------------------------------------------------------- + +## name selective warnings disabled, regular quotes +## failures 1 +## cut + +package foo; + +no warnings 'uninitialized', 'deprecated'; + +#----------------------------------------------------------------------------- + +## name selective warnings disabled, qw<> +## failures 1 +## cut + +package foo; + +no warnings qw(closure glob); + +#----------------------------------------------------------------------------- + +## name allow no warnings, mixed case config +## failures 0 +## parms {allow => 'iO Glob OnCe'} +## cut + +package foo; + +no warnings qw(glob io once); + +#----------------------------------------------------------------------------- + +## name allow no warnings, comma delimimted +## failures 0 +## parms {allow => 'numeric,portable, pack'} +# Funky config +## cut + +package foo; + +no warnings "numeric", "pack", "portable"; + +#----------------------------------------------------------------------------- + +## name wrong case, funky config +## parms { allow => 'NumerIC;PORTABLE' } +## failures 1 +## cut + +package foo; + +no warnings "numeric", "pack", 'portable'; + +#----------------------------------------------------------------------------- + +## name More wrong case, funky config +## failures 1 +## parms { allow => 'paCK/PortablE' } +## cut + +package foo; + +no warnings qw(numeric pack portable); + +#----------------------------------------------------------------------------- + +## name with_at_least_one, no categories +## failures 1 +## parms { allow_with_category_restriction => 1 } +## cut + +package foo; + +no warnings; + +#----------------------------------------------------------------------------- + +## name with_at_least_one, one category +## failures 0 +## parms { allow_with_category_restriction => 1 } +## cut + +package foo; + +no warnings "uninitalized"; + +#----------------------------------------------------------------------------- + +## name with_at_least_one, many categories, regular quotes +## failures 0 +## parms { allow_with_category_restriction => 1 } +## cut + +package foo; + +no warnings "uninitialized", 'glob'; + +#----------------------------------------------------------------------------- + +## name with_at_least_one, many categories, qw<> +## failures 0 +## parms { allow_with_category_restriction => 1 } +## cut + +package foo; + +no warnings qw< uninitialized glob >; + +#----------------------------------------------------------------------------- + +## name allow_with_category_restriction, category qw. RT #74647, +## failures 0 +## parms { allow_with_category_restriction => 1 } +## cut + +no warnings 'qw'; # Yes, 'qw' is an actual warnings category. +no warnings ( foo => "bar" ); + +#----------------------------------------------------------------------------- + +## allow experimental::signatures +## failures 0 +## parms { allow => 'experimental::signatures' } +## cut + +package foo; + +no warnings qw(experimental::signatures); + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/TestingAndDebugging/ProhibitProlongedStrictureOverride.run b/t/TestingAndDebugging/ProhibitProlongedStrictureOverride.run new file mode 100644 index 0000000..bbb2811 --- /dev/null +++ b/t/TestingAndDebugging/ProhibitProlongedStrictureOverride.run @@ -0,0 +1,89 @@ +## name standard pass +## failures 0 +## cut + +use strict; +no strict; + +#----------------------------------------------------------------------------- + +## name standard fail +## failures 1 +## cut + +use strict; +no strict; +print 1; +print 2; +print 3; +print 4; + +#----------------------------------------------------------------------------- + +## name pass that's almost to fail +## failures 0 +## cut + +use strict; +no strict; +print 1; +print 2; +print 3; + +#----------------------------------------------------------------------------- + +## name in a block +## failures 0 +## cut + +use strict; +sub foo { + no strict; +} +print 1; +print 2; +print 3; +print 4; + +#----------------------------------------------------------------------------- + +## name long fail in a block +## failures 1 +## cut + +use strict; +sub foo { + no strict; + print 1; + print 2; + print 3; + print 4; +} + +#----------------------------------------------------------------------------- + +## name config override +## failures 0 +## parms { statements => 6 } +## cut + +use strict; +sub foo { + no strict; + print 1; + print 2; + print 3; + print 4; + print 5; + print 6; +} + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/TestingAndDebugging/RequireTestLabels.run b/t/TestingAndDebugging/RequireTestLabels.run new file mode 100644 index 0000000..9eedc98 --- /dev/null +++ b/t/TestingAndDebugging/RequireTestLabels.run @@ -0,0 +1,104 @@ +## name standard failures +## failures 12 +## cut + +use Test::More tests => 10; +ok($foo); +ok(!$foo); +is(1,2); +isnt(1,2); +like('foo',qr/f/); +unlike('foo',qr/f/); +cmp_ok(1,'==',2); +is_deeply('literal','literal'); +is_deeply([], []); +is_deeply({}, {}); +pass(); +fail(); + +#----------------------------------------------------------------------------- + +## name standard passing +## failures 0 +## cut + +ok($foo); +ok(!$foo); +is(1,2); +isnt(1,2); +like('foo',qr/f/); +unlike('foo',qr/f/); +cmp_ok(1,'==',2); +is_deeply('literal','literal'); +is_deeply([], []); +is_deeply({}, {}); +pass(); +fail(); + +#----------------------------------------------------------------------------- + +## name more passing +## failures 0 +## cut + +use Test::More tests => 10; +ok($foo,'label'); +ok(!$foo,'label'); +is(1,2,'label'); +isnt(1,2,'label'); +like('foo',qr/f/,'label'); +unlike('foo',qr/f/,'label'); +cmp_ok(1,'==',2,'label'); +is_deeply('literal','literal','label'); +pass('label'); +fail('label'); + +#----------------------------------------------------------------------------- + +## name empty array and hash parsing +## failures 0 +## cut +is_deeply([],[],'label'); +is_deeply({},{},'label'); + +#----------------------------------------------------------------------------- + +## name exceptions +## failures 1 +## parms {modules => 'Test::Foo Test::Bar'} +## cut + +use Test::Bar tests => 10; +ok($foo); + +#----------------------------------------------------------------------------- + +## name more exceptions +## failures 0 +## parms {modules => 'Test::Foo Test::Bar'} +## cut + +use Test::Baz tests => 10; +ok($foo); + +#----------------------------------------------------------------------------- + +## name RT 24924, is_deeply +## failures 0 +## cut + +use Test::More; + +is_deeply( { foo => 1 }, { foo => 1 }, 'Boldly criticize where nobody has criticize before.' ); + +is_deeply( { get_empty_array() }, {}, 'Wrap sub-call in hash constructor' ); + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/TestingAndDebugging/RequireUseStrict.run b/t/TestingAndDebugging/RequireUseStrict.run new file mode 100644 index 0000000..711a44d --- /dev/null +++ b/t/TestingAndDebugging/RequireUseStrict.run @@ -0,0 +1,212 @@ +## name one statement before strict +## failures 1 +## cut + +$foo = $bar; +use strict; + +#----------------------------------------------------------------------------- + +## name several statements before strict +## failures 1 +## cut + +$foo = $bar; ## This one violates. +$baz = $nuts; ## no critic; This one is exempted +$blamo; ## This one should be squelched +use strict; + +#----------------------------------------------------------------------------- + +## name several statements before strict with maximum violations changed +## failures 2 +## parms { maximum_violations_per_document => 2 } +## cut + +$foo = $bar; ## This one violates. +$baz = $nuts; ## This one violates. +$blamo; ## This one should be squelched +use strict; + +#----------------------------------------------------------------------------- + +## name no strict at all +## failures 1 +## cut + +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name require strict +## failures 1 +## cut + +require strict; +1; + +#----------------------------------------------------------------------------- + +## name strictures used, but no code +## failures 0 +## cut + +use strict; + +#----------------------------------------------------------------------------- + +## name no strict at all, w/END +## failures 1 +## cut + +$foo = $bar; + +#Should not find the rest of these + +__END__ + +=head1 NAME + +Foo - A Foo factory class + +=cut + +#----------------------------------------------------------------------------- + +## name no strict at all, w/DATA +## failures 1 +## cut + +$foo = $bar; + +#Should not find the rest of these + +__DATA__ + +Fred +Barney +Wilma + + +#----------------------------------------------------------------------------- + +## name strictures used OK +## failures 0 +## cut + +use strict; +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name other module included before strict +## failures 0 +## cut + +use Module; +use strict; +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name package statement before strict +## failures 0 +## cut + +package FOO; +use strict; +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name Work around a PPI bug that doesn't return a location for C<({})>. +## failures 1 +## cut + +({}) + +#----------------------------------------------------------------------------- + +## name Moose support +## failures 0 +## cut + +use Moose; +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name Moose::Role support +## failures 0 +## cut + +use Moose::Role; +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name Built-in equivalent modules +## failures 0 +## cut + +use Moose::Util::TypeConstraints; +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name Custom configured equivalent modules +## failures 0 +## parms { equivalent_modules => 'Foo' } +## cut + +use Foo; +$foo = $bar; + +#----------------------------------------------------------------------------- +## name "use strict" in lexical context (BEGIN block) RT #42310 +## failures 1 +## cut + +BEGIN{ use strict } # notice this is first statement in file +$this_is_not_strict + +#----------------------------------------------------------------------------- +## name "use strict" in lexical context (subroutine) RT #42310 +## failures 1 +## cut + +sub foo { use strict } # notice this is first statement in file +$this_is_not_strict + +#----------------------------------------------------------------------------- +## name "use perl-version" equivalent to strict as of 5.011 +## failures 0 +## cut + +use 5.011; +$foo = $bar; + +#----------------------------------------------------------------------------- +## name "use perl-version" equivalent to strict as of 5.11.0 +## failures 0 +## cut + +use 5.11.0; +$foo = $bar; + +#----------------------------------------------------------------------------- +## name "use perl-version" in lexical context +## failures 1 +## cut + +sub foo { use 5.011 }; +$this_is_not_strict + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/TestingAndDebugging/RequireUseWarnings.run b/t/TestingAndDebugging/RequireUseWarnings.run new file mode 100644 index 0000000..aac8941 --- /dev/null +++ b/t/TestingAndDebugging/RequireUseWarnings.run @@ -0,0 +1,226 @@ +## name 1 statement before warnings +## failures 1 +## cut + +$foo = $bar; +use warnings; + +#----------------------------------------------------------------------------- + +## name several statements before warnings +## failures 1 +## cut + +$foo = $bar; ## This one violates. +$baz = $nuts; ## no critic; This one is exempted +$blamo; ## This one should be squelched +use warnings; + +#----------------------------------------------------------------------------- + +## name several statements before warnings with maximum violations changed +## failures 2 +## parms { maximum_violations_per_document => 2 } +## cut + +$foo = $bar; ## This one violates. +$baz = $nuts; ## This one violates. +$blamo; ## This one should be squelched +use warnings; + +#----------------------------------------------------------------------------- + +## name no warnings at all +## failures 1 +## cut + +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name no warnings at all with "use 5.005" +## failures 0 +## cut + +$foo = $bar; +use 5.005; + +#----------------------------------------------------------------------------- + +## name no warnings at all with "use 5.006" +## failures 1 +## cut + +$foo = $bar; +use 5.006; + +#----------------------------------------------------------------------------- + +## name require warnings +## failures 1 +## cut + +require warnings; +1; + +#----------------------------------------------------------------------------- + +## name warnings used, but no code +## failures 0 +## cut + +use warnings; + +#----------------------------------------------------------------------------- + +## name -w used, but no code +## failures 0 +## cut + +#!perl -w + +#----------------------------------------------------------------------------- + +## name -W used, but no code +## failures 0 +## cut + +#!perl -W + +#----------------------------------------------------------------------------- + +## name no warnings at all, w/END +## failures 1 +## cut + +$foo = $bar; + +#Should not find the rest of these + +__END__ + +=head1 NAME + +Foo - A Foo factory class + +=cut + +#----------------------------------------------------------------------------- + +## name no warnings at all, w/DATA +## failures 1 +## cut + +$foo = $bar; + +#Should not find the rest of these + +__DATA__ + +Fred +Barney +Wilma + + +#----------------------------------------------------------------------------- + +## name warnings used +## failures 0 +## cut + +use warnings; +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name Other module included before warnings +## failures 0 +## cut + +use Module; +use warnings; +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name package statement before warnings +## failures 0 +## cut + +package FOO; +use warnings; +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name Work around a PPI bug that doesn't return a location for C<({})>. +## failures 1 +## cut + +({}) + +#----------------------------------------------------------------------------- + +## name Moose support +## failures 0 +## cut + +use Moose; +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name Moose::Role support +## failures 0 +## cut + +use Moose::Role; +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name Built-in equivalent modules +## failures 0 +## cut + +use Moose::Util::TypeConstraints; +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name Custom configured equivalent modules +## failures 0 +## parms { equivalent_modules => 'Foo' } +## cut + +use Foo; +$foo = $bar; + +#----------------------------------------------------------------------------- + +## name "use warnings" in lexical context (BEGIN block) RT #42310 +## failures 1 +## cut + +BEGIN { use warnings } # notice this is first statement in file +$this_is_not_covered_by_warnings; + +#----------------------------------------------------------------------------- + +## name "use warnings" in lexical context (subroutine) RT #42310 +## failures 1 +## cut + +sub foo { use warnings } # notice this is first statement in file +$this_is_not_covered_by_warnings; + + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/ProhibitCommaSeparatedStatements.run b/t/ValuesAndExpressions/ProhibitCommaSeparatedStatements.run new file mode 100644 index 0000000..14ef125 --- /dev/null +++ b/t/ValuesAndExpressions/ProhibitCommaSeparatedStatements.run @@ -0,0 +1,309 @@ +## name Basic passing +## failures 0 +## cut + +@x = (@y, @z); +my $expl = [133, 138]; +$lookup = { a => 1, b => 2 }; + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 1 +## cut + +@x = @y, @z; + +#----------------------------------------------------------------------------- + +## name List including assignments +## failures 0 +## cut + +@w = ($x = 1, $y = 2, $z = 3); + +#----------------------------------------------------------------------------- + +## name List containing statement +## failures 0 +## cut + +@w = ( {}, [] ); + +#----------------------------------------------------------------------------- + +## name List containing statement in a constructor that is reported as a block +## failures 0 +## cut + +my %foo = ( + blah => { + blah => 'blah', + }, +); + +#----------------------------------------------------------------------------- + +## name Regular statement inside a block. +## failures 0 +## cut + +foreach my $path ( @ARGV ) { + utter 'Looking at ', $path, '.'; +} + +#----------------------------------------------------------------------------- + +## name Sub call after comma +## failures 1 +## cut + +@x = @y, foo @z; + +#----------------------------------------------------------------------------- + +## name Regular sub call before comma +## failures 1 +## cut + +# The space between the sub name and the left parenthesis is significant +# in that part of Conway's point is that things that look like lists may +# not be. + +@x = foo (@y), @z; + +#----------------------------------------------------------------------------- + +## name No-argument sub call via use of sigil +## failures 1 +## cut + +@x = &foo, @y, bar @z; + +#----------------------------------------------------------------------------- + +## name Two sub calls +## failures 0 +## cut + +@x = foo @y, bar @z; + +#----------------------------------------------------------------------------- + +## name Built-in call that provides a list context without parentheses +## failures 0 +## cut + +@x = push @y, @z; + +#----------------------------------------------------------------------------- + +## name Built-in call that provides a list context, called like a function +## failures 1 +## cut + +@x = push (@y), @z; + +#----------------------------------------------------------------------------- + +## name Built-in call that takes multiple arguments without parentheses +## failures 0 +## cut + +@x = substr $y, 1, 2; + +#----------------------------------------------------------------------------- + +## name Built-in call that takes multiple arguments, called like a function +## failures 1 +## cut + +@x = substr ($y, 1), 2; + +#----------------------------------------------------------------------------- + +## name Call to unary built-in without parentheses +## failures 1 +## cut + +@x = tied @y, @z; + +#----------------------------------------------------------------------------- + +## name Unary built-in, called like a function +## failures 1 +## cut + +@x = tied (@y), @z; + +#----------------------------------------------------------------------------- + +## name Call to no-argument built-in without parentheses +## failures 1 +## cut + +@x = time, @z; + +#----------------------------------------------------------------------------- + +## name No-argument built-in, called like a function +## failures 1 +## cut + +@x = time (), @z; + +#----------------------------------------------------------------------------- + +## name Call to optional argument built-in without an argument without parentheses +## failures 1 +## cut + +@x = sin, @z; + +#----------------------------------------------------------------------------- + +## name Optional argument built-in, called like a function without an argument +## failures 1 +## cut + +@x = sin (), @z; + +#----------------------------------------------------------------------------- + +## name Call to optional argument built-in with an argument without parentheses +## failures 1 +## cut + +@x = sin @y, @z; + +#----------------------------------------------------------------------------- + +## name Optional argument built-in, called like a function with an argument +## failures 1 +## cut + +@x = sin (@y), @z; + +#----------------------------------------------------------------------------- + +## name For loop +## failures 2 +## cut + +for ($x = 0, $y = 0; $x < 10; $x++, $y += 2) { + foo($x, $y); +} + +#----------------------------------------------------------------------------- + +## name For loop +## failures 0 +## cut + +for ($x, 'x', @y, 1, ) { + print; +} + +#----------------------------------------------------------------------------- + +## name qw<> +## failures 0 +## cut + +@list = qw<1, 2, 3>; # this really means @list = ('1,', '2,', '3'); + +#----------------------------------------------------------------------------- + +## name original RT #27654 +## failures 0 +## cut + +my @arr1; +@arr1 = split /b/, 'abc'; + +#----------------------------------------------------------------------------- + +## name RT #27654 - NKH example 1 +## failures 0 +## cut + +return + { + "string" => $aliased_history, + TIME => $self->{something}, + } ; + +#----------------------------------------------------------------------------- + +## name RT #27654 - NKH example 2 - without allow_last_statement_to_be_comma_separated_in_map_and_grep +## failures 1 +## cut + +%hash = map {$_, 1} @list ; + +#----------------------------------------------------------------------------- + +## name RT #27654 - NKH example 2 - with allow_last_statement_to_be_comma_separated_in_map_and_grep +## failures 0 +## parms { allow_last_statement_to_be_comma_separated_in_map_and_grep => 1 } +## cut + +%hash = map {$_, 1} @list ; + +#----------------------------------------------------------------------------- + +## name RT #27654 - NKH example 3 +## failures 0 +## cut + +$self->DoSomething + ( + { %{$a_hash_ref}, %{$another_hash_ref}}, + @more_data, + ) ; + +#----------------------------------------------------------------------------- + +## name RT #33935 and 49679 +## failures 0 +## cut + +func( @{ $href }{'1', '2'} ); + +#----------------------------------------------------------------------------- + +## name RT #61301 (requires PPI 1.215) +## failures 0 +## cut + +sub foo { + return { bar => 1, answer => 42 }; +} + +#----------------------------------------------------------------------------- + +## name RT #64132 (requires PPI 1.215) +## failures 0 +## cut + +sub new { + return bless { foo => 1, bar => 2 }, __PACKAGE__; +} + +#----------------------------------------------------------------------------- + +## name Hashref seen as block (GH #192) +## failures 0 +## cut + +my $o = shift || {'file' => 1, 'exec' => 1}; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/ProhibitComplexVersion.run b/t/ValuesAndExpressions/ProhibitComplexVersion.run new file mode 100644 index 0000000..4156430 --- /dev/null +++ b/t/ValuesAndExpressions/ProhibitComplexVersion.run @@ -0,0 +1,216 @@ +## name basic passes +## failures 0 +## cut + +our $VERSION = 2.718; +our $VERSION = '3.14159'; +our $VERSION = q{3.14159}; +our $VERSION = "1.718"; +our $VERSION = qq{1.718}; +use version; our $VERSION = qv('1.2.3'); +($VERSION) = q$REVISION: 42$ =~ m/(\d+)/; +$VERSION = "\$Foo::VERSION"; +$VERSION = $main::VERSION; + +#----------------------------------------------------------------------------- + +## name basic failures +## failures 4 +## cut + +use Foo; our $VERSION = $Foo::VERSION; +use Foo; our $VERSION = $FOO_VERSION; +our $VERSION = $Foo::VERSION; +our $VERSION = "$Foo::VERSION"; + +#----------------------------------------------------------------------------- + +## name configure 'use version' to fail. +## parms { forbid_use_version => '1' } +## failures 1 +## cut + +use version; our $VERSION = qv('1.2.3'); + +#----------------------------------------------------------------------------- + +## name passes from the ProhibitMagicNumbers.run treasury. +## failures 0 +## cut + +(our $VERSION = q$Revision$) =~ s/Revision //; +(our $VERSION) = '$Revision$' =~ /([\d.]+)/; +(our $VERSION) = sprintf "%d", q$Revision$ =~ /Revision:\s+(\S+)/; +our $VERSION : unique = "1.23"; +our $VERSION : unique = '1.23'; +our $VERSION = "$local_variable v1.23"; +our $VERSION = "1." . sprintf "%d", q$Revision$ =~ /: (\d+)/; +our $VERSION = "1.2.3"; +our $VERSION = "1.2.3.0"; +our $VERSION = "1.2.3.blah"; +our $VERSION = "1.23 (liblgrp version $local_variable)"; +our $VERSION = "1.23 2005-05-20"; +our $VERSION = "1.23"; +our $VERSION = "1.23, 2004-12-07"; +our $VERSION = "1.23_blah"; +our $VERSION = "1.23blah"; +our $VERSION = "1.2_3"; +our $VERSION = "123"; +our $VERSION = "INSERT"; +our $VERSION = $VERSION = (qw($Revision$))[1]; +our $VERSION = $local_variable; +our $VERSION = '$Date$'; $VERSION =~ s|^\$Date:\s*([0-9]{4})/([0-9]{2})/([0-9]{2})\s.*|\1.\2.\3| ; +our $VERSION = '$Revision$' =~ /\$Revision:\s+([^\s]+)/; +our $VERSION = '$Revision$'; +our $VERSION = '-123 blah'; +our $VERSION = '1.' . qw $Revision$[1]; +our $VERSION = '1.' . sprintf "%d", (qw($Revision$))[1]; +our $VERSION = '1.' . sprintf("%d", (qw($Revision$))[1]); +our $VERSION = '1.2.3'; +our $VERSION = '1.2.3.0'; +our $VERSION = '1.2.3blah'; +our $VERSION = '1.23'; +our $VERSION = '1.23_blah'; +our $VERSION = '1.23blah'; +our $VERSION = '1.2_3'; +our $VERSION = '1.23' || do { q $Revision$ =~ /(\d+)/; sprintf "%4.2f", $1 / 100 }; +our $VERSION = '123'; +our $VERSION = ('$Revision$' =~ /(\d+.\d+)/)[ 0]; +our $VERSION = ('$Revision$' =~ /(\d+\.\d+)/); +our $VERSION = ('$Revision$' =~ m/(\d+)/)[0]; +our $VERSION = (q$Revision$ =~ /([\d\.]+)/); +our $VERSION = (q$Revision$ =~ /(\d+)/g)[0]; +our $VERSION = (qq$Revision$ =~ /(\d+)/)[0]; +our $VERSION = (qw$Revision$)[-1]; +our $VERSION = (qw$Revision$)[1]; +our $VERSION = (qw($Revision$))[1]; +our $VERSION = (split(/ /, '$Revision$'))[1]; +our $VERSION = (split(/ /, '$Revision$'))[2]; +our $VERSION = 1.2.3; +our $VERSION = 1.23; +our $VERSION = 1.2_3; +our $VERSION = 123; +our $VERSION = [ qw{ $Revision$ } ]->[1]; +our $VERSION = do { (my $v = q%version: 1.23 %) =~ s/.*://; sprintf("%d.%d", split(/\./, $v), 0) }; +our $VERSION = do { (my $v = q%version: 123 %) =~ s/.*://; sprintf("%d.%d", split(/\./, $v), 0) }; +our $VERSION = do { q $Revision$ =~ /(\d+)/; sprintf "%4.2f", $1 / 100 }; +our $VERSION = do { q$Revision$ =~ /Revision: (\d+)/; sprintf "1.%d", $1; }; +our $VERSION = do {(q$URL$=~ m$.*/(?:tags|branches)/([^/ \t]+)$)[0] || "0.0"}; +our $VERSION = q$0.04$; +our $VERSION = q$Revision$; +our $VERSION = q(0.14); +our $VERSION = qv('1.2.3'); +our $VERSION = qw(1.2.3); +our $VERSION = sprintf "%.02f", $local_variable/100 + 0.3; +our $VERSION = sprintf "%.3f", 123 + substr(q$Revision$, 4)/1000; +our $VERSION = sprintf "%d.%d", '$Revision$' =~ /(\d+)\.(\d+)/; +our $VERSION = sprintf "%d.%d", '$Revision$' =~ /(\d+)/g; +our $VERSION = sprintf "%d.%d", '$Revision$' =~ /(\d+)\.(\d+)/; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ /: (\d+)\.(\d+)/; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ /(\d+)/g; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ /(\d+)\.(\d+)/; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ /(\d+)\.(\d+)/g; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ /: (\d+)\.(\d+)/; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ m/ (\d+) \. (\d+) /xg; +our $VERSION = sprintf "%d.%d", q$Revision$ ~~ m:P5:g/(\d+)/; +our $VERSION = sprintf "%d.%d%d", (split /\D+/, '$Name: beta0_1_1 $')[1..3]; +# This deserves to fail, if I can make it do it. +our $VERSION = sprintf "%s.%s%s", q$Name: Rel-0_90 $ =~ /^Name: Rel-(\d+)_(\d+)(_\d+|)\s*$/, 999, "00", join "", (gmtime)[5] +1900, map {sprintf "%d", $_} (gmtime)[4]+1; +our $VERSION = sprintf "1.%d", '$Revision$' =~ /(\d+)/; +our $VERSION = sprintf "1.%d", q$Revision$ =~ /(\d+)/g; +our $VERSION = sprintf '%d.%d', (q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf '%d.%d', q$Revision$ =~ /(\d+)\.(\d+)/; +our $VERSION = sprintf '%d.%d', q$Revision$ =~ /(\d+)\.(\d+)/; +our $VERSION = sprintf '%s', 'q$Revision$' =~ /\S+\s+(\S+)\s+/ ; +our $VERSION = sprintf '%s', 'q$Revision$' =~ /\S+\s+(\S+)\s+/ ; +our $VERSION = sprintf '%s', q$Revision$ =~ /Revision:\s+(\S+)\s+/ ; +our $VERSION = sprintf '%s', q{$Revision$} =~ /\S+\s+(\S+)/ ; +our $VERSION = sprintf '1.%d', (q$Revision$ =~ /\D(\d+)\s*$/)[0] + 15; +our $VERSION = sprintf("%d", q$Id: SomeModule.pm,v 1.23 2006/04/10 22:39:38 matthew Exp $ =~ /\s(\d+)\s/); +our $VERSION = sprintf("%d", q$Id: SomeModule.pm,v 1.23 2006/04/10 22:39:39 matthew Exp $ =~ /\s(\d+)\s/); +our $VERSION = sprintf("%d.%d", "Revision: 2006.0626" =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d", '$Name: v0_018-2006-06-15b $' =~ /(\d+)_(\d+)/, 0, 0); +our $VERSION = sprintf("%d.%d", 0, q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d", q$Name: REL-0-13 $ =~ /(\d+)-(\d+)/, 999, 99); +our $VERSION = sprintf("%d.%d", q$Name: ical-parser-html-1-6 $ =~ /(\d+)-(\d+)/); +our $VERSION = sprintf("%d.%d", q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d", q$Revision$ =~ /(\d+)\.(\d+)/o); +our $VERSION = sprintf("%d.%d", q$Revision$ =~ m/(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d", q$Revision$=~/(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d", q'$Revision$' =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d.%d", 0, q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf("1.%d", q$Revision$ =~ / (\d+) /); +our $VERSION = sprintf("1.%d", q$Revision$ =~ /(\d+)/); +our $VERSION = sprintf("1.2%d%d", q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf('%d.%d', '$Revision$' =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf('%d.%d', q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf('%d.%d', q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = substr q$Revision$, 10; +our $VERSION = substr(q$Revision$, 10); +our $VERSION = v1.2.3.0; +our $VERSION = v1.2.3; +our $VERSION = v1.23; +our $VERSION = version->new('1.2.3'); +our $VERSION = version->new(qw$Revision$); +our ($PACKAGE, $VERSION) = ('') x 2; +our ($VERSION) = "1.23"; +our ($VERSION) = '$Revision$' =~ /\$Revision:\s+([^\s]+)/; +our ($VERSION) = '$Revision$' =~ /\$Revision:\s+([^\s]+)/; +our ($VERSION) = '$Revision$' =~ m{ \$Revision: \s+ (\S+) }x; +our ($VERSION) = '$Revision$' =~ m{ \$Revision: \s+ (\S+) }xm; +our ($VERSION) = '$Revision$'=~/(\d+(\.\d+))/; +our ($VERSION) = '$Revision$' =~ m{ \$Revision: \s+ (\S+) }x; +our ($VERSION) = '1.23' =~ /([.,\d]+)/; +our ($VERSION) = '1.23'; +our ($VERSION) = ($local_variable =~ /(\d+\.\d+)/); +our ($VERSION) = ('$Revision$' =~ /(\d+\.\d+)/) ; +our ($VERSION) = ('$Revision$' =~ /(\d+\.\d+)/); +our ($VERSION) = ('$Revision$' =~ m/([\.\d]+)/) ; +our ($VERSION) = (q$Revision$ =~ /([\d\.]+)/); +our ($VERSION) = (qq$Revision$ =~ /(\d+)/)[0]; +our ($VERSION) = 1.23; +# These deserve to fail if I can make them do it. +our ($VERSION) = q$Revision$ =~ /Revision:\s+(\S+)/ or $VERSION = "1.23"; +our ($VERSION) = q$Revision$ =~ /Revision:\s+(\S+)/ or $VERSION = '1.23'; +our ($VERSION) = q$Revision$ =~ /[\d.]+/g; +our ($VERSION) = q$Revision$ =~ /^Revision:\s+(\S+)/ or $VERSION = "1.23"; +use version; our $VERSION = 1.23; +use version; our $VERSION = qv("1.2.3"); +use version; our $VERSION = qv('1.2.3'); +use version; our $VERSION = qv('1.23'); +use version; our $VERSION = qv((qw$Revision$)[1] / 1000); +use version; our $VERSION = version->new('1.23'); + +#----------------------------------------------------------------------------- + +## name failures from the ProhibitMagicNumbers.run treasury. +## failures 11 +## cut + +our $VERSION = $SomeOtherModule::VERSION; +our $VERSION = ((require SomeOtherModule), $SomeOtherModule::VERSION)[1]; +our $VERSION = SomeOtherModule::RCSVersion('$Revision$'); +our $VERSION = SomeOtherModule::VERSION; +our $VERSION = do { require mod_perl2; $mod_perl2::VERSION }; +our $VERSION = eval { require version; version::qv((qw$Revision$)[1] / 1000) }; +our ($VERSION) = $SomeOtherModule::VERSION; +# This deserves to fail, if I can make it do it. +# our $VERSION = sprintf "%s.%s%s", q$Name: Rel-0_90 $ =~ /^Name: Rel-(\d+)_(\d+)(_\d+|)\s*$/, 999, "00", join "", (gmtime)[5] +1900, map {sprintf "%d", $_} (gmtime)[4]+1; +# These deserve to fail if I can make them do it. +# our ($VERSION) = q$Revision$ =~ /Revision:\s+(\S+)/ or $VERSION = "1.23"; +# our ($VERSION) = q$Revision$ =~ /Revision:\s+(\S+)/ or $VERSION = '1.23'; +# our ($VERSION) = q$Revision$ =~ /[\d.]+/g; +# our ($VERSION) = q$Revision$ =~ /^Revision:\s+(\S+)/ or $VERSION = "1.23"; +require SomeOtherModule; our $VERSION = $SomeOtherModule::VERSION; +use SomeOtherModule; our $VERSION = $SomeOtherModule::VERSION; +use SomeOtherModule; our $VERSION = SomeOtherModule::VERSION; +use base 'SomeOtherModule'; our $VERSION = $SomeOtherModule::VERSION; + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/ProhibitConstantPragma.run b/t/ValuesAndExpressions/ProhibitConstantPragma.run new file mode 100644 index 0000000..00c7b8d --- /dev/null +++ b/t/ValuesAndExpressions/ProhibitConstantPragma.run @@ -0,0 +1,26 @@ +## name Basic passing +## failures 0 +## cut + +my $FOO = 42; +local BAR = 24; +our $NUTS = 16; + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 2 +## cut + +use constant FOO => 42; +use constant BAR => 24; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/ProhibitEmptyQuotes.run b/t/ValuesAndExpressions/ProhibitEmptyQuotes.run new file mode 100644 index 0000000..e7e5d0a --- /dev/null +++ b/t/ValuesAndExpressions/ProhibitEmptyQuotes.run @@ -0,0 +1,44 @@ +## name Basic failure +## failures 4 +## cut + +$var = ""; +$var = '' +$var = ' '; +$var = " "; + +#----------------------------------------------------------------------------- + +## name Quote-like operator passing +## failures 0 +## cut + +$var = qq{}; +$var = q{} +$var = qq{ }; +$var = q{ }; + +#----------------------------------------------------------------------------- + +## name Non-empty passing +## failures 0 +## cut + +$var = qq{this}; +$var = q{that} +$var = qq{the}; +$var = q{other}; +$var = "this"; +$var = 'that'; +$var = 'the'; +$var = "other"; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/ProhibitEscapedCharacters.run b/t/ValuesAndExpressions/ProhibitEscapedCharacters.run new file mode 100644 index 0000000..a513aad --- /dev/null +++ b/t/ValuesAndExpressions/ProhibitEscapedCharacters.run @@ -0,0 +1,29 @@ +## name Basic passing +## failures 0 +## cut + +"\t\r\n\\"; +"\N{DELETE}\N{ACKNOWLEDGE}\N{CANCEL}Z"; +"\"\'\0"; +'\x7f'; +q{\x7f}; + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 3 +## cut + +"\127\006\030Z"; +"\x7F\x06\x22Z"; +qq{\x7F\x06\x22Z}; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/ProhibitImplicitNewlines.run b/t/ValuesAndExpressions/ProhibitImplicitNewlines.run new file mode 100644 index 0000000..f4cb68b --- /dev/null +++ b/t/ValuesAndExpressions/ProhibitImplicitNewlines.run @@ -0,0 +1,57 @@ +## name Basic passing +## failures 0 +## cut + +$x = "foo"; +$x = 'foo'; +$x = q{foo}; +$x = qq{foo}; +$x = "foo\n"; +$x = "foo\r"; + +$x = <<'EOF'; +1 +2 +EOF + +$x = <<"EOF"; +1 +2 +EOF + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 4 +## cut + +$x = "1 +2"; +$x = '1 +2'; +$x = qq{1 +2}; +$x = q{1 +2}; + +#----------------------------------------------------------------------------- + +## name Bad whitespace usage, but allowed +## failures 0 +## cut + +$x = q +<1>; + +$x = qq +<1>; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/ProhibitInterpolationOfLiterals.run b/t/ValuesAndExpressions/ProhibitInterpolationOfLiterals.run new file mode 100644 index 0000000..60ea7f6 --- /dev/null +++ b/t/ValuesAndExpressions/ProhibitInterpolationOfLiterals.run @@ -0,0 +1,124 @@ +## name Basic failure +## failures 2 +## cut + +print "this is literal"; +print qq{this is literal}; + +#----------------------------------------------------------------------------- + +## name Basic passing +## failures 0 +## cut + +print 'this is literal'; +print q{this is literal}; + +#----------------------------------------------------------------------------- + +## name Code with all delimiters in configuration +## failures 0 +## parms {allow => 'qq( qq{ qq[ qq/'} +## cut + +$sql = qq(select foo from bar); +$sql = qq{select foo from bar}; +$sql = qq[select foo from bar]; +$sql = qq/select foo from bar/; + +is( pcritique($policy, \$code, \%config), 0, $policy); + +#----------------------------------------------------------------------------- + +## name Code with not all delimiters in configuration +## failures 2 +## parms {allow => 'qq( qq{'} +## cut + +$sql = qq(select foo from bar); +$sql = qq{select foo from bar}; +$sql = qq[select foo from bar]; +$sql = qq/select foo from bar/; + +#----------------------------------------------------------------------------- + +## name Configuration with only delimiters, no operators +## failures 2 +## parms {allow => '() {}'} +## cut + +$sql = qq(select foo from bar); +$sql = qq{select foo from bar}; +$sql = qq[select foo from bar]; +$sql = qq/select foo from bar/; + +#----------------------------------------------------------------------------- + +## name Configuration with matching closing delimiters +## failures 2 +## parms {allow => 'qq() qq{}'} +## cut + +$sql = qq(select foo from bar); +$sql = qq{select foo from bar}; +$sql = qq[select foo from bar]; +$sql = qq/select foo from bar/; + +#----------------------------------------------------------------------------- + +## name Disallow interpolationi f string contains single quote +## failures 2 +## cut + +$sql = "it's me"; +$sql = "\'"; + +#----------------------------------------------------------------------------- + +## name Allow interpolation if string contains single quote, with option on. +## failures 0 +## parms { allow_if_string_contains_single_quote => 1 } +## cut + +$sql = "it's me"; +$sql = "\'"; + +#----------------------------------------------------------------------------- + +## name allow double quotes if called for. +## failures 0 +## cut + +$text = "Able was $I ere $I saw Elba"; +$text = "$I think, therefore ..."; +$text = "Anyone @home?"; +$text = "Here we have\ta tab"; +$text = "Able was \\$I ere \\$I saw Elba"; +$text = "\\$I think, therefore ..."; +$text = "Anyone \\@home?"; +$text = "Here we have\\\ta tab"; + +#----------------------------------------------------------------------------- + +## name prohibit double quotes if not called for +## failures 8 +## cut + +$text = "Able was \$I ere \$I saw Elba"; +$text = "\$I think, therefore ..."; +$text = "Anyone \@home?"; +$text = "Here we do not have\\ta tab"; +$text = "Able was \\\$I ere \\\$I saw Elba"; +$text = "\\\$I think, therefore ..."; +$text = "Anyone \\\@home?"; +$text = "Here we do not have\\\\ta tab"; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/ProhibitLeadingZeros.run b/t/ValuesAndExpressions/ProhibitLeadingZeros.run new file mode 100644 index 0000000..4b014ba --- /dev/null +++ b/t/ValuesAndExpressions/ProhibitLeadingZeros.run @@ -0,0 +1,183 @@ +## name Basic passing +## failures 0 +## cut + +$var = 0; +$var = 0.; +$var = .0; +$var = 10; +$var = 0.0; +$var = 00.0; +$var = 00; +$var = 0.11; +$var = 10.0; +$var = -0; +$var = -0.; +$var = -10; +$var = -0.0; +$var = -10.0 +$var = -0.11; +$var = +0; +$var = +0.; +$var = +10; +$var = +0.0; +$var = +10.0; +$var = +0.11; +$var = +.011; +$var = .011; +$var = -.011; + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 12 +## cut + +$var = 01; +$var = 010; +$var = 001; +$var = 0010; +$var = -01; +$var = -010; +$var = -001; +$var = -0010; +$var = +01; +$var = +010; +$var = +001; +$var = +0010; + +#----------------------------------------------------------------------------- + +## name chmod +## failures 0 +## cut + +$cnt = chmod 0755, 'foo', 'bar'; +chmod 0755, @executables; + +$cnt = chmod ( 0755, 'foo', 'bar' ); +chmod ( 0755, @executables ); + +#----------------------------------------------------------------------------- + +## name chmod with strict option +## failures 4 +## parms { strict => 1 } +## cut + +$cnt = chmod 0755, 'foo', 'bar'; +chmod 0755, @executables; + +$cnt = chmod ( 0755, 'foo', 'bar' ); +chmod ( 0755, @executables ); + +#----------------------------------------------------------------------------- + +## name dbmopen +## failures 0 +## cut + +dbmopen %database, 'foo.db', 0600; +dbmopen ( %database, 'foo.db', 0600 ); + +#----------------------------------------------------------------------------- + +## name dbmopen with strict option +## failures 2 +## parms { strict => 1 } +## cut + +dbmopen %database, 'foo.db', 0600; +dbmopen ( %database, 'foo.db', 0600 ); + +#----------------------------------------------------------------------------- + +## name mkdir +## failures 0 +## cut + +mkdir $directory, 0755; +mkdir ( $directory, 0755 ); + +#----------------------------------------------------------------------------- + +## name mkdir with strict option +## failures 2 +## parms { strict => 1 } +## cut + +mkdir $directory, 0755; +mkdir ( $directory, 0755 ); + +#----------------------------------------------------------------------------- + +## name sysopen +## failures 0 +## cut + +sysopen $filehandle, $filename, O_RDWR, 0666; +sysopen ( $filehandle, $filename, O_WRONLY | O_CREAT | O_EXCL, 0666 ); +sysopen ( $filehandle, $filename, (O_WRONLY | O_CREAT | O_EXCL), 0666 ); + +#----------------------------------------------------------------------------- + +## name sysopen with strict option +## failures 3 +## parms { strict => 1 } +## cut + +sysopen $filehandle, $filename, O_RDWR, 0666; +sysopen ( $filehandle, $filename, O_WRONLY | O_CREAT | O_EXCL, 0666 ); +sysopen ( $filehandle, $filename, (O_WRONLY | O_CREAT | O_EXCL), 0666 ); + +#----------------------------------------------------------------------------- + +## name umask +## failures 0 +## cut + +umask 002; +umask ( 002 ); + +#----------------------------------------------------------------------------- + +## name umask with strict option +## failures 2 +## parms { strict => 1 } +## cut + +umask 002; +umask ( 002 ); + +## name mkfifo +## failures 0 +## cut + +use POSIX qw(mkfifo); +POSIX::mkfifo $fifo, 0700; +POSIX::mkfifo ( $fifo, 0700 ); +mkfifo $fifo, 0700; +mkfifo ( $fifo, 0700 ); + +#----------------------------------------------------------------------------- + +## name mkdir with strict option +## failures 4 +## parms { strict => 1 } +## cut + +use POSIX qw(mkfifo); +POSIX::mkfifo $fifo, 0700; +POSIX::mkfifo ( $fifo, 0700 ); +mkfifo $fifo, 0700; +mkfifo ( $fifo, 0700 ); + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/ProhibitLongChainsOfMethodCalls.run b/t/ValuesAndExpressions/ProhibitLongChainsOfMethodCalls.run new file mode 100644 index 0000000..1b54912 --- /dev/null +++ b/t/ValuesAndExpressions/ProhibitLongChainsOfMethodCalls.run @@ -0,0 +1,82 @@ +## name Basic passing +## failures 0 +## cut + +$x->y; +$x->y(); +$x->y(@foo); +$x->y(\%foo, *bar); + +$x->y->z; +$x->y()->z(); +$x->y(@foo)->z(@bar); +$x->y(\%foo, *bar)->z($baz, $qux); + +$x->y->z->w; +$x->y()->z()->w(); +$x->y(@foo)->z(@bar)->w(%baz); +$x->y(\%foo, *bar)->z($baz, $qux)->w(\@xyzzy, $plugh); + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 4 +## cut + +$x->y->z->w->u; +$x->y()->z()->w()->u(); +$x->y(@foo)->z(@bar)->w(%baz)->u($qux); +$x->y(\%foo, *bar)->z($baz, $qux)->w(\@xyzzy, $plugh)->u(@joe, @blow); + +#----------------------------------------------------------------------------- + +## name Reduced maximum chain length +## failures 4 +## parms { max_chain_length => 2 } +## cut + +$x->y->z->w; +$x->y()->z()->w(); +$x->y(@foo)->z(@bar)->w(%baz); +$x->y(\%foo, *bar)->z($baz, $qux)->w(\@xyzzy, $plugh); + +#----------------------------------------------------------------------------- + +## name Increased maximum chain length +## failures 0 +## parms { max_chain_length => 4 } +## cut + +$x->y->z->w->u; +$x->y()->z()->w()->u(); +$x->y(@foo)->z(@bar)->w(%baz)->u($qux); +$x->y(\%foo, *bar)->z($baz, $qux)->w(\@xyzzy, $plugh)->u(@joe, @blow); + +#----------------------------------------------------------------------------- + +## name Ignore array and hash ref chains +## failures 0 +## cut + +$blargh = $x->{y}->{z}->{w}->{u}; +$blargh = $x->[1]->[2]->[3]->[4]; +$blargh = $x->{y}->[2]->{w}->[4]; +$blargh = $x->[1]->{z}->[3]->{u}; + +#----------------------------------------------------------------------------- + +## name RT #30040 +## failures 0 +## cut + +$c->response->content_type( 'text/html; charset=utf-8' ) + unless $c->response->content_type; + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/ProhibitMagicNumbers.run b/t/ValuesAndExpressions/ProhibitMagicNumbers.run new file mode 100644 index 0000000..3e7a093 --- /dev/null +++ b/t/ValuesAndExpressions/ProhibitMagicNumbers.run @@ -0,0 +1,998 @@ +## name Version numbers allowed in use statements. +## failures 0 +## cut + +use 5.8.1; + +## name Version numbers allowed in require statements. +## failures 0 +## cut + +require 5.8.1; + +## name Version numbers not allowed in regular statements. +## failures 1 +## cut + +$Aleax = 5.8.1; + +## name All numbers are allowed on any use statement. +## failures 0 +## cut + +use Test::More plan => 57; + +## name Numbers allowed on plan statements. +## failures 0 +## cut + +plan tests => 2349; + +## name Decimal zero is allowed anywhere. +## failures 0 +## cut + +$tangle_tree = 0; + +## name Floating-point zero is allowed anywhere. +## failures 0 +## cut + +$xiron_golem = 0.0 + +## name Decimal one is allowed anywhere. +## failures 0 +## cut + +$killer_tomato = 1; + +## name Floating-point one is allowed anywhere. +## failures 0 +## cut + +$witch_doctor = 1.0; + +## name Decimal two is allowed anywhere. +## failures 0 +## cut + +$gold_golem = 2; + +## name Floating-point two is allowed anywhere. +## failures 0 +## cut + +$lich = 2.0; + +## name Fractional numbers not allowed in regular statements. +## failures 1 +## cut + +$soldier = 2.5; + +## name Negative one is not allowed by default. +## failures 1 +## cut + +$giant_pigmy = -1; + +## name The answer to life, the universe, and everything is not allowed in regular statements. +## failures 1 +## cut + +$frobnication_factor = 42; + +## name The answer to life, the universe, and everything is allowed as a constant. +## failures 0 +## cut + +use constant FROBNICATION_FACTOR => 42; + +## name Fractional numbers are allowed as a constant. +## failures 0 +## cut + +use constant FROBNICATION_FACTOR => 1_234.567_89; + +## name The Readonly subroutine works. +## failures 0 +## cut + +use Readonly; + +Readonly $frobnication_factor => 57; + +## name The Readonly::Scalar subroutine works. +## failures 0 +## cut + +use Readonly; + +Readonly::Scalar $frobnication_factor => 57; + +## name The Readonly::Scalar1 subroutine does work if allow_to_the_right_of_a_fat_comma is set. +## failures 0 +## cut + +use Readonly; + +Readonly::Scalar1 $frobnication_factor => 57; + +## name The Readonly::Scalar1 subroutine does not work if allow_to_the_right_of_a_fat_comma is not set. +## failures 1 +## parms { allow_to_the_right_of_a_fat_comma => 0 } +## cut + +use Readonly; + +Readonly::Scalar1 $frobnication_factor => 57; + +## name The Readonly::Array subroutine works. +## failures 0 +## cut + +use Readonly; + +Readonly::Array @frobnication_factors => ( 57, 193, 49675 ); + +## name The Readonly::Array1 subroutine does not work. +## failures 3 +## cut + +use Readonly; + +Readonly::Array1 @frobnication_factors => ( 57, 193, 49675 ); + +## name The Readonly::Hash subroutine works. +## failures 0 +## cut + +use Readonly; + +Readonly::Hash %frobnication_factors => ( 57 => 290 ); + +## name The Readonly::Hash1 subroutine does work if allow_to_the_right_of_a_fat_comma is set. +## failures 0 +## cut + +use Readonly; + +Readonly::Hash1 %frobnication_factors => ( quhh => 290 ); + +## name The Readonly::Hash1 subroutine does not work if allow_to_the_right_of_a_fat_comma is not set. +## failures 1 +## parms { allow_to_the_right_of_a_fat_comma => 0 } +## cut + +use Readonly; + +Readonly::Hash1 %frobnication_factors => ( quhh => 290 ); + +## name Const::Fast works even if allow_to_the_right_of_a_fat_comma is not set. +## failures 0 +## parms { allow_to_the_right_of_a_fat_comma => 0 } +## cut + +use Const::Fast; + +const my $frobnication_factor => 57; + +## name Constant subroutines containing just a number are allowed. +## failures 0 +## cut + +sub constant_subroutine { 104598 } + +## name Constant subroutines containing "return" and a number are allowed. +## failures 0 +## cut + +sub constant_subroutine { return 9068; } + +## name Subroutines that contain something other than a constant return value are not allowed. +## failures 1 +## cut + +sub constant_subroutine { + print 'blah'; + return 9068; +} + +## name Magic numbers not allowed in ranges. +## failures 1 +## cut + +foreach my $solid (1..5) { + frobnicate($solid); +} + +## name Readonly numbers allowed in ranges. +## failures 0 +## cut + +use Readonly; + +Readonly my $REGULAR_GEOMETRIC_SOLIDS => 5; + +foreach my $solid (1..$REGULAR_GEOMETRIC_SOLIDS) { + frobnicate($solid); +} + +## name Binary zero isn't allowed in regular statements. +## failures 1 +## cut + +$battlemech = 0b0; + +## name Readonly binary zero is allowed. +## failures 0 +## cut + +Readonly $giant_eel => 0b0; + +## name Binary one isn't allowed in regular statements. +## failures 1 +## cut + +$xeroc = 0b1; + +## name Readonly binary one is allowed. +## failures 0 +## cut + +Readonly $creeping_coins => 0b1; + +## name Octal zero isn't allowed in regular statements. +## failures 1 +## cut + +$basilisk = 000; + +## name Readonly octal zero is allowed. +## failures 0 +## cut + +Readonly $dwarf_lord => 000; + +## name Octal one isn't allowed in regular statements. +## failures 1 +## cut + +$brown_mold = 001; + +## name Readonly octal one is allowed. +## failures 0 +## cut + +Readonly $kobold_zombie => 001; + +## name Hexadecimal zero isn't allowed in regular statements. +## failures 1 +## cut + +$yeti = 0x00; + +## name Readonly hexadecimal zero is allowed. +## failures 0 +## cut + +Readonly $newt => 0x00; + +## name Hexadecimal one isn't allowed in regular statements. +## failures 1 +## cut + +$piranha = 0x01; + +## name Readonly hexadecimal one is allowed. +## failures 0 +## cut + +Readonly $Lord_Surtur => 0x01; + +## name Exponential zero isn't allowed in regular statements. +## failures 1 +## cut + +$Green_elf = 0e0; + +## name Readonly exponential zero is allowed. +## failures 0 +## cut + +Readonly $sasquatch => 0e0; + +## name Exponential one isn't allowed in regular statements. +## failures 1 +## cut + +$Uruk_hai = 1e0; + +## name Readonly exponential one is allowed. +## failures 0 +## cut + +Readonly $leather_golem => 1e0; + +## name Any numbers allowed in array references in use statement. +## failures 0 +## cut + +use Some::Module [ 1, 2, 3, 4 ]; + +## name Any numbers allowed in array references in require statement. +## failures 0 +## cut + +require Some::Other::Module [ 1, 2, 3, 4 ]; + +## name Any numbers allowed in array references in readonly statement. +## failures 0 +## cut + +Readonly $Totoro => [ 1, 2, 3, 4 ]; + +## name Magic numbers not allowed in array references in regular statement. +## failures 2 +## cut + +$Evil_Iggy = [ 1, 2, 3, 4 ]; + +## name Array references containing only good numbers are allowed (by this policy). +## failures 0 +## cut + +$titanothere = [ 1, 0, 1, 0 ]; + +## name Any numbers allowed in hash references in use statement. +## failures 0 +## parms { allow_to_the_right_of_a_fat_comma => 0 } +## cut + +use Some::Module { a => 6, b => 4 }; + +## name Any numbers allowed in hash references in require statement. +## failures 0 +## parms { allow_to_the_right_of_a_fat_comma => 0 } +## cut + +require Some::Other::Module { a => 6, b => 4 }; + +## name Any numbers allowed in hash references in readonly statement. +## failures 0 +## parms { allow_to_the_right_of_a_fat_comma => 0 } +## cut + +Readonly $Vlad_the_Impaler => { a => 6, b => 4 }; + +## name Magic numbers allowed in hash references in regular statement if allow_to_the_right_of_a_fat_comma is set. +## failures 0 +## cut + +$gnome_lord = { a => 6, b => 4 }; + +## name Magic numbers not allowed in hash references in regular statement if allow_to_the_right_of_a_fat_comma is not set. +## failures 2 +## parms { allow_to_the_right_of_a_fat_comma => 0 } +## cut + +$gnome_lord = { a => 6, b => 4 }; + +## name Hash references containing only good numbers are allowed (by this policy). +## failures 0 +## cut + +$aardvark = { 1 => 0, 0 => 1 }; + +## name Any numbers allowed in lists in use statement. +## failures 0 +## cut + +use Some::Module ( 1, 2, 3, 4 ); + +## name Any numbers allowed in lists in require statement. +## failures 0 +## cut + +require Some::Other::Module ( 1, 2, 3, 4 ); + +## name Any numbers allowed in lists in readonly statement. +## failures 0 +## cut + +Readonly @elf_mummy => ( 1, 2, 3, 4 ); + +## name Magic numbers not allowed in lists in regular statement. +## failures 2 +## cut + +@kitten = ( 1, 2, 3, 4 ); + +## name Lists containing only good numbers are allowed (by this policy). +## failures 0 +## cut + +@purple_worm = ( 1, 0, 1, 0 ); + +## name Magic numbers not allowed in nested lists in regular statement. +## failures 2 +## cut + +@quivering_blob = ( 1, ( 2, 3, 4 ) ); + +## name Magic numbers not allowed in nested array references in regular statement. +## failures 2 +## cut + +@green_slime = ( 1, [ 2, 3, 4 ] ); + +## name Magic numbers allowed in nested hash references in regular statement if allow_to_the_right_of_a_fat_comma is set. +## failures 0 +## cut + +@fire_elemental = ( 1, { 2 => 4 } ); + +## name Magic numbers not allowed in nested hash references in regular statement if allow_to_the_right_of_a_fat_comma is not set. +## failures 1 +## parms { allow_to_the_right_of_a_fat_comma => 0 } +## cut + +@fire_elemental = ( 1, { 2 => 4 } ); + +## name Good numbers allowed in nested hash references anywhere. +## failures 0 +## parms { allow_to_the_right_of_a_fat_comma => 0 } +## cut + +@Y2K_bug = ( 1, { 0 => 1 } ); + +## name Magic numbers not allowed in deep data structures in regular statement. +## failures 1 +## cut + +@fog_cloud = [ 1, { 0 => { 1 => [ 1, 1, [ \382 ] ] } } ]; + +## name Good numbers allowed in deep datastructures anywhere. +## failures 0 +## cut + +@fog_cloud = [ 1, { 0 => { 1 => [ 1, 1, [ 1 ] ] } } ]; + +## name $VERSION variables get a special exemption. +## failures 0 +## cut + +our $VERSION = 0.21; + +## name Last element of an array gets a special exemption. +## failures 0 +## cut + +$Invid = $nalfeshnee[-1]; + +## name Last element exemption does not work if there is anything else within the subscript. +## failures 1 +## cut + +$warhorse = $Cerberus[-1 * 1]; + +## name Penultimate element of an array does not get a special exemption. +## failures 1 +## cut + +$scorpion = $shadow[-2]; + +## name Decimal zero is allowed even if the configuration specifies that there aren't any allowed literals. +## failures 0 +## parms { allowed_values => '' } +## cut + +$tangle_tree = 0; + +## name Floating-point zero is allowed even if the configuration specifies that there aren't any allowed literals. +## failures 0 +## parms { allowed_values => '' } +## cut + +$xiron_golem = 0.0 + +## name Decimal one is allowed even if the configuration specifies that there aren't any allowed literals. +## failures 0 +## parms { allowed_values => '' } +## cut + +$killer_tomato = 1; + +## name Floating-point one is allowed even if the configuration specifies that there aren't any allowed literals. +## failures 0 +## parms { allowed_values => '' } +## cut + +$witch_doctor = 1.0; + +## name Decimal two is not allowed if the configuration specifies that there aren't any allowed literals. +## failures 1 +## parms { allowed_values => '' } +## cut + +$gold_golem = 2; + +## name Floating-point two is not allowed if the configuration specifies that there aren't any allowed literals. +## failures 1 +## parms { allowed_values => '' } +## cut + +$lich = 2.0; + +## name Decimal zero is allowed even if the configuration doesn't include it in the allowed literals. +## failures 0 +## parms { allowed_values => '3 -5' } +## cut + +$tangle_tree = 0; + +## name Floating-point zero is allowed even if the configuration doesn't include it in the allowed literals. +## failures 0 +## parms { allowed_values => '3 -5' } +## cut + +$xiron_golem = 0.0 + +## name Decimal one is allowed even if the configuration doesn't include it in the allowed literals. +## failures 0 +## parms { allowed_values => '3 -5' } +## cut + +$killer_tomato = 1; + +## name Floating-point one is allowed even if the configuration doesn't include it in the allowed literals. +## failures 0 +## parms { allowed_values => '3 -5' } +## cut + +$witch_doctor = 1.0; + +## name Decimal two is not allowed if the configuration doesn't include it in the allowed literals. +## failures 1 +## parms { allowed_values => '3 -5' } +## cut + +$gold_golem = 2; + +## name Floating-point two is not allowed if the configuration doesn't include it in the allowed literals. +## failures 1 +## parms { allowed_values => '3 -5' } +## cut + +$lich = 2.0; + +## name Decimal three is allowed if the configuration includes it in the allowed literals. +## failures 0 +## parms { allowed_values => '3 -5' } +## cut + +$ghoul = 3; + +## name Floating-point three is allowed if the configuration includes it in the allowed literals. +## failures 0 +## parms { allowed_values => '3 -5' } +## cut + +$water_elemental = 3.0; + +## name Decimal negative five is allowed if the configuration includes it in the allowed literals. +## failures 0 +## parms { allowed_values => '3 -5' } +## cut + +$glass_piercer = -5; + +## name Floating-point negative five is allowed if the configuration includes it in the allowed literals. +## failures 0 +## parms { allowed_values => '3 -5' } +## cut + +$clay_golem = -5.0; + +## name Decimal zero is allowed even if the configuration specifies that there aren't any allowed types. +## failures 0 +## parms { allowed_types => '' } +## cut + +$tangle_tree = 0; + +## name Floating-point zero is not allowed if the configuration specifies that there aren't any allowed types. +## failures 1 +## parms { allowed_types => '' } +## cut + +$xiron_golem = 0.0 + +## name Decimal one is allowed even if the configuration specifies that there aren't any allowed types. +## failures 0 +## parms { allowed_types => '' } +## cut + +$killer_tomato = 1; + +## name Floating-point one is not allowed if the configuration specifies that there aren't any allowed types. +## failures 1 +## parms { allowed_types => '' } +## cut + +$witch_doctor = 1.0; + +## name Decimal zero is allowed if the configuration specifies that there are any allowed types. +## failures 0 +## parms { allowed_types => 'Float' } +## cut + +$tangle_tree = 0; + +## name Floating-point zero is allowed if the configuration specifies that the Float type is allowed. +## failures 0 +## parms { allowed_types => 'Float' } +## cut + +$xiron_golem = 0.0 + +## name Decimal one is allowed if the configuration specifies that there are any allowed types. +## failures 0 +## parms { allowed_types => 'Float' } +## cut + +$killer_tomato = 1; + +## name Floating-point one is allowed if the configuration specifies that the Float type is allowed. +## failures 0 +## parms { allowed_types => 'Float' } +## cut + +$witch_doctor = 1.0; + +## name Binary zero is allowed if the configuration specifies that the Binary type is allowed. +## failures 0 +## parms { allowed_types => 'Binary' } +## cut + +$battlemech = 0b0; + +## name Binary one is allowed if the configuration specifies that the Binary type is allowed. +## failures 0 +## parms { allowed_types => 'Binary' } +## cut + +$xeroc = 0b1; + +## name Exponential zero is allowed if the configuration specifies that the Exp type is allowed. +## failures 0 +## parms { allowed_types => 'Exp' } +## cut + +$Green_elf = 0e0; + +## name Exponential one is allowed if the configuration specifies that the Exp type is allowed. +## failures 0 +## parms { allowed_types => 'Exp' } +## cut + +$Uruk_hai = 1e0; + +## name Hexadecimal zero is allowed if the configuration specifies that the Hex type is allowed. +## failures 0 +## parms { allowed_types => 'Hex' } +## cut + +$yeti = 0x00; + +## name Hexadecimal one is allowed if the configuration specifies that the Hex type is allowed. +## failures 0 +## parms { allowed_types => 'Hex' } +## cut + +$piranha = 0x01; + +## name Octal zero is allowed if the configuration specifies that the Octal type is allowed. +## failures 0 +## parms { allowed_types => 'Octal' } +## cut + +$basilisk = 000; + +## name Octal one is allowed if the configuration specifies that the Octal type is allowed. +## failures 0 +## parms { allowed_types => 'Octal' } +## cut + +$brown_mold = 001; + +## name Any integer value should pass if the allowed values contains 'all_integers'. +## failures 0 +## parms { allowed_values => 'all_integers' } +## cut + +$brogmoid = 356_634_627; +$rat_ant = -29_422; + +## name Any floating-point value without a fractional portion should pass if the allowed values contains 'all_integers'. +## failures 0 +## parms { allowed_values => 'all_integers' } +## cut + +$human = 102_938.0; + +## name A non-integral value should pass if the allowed values contains it and 'all_integers'. +## failures 0 +## parms { allowed_values => 'all_integers 429.73902' } +## cut + +$Norn = 429.73902; + +## name Any binary value should pass if the allowed values contains 'all_integers' and allowed types includes 'Binary'. +## failures 0 +## parms { allowed_values => 'all_integers', allowed_types => 'Binary' } +## cut + +$baby_blue_dragon = 0b01100101_01101010_01110011; + +## name Any hexadecimal value should pass if the allowed values contains 'all_integers' and allowed types includes 'Hex'. +## failures 0 +## parms { allowed_values => 'all_integers', allowed_types => 'Hex' } +## cut + +$killer_bee = 0x656a73; + +## name Any octal value should pass if the allowed values contains 'all_integers' and allowed types includes 'Octal'. +## failures 0 +## parms { allowed_values => 'all_integers', allowed_types => 'Octal' } +## cut + +$ettin_mummy = 0145_152_163; + +## name Zero, one, three, four, and five decimal values should pass if the allowed values contains the '3..5' range. +## failures 0 +## parms { allowed_values => '3..5' } +## cut + +$guide = 0; +$cuatl = 1; +$Master_Assassin = 3; +$orc = 4; +$trapper = 5; + +## name Negative one, two, and six decimal values and fractional values should not pass if the allowed values contains the '3..5' range. +## failures 4 +## parms { allowed_values => '3..5' } +## cut + +$Elvenking = -1; +$brown_pudding = 2; +$archeologist = 6; +$nurse = 4.5; + +## name -3/2, -2/2, -1/2 ... 7/5 should pass if the allowed values contains the '-1.5..3.5:by(0.5)' range. +## failures 0 +## parms { allowed_values => '-1.5..3.5:by(0.5)' } +## cut + +$owlbear = [ -1.5, -1, -.5, 0, 0.5, 1, 1.5, 2, 2.5, 3, 3.5 ]; + +## name Negative two and four should not pass if the allowed values contains the '-1.5..3.5:by(0.5)' range. +## failures 2 +## parms { allowed_values => '-1.5..3.5:by(0.5)' } +## cut + +$lurker_above = [ -2, 4 ]; + +## name -3/2, -1/2, 1/2 ... 7/5, plus 0 and 1 should pass if the allowed values contains the '-1.5..3.5' range. +## failures 0 +## parms { allowed_values => '-1.5..3.5' } +## cut + +$long_worm = [ -1.5, -.5, 0, 0.5, 1, 1.5, 2.5, 3.5 ]; + +## name -3/2, -2/2, -1/2 ... 7/5 should pass if the allowed values contains the '-1.5..3.5' range and 'all_integers'. +## failures 0 +## parms { allowed_values => 'all_integers -1.5..3.5' } +## cut + +$ice_devil = [ -1.5, -1, -.5, 0, 0.5, 1, 1.5, 2, 2.5, 3, 3.5 ]; + +## name -5, -4, -3, -2, 0, 1, 21, 22, 23, and 24 should pass if the allowed values contains the '-5..-2' and '21..24 ranges. +## failures 0 +## parms { allowed_values => '-5..-2 21..24' } +## cut + +$newt = [ -5, -4, -3, -2, 0, 1, 21, 22, 23, 24 ]; + +## name Should pass mini-CPAN accumulated \$VERSION declarations. +## failures 0 +## cut + +(our $VERSION = q$Revision$) =~ s/Revision //; +(our $VERSION) = '$Revision$' =~ /([\d.]+)/; +(our $VERSION) = sprintf "%d", q$Revision$ =~ /Revision:\s+(\S+)/; +our $VERSION : unique = "1.23"; +our $VERSION : unique = '1.23'; +our $VERSION = "$local_variable v1.23"; +our $VERSION = "1." . sprintf "%d", q$Revision$ =~ /: (\d+)/; +our $VERSION = "1.2.3"; +our $VERSION = "1.2.3.0"; +our $VERSION = "1.2.3.blah"; +our $VERSION = "1.23 (liblgrp version $local_variable)"; +our $VERSION = "1.23 2005-05-20"; +our $VERSION = "1.23"; +our $VERSION = "1.23, 2004-12-07"; +our $VERSION = "1.23_blah"; +our $VERSION = "1.23blah"; +our $VERSION = "1.2_3"; +our $VERSION = "123"; +our $VERSION = "INSERT"; +our $VERSION = $SomeOtherModule::VERSION; +our $VERSION = $VERSION = (qw($Revision$))[1]; +our $VERSION = $local_variable; +our $VERSION = '$Date$'; $VERSION =~ s|^\$Date:\s*([0-9]{4})/([0-9]{2})/([0-9]{2})\s.*|\1.\2.\3| ; +our $VERSION = '$Revision$' =~ /\$Revision:\s+([^\s]+)/; +our $VERSION = '$Revision$'; +our $VERSION = '-123 blah'; +our $VERSION = '1.' . qw $Revision$[1]; +our $VERSION = '1.' . sprintf "%d", (qw($Revision$))[1]; +our $VERSION = '1.' . sprintf("%d", (qw($Revision$))[1]); +our $VERSION = '1.2.3'; +our $VERSION = '1.2.3.0'; +our $VERSION = '1.2.3blah'; +our $VERSION = '1.23'; +our $VERSION = '1.23_blah'; +our $VERSION = '1.23blah'; +our $VERSION = '1.2_3'; +our $VERSION = '1.23' || do { q $Revision$ =~ /(\d+)/; sprintf "%4.2f", $1 / 100 }; +our $VERSION = '123'; +our $VERSION = ('$Revision$' =~ /(\d+.\d+)/)[ 0]; +our $VERSION = ('$Revision$' =~ /(\d+\.\d+)/); +our $VERSION = ('$Revision$' =~ m/(\d+)/)[0]; +our $VERSION = ((require SomeOtherModule), $SomeOtherModule::VERSION)[1]; +our $VERSION = (q$Revision$ =~ /([\d\.]+)/); +our $VERSION = (q$Revision$ =~ /(\d+)/g)[0]; +our $VERSION = (qq$Revision$ =~ /(\d+)/)[0]; +our $VERSION = (qw$Revision$)[-1]; +our $VERSION = (qw$Revision$)[1]; +our $VERSION = (qw($Revision$))[1]; +our $VERSION = (split(/ /, '$Revision$'))[1]; +our $VERSION = (split(/ /, '$Revision$'))[2]; +our $VERSION = 1.2.3; +our $VERSION = 1.23; +our $VERSION = 1.2_3; +our $VERSION = 123; +our $VERSION = SomeOtherModule::RCSVersion('$Revision$'); +our $VERSION = SomeOtherModule::VERSION; +our $VERSION = [ qw{ $Revision$ } ]->[1]; +our $VERSION = do { (my $v = q%version: 1.23 %) =~ s/.*://; sprintf("%d.%d", split(/\./, $v), 0) }; +our $VERSION = do { (my $v = q%version: 123 %) =~ s/.*://; sprintf("%d.%d", split(/\./, $v), 0) }; +our $VERSION = do { q $Revision$ =~ /(\d+)/; sprintf "%4.2f", $1 / 100 }; +our $VERSION = do { q$Revision$ =~ /Revision: (\d+)/; sprintf "1.%d", $1; }; +our $VERSION = do { require mod_perl2; $mod_perl2::VERSION }; +our $VERSION = do {(q$URL$=~ m$.*/(?:tags|branches)/([^/ \t]+)$)[0] || "0.0"}; +our $VERSION = eval { require version; version::qv((qw$Revision$)[1] / 1000) }; +our $VERSION = q$0.04$; +our $VERSION = q$Revision$; +our $VERSION = q(0.14); +our $VERSION = qv('1.2.3'); +our $VERSION = qw(1.2.3); +our $VERSION = sprintf "%.02f", $local_variable/100 + 0.3; +our $VERSION = sprintf "%.3f", 123 + substr(q$Revision$, 4)/1000; +our $VERSION = sprintf "%d.%d", '$Revision$' =~ /(\d+)\.(\d+)/; +our $VERSION = sprintf "%d.%d", '$Revision$' =~ /(\d+)/g; +our $VERSION = sprintf "%d.%d", '$Revision$' =~ /(\d+)\.(\d+)/; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ /: (\d+)\.(\d+)/; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ /(\d+)/g; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ /(\d+)\.(\d+)/; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ /(\d+)\.(\d+)/g; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ /: (\d+)\.(\d+)/; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ m/ (\d+) \. (\d+) /xg; +our $VERSION = sprintf "%d.%d", q$Revision$ ~~ m:P5:g/(\d+)/; +our $VERSION = sprintf "%d.%d%d", (split /\D+/, '$Name: beta0_1_1 $')[1..3]; +our $VERSION = sprintf "%s.%s%s", q$Name: Rel-0_90 $ =~ /^Name: Rel-(\d+)_(\d+)(_\d+|)\s*$/, 999, "00", join "", (gmtime)[5] +1900, map {sprintf "%d", $_} (gmtime)[4]+1; +our $VERSION = sprintf "1.%d", '$Revision$' =~ /(\d+)/; +our $VERSION = sprintf "1.%d", q$Revision$ =~ /(\d+)/g; +our $VERSION = sprintf '%d.%d', (q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf '%d.%d', q$Revision$ =~ /(\d+)\.(\d+)/; +our $VERSION = sprintf '%d.%d', q$Revision$ =~ /(\d+)\.(\d+)/; +our $VERSION = sprintf '%s', 'q$Revision$' =~ /\S+\s+(\S+)\s+/ ; +our $VERSION = sprintf '%s', 'q$Revision$' =~ /\S+\s+(\S+)\s+/ ; +our $VERSION = sprintf '%s', q$Revision$ =~ /Revision:\s+(\S+)\s+/ ; +our $VERSION = sprintf '%s', q{$Revision$} =~ /\S+\s+(\S+)/ ; +our $VERSION = sprintf '1.%d', (q$Revision$ =~ /\D(\d+)\s*$/)[0] + 15; +our $VERSION = sprintf("%d", q$Id: SomeModule.pm,v 1.23 2006/04/10 22:39:38 matthew Exp $ =~ /\s(\d+)\s/); +our $VERSION = sprintf("%d", q$Id: SomeModule.pm,v 1.23 2006/04/10 22:39:39 matthew Exp $ =~ /\s(\d+)\s/); +our $VERSION = sprintf("%d.%d", "Revision: 2006.0626" =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d", '$Name: v0_018-2006-06-15b $' =~ /(\d+)_(\d+)/, 0, 0); +our $VERSION = sprintf("%d.%d", 0, q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d", q$Name: REL-0-13 $ =~ /(\d+)-(\d+)/, 999, 99); +our $VERSION = sprintf("%d.%d", q$Name: ical-parser-html-1-6 $ =~ /(\d+)-(\d+)/); +our $VERSION = sprintf("%d.%d", q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d", q$Revision$ =~ /(\d+)\.(\d+)/o); +our $VERSION = sprintf("%d.%d", q$Revision$ =~ m/(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d", q$Revision$=~/(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d", q'$Revision$' =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d.%d", 0, q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf("1.%d", q$Revision$ =~ / (\d+) /); +our $VERSION = sprintf("1.%d", q$Revision$ =~ /(\d+)/); +our $VERSION = sprintf("1.2%d%d", q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf('%d.%d', '$Revision$' =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf('%d.%d', q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf('%d.%d', q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = substr q$Revision$, 10; +our $VERSION = substr(q$Revision$, 10); +our $VERSION = v1.2.3.0; +our $VERSION = v1.2.3; +our $VERSION = v1.23; +our $VERSION = version->new('1.2.3'); +our $VERSION = version->new(qw$Revision$); +our ($PACKAGE, $VERSION) = ('') x 2; +our ($VERSION) = "1.23"; +our ($VERSION) = $SomeOtherModule::VERSION; +our ($VERSION) = '$Revision$' =~ /\$Revision:\s+([^\s]+)/; +our ($VERSION) = '$Revision$' =~ /\$Revision:\s+([^\s]+)/; +our ($VERSION) = '$Revision$' =~ m{ \$Revision: \s+ (\S+) }x; +our ($VERSION) = '$Revision$' =~ m{ \$Revision: \s+ (\S+) }xm; +our ($VERSION) = '$Revision$'=~/(\d+(\.\d+))/; +our ($VERSION) = '$Revision$' =~ m{ \$Revision: \s+ (\S+) }x; +our ($VERSION) = '1.23' =~ /([.,\d]+)/; +our ($VERSION) = '1.23'; +our ($VERSION) = ($local_variable =~ /(\d+\.\d+)/); +our ($VERSION) = ('$Revision$' =~ /(\d+\.\d+)/) ; +our ($VERSION) = ('$Revision$' =~ /(\d+\.\d+)/); +our ($VERSION) = ('$Revision$' =~ m/([\.\d]+)/) ; +our ($VERSION) = (q$Revision$ =~ /([\d\.]+)/); +our ($VERSION) = (qq$Revision$ =~ /(\d+)/)[0]; +our ($VERSION) = 1.23; +our ($VERSION) = q$Revision$ =~ /Revision:\s+(\S+)/ or $VERSION = "1.23"; +our ($VERSION) = q$Revision$ =~ /Revision:\s+(\S+)/ or $VERSION = '1.23'; +our ($VERSION) = q$Revision$ =~ /[\d.]+/g; +our ($VERSION) = q$Revision$ =~ /^Revision:\s+(\S+)/ or $VERSION = "1.23"; +require SomeOtherModule; our $VERSION = $SomeOtherModule::VERSION; +use SomeOtherModule; our $VERSION = $SomeOtherModule::VERSION; +use SomeOtherModule; our $VERSION = SomeOtherModule::VERSION; +use base 'SomeOtherModule'; our $VERSION = $SomeOtherModule::VERSION; +use version; our $VERSION = 1.23; +use version; our $VERSION = qv("1.2.3"); +use version; our $VERSION = qv('1.2.3'); +use version; our $VERSION = qv('1.23'); +use version; our $VERSION = qv((qw$Revision$)[1] / 1000); +use version; our $VERSION = version->new('1.23'); + +## name user-defined constant creators. RT #62562 +## parms { allow_to_the_right_of_a_fat_comma => 0, constant_creator_subroutines => 'blahlahlah' } +## failures 0 +## cut + +blahlahlah my $answer => 42; + +## name allow version as second argument of package. RT #67159 +## failures 0 +## cut + +package Maggot 0.01; + +## name do not allow numbers elsewhere in package statement. RT #67159 +## failures 2 +## cut + +package 42; # Illegal, but check anyway. +package Maggot 0.01 42; + +## name Confusion with numbered regex capture variables (GH #455) +## failures 0 +## cut + +my $x = $13; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/ProhibitMismatchedOperators.run b/t/ValuesAndExpressions/ProhibitMismatchedOperators.run new file mode 100644 index 0000000..6e3ca55 --- /dev/null +++ b/t/ValuesAndExpressions/ProhibitMismatchedOperators.run @@ -0,0 +1,125 @@ +## name Basic passing +## failures 0 +## cut + +if (1 == 1 || 1 != 1 || 1 > 1 || 1 >= 1 || 1 < 1 || 1 <= 1) {} +if (1 + 1 || 1 - 1 || 1 * 1 || 1 / 1) {} + +if ($a == 1 || $a != 1 || $a > 1 || $a >= 1 || $a < 1 || $a <= 1) {} +if ($a + 1 || $a - 1 || $a * 1 || $a / 1) {} +$a += 1; +$a -= 1; +$a *= 1; +$a /= 1; + +if ($a == $a || $a != $a || $a > $a || $a >= $a || $a < $a || $a <= $a) {} +if ($a + $a || $a - $a || $a * $a || $a / $a) {} +$a += $a; +$a -= $a; +$a *= $a; +$a /= $a; + +if ('' eq '' || '' ne '' || '' gt '' || '' lt '' || '' ge '' || '' le '' || '' . '') {} +if ('' eq $a || '' ne $a || '' gt $a || '' lt $a || '' ge $a || '' le $a || '' . $a) {} + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 39 +## cut + +if ('' == 1 || '' != 1 || '' > 1 || '' >= 1 || '' < 1 || '' <= 1) {} +if ('' + 1 || '' - 1 || '' * 1 || '' / 1) {} + +if ($a == '' || $a != '' || $a > '' || $a >= '' || $a < '' || $a <= '') {} +if ($a + '' || $a - '' || $a * '' || $a / '') {} +$a += ''; +$a -= ''; +$a *= ''; +$a /= ''; + +if ($a eq 1 || $a ne 1 || $a lt 1 || $a gt 1 || $a le 1 || $a ge 1 || $a . 1) {} +if ('' eq 1 || '' ne 1 || '' lt 1 || '' gt 1 || '' le 1 || '' ge 1 || '' . 1) {} +$a .= 1; + +#----------------------------------------------------------------------------- + +## name 'foo' x 15 x 'bar' is OK ( RT #54524 ) +## failures 0 +## cut + +'foo' x 15 . 'bar'; +( 'foo' . ' ' ) x 15 . 'bar'; +@foo x 15 . 'bar'; +( 1, 2, 5 ) x 15 . 'bar'; + +#----------------------------------------------------------------------------- + +## name File operators passing +## failures 0 +## cut + +-M 'file' > 0; +-r 'file' < 1; +-w 'file' != 1; +-x 'file' == 0; +-o 'file' == 1234; +-R 'file' != 3210; +-W 'file' == 4321; +-X 'file' != 5678; +-O 'file' == 9876l; +-e 'file' == 1 && -z 'file'; +-s 'file' / 1024; +-f 'file' == 1 && -d 'file' != 1; +-l 'file' && !-p 'file'; +-S 'file' == 1 && -b 'file' != 1; +-c 'file' + 1; +-t 'file' > 1; +-u 'file' * 123; +-g 'file' != 1; +-k 'file' - -T 'file'; +-B 'file' < 1; +-M 'file' + -A 'file'; +(-M 'file') > 0 || -M 'file' > 0; + +#----------------------------------------------------------------------------- + +## name File operators failure +## failures 25 +## cut + +-M 'file' gt "0"; +-r 'file' lt "1"; +-w 'file' ne "1"; +-x 'file' eq "0"; +-o 'file' eq "1234"; +-R 'file' ne "3210"; +-W 'file' eq "4321"; +-X 'file' ne "5678"; +-O 'file' eq "9876l"; +-e 'file' eq "1"; +-z 'file' ne "1"; +-s 'file' eq "1024"; +-f 'file' eq "1"; +-d 'file' ne "1"; +-l 'file' eq "1"; +-S 'file' eq "1"; +-b 'file' ne "1"; +-c 'file' eq "1"; +-t 'file' gt "1"; +-u 'file' eq "123"; +-g 'file' ne "1"; +-k 'file' eq "1"; +-T 'file' ne "1"; +-B 'file' lt "1"; +-A 'file' eq "1"; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/ProhibitMixedBooleanOperators.run b/t/ValuesAndExpressions/ProhibitMixedBooleanOperators.run new file mode 100644 index 0000000..3cf2c4e --- /dev/null +++ b/t/ValuesAndExpressions/ProhibitMixedBooleanOperators.run @@ -0,0 +1,86 @@ +## name High-precedence passing +## failures 0 +## cut + +next if ! $finished || $foo < $bar; +if( $foo && !$bar || $baz){ do_something() } +this() && !that() || the_other(); + +#----------------------------------------------------------------------------- + +## name Low-precedence passing +## failures 0 +## cut + +next if not $finished or $foo < $bar; +if( $foo and not $bar or $baz){ do_something() } +this() and not that() or the_other(); + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 3 +## cut + +next if not $finished || $foo < $bar; +if( $foo && not $bar or $baz){ do_something() } +this() and ! that() or the_other(); + +#----------------------------------------------------------------------------- + +## name High-precedence with low precedence self-equals +## failures 0 +## cut + +$sub ||= sub { + return 1 and 2; +}; + +#----------------------------------------------------------------------------- + +## name Mixed booleans in same statement, but different expressions +## failures 0 +## cut + +# See http://rt.cpan.org/Ticket/Display.html?id=27637 +ok( ! 1, 'values are URLs' ) or diag 'never happens'; + +#----------------------------------------------------------------------------- + +## name Mixed booleans in code blocks +## failures 0 +## cut + +eval { + if (1 || 2) { + return not 3; + } +}; + +#----------------------------------------------------------------------------- + +## name Mixed booleans with ||= and &&= operators (https://github.com/adamkennedy/PPI/issues/74) +## failures 2 +## cut + +$foo ||= $this or $that; +$foo &&= $this or $that; + +#----------------------------------------------------------------------------- + +## name With a postfix control (GH #496) +## TODO need to treat left and right sides separately +## failures 0 +## cut + +$value ||= 1 if 1 and 1; + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/ProhibitNoisyQuotes.run b/t/ValuesAndExpressions/ProhibitNoisyQuotes.run new file mode 100644 index 0000000..885644c --- /dev/null +++ b/t/ValuesAndExpressions/ProhibitNoisyQuotes.run @@ -0,0 +1,77 @@ +## name Basic passing +## failures 0 +## cut + +$var = q{'}; +$var = q{"}; +$var = q{!!}; +$var = q{||}; +$var = "!!!"; +$var = '!!!'; +$var = 'a'; +$var = "a"; +$var = '1'; +$var = "1"; + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 4 +## cut + +$var = "!"; +$var = '!'; +$var = '!!'; +$var = "||"; + +#----------------------------------------------------------------------------- + +## name overload pragma +## failures 0 +## cut + +use overload '""'; + +#----------------------------------------------------------------------------- + +## name Parentheses, braces, brackets +## failures 0 +## cut + +$var = '('; +$var = ')'; +$var = '{'; +$var = '}'; +$var = '['; +$var = ']'; + +$var = '{('; +$var = ')}'; +$var = '[{'; +$var = '[}'; +$var = '[('; +$var = '])'; + +$var = "("; +$var = ")"; +$var = "{"; +$var = "}"; +$var = "["; +$var = "]"; + +$var = "{("; +$var = ")]"; +$var = "({"; +$var = "}]"; +$var = "{["; +$var = "]}"; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/ProhibitQuotesAsQuotelikeOperatorDelimiters.run b/t/ValuesAndExpressions/ProhibitQuotesAsQuotelikeOperatorDelimiters.run new file mode 100644 index 0000000..b59e92b --- /dev/null +++ b/t/ValuesAndExpressions/ProhibitQuotesAsQuotelikeOperatorDelimiters.run @@ -0,0 +1,173 @@ +## name Basic passing +## failures 0 +## cut + +$x = q{}; +$x = qq{}; +$x = qx{}; +$x = qr{}; +$x = qw{}; + +$x =~ //; +$x =~ m{}; +$x =~ s{}{}; +$x =~ tr{}{}; +$x =~ y{}{}; + +$x = qx''; +$x = qr''; + +$x =~ m''; +$x =~ s'''; + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 23 +## cut + +$x = q''; +$x = qq''; +$x = qw''; + +$x =~ tr'''; +$x =~ y'''; + +$x = q""; +$x = qq""; +$x = qx""; +$x = qr""; +$x = qw""; + +$x =~ m""; +$x =~ s"""; +$x =~ tr"""; +$x =~ y"""; + +$x = q``; +$x = qq``; +$x = qx``; +$x = qr``; +$x = qw``; + +$x =~ m``; +$x =~ s```; +$x =~ tr```; +$x =~ y```; + +#----------------------------------------------------------------------------- + +## name single_quote_allowed_operators = m q qq qr qw qx s tr y +## failures 0 +## parms { single_quote_allowed_operators => 'm q qq qr qw qx s tr y' } +## cut + +$x = q''; +$x = qq''; +$x = qx''; +$x = qr''; +$x = qw''; + +$x =~ m''; +$x =~ s'''; +$x =~ tr'''; +$x =~ y'''; + +#----------------------------------------------------------------------------- + +## name single_quote_allowed_operators = +## failures 9 +## parms { single_quote_allowed_operators => '' } +## cut + +$x = q''; +$x = qq''; +$x = qx''; +$x = qr''; +$x = qw''; + +$x =~ m''; +$x =~ s'''; +$x =~ tr'''; +$x =~ y'''; + +#----------------------------------------------------------------------------- + +## name double_quote_allowed_operators = m q qq qr qw qx s tr y +## failures 0 +## parms { double_quote_allowed_operators => 'm q qq qr qw qx s tr y' } +## cut + +$x = q""; +$x = qq""; +$x = qx""; +$x = qr""; +$x = qw""; + +$x =~ m""; +$x =~ s"""; +$x =~ tr"""; +$x =~ y"""; + +#----------------------------------------------------------------------------- + +## name double_quote_allowed_operators = +## failures 9 +## parms { double_quote_allowed_operators => '' } +## cut + +$x = q""; +$x = qq""; +$x = qx""; +$x = qr""; +$x = qw""; + +$x =~ m""; +$x =~ s"""; +$x =~ tr"""; +$x =~ y"""; + +#----------------------------------------------------------------------------- + +## name back_quote_allowed_operators = m q qq qr qw qx s tr y +## failures 0 +## parms { back_quote_allowed_operators => 'm q qq qr qw qx s tr y' } +## cut + +$x = q``; +$x = qq``; +$x = qx``; +$x = qr``; +$x = qw``; + +$x =~ m``; +$x =~ s```; +$x =~ tr```; +$x =~ y```; + +#----------------------------------------------------------------------------- + +## name back_quote_allowed_operators = +## failures 9 +## parms { back_quote_allowed_operators => '' } +## cut + +$x = q``; +$x = qq``; +$x = qx``; +$x = qr``; +$x = qw``; + +$x =~ m``; +$x =~ s```; +$x =~ tr```; +$x =~ y```; + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/ProhibitSpecialLiteralHeredocTerminator.run b/t/ValuesAndExpressions/ProhibitSpecialLiteralHeredocTerminator.run new file mode 100644 index 0000000..826ff40 --- /dev/null +++ b/t/ValuesAndExpressions/ProhibitSpecialLiteralHeredocTerminator.run @@ -0,0 +1,132 @@ +## name Basic failures +## failures 5 +## cut + +print <<__END__; +All language designers are arrogant. Goes with the territory... :-) +--Larry Wall in <1991Jul13.010945.19157@netlabs.com> +__END__ + +print <<__PACKAGE__; +#else /* !STDSTDIO */ /* The big, slow, and stupid way */ +--Larry Wall in str.c from the perl source code +__PACKAGE__ + +print <<__LINE__; +Does the same as the system call of that name. +If you don't know what it does, don't worry about it. +--Larry Wall in the perl man page regarding chroot(2) +__LINE__ + +print <<__FILE__; +When in doubt, parenthesize. At the very least it will let some +poor schmuck bounce on the % key in vi. +--Larry Wall in the perl man page +__FILE__ + +print <<__DATA__; +: I've tried (in vi) "g/[a-z]\n[a-z]/s//_/"...but that doesn't +: cut it. Any ideas? (I take it that it may be a two-pass sort of solution). +In the first pass, install perl. :-) + +--- Larry Wall <6849@jpl-devvax.JPL.NASA.GOV> +__DATA__ + +## name Basic failures with indented heredocs +## failures 5 +## cut + + +print <<~__END__; + All language designers are arrogant. Goes with the territory... :-) + --Larry Wall in <1991Jul13.010945.19157@netlabs.com> + __END__ + +print <<~__PACKAGE__; + #else /* !STDSTDIO */ /* The big, slow, and stupid way */ + --Larry Wall in str.c from the perl source code + __PACKAGE__ + +print <<~__LINE__; + Does the same as the system call of that name. + If you don't know what it does, don't worry about it. + --Larry Wall in the perl man page regarding chroot(2) + __LINE__ + +print <<~__FILE__; + When in doubt, parenthesize. At the very least it will let some + poor schmuck bounce on the % key in vi. + --Larry Wall in the perl man page + __FILE__ + +print <<~__DATA__; + : I've tried (in vi) "g/[a-z]\n[a-z]/s//_/"...but that doesn't + : cut it. Any ideas? (I take it that it may be a two-pass sort of solution). + In the first pass, install perl. :-) + + --- Larry Wall <6849@jpl-devvax.JPL.NASA.GOV> + __DATA__ + + +#----------------------------------------------------------------------------- + +## name failures with quotes +## failures 2 +## cut + +print <<"__END__"; +If you want your program to be readable, consider supplying the argument. +--Larry Wall in the perl man page +__END__ + +print <<'__END__'; +In general, if you think something isn't in Perl, try it out, because it +usually is. :-) +--Larry Wall in <1991Jul31.174523.9447@netlabs.com> +__END__ + +## name failures with quotes and indented heredocs +## failures 2 +## cut + +print <<~"__END__"; + If you want your program to be readable, consider supplying the argument. + --Larry Wall in the perl man page + __END__ + +print <<~'__END__'; + In general, if you think something isn't in Perl, try it out, because it + usually is. :-) + --Larry Wall in <1991Jul31.174523.9447@netlabs.com> + __END__ + + +## name outside the scope of this policy +## failures 0 +## cut + +print <<__end__; +OOPS! You naughty creature! You didn't run Configure with sh! +I will attempt to remedy the situation by running sh for you... +--Larry Wall in Configure from the perl distribution +__end__ + +## name outside the scope of this policy with indented heredocs +## failures 0 +## cut + +print <<~__end__; + OOPS! You naughty creature! You didn't run Configure with sh! + I will attempt to remedy the situation by running sh for you... + --Larry Wall in Configure from the perl distribution + __end__ + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/ProhibitVersionStrings.run b/t/ValuesAndExpressions/ProhibitVersionStrings.run new file mode 100644 index 0000000..55d836a --- /dev/null +++ b/t/ValuesAndExpressions/ProhibitVersionStrings.run @@ -0,0 +1,65 @@ +## name Basic passing +## failures 0 +## cut + +use 5.006_001; +require 5.006_001; + +use Foo 1.0203; +require Foo 1.0203; + +use Foo 1.0203 qw(foo bar); +require Foo 1.0203 qw(foo bar); + +is( pcritique($policy, \$code), 0, $policy); + +use lib '/usr/lib/perl5/vendor_perl/5.8.8'; # RT #30388 + +#----------------------------------------------------------------------------- + +## name use failure +## failures 7 +## cut + +use 5.6.1; +use v5.6.1; +use Foo 1.2.3; +use Foo v1.2.3; +use Foo 1.2.3 qw(foo bar); +use Foo v1.2.3 qw(foo bar); +use Foo v1.2.3 ('foo', 'bar'); + +#----------------------------------------------------------------------------- + +## name require failure +## failures 7 +## cut + +require 5.6.1; +require v5.6.1; +require Foo 1.2.3; +require Foo v1.2.3; +require Foo 1.2.3 qw(foo bar); +require Foo v1.2.3 qw(foo bar); +require Foo v1.2.3 ('foo', 'bar'); + +#----------------------------------------------------------------------------- + +## name embedded comment - RT 44986 +## failures 0 +## cut + +use Foo::Bar xyzzy => 1; +use Foo::Bar +# With Foo::Bar 1.2.3 we can use the 'plugh' option. +plugh => 1; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/RequireConstantVersion.run b/t/ValuesAndExpressions/RequireConstantVersion.run new file mode 100644 index 0000000..e3ed681 --- /dev/null +++ b/t/ValuesAndExpressions/RequireConstantVersion.run @@ -0,0 +1,295 @@ +## name basic passes +## failures 0 +## cut + +our $VERSION = 2.718; +our $VERSION = $VERSION = 2.718; +$VERSION = '3.14159'; +$VERSION = "3.14159"; +$VERSION = "foo\$bar"; +our $VERSION = q{1.618}; +our $VERSION = qq{1.618}; +use version; $VERSION = qv('1.2.3'); +use version; $VERSION = qv("1.2.3"); +# The following from ExtUtils::MakeMaker +(our $Revision = $VERSION) =~ s{_}{}; + +#----------------------------------------------------------------------------- + +## name basic failures +## failures 7 +## cut + +our $VERSION = "$foo"; +our $VERSION = eval $VERSION; +our $VERSION = qq{foo\\$bar}; +our ( $VERSION ) = q$REVISION: 42$ =~ m/(\d+)/; +( $VERSION = '$REVISION: 42$' ) =~ s/.*\s+(\d+).*/$1/; +use Foo; $VERSION = $Foo::VERSION; +use version; $VERSION = qv("1.$foo.3"); + +#----------------------------------------------------------------------------- + +## name require 'use version' before qv() +## failures 1 +## cut + +$VERSION = qv('1.2.3'); + +#----------------------------------------------------------------------------- + +## name require 'use version' before version->new() +## failures 1 +## cut + +$VERSION = version->new('1.2.3'); + +#----------------------------------------------------------------------------- + +## name passes involving other assignment operators +## failures 0 +## cut + +our $VERSION ||= 1.23; +our $VERSION ||= '1.23'; +our $VERSION ||= "1.23"; +use version; our $VERSION = version->new('1.2.3'); + +#----------------------------------------------------------------------------- + +## name failures involving other assignment operators +## failures 4 +## cut + +our $VERSION ||= qw{$Revision 42 $}[1]; +our $VERSION ||= $Foo::VERSION; +our $VERSION ||= "$Foo::VERSION"; +our $VERSION ||= version->new('1.2.3'); + +#----------------------------------------------------------------------------- + +## name passes from the ProhibitMagicNumbers.run treasury +## failures 0 +## cut + +our $VERSION : unique = "1.23"; +our $VERSION : unique = '1.23'; +our $VERSION = "1.2.3"; +our $VERSION = "1.2.3.0"; +our $VERSION = "1.2.3.blah"; +our $VERSION = "1.23 2005-05-20"; +our $VERSION = "1.23"; +our $VERSION = "1.23, 2004-12-07"; +our $VERSION = "1.23_blah"; +our $VERSION = "1.23blah"; +our $VERSION = "1.2_3"; +our $VERSION = "123"; +our $VERSION = "INSERT"; +our $VERSION = '$Revision$'; +our $VERSION = '-123 blah'; +our $VERSION = '1.2.3'; +our $VERSION = '1.2.3.0'; +our $VERSION = '1.2.3blah'; +our $VERSION = '1.23'; +our $VERSION = '1.23_blah'; +our $VERSION = '1.23blah'; +our $VERSION = '1.2_3'; +our $VERSION = '123'; +our $VERSION = 1.23; +our $VERSION = 1.2_3; +our $VERSION = 123; +our $VERSION = q$0.04$; +our $VERSION = q$Revision$; +our $VERSION = q(0.14); +# Should the following be allowed? I am not sure I really know what qv() means +# without the 'use version;'. +# our $VERSION = qv('1.2.3'); +# Hmmm - this is not technically a violation +our $VERSION = qw(1.2.3); +# Should the following be allowed? I am not sure I really know what +# version->new() means without the 'use version;'. +# our $VERSION = version->new('1.2.3'); +# our $VERSION = version->new(qw$Revision$); +our ($VERSION) = "1.23"; +our ($VERSION) = '1.23'; +our ($VERSION) = 1.23; +use version; our $VERSION = 1.23; +use version; our $VERSION = qv("1.2.3"); +use version; our $VERSION = qv('1.2.3'); +use version; our $VERSION = qv('1.23'); +use version; our $VERSION = version->new('1.23'); +# V-strings are deprecated, but ... +our $VERSION = 1.2.3; +our $VERSION = v1.2.3.0; +our $VERSION = v1.2.3; +our $VERSION = v1.23; + +#----------------------------------------------------------------------------- + +## name failures from the ProhibitMagicNumbers.run treasury +## failures 109 +## cut + +(our $VERSION = q$Revision$) =~ s/Revision //; +(our $VERSION) = '$Revision$' =~ /([\d.]+)/; +(our $VERSION) = sprintf "%d", q$Revision$ =~ /Revision:\s+(\S+)/; +our $VERSION = "$local_variable v1.23"; +our $VERSION = "1." . sprintf "%d", q$Revision$ =~ /: (\d+)/; +our $VERSION = "1.23 (liblgrp version $local_variable)"; +our $VERSION = $SomeOtherModule::VERSION; +# Technically the following is a constant, but it is also one of the things +# the policy is designed to prevent. +our $VERSION = $VERSION = (qw($Revision$))[1]; +our $VERSION = $local_variable; +our $VERSION = '$Date$'; $VERSION =~ s|^\$Date:\s*([0-9]{4})/([0-9]{2})/([0-9]{2})\s.*|\1.\2.\3| ; +our $VERSION = '$Revision$' =~ /\$Revision:\s+([^\s]+)/; +our $VERSION = '1.' . qw $Revision$[1]; +our $VERSION = '1.' . sprintf "%d", (qw($Revision$))[1]; +our $VERSION = '1.' . sprintf("%d", (qw($Revision$))[1]); +# In practice the following is a constant, but if someone goes this far out of +# their way to obfuscate a constant, I for one am not going to dissapoint +# them. +our $VERSION = '1.23' || do { q $Revision$ =~ /(\d+)/; sprintf "%4.2f", $1 / 100 }; +our $VERSION = ('$Revision$' =~ /(\d+.\d+)/)[ 0]; +our $VERSION = ('$Revision$' =~ /(\d+\.\d+)/); +our $VERSION = ('$Revision$' =~ m/(\d+)/)[0]; +our $VERSION = ((require SomeOtherModule), $SomeOtherModule::VERSION)[1]; +our $VERSION = (q$Revision$ =~ /([\d\.]+)/); +our $VERSION = (q$Revision$ =~ /(\d+)/g)[0]; +our $VERSION = (qq$Revision$ =~ /(\d+)/)[0]; +our $VERSION = (qw$Revision$)[-1]; +our $VERSION = (qw$Revision$)[1]; +our $VERSION = (qw($Revision$))[1]; +our $VERSION = (split(/ /, '$Revision$'))[1]; +our $VERSION = (split(/ /, '$Revision$'))[2]; +our $VERSION = SomeOtherModule::RCSVersion('$Revision$'); +our $VERSION = SomeOtherModule::VERSION; +our $VERSION = [ qw{ $Revision$ } ]->[1]; +our $VERSION = do { (my $v = q%version: 1.23 %) =~ s/.*://; sprintf("%d.%d", split(/\./, $v), 0) }; +our $VERSION = do { (my $v = q%version: 123 %) =~ s/.*://; sprintf("%d.%d", split(/\./, $v), 0) }; +our $VERSION = do { q $Revision$ =~ /(\d+)/; sprintf "%4.2f", $1 / 100 }; +our $VERSION = do { q$Revision$ =~ /Revision: (\d+)/; sprintf "1.%d", $1; }; +our $VERSION = do { require mod_perl2; $mod_perl2::VERSION }; +our $VERSION = do {(q$URL$=~ m$.*/(?:tags|branches)/([^/ \t]+)$)[0] || "0.0"}; +our $VERSION = eval { require version; version::qv((qw$Revision$)[1] / 1000) }; +# Should the following be allowed? I really don't know what 'qv' means without +# the leading 'use version;'. +our $VERSION = qv('1.2.3'); +our $VERSION = sprintf "%.02f", $local_variable/100 + 0.3; +our $VERSION = sprintf "%.3f", 123 + substr(q$Revision$, 4)/1000; +our $VERSION = sprintf "%d.%d", '$Revision$' =~ /(\d+)\.(\d+)/; +our $VERSION = sprintf "%d.%d", '$Revision$' =~ /(\d+)/g; +our $VERSION = sprintf "%d.%d", '$Revision$' =~ /(\d+)\.(\d+)/; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ /: (\d+)\.(\d+)/; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ /(\d+)/g; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ /(\d+)\.(\d+)/; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ /(\d+)\.(\d+)/g; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ /: (\d+)\.(\d+)/; +our $VERSION = sprintf "%d.%d", q$Revision$ =~ m/ (\d+) \. (\d+) /xg; +our $VERSION = sprintf "%d.%d", q$Revision$ ~~ m:P5:g/(\d+)/; +our $VERSION = sprintf "%d.%d%d", (split /\D+/, '$Name: beta0_1_1 $')[1..3]; +our $VERSION = sprintf "%s.%s%s", q$Name: Rel-0_90 $ =~ /^Name: Rel-(\d+)_(\d+)(_\d+|)\s*$/, 999, "00", join "", (gmtime)[5] +1900, map {sprintf "%d", $_} (gmtime)[4]+1; +our $VERSION = sprintf "1.%d", '$Revision$' =~ /(\d+)/; +our $VERSION = sprintf "1.%d", q$Revision$ =~ /(\d+)/g; +our $VERSION = sprintf '%d.%d', (q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf '%d.%d', q$Revision$ =~ /(\d+)\.(\d+)/; +our $VERSION = sprintf '%d.%d', q$Revision$ =~ /(\d+)\.(\d+)/; +our $VERSION = sprintf '%s', 'q$Revision$' =~ /\S+\s+(\S+)\s+/ ; +our $VERSION = sprintf '%s', 'q$Revision$' =~ /\S+\s+(\S+)\s+/ ; +our $VERSION = sprintf '%s', q$Revision$ =~ /Revision:\s+(\S+)\s+/ ; +our $VERSION = sprintf '%s', q{$Revision$} =~ /\S+\s+(\S+)/ ; +our $VERSION = sprintf '1.%d', (q$Revision$ =~ /\D(\d+)\s*$/)[0] + 15; +our $VERSION = sprintf("%d", q$Id: SomeModule.pm,v 1.23 2006/04/10 22:39:38 matthew Exp $ =~ /\s(\d+)\s/); +our $VERSION = sprintf("%d", q$Id: SomeModule.pm,v 1.23 2006/04/10 22:39:39 matthew Exp $ =~ /\s(\d+)\s/); +our $VERSION = sprintf("%d.%d", "Revision: 2006.0626" =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d", '$Name: v0_018-2006-06-15b $' =~ /(\d+)_(\d+)/, 0, 0); +our $VERSION = sprintf("%d.%d", 0, q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d", q$Name: REL-0-13 $ =~ /(\d+)-(\d+)/, 999, 99); +our $VERSION = sprintf("%d.%d", q$Name: ical-parser-html-1-6 $ =~ /(\d+)-(\d+)/); +our $VERSION = sprintf("%d.%d", q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d", q$Revision$ =~ /(\d+)\.(\d+)/o); +our $VERSION = sprintf("%d.%d", q$Revision$ =~ m/(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d", q$Revision$=~/(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d", q'$Revision$' =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf("%d.%d.%d", 0, q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf("1.%d", q$Revision$ =~ / (\d+) /); +our $VERSION = sprintf("1.%d", q$Revision$ =~ /(\d+)/); +our $VERSION = sprintf("1.2%d%d", q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf('%d.%d', '$Revision$' =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf('%d.%d', q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = sprintf('%d.%d', q$Revision$ =~ /(\d+)\.(\d+)/); +our $VERSION = substr q$Revision$, 10; +our $VERSION = substr(q$Revision$, 10); +# Initially at least this is a violation simply because of the hoops that need +# to be jumped through to make it work. +our ($PACKAGE, $VERSION) = ('') x 2; +# Should the following be allowed? I am not sure I really know what +# version->new() means without the leading 'use version;'. +our $VERSION = version->new('1.2.3'); +our $VERSION = version->new(qw$Revision$); +our ($VERSION) = $SomeOtherModule::VERSION; +our ($VERSION) = '$Revision$' =~ /\$Revision:\s+([^\s]+)/; +our ($VERSION) = '$Revision$' =~ /\$Revision:\s+([^\s]+)/; +our ($VERSION) = '$Revision$' =~ m{ \$Revision: \s+ (\S+) }x; +our ($VERSION) = '$Revision$' =~ m{ \$Revision: \s+ (\S+) }xm; +our ($VERSION) = '$Revision$'=~/(\d+(\.\d+))/; +our ($VERSION) = '$Revision$' =~ m{ \$Revision: \s+ (\S+) }x; +# Another case of a constant so obfuscated as to perhaps not be worth the +# analysis to straighten it out. +our ($VERSION) = '1.23' =~ /([.,\d]+)/; +our ($VERSION) = ($local_variable =~ /(\d+\.\d+)/); +our ($VERSION) = ('$Revision$' =~ /(\d+\.\d+)/) ; +our ($VERSION) = ('$Revision$' =~ /(\d+\.\d+)/); +our ($VERSION) = ('$Revision$' =~ m/([\.\d]+)/) ; +our ($VERSION) = (q$Revision$ =~ /([\d\.]+)/); +our ($VERSION) = (qq$Revision$ =~ /(\d+)/)[0]; +our ($VERSION) = q$Revision$ =~ /Revision:\s+(\S+)/ or $VERSION = "1.23"; +our ($VERSION) = q$Revision$ =~ /Revision:\s+(\S+)/ or $VERSION = '1.23'; +our ($VERSION) = q$Revision$ =~ /[\d.]+/g; +our ($VERSION) = q$Revision$ =~ /^Revision:\s+(\S+)/ or $VERSION = "1.23"; +require SomeOtherModule; our $VERSION = $SomeOtherModule::VERSION; +use SomeOtherModule; our $VERSION = $SomeOtherModule::VERSION; +use SomeOtherModule; our $VERSION = SomeOtherModule::VERSION; +use base 'SomeOtherModule'; our $VERSION = $SomeOtherModule::VERSION; +use version; our $VERSION = qv((qw$Revision$)[1] / 1000); + +#----------------------------------------------------------------------------- + +## name version-like things are OK without 'use version;' if explicitly allowed +## failures 0 +## parms { allow_version_without_use_on_same_line => '1' } +## cut + +our $VERSION = qv('1.2.3'); +our $VERSION = version->new('1.2.3'); +our $VERSION = version->new(qw$Revision$); + +#----------------------------------------------------------------------------- + +## name RT #55600 ( $bar = sprintf '%s', $VERSION ) =~ s/0// false positive +## failures 0 +## cut + +# This is cut-and-paste directly from the RT ticket. I did not make it up. +(my $BAR = sprintf q{%s/%s}, __PACKAGE__, $VERSION) =~ s{o\z}{}xms; + +# The following were not issues raised in the ticket, but ought to pass as a +# result of the work done for the ticket. + +( my $BAR = ___PACKAGE__ . '/' . $VERSION ) =~ s{ o \z }{}xms; +( my $BAR = join '/', __PACKAGE__, $VERSION ) =~ s{ o \z }{}xms; + +# In fact, the following should pass also, though I can't imagine why anyone +# would do it. + +sprintf( q{%s/%s}, __PACKAGE__, $VERSION ) =~ s{ o \z }{}xms; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/RequireInterpolationOfMetachars.run b/t/ValuesAndExpressions/RequireInterpolationOfMetachars.run new file mode 100644 index 0000000..578dee0 --- /dev/null +++ b/t/ValuesAndExpressions/RequireInterpolationOfMetachars.run @@ -0,0 +1,316 @@ +## name Basic passing. +## failures 0 +## cut + +print "this is not $literal"; +print qq{this is not $literal}; +print "this is not literal\n"; +print qq{this is not literal\n}; + +#----------------------------------------------------------------------------- + +## name Basic failure. +## failures 5 +## cut + +print 'this is not $literal'; +print q{this is not $literal}; +print 'this is not literal\n'; +print q{this is not literal\n}; +print 'this is not @literal'; + +#----------------------------------------------------------------------------- + +## name Failure of simple scalar variables. +## failures 1 +## cut + +print '$blah'; + +#----------------------------------------------------------------------------- + +## name Failure of simple array variables. +## failures 1 +## cut + +print '@blah'; + +#----------------------------------------------------------------------------- + +## name Failure of common punctuation variables. +## failures 4 +## cut + +print '$_'; +print '@_'; +print '$@'; +print '$!'; + +#----------------------------------------------------------------------------- + +## name Failure of @+ & @-. +## failures 2 +## cut + +print '@+'; +print '@-'; + +#----------------------------------------------------------------------------- + +## name Failure of @^H. +## failures 1 +## cut + +print '@^H'; + +#----------------------------------------------------------------------------- + +## name Readonly constant from Modules::ProhibitAutomaticExportation. +## failures 1 +## cut + +Readonly::Scalar my $EXPL => q{Use '@EXPORT_OK' or '%EXPORT_TAGS' instead}; + +#----------------------------------------------------------------------------- + +## name OK to escape backslashes. +## failures 0 +## cut + +print 'it is ok to escape a backslash: \\t' +print q{it is ok to escape a backslash: \\t} +print 'you can do it multiple times: \\\\\\t' +print q{you can do it multiple times: \\\\\\t} + +#----------------------------------------------------------------------------- + +## name OK to escape quotes. +## failures 0 +## cut + +print 'you can also escape a quote: \'' +print q{you can also escape a quote: \'} +print 'you can escape a quote preceded by backslashes: \\\\\'' +print q{you can escape a quote preceded by backslashes: \\\\\'} + +#----------------------------------------------------------------------------- + +## name Valid escapes should not hide invalid ones. +## failures 4 +## cut + +print 'it is ok to escape a backslash: \\t but not a tee: \t' +print q{it is ok to escape a backslash: \\t but not a tee: \t} +print 'you can also escape a quote: \' but not a tee: \t' +print q{you can also escape a quote: \' but not a tee: \t} + +#----------------------------------------------------------------------------- + +## name Sigil characters not looking like sigils. +## failures 0 +## cut + +$sigil_at_end_of_word = 'list@ scalar$'; +$sigil_at_end_of_word = 'scalar$ list@'; +$sigil_at_end_of_word = q(list@ scalar$); +$sigil_at_end_of_word = q(scalar$ list@); +%options = ( 'foo=s@' => \@foo); #Like with Getopt::Long +%options = ( q{foo=s@} => \@foo); #Like with Getopt::Long +$sigil_as_delimiter = q$blah$; +$sigil_as_delimiter = q $blah$; +$sigil_as_delimiter = q@blah@; +$sigil_as_delimiter = q @blah@; + +#----------------------------------------------------------------------------- + +## name Do complain about RCS variables, if not turned on. +## failures 7 +## cut + +$VERSION = q<$Revision$>; +($VERSION) = q<$Revision$> =~ m/(\d+)/mx; +our $VERSION = substr(q/$Revision$/, 10); +our ($VERSION) = q<$Revision$> =~ m/(\d+)/mx; +our ($VERSION) = (q<$Revision$> =~ m/(\d+)/mx); +our (undef, $AUTHOR, undef, undef, $VERSION) = split m/\s+/, q<$Author$ $Revision$>; + +# Yes, silly example, but still need to check it. +if ( ($VERSION) = q<$Revision$> =~ m/(\d+)/mx ) {} + +#----------------------------------------------------------------------------- + +## name Don't complain about RCS variables, if turned on. +## failures 0 +## parms { rcs_keywords => 'Revision Author' } +## cut + +$VERSION = q<$Revision$>; +($VERSION) = q<$Revision$> =~ m/(\d+)/mx; +our $VERSION = substr(q/$Revision$/, 10); +our ($VERSION) = q<$Revision$> =~ m/(\d+)/mx; +our ($VERSION) = (q<$Revision$> =~ m/(\d+)/mx); +our (undef, $AUTHOR, undef, undef, $VERSION) = split m/\s+/, q<$Author$ $Revision$>; + +# Yes, silly example, but still need to check it. +if ( ($VERSION) = q<$Revision$> =~ m/(\d+)/mx ) {} + +#----------------------------------------------------------------------------- + +## name Don't complain about '${}' and '@{}' because they're invalid syntax. See RT #38528/commit r3077 for original problem/solution. +## failures 0 +## cut + +use Blah '${}' => \&scalar_deref; +use Blah '@{}' => \&array_deref; +use Blah '%{}' => \&hash_deref; +use Blah '&{}' => \&code_deref; +use Blah '*{}' => \&glob_deref; +use Blah ('${}' => \&scalar_deref); +use Blah ('@{}' => \&array_deref); +use Blah ('%{}' => \&hash_deref); +use Blah ('&{}' => \&code_deref); +use Blah ('*{}' => \&glob_deref); +use Blah 1.0 ('${}' => \&scalar_deref); +use Blah 1.0 ('@{}' => \&array_deref); + +#----------------------------------------------------------------------------- + +## name use vars arguments. +## failures 0 +## cut + +use vars '$FOO'; +use vars '$FOO', '@BAR'; +use vars ('$FOO'); +use vars ('$FOO', '@BAR'); +use vars (('$FOO')); +use vars (('$FOO', '@BAR')); +use vars ((('$FOO'))); +use vars ((('$FOO', '@BAR'))); +use vars qw< $FOO @BAR >; +use vars qw< $FOO @BAR >, '$BAZ'; + +#----------------------------------------------------------------------------- + +## name Include statement failure. +## failures 1 +## cut + +use Generic::Module '$FOO'; + +#----------------------------------------------------------------------------- + +## name Things that look like email addresses. +## failures 0 +## cut + +$simple = 'me@foo.bar'; +$complex = q{don-quixote@man-from.lamancha.org}; + +#----------------------------------------------------------------------------- +## name More things that look like email addresses. +## failures 0 +## cut + +$simple = 'Email: me@foo.bar'; +$complex = q{"don-quixote@man-from.lamancha.org" is my address}; +send_email_to ('foo@bar.com', ...); + +#----------------------------------------------------------------------------- +## name Email addresses with embedded violations. +## TODO Policy is not smart enough to handle this yet. +## failures 2 +## cut + +$simple = 'Email: $name@$company.$domain'; +send_email_to('$some_var: foo@bar.com', ...); + +#----------------------------------------------------------------------------- +## name Confirm we flag all defined backslashed interpolations. RT #61970 +## failures 26 +## cut + +'\t'; # tab (HT, TAB) +'\n'; # newline (NL) +'\r'; # return (CR) +'\f'; # form feed (FF) +'\b'; # backspace (BS) +'\a'; # alarm (bell) (BEL) +'\e'; # escape (ESC) +'\033'; # octal char (example: ESC) +'\x1b'; # hex char (example: ESC) +'\x{263a}'; # wide hex char (example: SMILEY) +'\c['; # control char (example: ESC) +'\N{name}'; # named Unicode character +'\N{U+263D}'; # Unicode character (example: FIRST QUARTER MOON) +'\l'; # lowercase next char +'\u'; # uppercase next char +'\L'; # lowercase till \E +'\U'; # uppercase till \E +'\E'; # end case modification +'\Q'; # quote non-word characters till \E +'\1'; # See note 1, below +'\2'; # See note 1, below +'\3'; # See note 1, below +'\4'; # See note 1, below +'\5'; # See note 1, below +'\6'; # See note 1, below +'\7'; # See note 1, below + +# Note 1: These are not documented in perop that I can find, but the code in +# toke.c makes them equivalent to \0 for interpolated strings (though +# not, of course, for regular expressions or the substitution portion +# of s///). + +#----------------------------------------------------------------------------- +## name Confirm we ignore all non-special backslashed word characters. RT #61970 +## failures 0 +## cut + +'\8'; +'\9'; +'\A'; +'\B'; +'\C'; +'\D'; +'\F'; +'\G'; +'\H'; +'\I'; +'\J'; +'\K'; +'\M'; +'\O'; +'\P'; +'\R'; +'\S'; +'\T'; +'\V'; +'\W'; +'\X'; +'\Y'; +'\Z'; +'\d'; +'\g'; +'\h'; +'\i'; +'\j'; +'\k'; +'\m'; +'\o'; +'\p'; +'\q'; +'\s'; +'\v'; +'\w'; +'\y'; +'\z'; + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/RequireNumberSeparators.run b/t/ValuesAndExpressions/RequireNumberSeparators.run new file mode 100644 index 0000000..eeb3fdd --- /dev/null +++ b/t/ValuesAndExpressions/RequireNumberSeparators.run @@ -0,0 +1,87 @@ +## name Basic passing +## failures 0 +## cut + +$var = 12; +$var = 1234; +$var = 1_234; +$var = 1_234.01; +$var = 1_234_567; +$var = 1_234_567.; +$var = 1_234_567.890_123; +$var = -1_234; +$var = -1_234.01; +$var = -1_234_567; +$var = -1_234_567.; +$var = -1_234_567.890_123; +$var = +1_234; +$var = +1_234.01; +$var = +1_234_567; +$var = +1_234_567.; +$var = +1_234_567.890_123; + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 12 +## cut + +$var = 1234_567; +$var = 1234_567.; +$var = 1234_567.890; +$var = -1234_567.8901; +$var = -1234_567; +$var = -1234_567.; +$var = -1234_567.890; +$var = -1234_567.8901; +$var = +1234_567; +$var = +1234_567.; +$var = +1234_567.890; +$var = +1234_567.8901; + +is( pcritique($policy, \$code), 12, $policy); + +#----------------------------------------------------------------------------- + +## name Below configuration minimum passing +## failures 0 +## parms {min_value => 1_000_000} +## cut + +$var = 999999; +$var = 123456; +$var = 100000.01; +$var = 10_000.01; +$var = 100_000.01; +$var = -999999; +$var = -123456; +$var = -100000.01; +$var = -10_000.01; +$var = -100_000.01; + +#----------------------------------------------------------------------------- + +## name Above configuration minimum failure +## failures 9 +## parms {min_value => 1_000_000} +## cut + +$var = 1000001; +$var = 1000000.01; +$var = 1000_000.01; +$var = 10000_000.01; +$var = -1000001; +$var = -1234567; +$var = -1000000.01; +$var = -1000_000.01; +$var = -10000_000.01; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/ValuesAndExpressions/RequireQuotedHeredocTerminator.run b/t/ValuesAndExpressions/RequireQuotedHeredocTerminator.run new file mode 100644 index 0000000..14fd5dd --- /dev/null +++ b/t/ValuesAndExpressions/RequireQuotedHeredocTerminator.run @@ -0,0 +1,85 @@ +## name Basic failure +## failures 1 +## cut + +print <exception_class); +my $exception_class = $exception_class_for{$class} ||= $class->exception_class; +my $feature = ${*$ftp}{net_ftp_feature} ||= do { my @feat; @feat = map { /^\s+(.*\S)/ } $ftp->message if $ftp->_FEAT; \@feat; }; +my $tests = $self->{tests} ||= {}; +my $attr = $_[0]->{A}->{$attrName} ||= new XML::XQL::DirAttr (Parent => $self, Name => $attrName); + + +#----------------------------------------------------------------------------- + +## name Scalar augmented assignment +## failures 64 +## cut + +my $foo **= 0; +my $foo += 0; +my $foo -= 0; +my $foo .= 0; +my $foo *= 0; +my $foo /= 0; +my $foo %= 0; +my $foo x= 0; +my $foo &= 0; +my $foo |= 0; +my $foo ^= 0; +my $foo <<= 0; +my $foo >>= 0; +my $foo &&= 0; +my $foo ||= 0; +my $foo //= 0; + +local $foo **= 0; +local $foo += 0; +local $foo -= 0; +local $foo .= 0; +local $foo *= 0; +local $foo /= 0; +local $foo %= 0; +local $foo x= 0; +local $foo &= 0; +local $foo |= 0; +local $foo ^= 0; +local $foo <<= 0; +local $foo >>= 0; +local $foo &&= 0; +local $foo ||= 0; +local $foo //= 0; + +our $foo **= 0; +our $foo += 0; +our $foo -= 0; +our $foo .= 0; +our $foo *= 0; +our $foo /= 0; +our $foo %= 0; +our $foo x= 0; +our $foo &= 0; +our $foo |= 0; +our $foo ^= 0; +our $foo <<= 0; +our $foo >>= 0; +our $foo &&= 0; +our $foo ||= 0; +our $foo //= 0; + +state $foo **= 0; +state $foo += 0; +state $foo -= 0; +state $foo .= 0; +state $foo *= 0; +state $foo /= 0; +state $foo %= 0; +state $foo x= 0; +state $foo &= 0; +state $foo |= 0; +state $foo ^= 0; +state $foo <<= 0; +state $foo >>= 0; +state $foo &&= 0; +state $foo ||= 0; +state $foo //= 0; + +#----------------------------------------------------------------------------- + +## name Real-life examples +## failures 8 +## cut + +local $Carp::CarpLevel += $level; +local $Carp::CarpLevel += ($lvl + 1); +*$func = sub { local $Carp::CarpLevel += 2 if grep { $_ eq $func } @EXPORT_OK; +my $name .= $param->value('Name') ; +my $curr += ord( lc($char) ) - ord('a') + 1; +my $port ||= $port_memoized || $ENV{APACHE_TEST_PORT} || $self->{vars}{port} || DEFAULT_PORT; +my $output .= 'getNodeName; +my $data .= &stripzerobytes(inet_aton($self->address())); + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Variables/ProhibitConditionalDeclarations.run b/t/Variables/ProhibitConditionalDeclarations.run new file mode 100644 index 0000000..4c097b3 --- /dev/null +++ b/t/Variables/ProhibitConditionalDeclarations.run @@ -0,0 +1,99 @@ +## name With if +## failures 4 +## cut + +my $foo = 1 if $bar; +our $foo = 1 if $bar; + +my ($foo, $baz) = @list if $bar; +our ($foo, $baz) = 1 if $bar; + + +#----------------------------------------------------------------------------- + +## name With unless +## failures 4 +## cut + +my $foo = 1 unless $bar; +our $foo = 1 unless $bar; + +my ($foo, $baz) = @list unless $bar; +our ($foo, $baz) = 1 unless $bar; + + +#----------------------------------------------------------------------------- + +## name With while +## failures 4 +## cut + +my $foo = 1 while $bar; +our $foo = 1 while $bar; + +my ($foo, $baz) = @list while $bar; +our ($foo, $baz) = 1 while $bar; + +#----------------------------------------------------------------------------- + +## name With for +## failures 4 +## cut + +my $foo = 1 for @bar; +our $foo = 1 for @bar; + +my ($foo, $baz) = @list for @bar; +our ($foo, $baz) = 1 for @bar; + +#----------------------------------------------------------------------------- + +## name With foreach +## failures 4 +## cut + +my $foo = 1 foreach @bar; +our $foo = 1 foreach @bar; + +my ($foo, $baz) = @list foreach @bar; +our ($foo, $baz) = 1 foreach @bar; + +#----------------------------------------------------------------------------- + +## name Passing cases +## failures 0 +## cut + +for my $foo (@list) { do_something() } +foreach my $foo (@list) { do_something() } +while (my $foo $condition) { do_something() } +until (my $foo = $condition) { do_something() } +unless (my $foo = $condition) { do_something() } + +# these are terrible uses of "if" but do not violate the policy +my $foo = $hash{if}; +my $foo = $obj->if(); + +#----------------------------------------------------------------------------- + +## name local is exempt +## failures 0 +## cut + +local $foo = $bar if $baz; +local ($foo) = $bar if $baz; +local $foo = $bar unless $baz; +local ($foo) = $bar unless $baz; +local $foo = $bar until $baz; +local ($foo) = $bar until $baz; +local ($foo, $bar) = 1 foreach @baz; +local ($foo, $bar) = 1 for @baz; + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Variables/ProhibitEvilVariables.d/variables-no-regular-expressions.txt b/t/Variables/ProhibitEvilVariables.d/variables-no-regular-expressions.txt new file mode 100644 index 0000000..8128aa5 --- /dev/null +++ b/t/Variables/ProhibitEvilVariables.d/variables-no-regular-expressions.txt @@ -0,0 +1,7 @@ +$[ # Comment on same line as meaningful content. + +$SIG{__DIE__} Found use of $SIG{__DIE__}. Use END{} or override CORE::GLOBAL::die() instead. + +# Extra leading and trailing whitespace here is intentional. + + $^S Found use of $^S. You should seriously consider what your code is trying to do. diff --git a/t/Variables/ProhibitEvilVariables.d/variables-regular-expressions.txt b/t/Variables/ProhibitEvilVariables.d/variables-regular-expressions.txt new file mode 100644 index 0000000..8d7924d --- /dev/null +++ b/t/Variables/ProhibitEvilVariables.d/variables-regular-expressions.txt @@ -0,0 +1,7 @@ +/\$\[/ # Comment on same line as meaningful content. + +# Lack of whitespace between regex and message intentional. +/\$SIG\{__DIE__\}/Do not use $SIG{__DIE__}. Use END{} or override CORE::GLOBAL::die() instead. + +# Extra leading and trailing whitespace here is intentional. + /\$\^S/ Found use of $^S. You should seriously consider what your code is trying to do. diff --git a/t/Variables/ProhibitEvilVariables.run b/t/Variables/ProhibitEvilVariables.run new file mode 100644 index 0000000..05688fa --- /dev/null +++ b/t/Variables/ProhibitEvilVariables.run @@ -0,0 +1,165 @@ +## name 2 evil variables +## parms {variables => '$[ $SIG{__DIE__}'} +## failures 2 +## cut + +print 'First subscript is ', $[, "\n"; +local $SIG{__DIE__} = sub {warn "I cannot die!"}; + +#----------------------------------------------------------------------------- + +## name evil variables with brackets +## parms { variables => '${^WIN32_SLOPPY_STAT} %{^_Fubar}' } +## failures 2 +## cut + +${^WIN32_SLOPPY_STAT} and print "We are being sloppy\n"; +our %{^_Fubar}; + +#----------------------------------------------------------------------------- + +## name subscripted evil variables with brackets +## parms { variables => '%{^_Fubar}' } +## failures 1 +## cut + +print "The value of \${^_Fubar}{baz} is ", ${^_Fubar}{baz}, "\n"; + +#----------------------------------------------------------------------------- + +## name No evil variables +## parms {variables => '$[ $SIG{__DIE__}'} +## failures 0 +## cut + +print 'Perl version is ', $], "\n"; +local $SIG{__WARN__} = sub {print {STDERR} "Danger Will Robinson!\n"}; + +#----------------------------------------------------------------------------- + +## name 2 evil variables, with pattern matching +## parms { variables => '/\[/ /\bSIG\b/ ' } +## failures 2 +## cut + +print 'First subscript is ', $[, "\n"; +local $SIG{__DIE__} = sub {warn "I cannot die!"}; + +#----------------------------------------------------------------------------- + +## name More evil variables, with mixed config +## parms { variables => ' $[ /\bSIG\b/ $^S' } +## failures 5 +## cut + +print 'First subscript is ', $[, "\n"; +local $SIG{__DIE__} = sub {warn "I cannot die!"}; +print $^S ? 'Executing eval' : defined $^S ? 'Otherwise' : 'Parsing'; +local $SIG{__WARN__} = sub {print {STDERR} "Danger, Will Robinson!\n"; + +#----------------------------------------------------------------------------- + +## name Recognize use of elements of evil arrays and hashes +## parms { variables => '%SIG @INC' } +## failures 2 +## cut + +local $SIG{__DIE__} = sub {warn "I cannot die!"}; +print '$INC[0] is ', $INC[0], "\n"; + +#----------------------------------------------------------------------------- + +## name Regexes with modifiers +## parms { variables => ' /(?x: \b SIG \b )/ /(?i:\binc\b)/ /(?ix: acme )/ ' } +## failures 4 +## cut + +local $SIG{__DIE__} = sub {warn "I cannot die!"}; +print '$INC[0] is ', $INC[0], "\n"; +print '$inc[0] is ', $inc[0], "\n"; +my $Acme = 'For the discerning coyote'; + +#----------------------------------------------------------------------------- + +## name More evil variables, with more pattern matching +## parms { variables => '/foo|bar|baz/ ' } +## failures 4 +## cut + +my $foo; +my $bar; +my $baz; +my $foonly; + +#----------------------------------------------------------------------------- + +## name Pattern matching exceptions +## parms { variables => '/(/' } +## failures 0 +## error /invalid regular expression/ +## cut + +print 'Hello World'; + +#----------------------------------------------------------------------------- + +## name Providing the description for variables, no regular expressions. +## parms { variables => q'$[ {Found use of $[. Code for first index = 0 instead} $SIG{__DIE__} ' } +## failures 2 +## cut + +print 'First subscript is ', $[, "\n"; +local $SIG{__DIE__} = sub {warn "I cannot die!"}; + +#----------------------------------------------------------------------------- + +## name Providing the description for variables, regular expressions. +## parms { variables => q' /\bSIG\b/ {Found use of SIG. Do not use signals} /\bINC\b/ {Found use of INC. Do not manipulate @INC directly} ' } +## failures 2 +## cut + +local $SIG{__DIE__} = sub {warn "I cannot die!"}; +print '$INC[0] is ', $INC[0], "\n"; + +#----------------------------------------------------------------------------- + +## name Providing the description for variables, regular expressions with modifiers. +## parms { variables => ' /(?x: \b SIG \b )/{We do not like signals.} /(?i:\binc\b)/[Do not fiddle with INC, no mater how it is capitalized] ' } +## failures 3 +## cut + +local $SIG{__DIE__} = sub {warn "I cannot die!"}; +print '$INC[0] is ', $INC[0], "\n"; +print '$inc[0] is ', $inc[0], "\n"; + +#----------------------------------------------------------------------------- + +## name Providing the description for variables from file, no regular expressions. +## parms { variables_file => 't/Variables/ProhibitEvilVariables.d/variables-no-regular-expressions.txt' } +## failures 4 +## cut + +print 'First subscript is ', $[, "\n"; +local $SIG{__DIE__} = sub {warn "I cannot die!"}; +print $^S ? 'Executing eval' : defined $^S ? 'Otherwise' : 'Parsing'; + +#----------------------------------------------------------------------------- + +## name Providing the description for variables from file, regular expressions. +## parms { variables_file => 't/Variables/ProhibitEvilVariables.d/variables-regular-expressions.txt' } +## failures 4 +## cut + +print 'First subscript is ', $[, "\n"; +local $SIG{__DIE__} = sub {warn "I cannot die!"}; +print $^S ? 'Executing eval' : defined $^S ? 'Otherwise' : 'Parsing'; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Variables/ProhibitLocalVars.run b/t/Variables/ProhibitLocalVars.run new file mode 100644 index 0000000..bc6e8a7 --- /dev/null +++ b/t/Variables/ProhibitLocalVars.run @@ -0,0 +1,38 @@ +## name basics +## failures 3 +## cut + +local $foo = $bar; +local ($foo, $bar) = (); +local ($foo, %SIG); + +#----------------------------------------------------------------------------- + +## name exceptions +## failures 0 +## cut + +local $/ = undef; +local $| = 1; +local ($/) = undef; +local ($RS, $>) = (); +local ($RS); +local $INPUT_RECORD_SEPARATOR; +local $PROGRAM_NAME; +local ($EVAL_ERROR, $OS_ERROR); +local $Other::Package::foo; +local (@Other::Package::foo, $EVAL_ERROR); +my $var1 = 'foo'; +our $var2 = 'bar'; +local $SIG{HUP} \&handler; +local $INC{$module} = $path; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Variables/ProhibitMatchVars.run b/t/Variables/ProhibitMatchVars.run new file mode 100644 index 0000000..047fa51 --- /dev/null +++ b/t/Variables/ProhibitMatchVars.run @@ -0,0 +1,38 @@ +## name Basic +## failures 9 +## cut + +use English qw($PREMATCH); +use English qw($MATCH); +use English qw($POSTMATCH); +$`; +$&; +$'; +$PREMATCH; +$MATCH; +$POSTMATCH; + + +## name Ignore case handled by RequireNoMatchVarsWithUseEnglish +## failures 0 +## cut + +use English; + + +## name no_match_vars +## failures 0 +## cut + +use English qw(-no_match_vars); +use English qw($EVAL_ERROR); + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Variables/ProhibitPackageVars.run b/t/Variables/ProhibitPackageVars.run new file mode 100644 index 0000000..8fa3b79 --- /dev/null +++ b/t/Variables/ProhibitPackageVars.run @@ -0,0 +1,147 @@ +## name Basic failures +## failures 15 +## cut + +our $var1 = 'foo'; +our (%var2, %var3) = 'foo'; +our (%VAR4, $var5) = (); + +$Package::foo; +@Package::list = ('nuts'); +%Package::hash = ('nuts'); + +$::foo = $bar; +@::foo = ($bar); +%::foo = (); + +use vars qw($fooBar $baz); +use vars qw($fooBar @EXPORT); +use vars '$fooBar', "$baz"; +use vars '$fooBar', '@EXPORT'; +use vars ('$fooBar', '$baz'); +use vars ('$fooBar', '@EXPORT'); + + +#----------------------------------------------------------------------------- + +## name Basic passes - our +## failures 0 +## cut + +our $VAR1 = 'foo'; +our (%VAR2, %VAR3) = (); +our $VERSION = '1.0'; +our @EXPORT = qw(some symbols); + +#----------------------------------------------------------------------------- + +## name Basic passes - use vars +## failures 0 +## cut + +use vars qw($VERSION @EXPORT); +use vars ('$VERSION, '@EXPORT'); +use vars '$VERSION, '@EXPORT'; + +use vars '+foo'; #Illegal, but not a violaton + +#----------------------------------------------------------------------------- + +## name Basic passes - symbols +## failures 0 +## cut + +#local $Foo::bar; +#local @This::that; +#local %This::that; +#local $This::that{ 'key' }; +#local $This::that[ 1 ]; +#local (@Baz::bar, %Baz::foo); + +$Package::VERSION = '1.2'; +%Package::VAR = ('nuts'); +@Package::EXPORT = (); + +$::VERSION = '1.2'; +%::VAR = ('nuts'); +@::EXPORT = (); +&Package::my_sub(); +&::my_sub(); +*foo::glob = $code_ref; + +#----------------------------------------------------------------------------- + +## name Lexicals should pass +## failures 0 +## cut + +my $var1 = 'foo'; +my %var2 = 'foo'; +my ($foo, $bar) = (); + + +#----------------------------------------------------------------------------- + +## name Default package exceptions +## failures 0 +## cut + +use File::Find; +print $File::Find::dir; +use Data::Dumper; +$Data::Dumper::Indent = 1; + + +use File::Spec::Functions qw< catdir >; +use lib catdir( $FindBin::Bin, qw< .. lib perl5 > ); + +local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 1; + +#----------------------------------------------------------------------------- + +## name Add to default exceptions +## parms {add_packages => 'Addl::Package'} +## failures 3 +## cut + + +use File::Find; +print $File::Find::dir; + +$Addl::Package::bar = 27; + +$Addl::Other::wango = 9; +$Addl::Other::tango = 9; +$Addl::Other::bango = 9; + + +#----------------------------------------------------------------------------- + +## name Override default package exceptions +## parms {add_packages => 'Incorrect::Override::Package'} +## failures 2 +## cut + +use File::Find; +print $File::Find::dir; +$Override::Defaults::wango = $x; +$Override::Defaults::tango = 47; + +#----------------------------------------------------------------------------- + +## name Override default package exceptions, null package +## parms {add_packages => 'Incorrect::Override::Package'} +## failures 1 +## cut + +$::foo = 1; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Variables/ProhibitPerl4PackageNames.run b/t/Variables/ProhibitPerl4PackageNames.run new file mode 100644 index 0000000..1d6277d --- /dev/null +++ b/t/Variables/ProhibitPerl4PackageNames.run @@ -0,0 +1,251 @@ +## name Perl 4 package declarations +## failures 3 +## cut + + +package Foo'Bar; +package Foo::Bar'Baz; +package Foo'Bar::Baz; + +#----------------------------------------------------------------------------- +## name Perl 5 package declarations +## failures 0 +## cut + +package Foo; +package Foo::Bar; +package Foo::Bar::Baz; + +#----------------------------------------------------------------------------- +## name Perl 4 simple variable access +## failures 9 +## cut + + +my $x = $Foo'bar; +my $x = $Foo'Bar::baz; +my $x = $Foo::Bar'baz; + +my @x = @Foo'bar; +my @x = @Foo'Bar::baz; +my @x = @Foo::Bar'baz; + + +my %x = %Foo'bar; +my %x = %Foo'Bar::baz; +my %x = %Foo::Bar'baz; + +#----------------------------------------------------------------------------- +## name Perl 5 simple variable access +## failures 0 +## cut + +my $x = $Foo::bar; +my $x = $Foo::Bar::baz; + +my @x = @Foo; +my @x = @Foo::bar; + +my %x = %Foo::baz; +my %x = %Foo::Bar::baz; + +#----------------------------------------------------------------------------- +## name Perl 4 simple variable assignment +## failures 9 +## cut + +$Foo'bar = $x; +$Foo'Bar::baz = $x; +$Foo::Bar'baz = $x; + +@Foo'bar = @x; +@Foo'Bar::baz = @x; +@Foo::Bar'baz = @x; + +%Foo'bar = %x; +%Foo'Bar::baz = %x; +%Foo::Bar'baz = %x; + +#----------------------------------------------------------------------------- +## name Perl 4 localized variable assignment +## failures 11 +## cut + +local $Foo'bar = $x; +local $Foo'Bar::baz = $x; +local $Foo::Bar'baz = $x; + +local @Foo'bar = @x; +local @Foo'Bar::baz = @x; +local @Foo::Bar'baz = @x; + +local %Foo'bar = %x; +local %Foo'Bar::baz = %x; +local %Foo::Bar'baz = %x; + +local ($Foo'Bar'baz, $Foo'Bar'bam) = @list; + +#----------------------------------------------------------------------------- +## name Perl 5 simple variable assignment +## failures 0 +## cut + +$Foo::Bar = $x; +$Foo::Bar::baz = $x; + +@Foo::Bar = @x; +@Foo::Bar::baz = @x; + +%Foo::Bar = %x; +%Foo::Bar::baz = %x; + +#----------------------------------------------------------------------------- +## name Perl 5 localized variable assignment +## failures 0 +## cut + +local $Foo::Bar = $x; +local $Foo::Bar::baz = $x; + +local @Foo::Bar = @x; +local @Foo::Bar::baz = @x; + +local %Foo::Bar = %x; +local %Foo::Bar::baz = %x; + +local ($Foo::Bar::baz, $Foo::Bar::bam) = @list; + +#----------------------------------------------------------------------------- +## name Perl 4 simple subroutine invocation +## failures 8 +## cut + +Foo'bar(); +&Foo'bar; +Foo'Bar::baz($x, 'y'); +Foo::Bar'baz($x, 'y'); + +my $x = Foo'bar(); +my $x = &Foo'bar; +my $x = Foo'Bar::baz($x, 'y'); +my $x = Foo::Bar'baz($x, 'y'); + +#----------------------------------------------------------------------------- +## name Perl 5 simple subroutine invocation +## failures 0 +## cut + +Foo::bar(); +&Foo::bar; +Foo::Bar::baz($x, 'y'); +my $x = Foo::bar(); +my $x = &Foo::bar; +my $x = Foo::Bar::baz($x, 'y'); + +#----------------------------------------------------------------------------- +## name Perl 4 simple direct class method invocation +## failures 8 +## cut + +Foo'bar->new(); +&Foo'bar->new; +Foo'Bar::baz->new($x, 'y'); +Foo::Bar'baz->new($x, 'y'); + +my $x = Foo'bar->new(); +my $x = &Foo'bar->new; +my $x = Foo'Bar::baz->new($x, 'y'); +my $x = Foo::Bar'baz->new($x, 'y'); + +#----------------------------------------------------------------------------- +## name Perl 5 simple direct class method invocation +## failures 0 +## cut + +Foo::bar->new(); +&Foo::bar->new; +Foo::Bar::baz->new($x, 'y'); + +my $x = &Foo::bar->new; +my $x = Foo::bar->new(); +my $x = Foo::Bar::baz->new($x, 'y'); + +#----------------------------------------------------------------------------- +## name Perl 4 simple indirect class method invocation +## failures 4 +## cut + +$z = new Foo'bar(); +$z = new Foo'bar; +$z = new Foo'Bar::baz($x, 'y'); +$z = new Foo::Bar'baz($x, 'y'); + +#----------------------------------------------------------------------------- +## name Perl 5 simple indirect class method invocation +## failures 0 +## cut + +$z = new Foo::bar(); +$z = new Foo::bar; +$z = new Foo::Bar::baz($x, 'y'); + +#----------------------------------------------------------------------------- +## name complicated statements +## failures 20 +## cut + +# If PPI ever gains the ability to parse regexes failures ought to be 26. +@Foo::bar = Xyzzy::Qux::corge(Grault::Thud->fred('x') + new Plugh::Waldo) =~ m/ a $B::C::d e /xms; +@Foo'bar = Xyzzy::Qux::corge(Grault::Thud->fred('x') + new Plugh::Waldo) =~ m/ a $B::C::d e /xms; +@Foo::bar = Xyzzy'Qux::corge(Grault::Thud->fred('x') + new Plugh::Waldo) =~ m/ a $B::C::d e /xms; +@Foo::bar = Xyzzy::Qux'corge(Grault::Thud->fred('x') + new Plugh::Waldo) =~ m/ a $B::C::d e /xms; +@Foo::bar = Xyzzy::Qux::corge(Grault'Thud->fred('x') + new Plugh::Waldo) =~ m/ a $B::C::d e /xms; +@Foo::bar = Xyzzy::Qux::corge(Grault::Thud->fred('x') + new Plugh'Waldo) =~ m/ a $B::C::d e /xms; +@Foo::bar = Xyzzy::Qux::corge(Grault::Thud->fred('x') + new Plugh::Waldo) =~ m/ a $B'C::d e /xms; +@Foo::bar = Xyzzy::Qux::corge(Grault::Thud->fred('x') + new Plugh::Waldo) =~ m/ a $B::C'd e /xms; + +@Foo'bar = Xyzzy::Qux'corge(Grault::Thud->fred('x') + new Plugh::Waldo) =~ m/ a $B::C::d e /xms; +@Foo::bar = Xyzzy'Qux::corge(Grault'Thud->fred('x') + new Plugh::Waldo) =~ m/ a $B::C::d e /xms; +@Foo::bar = Xyzzy::Qux'corge(Grault::Thud->fred('x') + new Plugh'Waldo) =~ m/ a $B::C::d e /xms; +@Foo::bar = Xyzzy::Qux::corge(Grault'Thud->fred('x') + new Plugh::Waldo) =~ m/ a $B'C::d e /xms; +@Foo::bar = Xyzzy::Qux::corge(Grault::Thud->fred('x') + new Plugh'Waldo) =~ m/ a $B::C'd e /xms; + +@Foo'bar = Xyzzy::Qux'corge(Grault::Thud->fred('x') + new Plugh'Waldo) =~ m/ a $B'C::d e /xms; + +@Foo'bar = Xyzzy'Qux'corge(Grault'Thud->fred('x') + new Plugh'Waldo) =~ m/ a $B'C'd e /xms; + + +#----------------------------------------------------------------------------- + +## name hash keys +## failures 0 +## cut + +$foo = { bar'baz => 0 }; +print $foo{ bar'baz }; + + +#----------------------------------------------------------------------------- + +## name $POSTMATCH +## failures 0 +## cut + +$foo = $'; +print $'; + +@foo = @'; +%foo = %'; +$foo = \&'; +*foo = *'; + + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Variables/ProhibitPunctuationVars.run b/t/Variables/ProhibitPunctuationVars.run new file mode 100644 index 0000000..3537aac --- /dev/null +++ b/t/Variables/ProhibitPunctuationVars.run @@ -0,0 +1,431 @@ +## name Basic failure +## failures 3 +## cut + +$/ = undef; +$| = 1; +$> = 3; + +#----------------------------------------------------------------------------- + +## name Basic failure (needs to be merged into prior test once PPI knows how to parse '%-' +## failures 1 +## cut + +%- = (foo => 1); + +#----------------------------------------------------------------------------- + +## name English is nice +## failures 0 +## cut + +$RS = undef; +$INPUT_RECORD_SEPARATOR = "\n"; +$OUTPUT_AUTOFLUSH = 1; +print $foo, $baz; + +#----------------------------------------------------------------------------- + +## name Permitted variables +## failures 0 +## cut + +$string =~ /((foo)bar)/; +$foobar = $1; +$foo = $2; +$3; +$stat = stat(_); +@list = @_; +my $line = $_; + +my $perl_version = $]; + +#----------------------------------------------------------------------------- + +## name Configuration +## parms { allow => '$@ $!' } +## failures 0 +## cut + +print $@; +print $!; + +#----------------------------------------------------------------------------- + +## name PPI::Token::Quote::Double Interpolation: violations +## parms { allow => '$@ $!' } +## failures 7 +## cut + +print "$+"; +print "This is my $+. is it not nifty?"; +print "This is my $+. is it not $@?"; +print "this \n should $+\n violate"; +print "as \n$+ should this"; +print "${\($$)}"; +print "${[$$]}"; + +## name PPI::Token::Quote::Double Interpolation: non-violations +## parms { allow => '$@ $!' } +## failures 0 +## cut + +print "\$+"; +print "$@"; +print "$!"; +print "no magic here"; +print "This is my $@; is it not nifty?"; +print "but not \n\$+ this"; + +## name PPI::Token::Quote::Interpolate Interpolation: violations +## failures 3 +## cut + +print qq<$+>; +print qq<\\$+>; +print qq<\\\\$+>; + +## name PPI::Token::Quote::Interpolate Interpolation: non-violations +## failures 0 +## cut + +print qq<\$+>; +print qq<\\\$+>; + +## name PPI::Token::QuoteLike::Command: violations +## failures 1 +## cut + +print qx<$+>; + +## name PPI::Token::QuoteLike::Command: non-violations +## failures 0 +## cut + +print qx<\$+>; + +## name PPI::Token::QuoteLike::Backtick: violations +## failures 1 +## cut + +print `$+`; + +## name PPI::Token::QuoteLike::Backtick: non-violations +## failures 0 +## cut + +print `\$+`; + +## name PPI::Token::QuoteLike::Regexp: violations +## failures 1 +## cut + +print qr<$+>; + +## name PPI::Token::QuoteLike::Regexp: non-violations +## failures 0 +## cut + +print qr<\$+>; +print qr/TEST$/xsm; # GitHub #843 + +## name PPI::Token::QuoteLike::Readline: violations +## failures 1 +## cut + +while (<$+>) { 1; } + +## name PPI::Token::QuoteLike::Readline: non-violations +## failures 0 +## cut + +while (<\$+>) { 1; } + +#----------------------------------------------------------------------------- + +## name Heredoc Interpolation: violations +## parms { allow => '$@ $!' } +## failures 8 +## cut + +print < '$@ $!' } +## failures 0 +## cut + +print < 'simple' } +## failures 0 +## cut +print "$#"; # 3 of 59 Exception made for $# +print "$$"; # 6 of 59 Exception made for $$ +print "$'"; # 9 of 59 Exception made for $' +print "$:"; # 19 of 59 Exception made for $: + +#----------------------------------------------------------------------------- + +## name Quoted String Interpolation - exhaustive tests +## failures 52 +## cut + +print "$!"; # 1 of 54 + +#print "$""; # 2 of 54 BROKEN, copied to TODO +print "$#"; # 3 of 54 +print "$#+"; # 4 of 54 +print "$#-"; # 5 of 54 +print "$$"; # 6 of 54 +print "$%"; # 7 of 54 +print "$&"; # 8 of 54 +print "$'"; # 9 of 54 +print "$("; # 10 of 54 +print "$)"; # 11 of 54 +print "$*"; # 12 of 54 +print "$+"; # 13 of 54 +print "$,"; # 14 of 54 +print "$-"; # 15 of 54 +print "$."; # 16 of 54 +print "$/"; # 17 of 54 +print "$0"; # 18 of 54 +print "$:"; # 19 of 54 +print "$::|"; # 20 of 54 +print "$;"; # 21 of 54 +print "$<"; # 22 of 54 +print "$="; # 23 of 54 +print "$>"; # 24 of 54 +print "$?"; # 25 of 54 +print "$@"; # 26 of 54 +print "$["; # 27 of 54 + +#print "$\\"; # 28 of 54 BROKEN, copied to TODO +print "$^"; # 29 of 54 +print "$^A"; # 30 of 54 +print "$^C"; # 31 of 54 +print "$^D"; # 32 of 54 +print "$^E"; # 33 of 54 +print "$^F"; # 34 of 54 +print "$^H"; # 35 of 54 +print "$^I"; # 36 of 54 +print "$^L"; # 37 of 54 +print "$^M"; # 38 of 54 +print "$^N"; # 39 of 54 +print "$^O"; # 40 of 54 +print "$^P"; # 41 of 54 +print "$^R"; # 42 of 54 +print "$^S"; # 43 of 54 +print "$^T"; # 44 of 54 +print "$^V"; # 45 of 54 +print "$^W"; # 46 of 54 +print "$^X"; # 47 of 54 +print "$`"; # 48 of 54 +print "$|"; # 49 of 54 +print "$}"; # 50 of 54 +print "$~"; # 51 of 54 +print "@*"; # 52 of 54 +print "@+"; # 53 of 54 +print "@-"; # 54 of 54 + +#----------------------------------------------------------------------------- + +## name String Interpolation - 'disable' mode +## failures 0 +## parms { string_mode => 'disable' } +## cut + +print "$!"; + +## name String Interpolation - explicit 'simple' mode +## parms { string_mode => 'simple' } +## failures 5 +## cut + +print "$+"; +print "This is my $+. is it not nifty?"; +print "This is my $+. is it not $@?"; +print "this \n should $+\n violate"; +print "as \n$+ should this"; + +#----------------------------------------------------------------------------- + +## name String Interpolation - thorough-mode violations +## failures 4 +## parms { string_mode => 'thorough' } +## cut + +print "$!"; +print "this \n should $+\n violate"; +print <<"DOUBLE_QUOTE"; # explicit "" context +$+with stuff +$!more stuff +$/thingy +$$ $; $= $/ +DOUBLE_QUOTE +print "blahblah ${\($$))}" # sneaky scalar dereference syntax + +#----------------------------------------------------------------------------- + + +## name String Interpolation - thorough-mode special case violations +## failures 16 +## parms { string_mode => 'thorough' } +## cut + +# related to $', $:, and $_ +print "$' ralph"; +print "$'3"; +print "$:"; +print "$: "; +print "$:fred"; +print "$: something else"; + +# related to $# +print "$#"; + + +# related to $$ +print "$$"; +print "$$ foovar"; +print "$$(foovar"; + +# related to $^ +print "$^"; +print "$^M"; # violates $^M +print "$^G"; # violates $^ (there is no $^G) +print "$^ foovar"; +print "$^(foovar"; + +# sneakier combos +print "$::foo then $' followed by $'3"; # violates for $' + +#----------------------------------------------------------------------------- + +## name String Interpolation - thorough-mode mixed multiple violations +## failures 1 +## parms { string_mode => 'thorough' } +## cut + +print "$::foo then $' followed by $'3 and $+ and $]"; + +#----------------------------------------------------------------------------- + +## name String Interpolation - thorough-mode special case non-violations +## failures 0 +## parms { string_mode => 'thorough' } +## cut + +# related to $', $:, and $_ +print "$'global_symbol"; +print "$::global_symbol"; +print "$::"; +print "$:: "; +print "$:: something else"; + +print "$_varname"; + +# related to $# +print "$#foovar"; +print "$#$"; +print "$#{"; + +# related to $$ +print "$$foovar"; + +# related to $^ +#print "$^WIDE_SYSTEM_CALLS; + +#----------------------------------------------------------------------------- + +## name sprintf formats - RT #49016 +## failures 0 +## cut + +sprintf "%-03f\n", $foo; + +#----------------------------------------------------------------------------- + +## name trailing dollar sign is not a punctuation variable - RT #55604 +## failures 0 +## cut + +qr/foo$/ + +#----------------------------------------------------------------------------- + +## name detect bracketed punctuation variables - RT #72910 +## failures 0 +## parms { allow => '$$' } +## cut + +"${$}"; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Variables/ProhibitReusedNames.run b/t/Variables/ProhibitReusedNames.run new file mode 100644 index 0000000..9a137d7 --- /dev/null +++ b/t/Variables/ProhibitReusedNames.run @@ -0,0 +1,291 @@ +## name Simple block +## failures 2 +## cut + +my $x; +{ + my $x; +} + +sub foo { + my $i; + { + my $i; + } +} + +#----------------------------------------------------------------------------- + +## name Array +## failures 1 +## cut + +my @x; +{ + my @x; +} + +#----------------------------------------------------------------------------- + +## name Hash +## failures 1 +## cut + +my %x; +{ + my %x; +} + +#----------------------------------------------------------------------------- + +## name Outer bleeds into sub +## failures 3 +## cut + +my $x; +{ + my $x; +} + +sub foo { + my $x; + { + my $x; + } +} + +#----------------------------------------------------------------------------- + +## name Reversed scope +## failures 0 +## cut + +{ + my $x; +} +my $x; + +sub foo { + { + my $i; + } + my $i; +} + +#----------------------------------------------------------------------------- + +## name Our +## failures 2 +## cut + +our $x; +{ + our $x; +} + +sub foo { + our $i; + { + our $i; + } +} + +#----------------------------------------------------------------------------- + +## name Our vs. my +## failures 2 +## cut + +our $x; +{ + my $x; +} + +sub foo { + our $i; + { + my $i; + } +} + +#----------------------------------------------------------------------------- + +## name Same scope +## failures 2 +## cut + +my $x; +my $x; + +sub foo { + my $i; + my $i; +} + +#----------------------------------------------------------------------------- + +## name Conditional block +## failures 2 +## cut + +my $x; +if (1) { + my $x; +} + +sub foo { + my $i; + if (1) { + my $i; + } +} + +#----------------------------------------------------------------------------- + +## name For loop +## failures 2 +## cut + +my $x; +for my $y (0..10) { + my $x; +} + +sub foo { + my $i; + for my $z (0..10) { + my $i; + } +} + +#----------------------------------------------------------------------------- + +## name While loop +## failures 2 +## cut + +my $x; +while (1) { + my $x; +} + +sub foo { + my $i; + while (1) { + my $i; + } +} + +#----------------------------------------------------------------------------- + +## name Deep block +## failures 2 +## cut + +my $x; +for (0..5) { + while (1) { + if (foo()) { + { + my $x; + } + } + } +} + +sub foo { + my $i; + for (0..5) { + while (1) { + if (foo()) { + { + my $i; + } + } + } + } +} + +#----------------------------------------------------------------------------- + +## name Other "my" syntax +## failures 4 +## cut + +my $x; +{ + my ($x, $y, @z); + { + my ($x, $y, @z, $w); + { + my (@w); + } + } +} + +#----------------------------------------------------------------------------- + +## name Empty "my" (which is invalid Perl syntax, but supported) +## failures 0 +## cut + +my $x; +{ + my (); +} + +#----------------------------------------------------------------------------- + +## name $self - RT #42767 +## failures 0 +## cut + +my $self; +{ + my $self; +} + +#----------------------------------------------------------------------------- + +## name $class - RT #42767 +## failures 0 +## cut + +my $class; +{ + my $class; +} + +#----------------------------------------------------------------------------- + +## name allow +## failures 0 +## parms { allow => '$foobie' } +## cut + +my $foobie; +{ + my $foobie; +} + +#----------------------------------------------------------------------------- + +## name our with multiple packages - RT #43754 +## failures 0 +## TODO We don't handle multiple packages in general, let alone in this policy. +## cut + +package Foo; +our @ISA; +package Bar; +our @ISA; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Variables/ProhibitUnusedVariables.run b/t/Variables/ProhibitUnusedVariables.run new file mode 100644 index 0000000..84d0316 --- /dev/null +++ b/t/Variables/ProhibitUnusedVariables.run @@ -0,0 +1,189 @@ +## name Simple unused, single, unassigned lexical. +## failures 1 +## cut + +my $x; + +#----------------------------------------------------------------------------- + +## name Simple unused, multiple, unassigned lexicals. +## failures 3 +## cut + +my ($x, @z, %y); + +#----------------------------------------------------------------------------- + +## name Simple unused assigned lexicals. Not going to handle this yet. +## failures 0 +## cut + +# Need to look out for RAII. +my $y = foo(); + +#----------------------------------------------------------------------------- + +## name List assignment. Not going to handle this yet. +## failures 0 +## cut + +sub foo { + my ($b, $y) = @_; +} + +#----------------------------------------------------------------------------- + +## name Simple unused explicit global. +## failures 0 +## cut + +our $x; + +#----------------------------------------------------------------------------- + +## name Simple unused implicit global. +## failures 0 +## cut + +$x; + +#----------------------------------------------------------------------------- + +## name Simple unused localized. +## failures 0 +## cut + +local $x; + +#----------------------------------------------------------------------------- + +## name Simple used lexical scalar. +## failures 0 +## cut + +my $x = 1; + +print $x; + +#----------------------------------------------------------------------------- + +## name Simple used lexical array. +## failures 0 +## cut + +my @x; + +$x[0] = 5; + +#----------------------------------------------------------------------------- + +## name Simple used lexical hash. +## failures 0 +## cut + +my %foo; + +$foo{bar} = -24; + +#----------------------------------------------------------------------------- + +## name Shadowed variable. No going to handle this yet. +## failures 0 +## cut + +my $x = 2; + +{ + my $x = 1; + blah(); +} + +#----------------------------------------------------------------------------- + +## name Separate lexicals. No going to handle this yet. +## failures 0 +## cut + +{ + my $x = 2; +} + +{ + my $x = 1; + blah(); +} + +#----------------------------------------------------------------------------- + +## name Closures +## failures 0 +## cut + +{ + my $has_graphviz = undef; + + sub has_graphviz { + if (!defined $has_graphviz) { + $has_graphviz = eval { require GraphViz; 1; } ? 1 : 0; + } + return $has_graphviz; + } +} + +#----------------------------------------------------------------------------- + +## name Interpolation in replacement portion of s/.../.../smx +## failures 0 +## cut + +my %foo; + +s/ ( \w+ ) /$foo{$1}/smx; + +#----------------------------------------------------------------------------- + +## name Interpolation in replacement portion of s/.../.../smxe +## failures 0 +## cut + +my %foo; + +s/ ( \w+ ) / $foo{$1} /smxe; + +#----------------------------------------------------------------------------- + +## name Variable used in regexp embedded code +## failures 0 +## cut + +my %foo; + +m/ (?{ $foo{bar} }) /smx; + +#----------------------------------------------------------------------------- + +## name Open a file handle and use in a readline operator. +## failures 0 +## cut + +open(my $foo, '<', '/tmp/foo') or die; +my $line = <$foo>; + +#----------------------------------------------------------------------------- + +## name Interpolating a variable is detected as a usage. +## failures 0 +## cut + +my $foo; +print "Interpolating variable: $foo"; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Variables/ProtectPrivateVars.run b/t/Variables/ProtectPrivateVars.run new file mode 100644 index 0000000..69547b0 --- /dev/null +++ b/t/Variables/ProtectPrivateVars.run @@ -0,0 +1,33 @@ +## name Basic failure +## failures 6 +## cut + +$Other::Package::_foo; +@Other::Package::_bar; +%Other::Package::_baz; +&Other::Package::_quux; +*Other::Package::_xyzzy; +\$Other::Package::_foo; + +#----------------------------------------------------------------------------- + +## name Basic passing +## failures 0 +## cut + +$_foo; +@_bar; +%_baz; +&_quux; +\$_foo; +$::_foo; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Variables/RequireInitializationForLocalVars.run b/t/Variables/RequireInitializationForLocalVars.run new file mode 100644 index 0000000..46bcb1c --- /dev/null +++ b/t/Variables/RequireInitializationForLocalVars.run @@ -0,0 +1,45 @@ +## name Basic +## failures 6 +## cut + +local $foo; +local ($foo, $bar); + +local $|; +local ($|, $$); + +local $OUTPUT_RECORD_SEPARATOR; +local ($OUTPUT_RECORD_SEPARATOR, $PROGRAM_NAME); + +#----------------------------------------------------------------------------- + +## name Initialized passes +## failures 0 +## cut + +local $foo = 'foo'; +local ($foo, $bar) = 'foo'; #Not right, but still passes +local ($foo, $bar) = qw(foo bar); + +my $foo; +my ($foo, $bar); +our $bar +our ($foo, $bar); + +#----------------------------------------------------------------------------- + +## name key named "local" +## failures 0 +## cut + +$x->{local}; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Variables/RequireLexicalLoopIterators.run b/t/Variables/RequireLexicalLoopIterators.run new file mode 100644 index 0000000..c1474c7 --- /dev/null +++ b/t/Variables/RequireLexicalLoopIterators.run @@ -0,0 +1,78 @@ +## name Basic failure +## failures 2 +## cut + +for $foo ( @list ) {} +foreach $foo ( @list ) {} + +#----------------------------------------------------------------------------- + +## name Basic passing +## failures 0 +## cut + +for my $foo ( @list ) {} +foreach my $foo ( @list ) {} + +#----------------------------------------------------------------------------- + +## name Passing lexicals on loops with labels. +## failures 0 +## cut + +LABEL: for my $foo ( @list ) {} +ANOTHER_LABEL: foreach my $foo ( @list ) {} + +BING: for ( @list ) {} +BANG: foreach ( @list ) {} + +#----------------------------------------------------------------------------- + +## name Failing lexicals on loops with labels. +## failures 2 +## cut + +LABEL: for $foo ( @list ) {} +ANOTHER_LABEL: foreach $foo ( @list ) {} + +#----------------------------------------------------------------------------- + +## name Implicit $_ passes +## failures 0 +## cut + +for ( @list ) {} +foreach ( @list ) {} + +#----------------------------------------------------------------------------- + +## name Other compounds +## failures 0 +## cut + +for ( $i=0; $i<10; $i++ ) {} +while ( $condition ) {} +until ( $condition ) {} + +#----------------------------------------------------------------------------- + +## name Ignore really, really old Perls. RT #67760 +## failures 0 +## cut + +require 5.003; + +foreach $foo ( @list ) { + bar( $foo ); +} + + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Variables/RequireLocalizedPunctuationVars.run.PL b/t/Variables/RequireLocalizedPunctuationVars.run.PL new file mode 100644 index 0000000..81994d8 --- /dev/null +++ b/t/Variables/RequireLocalizedPunctuationVars.run.PL @@ -0,0 +1,359 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use English qw(-no_match_vars); +use Carp qw(confess); + +use B::Keywords qw(); +use List::MoreUtils qw< apply uniq >; + +my $this_program = __FILE__; +(my $test_file_name = $this_program) =~ s< [.] PL \z ><>xms; +if ($this_program eq $test_file_name) { + confess + 'Was not able to figure out the name of the file to generate.' + . "This program: $this_program."; +} + +print "\n\nGenerating $test_file_name.\n"; + + +my @globals = ( + @B::Keywords::Arrays, + @B::Keywords::Hashes, + @B::Keywords::Scalars, +); +push @globals, uniq apply { s/ \A ([^*]) /*$1/xms } @B::Keywords::Filehandles; +my %exemptions = map {$_ => 1} qw( + $_ + $ARG + @_ +); + +my $carat_re = qr/\A [\$%]\^\w+ /xms; + +my $numvars = @globals - keys %exemptions; +my $numcarats = grep {!$exemptions{$_} && m/ $carat_re /xms} @globals; + + +open my $test_file, '>', $test_file_name ## no critic (RequireBriefOpen) + or confess "Could not open $test_file_name: $ERRNO"; + +print_header($test_file); +print_pass_local($test_file, \@globals); +print_pass_local_deref($test_file, \@globals); +print_pass_non_local_exception($test_file, \@globals); +print_fail_non_local($test_file, \@globals, $numvars, $numcarats); +print_fail_non_local_deref($test_file, \@globals); +print_footer($test_file); + +close $test_file + or confess "Could not close $test_file_name: $ERRNO"; + +print "Done.\n\n"; + +sub print_header { + my ($test_file) = @_; + + print {$test_file} <<'END_CODE'; + +## name Named magic variables, special case passes +## failures 0 +## cut + +local ($_, $RS) = (); +local $SIG{__DIE__} = sub { print "AAAAAAARRRRRGGGGHHHHH....\n"; }; +$_ = 1; +$ARG = 1; +@_ = (1, 2, 3); + +#----------------------------------------------------------------------------- + +END_CODE + + return; +} + +sub print_pass_local { + my ($test_file, $globals) = @_; + + print {$test_file} <<'END_CODE'; +## name Named magic variables, pass local +## failures 0 +## cut + +END_CODE + + for my $varname (@{$globals}) { + print {$test_file} "local $varname = ();\n"; + } + + print {$test_file} <<"END_CODE"; + +#----------------------------------------------------------------------------- + +## name Named magic variables, pass local() +## failures 0 +## cut + +END_CODE + + for my $varname (@{$globals}) { + print {$test_file} "local ($varname) = ();\n"; + } + + print {$test_file} <<"END_CODE"; + +#----------------------------------------------------------------------------- + +## name Named magic variables, pass (local) +## failures 0 +## cut + +END_CODE + + for my $varname (@{$globals}) { + print {$test_file} "(local $varname) = ();\n"; + } + + print {$test_file} <<"END_CODE"; + +#----------------------------------------------------------------------------- + +## name Named magic variables, pass = (local) = +## failures 0 +## cut + +END_CODE + + for my $varname (@{$globals}) { + print {$test_file} "\@foo = (local $varname) = ();\n"; + } + + return; +} + + +sub print_pass_local_deref { + my ($test_file, $globals) = @_; + + my %subscript = ( + '%' => '{foo}', + '@' => '[0]', + ); + + my @derefs = grep { $subscript{substr $_, 0, 1} } @{ $globals }; + + print {$test_file} <<"END_CODE"; + +#----------------------------------------------------------------------------- + +## name Named magic variables, pass local dereferenced +## failures 0 +## cut + +END_CODE + + foreach my $varname ( @derefs ) { + my ($sigil, $barename) = $varname =~ m/ (.)(.*) /smx; + print {$test_file} 'local $', $barename, + $subscript{$sigil}, " = 'bar';\n"; + } + +} + + +sub print_pass_non_local_exception { + my ($test_file, $globals) = @_; + + (my $except = "@$globals") =~ s< ([\\']) ><\\$1>gmsx; + print {$test_file} <<"END_CODE"; + +#----------------------------------------------------------------------------- + +## name Named magic variables, pass non-local but in exception list +## failures 0 +## parms { allow => '$except' } +## cut + +END_CODE + + foreach my $varname (@{$globals}) { + next if $exemptions{$varname}; + print {$test_file} "$varname = ();\n"; + } +} + + +sub print_fail_non_local { + my ($test_file, $globals, $numvars, $numcarats) = @_; + + print {$test_file} <<"END_CODE"; + +#----------------------------------------------------------------------------- + +## name Named magic variables, fail non-local, non-carats +## failures @{[$numvars - $numcarats]} +## cut + +END_CODE + + for my $varname (@{$globals}) { + next if $exemptions{$varname}; + next if $varname =~ m/ $carat_re /xms; + print {$test_file} "$varname = ();\n"; + } + + print {$test_file} <<"END_CODE"; + +#----------------------------------------------------------------------------- + +## name Named magic variables, fail non-local, carats +## failures $numcarats +## cut + +END_CODE + + for my $varname (@{$globals}) { + next if $exemptions{$varname}; + next if $varname !~ m/ $carat_re /xms; + print {$test_file} "$varname = ();\n"; + } + + print {$test_file} <<"END_CODE"; + +#----------------------------------------------------------------------------- + +## name Named magic variables, fail non-local, carats, no space +## failures $numcarats +## cut + +END_CODE + + for my $varname (@{$globals}) { + next if $exemptions{$varname}; + next if $varname !~ m/ $carat_re /xms; + print {$test_file} "$varname= ();\n"; + } + + print {$test_file} <<"END_CODE"; + +#----------------------------------------------------------------------------- + +## name Named magic variables, fail = (non-local) = +## failures $numvars +## cut + +END_CODE + + for my $varname (@{$globals}) { + next if $exemptions{$varname}; + print {$test_file} "\@foo = ($varname) = ();\n"; + } + + print {$test_file} <<"END_CODE"; + +#----------------------------------------------------------------------------- + +## name Named magic variables, fail (non-local) +## failures $numvars +## cut + +END_CODE + + for my $varname (@{$globals}) { + next if $exemptions{$varname}; + print {$test_file} "($varname) = ();\n"; + } + + return; +} + + +sub print_fail_non_local_deref { + my ($test_file, $globals) = @_; + + my %subscript = ( + '%' => '{foo}', + '@' => '[0]', + ); + + my @derefs = grep { $subscript{substr $_, 0, 1} && !$exemptions{$_} } + @{ $globals }; + my $numvars = scalar @derefs; + + print {$test_file} <<"END_CODE"; + +#----------------------------------------------------------------------------- + +## name Named magic variables, fail non-local dereferenced +## failures $numvars +## cut + +END_CODE + + foreach my $varname ( @derefs ) { + my ($sigil, $barename) = $varname =~ m/ (.)(.*) /smx; + print {$test_file} '$', $barename, + $subscript{$sigil}, " = 'bar';\n"; + } + +} + + +sub print_footer { + my ($test_file) = @_; + + print {$test_file} <<'END_CODE'; + +#----------------------------------------------------------------------------- + +## name Allowing a variable with a particular sigil doesn't allow other variables with the same name but different sigils +## failures 1 +## parms { allow => '$ARGV' } +## cut + +@ARGV = (1, 2, 3); + +#----------------------------------------------------------------------------- + +## name Allow "my" as well, RT #33937 +## failures 0 +## cut + +for my $entry ( + sort { + my @a = split m{,}xms, $a; + my @b = split m{,}xms, $b; + $a[0] cmp $b[0] || $a[1] <=> $b[1] + } qw( b,6 c,3 ) + ) +{ + print; +} + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : +END_CODE + + return; +} + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/Variables/RequireNegativeIndices.run b/t/Variables/RequireNegativeIndices.run new file mode 100644 index 0000000..7204018 --- /dev/null +++ b/t/Variables/RequireNegativeIndices.run @@ -0,0 +1,71 @@ +## name Basic passing +## failures 0 +## cut + +$arr[-1]; +$arr[ -2 ]; +$arr[$m-$n]; +$arr[@foo-1]; +$arr[$#foo-1]; +$arr[@$arr-1]; +$arr[$#$arr-1]; +1+$arr[$#{$arr}-1]; +$arr->[-1]; +$arr->[ -2 ]; +3+$arr->[@foo-1 ]; +$arr->[@arr-1 ]; +$arr->[ $#foo - 2 ]; +$$arr[-1]; +$$arr[ -2 ]; +$$arr[@foo-1 ]; +$$arr[@arr-1 ]; +$$arr[ $#foo - 2 ]; + +#----------------------------------------------------------------------------- + +## name Basic failure +## failures 5 +## cut + +$arr[$#arr]; +$arr[$#arr-1]; +$arr[ $#arr - 2 ]; +$arr[@arr-1]; +$arr[@arr - 2]; + +#----------------------------------------------------------------------------- + +## name Complex failures +## failures 8 +## cut + +$arr_ref->[$#{$arr_ref}-1]; +$arr_ref->[$#$arr_ref-1]; +$arr_ref->[@{$arr_ref}-1]; +$arr_ref->[@$arr_ref-1]; +$$arr_ref[$#{$arr_ref}-1]; +$$arr_ref[$#$arr_ref-1]; +$$arr_ref[@{$arr_ref}-1]; +$$arr_ref[@$arr_ref-1]; + +#----------------------------------------------------------------------------- + +## name Really hard failures that we can't detect yet +## failures 0 +## cut + +# These ones are too hard to detect for now; FIXME?? +$some->{complicated}->[$data_structure]->[$#{$some->{complicated}->[$data_structure]} -1]; +my $ref = $some->{complicated}->[$data_structure]; +$some->{complicated}->[$data_structure]->[$#{$ref} -1]; +$ref->[$#{$some->{complicated}->[$data_structure]} -1]; + +#----------------------------------------------------------------------------- +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/t/gh-734.t b/t/gh-734.t new file mode 100644 index 0000000..d58502c --- /dev/null +++ b/t/gh-734.t @@ -0,0 +1,79 @@ +#!perl + +use strict; +use warnings; + +use Perl::Critic::TestUtils qw(pcritique_with_violations); +use Readonly; + +use Test::More; + +Readonly::Scalar my $NUMBER_OF_TESTS => 7; + +plan( tests => $NUMBER_OF_TESTS ); + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); +Perl::Critic::TestUtils::block_perlcriticrc(); + +sub has_policy { + return eval { + require Perl::Critic::Policy::CodeLayout::ProhibitHashBarewords; + 1; + }; +} + +my $policy = 'CodeLayout::ProhibitHashBarewords'; +my $code; + +#----------------------------------------------------------------------------- +SKIP: { + +has_policy() + or skip 'You need CodeLayout::ProhibitHashBarewords policy for this test', + $NUMBER_OF_TESTS; + +$code = <<'END_PERL'; +my %hash = ( + foo => 1, + bar => 2, + + + + baz => 3, + + quux => 4, + + +); +END_PERL + +my @violations_re = ( + qr{^ \s* foo \s =>}xms, + qr{^ \s* bar \s =>}xms, + qr{^ \s* baz \s =>}xms, + qr{^ \s* quux \s =>}xms, +); + +my @violations; +my $rc = eval { @violations = pcritique_with_violations( $policy, \$code ); 2112; }; +is( $rc, 2112, 'Eval ran OK' ); +is( scalar @violations, 4, 'Found 4 violations' ); +is( scalar @violations, @violations_re, 'Violations and regexes match' ); + +foreach my $violation (@violations) { + my $violation_re = shift @violations_re; + like( $violation->source, $violation_re, 'Correct line for violation' ); +} + +} # end skip + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/tools/ppidump b/tools/ppidump new file mode 100755 index 0000000..2415d4e --- /dev/null +++ b/tools/ppidump @@ -0,0 +1,64 @@ +#!/usr/bin/env perl + +use strict; +use warnings; + +use PPI::Document; +use PPI::Dumper; + +my $whitespace = $ARGV[0] && $ARGV[0] eq '-w' ? shift : 0; +my $code = $ARGV[0] ? (-f $ARGV[0] ? shift : \shift) : \join q{}, ; +my $doc = PPI::Document->new( $code ) + or die 'Could not parse code: ', PPI::Document::errstr(), "\n"; +my $dump = PPI::Dumper->new( $doc, whitespace => $whitespace, locations => 1 ); +$dump->print(); + +__END__ + +#----------------------------------------------------------------------------- + +=pod + +=head1 NAME + +ppidump - Dump Perl code as PPI structure. + +=head1 SYNOPSIS + + ppidump #Read from STDIN + ppidump MyModule.pm #Read code from file + ppidump 'my $foo = $bar;' #Read code as from string + ppidump -w 'foo( );' #Show whitespace tokens + +=head1 DESCRIPTION + +This is a simple tool for helping to develop Perl::Critic::Policy +modules. If you want to see how L would parse a snippet of +code, just feed it to C. + +By default, whitespace tokens are hidden. Use the C<-w> flag to show +them. + +=head1 AUTHOR + +Jeffrey Ryan Thalhammer + +=head1 COPYRIGHT + +Copyright (c) 2005-2011 Imaginative Software Systems. All rights reserved. + +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. The full text of this license +can be found in the LICENSE file included with this module. + +=cut + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/xt/40_criticize-code.t b/xt/40_criticize-code.t new file mode 100644 index 0000000..6242021 --- /dev/null +++ b/xt/40_criticize-code.t @@ -0,0 +1,71 @@ +#!perl + +# Self-compliance tests + +use strict; +use warnings; + +use File::Spec qw(); + +use Perl::Critic::Utils qw{ :characters }; +use Perl::Critic::TestUtils qw{ starting_points_including_examples }; + +# Note: "use PolicyFactory" *must* appear after "use TestUtils" for the +# -extra-test-policies option to work. +use Perl::Critic::PolicyFactory ( + '-test' => 1, +); + +use Test::More; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +#----------------------------------------------------------------------------- + +use Test::Perl::Critic; + +#----------------------------------------------------------------------------- +# Set up PPI caching for speed (used primarily during development) + +if ( $ENV{PERL_CRITIC_CACHE} ) { + require PPI::Cache; + my $cache_path = + File::Spec->catdir( + File::Spec->tmpdir, + "test-perl-critic-cache-$ENV{USER}", + ); + if ( ! -d $cache_path) { + mkdir $cache_path, oct 700; + } + PPI::Cache->import( path => $cache_path ); +} + +#----------------------------------------------------------------------------- +# Strict object testing -- prevent direct hash key access + +use Devel::EnforceEncapsulation; +foreach my $pkg ( $EMPTY, qw< ::Config ::Policy ::Violation> ) { + Devel::EnforceEncapsulation->apply_to('Perl::Critic'.$pkg); +} + +#----------------------------------------------------------------------------- +# Run critic against all of our own files + +my $rcfile = File::Spec->catfile( 'xt', '40_perlcriticrc-code' ); +Test::Perl::Critic->import( -profile => $rcfile ); + +all_critic_ok( starting_points_including_examples() ); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/xt/40_perlcriticrc-code b/xt/40_perlcriticrc-code new file mode 100644 index 0000000..c63df2c --- /dev/null +++ b/xt/40_perlcriticrc-code @@ -0,0 +1,49 @@ +profile-strictness = fatal +severity = 1 +theme = core +verbose = %f: %m at line %l, column %c. %e. (Severity: %s, %p)\n + +#----------------------------------------------------------------------------- + +[BuiltinFunctions::ProhibitStringyEval] +allow_includes = 1 + +[CodeLayout::ProhibitHardTabs] +allow_leading_tabs = 0 + +[CodeLayout::ProhibitQuotedWordLists] +strict = 1 + +[-CodeLayout::RequireTidyCode] + +[Documentation::PodSpelling] +spell_command = aspell list -l en_US +stop_words_file = xt/40_stop_words + +[Documentation::RequirePodSections] +lib_sections = NAME|DESCRIPTION|AUTHOR|COPYRIGHT +script_sections = NAME|DESCRIPTION|AUTHOR|COPYRIGHT + +# Wrapping Exception constructor calls across lines runs into 9 lines too quickly. +[InputOutput::RequireBriefOpen] +lines = 20 + +[InputOutput::RequireCheckedSyscalls] +functions = open close + +[-Miscellanea::ProhibitUselessNoCritic] +# With Perl 5.32, isa() becomes a reserved word. This means we need to Subroutines::ProhibitBuiltinHomonyms for it. +# However, for all other Perls, that causes a Miscellanea::ProhibitUselessNoCritic to fire. + +[RegularExpressions::ProhibitUnusualDelimiters] +allow_all_brackets = 1 + +[RegularExpressions::RequireBracesForMultiline] +allow_all_brackets = 1 + +[Subroutines::ProhibitUnusedPrivateSubroutines] +private_name_regex = _(?!_)\w+ +allow = _get_behavior_values _get_description_with_trailing_period + +[Subroutines::ProtectPrivateSubs] +private_name_regex = _(?!_)\w+ diff --git a/xt/40_stop_words b/xt/40_stop_words new file mode 100644 index 0000000..f173360 --- /dev/null +++ b/xt/40_stop_words @@ -0,0 +1,118 @@ +accessor +accessors +ActiveState +autoflushes +AUTOLOAD +backticks +bareword +barewords +BBEdit +bitwise +boolean +booleans +builtin +CGI +colour +colours +config +Conway's +CPAN +customizable +CVS +dereference +dereferencing +Dolan +Dominus +elsif +evaluatable +exponentials +filehandle +filehandles +filename +filenames +Fowler's +globals +globbing +Guzis +hashref +Hasselbacher +HEREDOC +HEREDOCs +IDE +lvalue +maintainer's +matcher +Maxia +Mehner +memoization +merchantability +metacharacters +Metadata +metadata +misterwhipple +multi-line +mutators +namespace +namespaces +octothorp +optimizations +PBP +pbp +perl +perlcritic +perlcriticrc +perldoc +Perlish +perlmonk +perls +PDK +PolicyListing +POSIX +postfix +PPI +PPI's +pragma +pragmas +pragmata +prepend +prepending +programmatically +ProhibitPunctuationVars +quotish +readline +Readonly +refactor +refactoring +regex +regexes +runtime +Schwartzian +segfault +severities +sigil +sigils +SQL +STDERR +STDIN +STDOUT +stringification +subclasses +subdirectories +subscripted +superclass +superclasses +TerMarsch +Thalhammer +TODO +typeglob +UI +unblessed +undef +unescaped +unparsed +untestable +untrusted +unvalidated +vice-versa +whitespace +Wyant diff --git a/xt/41_criticize-policies.t b/xt/41_criticize-policies.t new file mode 100644 index 0000000..6f9d4ef --- /dev/null +++ b/xt/41_criticize-policies.t @@ -0,0 +1,64 @@ +#!perl + +# Extra self-compliance tests for Policy classes. This just checks for +# additional POD sections that we want in every Policy module. See the +# 41_perlcriticrc-policies file for the precise configuration. + +use strict; +use warnings; + +use File::Spec qw<>; + +use Perl::Critic::PolicyFactory ( '-test' => 1 ); + +use Test::More; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +#----------------------------------------------------------------------------- + +use Test::Perl::Critic; + +#----------------------------------------------------------------------------- + +# Set up PPI caching for speed (used primarily during development) + +if ( $ENV{PERL_CRITIC_CACHE} ) { + require PPI::Cache; + my $cache_path = + File::Spec->catdir( + File::Spec->tmpdir(), + "test-perl-critic-cache-$ENV{USER}" + ); + if ( ! -d $cache_path) { + mkdir $cache_path, oct 700; + } + PPI::Cache->import( path => $cache_path ); +} + +#----------------------------------------------------------------------------- +# Run critic against all of our own files + +my $rcfile = File::Spec->catfile( qw< xt 41_perlcriticrc-policies > ); +Test::Perl::Critic->import( -profile => $rcfile ); + +my $path = + File::Spec->catfile( + -e 'blib' ? 'blib/lib' : 'lib', + qw< Perl Critic Policy >, + ); +all_critic_ok( $path ); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/xt/41_perlcriticrc-policies b/xt/41_perlcriticrc-policies new file mode 100644 index 0000000..158748d --- /dev/null +++ b/xt/41_perlcriticrc-policies @@ -0,0 +1,9 @@ +profile-strictness = fatal +severity = 1 +only = 1 +verbose = %f: %m at line %l, column %c. %e. (Severity: %s, %p)\n + +#----------------------------------------------------------------------------- + +[Documentation::RequirePodSections] +lib_sections = NAME|AFFILIATION|DESCRIPTION|CONFIGURATION|AUTHOR|COPYRIGHT diff --git a/xt/42_criticize-tests.t b/xt/42_criticize-tests.t new file mode 100644 index 0000000..a279962 --- /dev/null +++ b/xt/42_criticize-tests.t @@ -0,0 +1,66 @@ +#!perl + +# Self-compliance tests + +use strict; +use warnings; + +use File::Spec qw(); + +use Perl::Critic::Utils qw{ :characters }; +use Perl::Critic::TestUtils qw{ starting_points_including_examples }; + +# Note: "use PolicyFactory" *must* appear after "use TestUtils" for the +# -extra-test-policies option to work. +use Perl::Critic::PolicyFactory ( + '-test' => 1, +); + +use Test::More; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +#----------------------------------------------------------------------------- + +use Test::Perl::Critic; + +#----------------------------------------------------------------------------- +# Set up PPI caching for speed (used primarily during development) + +if ( $ENV{PERL_CRITIC_CACHE} ) { + require PPI::Cache; + my $cache_path = + File::Spec->catdir( + File::Spec->tmpdir, + "test-perl-critic-cache-$ENV{USER}", + ); + if ( ! -d $cache_path) { + mkdir $cache_path, oct 700; + } + PPI::Cache->import( path => $cache_path ); +} + +#----------------------------------------------------------------------------- +# Run critic against all of our own files + +my $rcfile = File::Spec->catfile( 'xt', '42_perlcriticrc-tests' ); +Test::Perl::Critic->import( -profile => $rcfile ); + +all_critic_ok( + glob ('t/*.t'), + glob ('xt/*.t'), +); + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/xt/42_perlcriticrc-tests b/xt/42_perlcriticrc-tests new file mode 100644 index 0000000..358ef9a --- /dev/null +++ b/xt/42_perlcriticrc-tests @@ -0,0 +1,55 @@ +profile-strictness = fatal +severity = 1 +theme = core +verbose = %f: %m at line %l, column %c. %e. (Severity: %s, %p)\n + +#----------------------------------------------------------------------------- + +[BuiltinFunctions::ProhibitStringyEval] +allow_includes = 1 + +[CodeLayout::ProhibitQuotedWordLists] +strict = 1 + +[CodeLayout::ProhibitHardTabs] +allow_leading_tabs = 0 + +[-CodeLayout::RequireTidyCode] + +[ControlStructures::ProhibitPostfixControls] +flowcontrol = warn die carp croak cluck confess goto exit plan skip + +# None of our tests contain real POD, but POD::Spell gets confused by the code +# in some of our test files. +[-Documentation::PodSpelling] + +[-Documentation::RequirePodSections] + +# Too endemic for me to deal with right now +[-ErrorHandling::RequireCheckingReturnValueOfEval] + +# Wrapping Exception constructor calls across lines runs into 9 lines too quickly. +[InputOutput::RequireBriefOpen] +lines = 20 + +[InputOutput::RequireCheckedSyscalls] +functions = open close + +# Character length is not a proper measure of complexity. +[-RegularExpressions::ProhibitComplexRegexes] + +[RegularExpressions::ProhibitUnusualDelimiters] +allow_all_brackets = 1 + +[RegularExpressions::RequireBracesForMultiline] +allow_all_brackets = 1 + +# Tests are allowed to peek. +[-Subroutines::ProtectPrivateSubs] + +# Tests can be evil. +[TestingAndDebugging::ProhibitNoWarnings] +allow = redefine + +# Too endemic for me to deal with right now. +[-ValuesAndExpressions::ProhibitMagicNumbers] diff --git a/xt/43_criticize-run-files.t b/xt/43_criticize-run-files.t new file mode 100644 index 0000000..64cd426 --- /dev/null +++ b/xt/43_criticize-run-files.t @@ -0,0 +1,61 @@ +#!perl + +# Simple self-compliance tests for .run files. + +use strict; +use warnings; + +use File::Spec qw<>; + +use Test::More; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +#----------------------------------------------------------------------------- + +use Test::Perl::Critic; + +#----------------------------------------------------------------------------- + +# Set up PPI caching for speed (used primarily during development) + +if ( $ENV{PERL_CRITIC_CACHE} ) { + require PPI::Cache; + my $cache_path = + File::Spec->catdir( + File::Spec->tmpdir(), + "test-perl-critic-cache-$ENV{USER}" + ); + if ( ! -d $cache_path) { + mkdir $cache_path, oct 700; + } + PPI::Cache->import( path => $cache_path ); +} + +#----------------------------------------------------------------------------- +# Run critic against all of our own files + +my $rcfile = File::Spec->catfile( qw< xt 43_perlcriticrc-run-files > ); +Test::Perl::Critic->import( -profile => $rcfile ); + +{ + # About to commit evil, but it's against ourselves. + no warnings qw< redefine >; + local *Perl::Critic::Utils::_is_perl = sub { 1 }; ## no critic (Variables::ProtectPrivateVars) + + all_critic_ok( glob 't/*/*.run' ); +} + +#----------------------------------------------------------------------------- + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/xt/43_perlcriticrc-run-files b/xt/43_perlcriticrc-run-files new file mode 100644 index 0000000..2054028 --- /dev/null +++ b/xt/43_perlcriticrc-run-files @@ -0,0 +1,11 @@ +profile-strictness = fatal +severity = 1 +only = 1 +verbose = %f: %m at line %l, column %c. %e. (Severity: %s, %p)\n + +#----------------------------------------------------------------------------- + +[CodeLayout::ProhibitHardTabs] +allow_leading_tabs = 0 + +[CodeLayout::ProhibitTrailingWhitespace] diff --git a/xt/80_policysummary.t b/xt/80_policysummary.t new file mode 100644 index 0000000..8807048 --- /dev/null +++ b/xt/80_policysummary.t @@ -0,0 +1,95 @@ +#!perl + +use strict; +use warnings; + +use English qw< -no_match_vars >; +use Carp qw< confess >; + +use File::Spec; + +use Perl::Critic::PolicyFactory ( -test => 1 ); +use Perl::Critic::TestUtils qw{ bundled_policy_names }; + +use Test::More; + +our $VERSION = '1.140'; + +Perl::Critic::TestUtils::assert_version( $VERSION ); + +#----------------------------------------------------------------------------- + +my $summary_file = + File::Spec->catfile( qw< lib Perl Critic PolicySummary.pod > ); +if (open my ($fh), '<', $summary_file) { + + my $content = do {local $INPUT_RECORD_SEPARATOR=undef; <$fh> }; + close $fh or confess "Couldn't close $summary_file: $OS_ERROR"; + + my @policy_names = bundled_policy_names(); + my @summaries = $content =~ m/^=head2 [ ]+ L<[\w:]+[|]([\w:]+)>/gxms; + plan( tests => 2 + 2 * @policy_names ); + + my %num_summaries; + for my $summary (@summaries) { + ++$num_summaries{$summary}; + } + if (!ok(@summaries == keys %num_summaries, 'right number of summaries')) { + for my $policy_name (sort keys %num_summaries) { + next if 1 == $num_summaries{$policy_name}; + diag('Duplicate summary for ' . $policy_name); + } + } + + my $profile = Perl::Critic::UserProfile->new(); + my $factory = Perl::Critic::PolicyFactory->new( -profile => $profile ); + my %found_policies = map { ref $_ => $_ } $factory->create_all_policies(); + + my %descriptions = $content =~ m/^=head2 [ ]+ L<[\w:]+[|]([\w:]+)>\n\n([^\n]+)/gxms; + for my $policy_name (keys %descriptions) { + my $severity; + if ( + $descriptions{$policy_name} =~ s/ [ ] \[ Default [ ] severity [ ] (\d+) \] //xms + ) { + $severity = $1; + } + else { + $severity = ''; + } + + $descriptions{$policy_name} = { + desc => $descriptions{$policy_name}, + severity => $severity, + }; + } + + for my $policy_name ( @policy_names ) { + my $label = qq{PolicySummary.pod has "$policy_name"}; + my $has_summary = delete $num_summaries{$policy_name}; + is( $has_summary, 1, $label ); + + my $summary_severity = $descriptions{$policy_name}->{severity}; + my $real_severity = $found_policies{$policy_name} && + $found_policies{$policy_name}->default_severity; + is( $summary_severity, $real_severity, "severity for $policy_name" ); + } + + if (!ok(0 == keys %num_summaries, 'no extra summaries')) { + for my $policy_name (sort keys %num_summaries) { + diag('Extraneous summary for ' . $policy_name); + } + } +} +else { + plan 'no_plan'; + fail qq; +} + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/xt/81_ppi_problems.t b/xt/81_ppi_problems.t new file mode 100644 index 0000000..331aabf --- /dev/null +++ b/xt/81_ppi_problems.t @@ -0,0 +1,63 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use PPI::Document; + +use Test::More tests => 1; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +#----------------------------------------------------------------------------- + +# Things we're looking for from PPI. + +{ + local $TODO = q; + + my $document = PPI::Document->new(\'sub { }'); + + # Since we don't know what a correctly parsing PPI would do, simply test + # that it doesn't like it does when it doesn't correctly parse. + my @children = $document->schildren(); + if ( + @children == 1 + and ( my $statement = $children[0] )->isa('PPI::Statement') + ) { + @children = $statement->schildren(); + if (@children == 2) { + my ($maybe_sub, $maybe_block) = @children; + + if ( + $maybe_sub->isa('PPI::Token::Word') + and $maybe_sub->content() eq 'sub' + and $maybe_block->isa('PPI::Structure::Block') + and $maybe_block->schildren() == 0 + ) { + fail(q); + } + else { + pass(q); + } + } + else { + pass(q); + } + } + else { + pass(q); + } +} + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/xt/94_includes.t b/xt/94_includes.t new file mode 100644 index 0000000..d428767 --- /dev/null +++ b/xt/94_includes.t @@ -0,0 +1,103 @@ +#!perl + +use strict; +use warnings; + +use Carp qw< confess >; + +use File::Find; +use PPI::Document; + +use Test::More; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +my %implied = ( + # Universal + SUPER => 1, + + 'Readonly::Scalar' => 'Readonly', + 'Readonly::Array' => 'Readonly', + 'Readonly::Hash' => 'Readonly', +); + + +my @pm; +find( + { + wanted => sub { if (m< [.] pm \z >xms && ! mxms) { push @pm, $_ } }, + no_chdir => 1, + }, + 'lib', +); +plan tests => scalar @pm; + +for my $file (@pm) { + SKIP: + { + my $doc = PPI::Document->new($file) or confess qq; + + my @incs = @{$doc->find('PPI::Statement::Include') || []}; + my %deps = map {$_->module => 1} grep {$_->type eq 'use' || $_->type eq 'require'} @incs; + my %thispkg = map {$_->namespace => 1} @{$doc->find('PPI::Statement::Package') || []}; + my @pkgs = @{$doc->find('PPI::Token::Word')}; + my %failed; + + for my $pkg (@pkgs) { + my $name = "$pkg"; + next if $name !~ m/::/xms; + next if $name =~ m/::_private::/xms; + next if $name =~ m/List::Util::[[:lower:]]+/xms; + + # subroutine declaration with absolute name? + # (bad form, but legal) + my $prev_sib = $pkg->sprevious_sibling; + next if ($prev_sib && + $prev_sib eq 'sub' && + !$prev_sib->sprevious_sibling && + $pkg->parent->isa('PPI::Statement::Sub')); + + my $token = $pkg->next_sibling; + + if ($token =~ m< \A [(] >xms) { + $name =~ s/::\w+\z//xms; + } + + if ( !match($name, \%deps, \%thispkg) ) { + $failed{$name} = 1; + } + } + + my @failures = sort keys %failed; + ok(@failures == 0, "$file has an include statement for each package that it refers to.") + or do { + diag("Found dependencies: @{[sort keys %deps]}."); + diag("Missing import of: @failures."); + }; + } +} + +sub match { + my $pkg = shift; + my $deps = shift; + my $thispkg = shift; + + return 1 if $thispkg->{$pkg}; + return 1 if $deps->{$pkg}; + $pkg = $implied{$pkg}; + return 0 if !defined $pkg; + return 1 if '1' eq $pkg; + return match($pkg, $deps, $thispkg); +} + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/xt/95_kwalitee.t b/xt/95_kwalitee.t new file mode 100644 index 0000000..eaf8e21 --- /dev/null +++ b/xt/95_kwalitee.t @@ -0,0 +1,24 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +eval 'use Test::Kwalitee 1.15 tests => [ qw{ -no_symlinks } ]; 1' + or plan skip_all => 'Test::Kwalitee required to test kwalitee'; + + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/xt/98_pod_syntax.t b/xt/98_pod_syntax.t new file mode 100644 index 0000000..86bf6e4 --- /dev/null +++ b/xt/98_pod_syntax.t @@ -0,0 +1,27 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Perl::Critic::TestUtils qw{ starting_points_including_examples }; + +use Test::More;# 1.41; # Need 1.41 or newer for correct support of L links. + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +use Test::Pod 1.00; + +all_pod_files_ok( all_pod_files( starting_points_including_examples() ) ); + +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : diff --git a/xt/99_pod_coverage.t b/xt/99_pod_coverage.t new file mode 100644 index 0000000..79ca128 --- /dev/null +++ b/xt/99_pod_coverage.t @@ -0,0 +1,70 @@ +#!perl + +use 5.006001; +use strict; +use warnings; + +use Test::More; + +our $VERSION = '1.140'; + +use Perl::Critic::TestUtils; +Perl::Critic::TestUtils::assert_version( $VERSION ); + +use Test::Pod::Coverage 1.04; + +{ + # HACK: Perl::Critic::Violation uses Pod::Parser to extract the + # DIAGNOSTIC section of the POD in each Policy module. This + # happens when the Policy first C the Violation module. + # Meanwhile, Pod::Coverage also uses Pod::Parser to extract the + # POD and compare it with the subroutines that are in the symbol + # table for that module. For reasons I cannot yet explain, using + # Pod::Parser twice this way causes the symbol table to get very + # wacky and this test program dies with "Can't call method 'OPEN' + # on IO::String at line 1239 of Pod/Parser.pm". + + # For now, my workaround is to temporarily redefine the import() + # method in the Violation module so that it doesn't do any Pod + # parsing. I'll look for a better solution (or file a bug report) + # when / if I have better understanding of the problem. + + no warnings qw; ## no critic (ProhibitNoWarnings) + require Perl::Critic::Violation; + *Perl::Critic::Violation::import = sub { 1 }; +} + +my @trusted_methods = get_trusted_methods(); +my $method_string = join ' | ', @trusted_methods; +my $trusted_rx = qr{ \A (?: $method_string ) \z }xms; +all_pod_coverage_ok( {trustme => [$trusted_rx]} ); + +#----------------------------------------------------------------------------- + +sub get_trusted_methods { + return qw( + new + initialize_if_enabled + prepare_to_scan_document + violates + applies_to + is_safe + default_themes + default_maximum_violations_per_document + default_severity + supported_parameters + description + Fields + got_sigpipe + ); +} + +############################################################################## +# Local Variables: +# mode: cperl +# cperl-indent-level: 4 +# fill-column: 78 +# indent-tabs-mode: nil +# c-indentation-style: bsd +# End: +# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :