Perl-Critic-1.126000755000766000024 012562314714 13044 5ustar00jeffstaff000000000000.travis.yml000444000766000024 104312562314714 15231 0ustar00jeffstaff000000000000Perl-Critic-1.126sudo: false language: perl perl: - "5.21" - "5.20" - "5.18" - "5.16" - "5.14" - "5.12" - "5.10" - "5.8" notifications: on_success: change on_failure: always irc: channels: - "irc.perl.org#perlcritic" template: - "%{branch}: %{message} %{build_url}" addons: apt: packages: - aspell - aspell-en install: - cpanm Perl::Critic::More Test::Perl::Critic Devel::EnforceEncapsulation script: - export HARNESS_OPTIONS='j:c' - perl Build.PL - ./Build authortest Build.PL000444000766000024 520012562314714 14413 0ustar00jeffstaff000000000000Perl-Critic-1.126use 5.006001; use strict; use warnings; use Module::Build 0.4200; # 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.4024', }, 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 => 'http://perlcritic.tigris.org/servlets/SummarizeList?listName=users', 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 : Changes000444000766000024 25747412562314714 14500 0ustar00jeffstaff000000000000Perl-Critic-1.126Revision history for Perl module Perl::Critic 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 : INSTALL000444000766000024 37612562314714 14141 0ustar00jeffstaff000000000000Perl-Critic-1.126INSTALLATION 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 LICENSE000444000766000024 4737012562314714 14162 0ustar00jeffstaff000000000000Perl-Critic-1.126Terms 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" ---------------------------------------------------------------------------- The General Public License (GPL) Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 675 Mass Ave, Cambridge, MA 02139, USA. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU 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. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), 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 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 show them these terms so they know 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. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. 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 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 derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 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 License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. 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. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary 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 License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 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 Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing 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 for copying, distributing or modifying the Program or works based on it. 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. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. 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 this 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 this License, you may choose any version ever published by the Free Software Foundation. 10. 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 11. 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. 12. 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 MANIFEST000444000766000024 4736412562314714 14311 0ustar00jeffstaff000000000000Perl-Critic-1.126.travis.yml bin/perlcritic Build.PL Changes 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/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/RequirePodLinksIncludeText.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 README.md t/00_modules.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/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/RequirePodLinksIncludeText.run t/Documentation/RequirePodSections.run t/ErrorHandling/RequireCarping.run t/ErrorHandling/RequireCheckingReturnValueOfEval.run 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/author/40_criticize-code.t xt/author/40_perlcriticrc-code xt/author/40_stop_words xt/author/41_criticize-policies.t xt/author/41_perlcriticrc-policies xt/author/42_criticize-tests.t xt/author/42_perlcriticrc-tests xt/author/43_criticize-run-files.t xt/author/43_perlcriticrc-run-files xt/author/80_policysummary.t xt/author/81_ppi_problems.t xt/author/93_version.t xt/author/94_includes.t xt/author/95_kwalitee.t xt/author/98_pod_syntax.t xt/author/99_pod_coverage.t README META.yml META.json META.json000444000766000024 11460012562314714 14605 0ustar00jeffstaff000000000000Perl-Critic-1.126{ "abstract" : "Critique Perl source code for best-practices.", "author" : [ "Jeffrey Thalhammer " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.421", "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.4024" } }, "runtime" : { "requires" : { "B::Keywords" : "1.05", "Carp" : "0", "Config::Tiny" : "2", "Email::Address" : "1.889", "English" : "0", "Exception::Class" : "1.23", "Exporter" : "5.63", "File::Basename" : "0", "File::Find" : "0", "File::HomeDir" : "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::Pluggable" : "3.1", "PPI" : "1.220", "PPI::Document" : "1.220", "PPI::Document::File" : "1.220", "PPI::Node" : "1.220", "PPI::Token::Quote::Single" : "1.220", "PPI::Token::Whitespace" : "1.220", "PPIx::Regexp" : "0.027", "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.13", "Task::Weaken" : "0", "Term::ANSIColor" : "2.02", "Test::Builder" : "0.92", "Text::ParseWords" : "3", "base" : "0", "charnames" : "0", "overload" : "0", "strict" : "0", "version" : "0.77", "warnings" : "0" } } }, "provides" : { "Perl::Critic" : { "file" : "lib/Perl/Critic.pm", "version" : "1.126" }, "Perl::Critic::Annotation" : { "file" : "lib/Perl/Critic/Annotation.pm", "version" : "1.126" }, "Perl::Critic::Command" : { "file" : "lib/Perl/Critic/Command.pm", "version" : "1.126" }, "Perl::Critic::Config" : { "file" : "lib/Perl/Critic/Config.pm", "version" : "1.126" }, "Perl::Critic::Document" : { "file" : "lib/Perl/Critic/Document.pm", "version" : "1.126" }, "Perl::Critic::Exception" : { "file" : "lib/Perl/Critic/Exception.pm", "version" : "1.126" }, "Perl::Critic::Exception::AggregateConfiguration" : { "file" : "lib/Perl/Critic/Exception/AggregateConfiguration.pm", "version" : "1.126" }, "Perl::Critic::Exception::Configuration" : { "file" : "lib/Perl/Critic/Exception/Configuration.pm", "version" : "1.126" }, "Perl::Critic::Exception::Configuration::Generic" : { "file" : "lib/Perl/Critic/Exception/Configuration/Generic.pm", "version" : "1.126" }, "Perl::Critic::Exception::Configuration::NonExistentPolicy" : { "file" : "lib/Perl/Critic/Exception/Configuration/NonExistentPolicy.pm", "version" : "1.126" }, "Perl::Critic::Exception::Configuration::Option" : { "file" : "lib/Perl/Critic/Exception/Configuration/Option.pm", "version" : "1.126" }, "Perl::Critic::Exception::Configuration::Option::Global" : { "file" : "lib/Perl/Critic/Exception/Configuration/Option/Global.pm", "version" : "1.126" }, "Perl::Critic::Exception::Configuration::Option::Global::ExtraParameter" : { "file" : "lib/Perl/Critic/Exception/Configuration/Option/Global/ExtraParameter.pm", "version" : "1.126" }, "Perl::Critic::Exception::Configuration::Option::Global::ParameterValue" : { "file" : "lib/Perl/Critic/Exception/Configuration/Option/Global/ParameterValue.pm", "version" : "1.126" }, "Perl::Critic::Exception::Configuration::Option::Policy" : { "file" : "lib/Perl/Critic/Exception/Configuration/Option/Policy.pm", "version" : "1.126" }, "Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter" : { "file" : "lib/Perl/Critic/Exception/Configuration/Option/Policy/ExtraParameter.pm", "version" : "1.126" }, "Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue" : { "file" : "lib/Perl/Critic/Exception/Configuration/Option/Policy/ParameterValue.pm", "version" : "1.126" }, "Perl::Critic::Exception::Fatal" : { "file" : "lib/Perl/Critic/Exception/Fatal.pm", "version" : "1.126" }, "Perl::Critic::Exception::Fatal::Generic" : { "file" : "lib/Perl/Critic/Exception/Fatal/Generic.pm", "version" : "1.126" }, "Perl::Critic::Exception::Fatal::Internal" : { "file" : "lib/Perl/Critic/Exception/Fatal/Internal.pm", "version" : "1.126" }, "Perl::Critic::Exception::Fatal::PolicyDefinition" : { "file" : "lib/Perl/Critic/Exception/Fatal/PolicyDefinition.pm", "version" : "1.126" }, "Perl::Critic::Exception::IO" : { "file" : "lib/Perl/Critic/Exception/IO.pm", "version" : "1.126" }, "Perl::Critic::Exception::Parse" : { "file" : "lib/Perl/Critic/Exception/Parse.pm", "version" : "1.126" }, "Perl::Critic::OptionsProcessor" : { "file" : "lib/Perl/Critic/OptionsProcessor.pm", "version" : "1.126" }, "Perl::Critic::Policy" : { "file" : "lib/Perl/Critic/Policy.pm", "version" : "1.126" }, "Perl::Critic::Policy::BuiltinFunctions::ProhibitBooleanGrep" : { "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitBooleanGrep.pm", "version" : "1.126" }, "Perl::Critic::Policy::BuiltinFunctions::ProhibitComplexMappings" : { "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitComplexMappings.pm", "version" : "1.126" }, "Perl::Critic::Policy::BuiltinFunctions::ProhibitLvalueSubstr" : { "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitLvalueSubstr.pm", "version" : "1.126" }, "Perl::Critic::Policy::BuiltinFunctions::ProhibitReverseSortBlock" : { "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitReverseSortBlock.pm", "version" : "1.126" }, "Perl::Critic::Policy::BuiltinFunctions::ProhibitSleepViaSelect" : { "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitSleepViaSelect.pm", "version" : "1.126" }, "Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval" : { "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringyEval.pm", "version" : "1.126" }, "Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit" : { "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringySplit.pm", "version" : "1.126" }, "Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalCan" : { "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalCan.pm", "version" : "1.126" }, "Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa" : { "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalIsa.pm", "version" : "1.126" }, "Perl::Critic::Policy::BuiltinFunctions::ProhibitUselessTopic" : { "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUselessTopic.pm", "version" : "1.126" }, "Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep" : { "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidGrep.pm", "version" : "1.126" }, "Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap" : { "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidMap.pm", "version" : "1.126" }, "Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep" : { "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockGrep.pm", "version" : "1.126" }, "Perl::Critic::Policy::BuiltinFunctions::RequireBlockMap" : { "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockMap.pm", "version" : "1.126" }, "Perl::Critic::Policy::BuiltinFunctions::RequireGlobFunction" : { "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/RequireGlobFunction.pm", "version" : "1.126" }, "Perl::Critic::Policy::BuiltinFunctions::RequireSimpleSortBlock" : { "file" : "lib/Perl/Critic/Policy/BuiltinFunctions/RequireSimpleSortBlock.pm", "version" : "1.126" }, "Perl::Critic::Policy::ClassHierarchies::ProhibitAutoloading" : { "file" : "lib/Perl/Critic/Policy/ClassHierarchies/ProhibitAutoloading.pm", "version" : "1.126" }, "Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA" : { "file" : "lib/Perl/Critic/Policy/ClassHierarchies/ProhibitExplicitISA.pm", "version" : "1.126" }, "Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless" : { "file" : "lib/Perl/Critic/Policy/ClassHierarchies/ProhibitOneArgBless.pm", "version" : "1.126" }, "Perl::Critic::Policy::CodeLayout::ProhibitHardTabs" : { "file" : "lib/Perl/Critic/Policy/CodeLayout/ProhibitHardTabs.pm", "version" : "1.126" }, "Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins" : { "file" : "lib/Perl/Critic/Policy/CodeLayout/ProhibitParensWithBuiltins.pm", "version" : "1.126" }, "Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists" : { "file" : "lib/Perl/Critic/Policy/CodeLayout/ProhibitQuotedWordLists.pm", "version" : "1.126" }, "Perl::Critic::Policy::CodeLayout::ProhibitTrailingWhitespace" : { "file" : "lib/Perl/Critic/Policy/CodeLayout/ProhibitTrailingWhitespace.pm", "version" : "1.126" }, "Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines" : { "file" : "lib/Perl/Critic/Policy/CodeLayout/RequireConsistentNewlines.pm", "version" : "1.126" }, "Perl::Critic::Policy::CodeLayout::RequireTidyCode" : { "file" : "lib/Perl/Critic/Policy/CodeLayout/RequireTidyCode.pm", "version" : "1.126" }, "Perl::Critic::Policy::CodeLayout::RequireTrailingCommas" : { "file" : "lib/Perl/Critic/Policy/CodeLayout/RequireTrailingCommas.pm", "version" : "1.126" }, "Perl::Critic::Policy::ControlStructures::ProhibitCStyleForLoops" : { "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitCStyleForLoops.pm", "version" : "1.126" }, "Perl::Critic::Policy::ControlStructures::ProhibitCascadingIfElse" : { "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitCascadingIfElse.pm", "version" : "1.126" }, "Perl::Critic::Policy::ControlStructures::ProhibitDeepNests" : { "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitDeepNests.pm", "version" : "1.126" }, "Perl::Critic::Policy::ControlStructures::ProhibitLabelsWithSpecialBlockNames" : { "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitLabelsWithSpecialBlockNames.pm", "version" : "1.126" }, "Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions" : { "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitMutatingListFunctions.pm", "version" : "1.126" }, "Perl::Critic::Policy::ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions" : { "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.pm", "version" : "1.126" }, "Perl::Critic::Policy::ControlStructures::ProhibitPostfixControls" : { "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitPostfixControls.pm", "version" : "1.126" }, "Perl::Critic::Policy::ControlStructures::ProhibitUnlessBlocks" : { "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitUnlessBlocks.pm", "version" : "1.126" }, "Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode" : { "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitUnreachableCode.pm", "version" : "1.126" }, "Perl::Critic::Policy::ControlStructures::ProhibitUntilBlocks" : { "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitUntilBlocks.pm", "version" : "1.126" }, "Perl::Critic::Policy::ControlStructures::ProhibitYadaOperator" : { "file" : "lib/Perl/Critic/Policy/ControlStructures/ProhibitYadaOperator.pm", "version" : "1.126" }, "Perl::Critic::Policy::Documentation::PodSpelling" : { "file" : "lib/Perl/Critic/Policy/Documentation/PodSpelling.pm", "version" : "1.126" }, "Perl::Critic::Policy::Documentation::RequirePackageMatchesPodName" : { "file" : "lib/Perl/Critic/Policy/Documentation/RequirePackageMatchesPodName.pm", "version" : "1.126" }, "Perl::Critic::Policy::Documentation::RequirePodAtEnd" : { "file" : "lib/Perl/Critic/Policy/Documentation/RequirePodAtEnd.pm", "version" : "1.126" }, "Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText" : { "file" : "lib/Perl/Critic/Policy/Documentation/RequirePodLinksIncludeText.pm", "version" : "1.126" }, "Perl::Critic::Policy::Documentation::RequirePodSections" : { "file" : "lib/Perl/Critic/Policy/Documentation/RequirePodSections.pm", "version" : "1.126" }, "Perl::Critic::Policy::ErrorHandling::RequireCarping" : { "file" : "lib/Perl/Critic/Policy/ErrorHandling/RequireCarping.pm", "version" : "1.126" }, "Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval" : { "file" : "lib/Perl/Critic/Policy/ErrorHandling/RequireCheckingReturnValueOfEval.pm", "version" : "1.126" }, "Perl::Critic::Policy::InputOutput::ProhibitBacktickOperators" : { "file" : "lib/Perl/Critic/Policy/InputOutput/ProhibitBacktickOperators.pm", "version" : "1.126" }, "Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles" : { "file" : "lib/Perl/Critic/Policy/InputOutput/ProhibitBarewordFileHandles.pm", "version" : "1.126" }, "Perl::Critic::Policy::InputOutput::ProhibitExplicitStdin" : { "file" : "lib/Perl/Critic/Policy/InputOutput/ProhibitExplicitStdin.pm", "version" : "1.126" }, "Perl::Critic::Policy::InputOutput::ProhibitInteractiveTest" : { "file" : "lib/Perl/Critic/Policy/InputOutput/ProhibitInteractiveTest.pm", "version" : "1.126" }, "Perl::Critic::Policy::InputOutput::ProhibitJoinedReadline" : { "file" : "lib/Perl/Critic/Policy/InputOutput/ProhibitJoinedReadline.pm", "version" : "1.126" }, "Perl::Critic::Policy::InputOutput::ProhibitOneArgSelect" : { "file" : "lib/Perl/Critic/Policy/InputOutput/ProhibitOneArgSelect.pm", "version" : "1.126" }, "Perl::Critic::Policy::InputOutput::ProhibitReadlineInForLoop" : { "file" : "lib/Perl/Critic/Policy/InputOutput/ProhibitReadlineInForLoop.pm", "version" : "1.126" }, "Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen" : { "file" : "lib/Perl/Critic/Policy/InputOutput/ProhibitTwoArgOpen.pm", "version" : "1.126" }, "Perl::Critic::Policy::InputOutput::RequireBracedFileHandleWithPrint" : { "file" : "lib/Perl/Critic/Policy/InputOutput/RequireBracedFileHandleWithPrint.pm", "version" : "1.126" }, "Perl::Critic::Policy::InputOutput::RequireBriefOpen" : { "file" : "lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm", "version" : "1.126" }, "Perl::Critic::Policy::InputOutput::RequireCheckedClose" : { "file" : "lib/Perl/Critic/Policy/InputOutput/RequireCheckedClose.pm", "version" : "1.126" }, "Perl::Critic::Policy::InputOutput::RequireCheckedOpen" : { "file" : "lib/Perl/Critic/Policy/InputOutput/RequireCheckedOpen.pm", "version" : "1.126" }, "Perl::Critic::Policy::InputOutput::RequireCheckedSyscalls" : { "file" : "lib/Perl/Critic/Policy/InputOutput/RequireCheckedSyscalls.pm", "version" : "1.126" }, "Perl::Critic::Policy::InputOutput::RequireEncodingWithUTF8Layer" : { "file" : "lib/Perl/Critic/Policy/InputOutput/RequireEncodingWithUTF8Layer.pm", "version" : "1.126" }, "Perl::Critic::Policy::Miscellanea::ProhibitFormats" : { "file" : "lib/Perl/Critic/Policy/Miscellanea/ProhibitFormats.pm", "version" : "1.126" }, "Perl::Critic::Policy::Miscellanea::ProhibitTies" : { "file" : "lib/Perl/Critic/Policy/Miscellanea/ProhibitTies.pm", "version" : "1.126" }, "Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic" : { "file" : "lib/Perl/Critic/Policy/Miscellanea/ProhibitUnrestrictedNoCritic.pm", "version" : "1.126" }, "Perl::Critic::Policy::Miscellanea::ProhibitUselessNoCritic" : { "file" : "lib/Perl/Critic/Policy/Miscellanea/ProhibitUselessNoCritic.pm", "version" : "1.126" }, "Perl::Critic::Policy::Modules::ProhibitAutomaticExportation" : { "file" : "lib/Perl/Critic/Policy/Modules/ProhibitAutomaticExportation.pm", "version" : "1.126" }, "Perl::Critic::Policy::Modules::ProhibitConditionalUseStatements" : { "file" : "lib/Perl/Critic/Policy/Modules/ProhibitConditionalUseStatements.pm", "version" : "1.126" }, "Perl::Critic::Policy::Modules::ProhibitEvilModules" : { "file" : "lib/Perl/Critic/Policy/Modules/ProhibitEvilModules.pm", "version" : "1.126" }, "Perl::Critic::Policy::Modules::ProhibitExcessMainComplexity" : { "file" : "lib/Perl/Critic/Policy/Modules/ProhibitExcessMainComplexity.pm", "version" : "1.126" }, "Perl::Critic::Policy::Modules::ProhibitMultiplePackages" : { "file" : "lib/Perl/Critic/Policy/Modules/ProhibitMultiplePackages.pm", "version" : "1.126" }, "Perl::Critic::Policy::Modules::RequireBarewordIncludes" : { "file" : "lib/Perl/Critic/Policy/Modules/RequireBarewordIncludes.pm", "version" : "1.126" }, "Perl::Critic::Policy::Modules::RequireEndWithOne" : { "file" : "lib/Perl/Critic/Policy/Modules/RequireEndWithOne.pm", "version" : "1.126" }, "Perl::Critic::Policy::Modules::RequireExplicitPackage" : { "file" : "lib/Perl/Critic/Policy/Modules/RequireExplicitPackage.pm", "version" : "1.126" }, "Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage" : { "file" : "lib/Perl/Critic/Policy/Modules/RequireFilenameMatchesPackage.pm", "version" : "1.126" }, "Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish" : { "file" : "lib/Perl/Critic/Policy/Modules/RequireNoMatchVarsWithUseEnglish.pm", "version" : "1.126" }, "Perl::Critic::Policy::Modules::RequireVersionVar" : { "file" : "lib/Perl/Critic/Policy/Modules/RequireVersionVar.pm", "version" : "1.126" }, "Perl::Critic::Policy::NamingConventions::Capitalization" : { "file" : "lib/Perl/Critic/Policy/NamingConventions/Capitalization.pm", "version" : "1.126" }, "Perl::Critic::Policy::NamingConventions::ProhibitAmbiguousNames" : { "file" : "lib/Perl/Critic/Policy/NamingConventions/ProhibitAmbiguousNames.pm", "version" : "1.126" }, "Perl::Critic::Policy::Objects::ProhibitIndirectSyntax" : { "file" : "lib/Perl/Critic/Policy/Objects/ProhibitIndirectSyntax.pm", "version" : "1.126" }, "Perl::Critic::Policy::References::ProhibitDoubleSigils" : { "file" : "lib/Perl/Critic/Policy/References/ProhibitDoubleSigils.pm", "version" : "1.126" }, "Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest" : { "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitCaptureWithoutTest.pm", "version" : "1.126" }, "Perl::Critic::Policy::RegularExpressions::ProhibitComplexRegexes" : { "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitComplexRegexes.pm", "version" : "1.126" }, "Perl::Critic::Policy::RegularExpressions::ProhibitEnumeratedClasses" : { "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitEnumeratedClasses.pm", "version" : "1.126" }, "Perl::Critic::Policy::RegularExpressions::ProhibitEscapedMetacharacters" : { "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitEscapedMetacharacters.pm", "version" : "1.126" }, "Perl::Critic::Policy::RegularExpressions::ProhibitFixedStringMatches" : { "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitFixedStringMatches.pm", "version" : "1.126" }, "Perl::Critic::Policy::RegularExpressions::ProhibitSingleCharAlternation" : { "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitSingleCharAlternation.pm", "version" : "1.126" }, "Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture" : { "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusedCapture.pm", "version" : "1.126" }, "Perl::Critic::Policy::RegularExpressions::ProhibitUnusualDelimiters" : { "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusualDelimiters.pm", "version" : "1.126" }, "Perl::Critic::Policy::RegularExpressions::ProhibitUselessTopic" : { "file" : "lib/Perl/Critic/Policy/RegularExpressions/ProhibitUselessTopic.pm", "version" : "1.126" }, "Perl::Critic::Policy::RegularExpressions::RequireBracesForMultiline" : { "file" : "lib/Perl/Critic/Policy/RegularExpressions/RequireBracesForMultiline.pm", "version" : "1.126" }, "Perl::Critic::Policy::RegularExpressions::RequireDotMatchAnything" : { "file" : "lib/Perl/Critic/Policy/RegularExpressions/RequireDotMatchAnything.pm", "version" : "1.126" }, "Perl::Critic::Policy::RegularExpressions::RequireExtendedFormatting" : { "file" : "lib/Perl/Critic/Policy/RegularExpressions/RequireExtendedFormatting.pm", "version" : "1.126" }, "Perl::Critic::Policy::RegularExpressions::RequireLineBoundaryMatching" : { "file" : "lib/Perl/Critic/Policy/RegularExpressions/RequireLineBoundaryMatching.pm", "version" : "1.126" }, "Perl::Critic::Policy::Subroutines::ProhibitAmpersandSigils" : { "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitAmpersandSigils.pm", "version" : "1.126" }, "Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms" : { "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitBuiltinHomonyms.pm", "version" : "1.126" }, "Perl::Critic::Policy::Subroutines::ProhibitExcessComplexity" : { "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitExcessComplexity.pm", "version" : "1.126" }, "Perl::Critic::Policy::Subroutines::ProhibitExplicitReturnUndef" : { "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitExplicitReturnUndef.pm", "version" : "1.126" }, "Perl::Critic::Policy::Subroutines::ProhibitManyArgs" : { "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitManyArgs.pm", "version" : "1.126" }, "Perl::Critic::Policy::Subroutines::ProhibitNestedSubs" : { "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitNestedSubs.pm", "version" : "1.126" }, "Perl::Critic::Policy::Subroutines::ProhibitReturnSort" : { "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitReturnSort.pm", "version" : "1.126" }, "Perl::Critic::Policy::Subroutines::ProhibitSubroutinePrototypes" : { "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitSubroutinePrototypes.pm", "version" : "1.126" }, "Perl::Critic::Policy::Subroutines::ProhibitUnusedPrivateSubroutines" : { "file" : "lib/Perl/Critic/Policy/Subroutines/ProhibitUnusedPrivateSubroutines.pm", "version" : "1.126" }, "Perl::Critic::Policy::Subroutines::ProtectPrivateSubs" : { "file" : "lib/Perl/Critic/Policy/Subroutines/ProtectPrivateSubs.pm", "version" : "1.126" }, "Perl::Critic::Policy::Subroutines::RequireArgUnpacking" : { "file" : "lib/Perl/Critic/Policy/Subroutines/RequireArgUnpacking.pm", "version" : "1.126" }, "Perl::Critic::Policy::Subroutines::RequireFinalReturn" : { "file" : "lib/Perl/Critic/Policy/Subroutines/RequireFinalReturn.pm", "version" : "1.126" }, "Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict" : { "file" : "lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoStrict.pm", "version" : "1.126" }, "Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings" : { "file" : "lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoWarnings.pm", "version" : "1.126" }, "Perl::Critic::Policy::TestingAndDebugging::ProhibitProlongedStrictureOverride" : { "file" : "lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitProlongedStrictureOverride.pm", "version" : "1.126" }, "Perl::Critic::Policy::TestingAndDebugging::RequireTestLabels" : { "file" : "lib/Perl/Critic/Policy/TestingAndDebugging/RequireTestLabels.pm", "version" : "1.126" }, "Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict" : { "file" : "lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseStrict.pm", "version" : "1.126" }, "Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings" : { "file" : "lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseWarnings.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::ProhibitCommaSeparatedStatements" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitCommaSeparatedStatements.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::ProhibitComplexVersion" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitComplexVersion.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::ProhibitConstantPragma" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitConstantPragma.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::ProhibitEmptyQuotes" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEmptyQuotes.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::ProhibitEscapedCharacters" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEscapedCharacters.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::ProhibitImplicitNewlines" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitImplicitNewlines.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::ProhibitInterpolationOfLiterals" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitInterpolationOfLiterals.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLeadingZeros.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::ProhibitLongChainsOfMethodCalls" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLongChainsOfMethodCalls.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::ProhibitMagicNumbers" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMagicNumbers.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::ProhibitMismatchedOperators" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMismatchedOperators.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMixedBooleanOperators.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::ProhibitNoisyQuotes" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitNoisyQuotes.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitQuotesAsQuotelikeOperatorDelimiters.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitSpecialLiteralHeredocTerminator.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::ProhibitVersionStrings" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitVersionStrings.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::RequireConstantVersion" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/RequireConstantVersion.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/RequireInterpolationOfMetachars.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::RequireNumberSeparators" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/RequireNumberSeparators.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::RequireQuotedHeredocTerminator" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/RequireQuotedHeredocTerminator.pm", "version" : "1.126" }, "Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator" : { "file" : "lib/Perl/Critic/Policy/ValuesAndExpressions/RequireUpperCaseHeredocTerminator.pm", "version" : "1.126" }, "Perl::Critic::Policy::Variables::ProhibitAugmentedAssignmentInDeclaration" : { "file" : "lib/Perl/Critic/Policy/Variables/ProhibitAugmentedAssignmentInDeclaration.pm", "version" : "1.126" }, "Perl::Critic::Policy::Variables::ProhibitConditionalDeclarations" : { "file" : "lib/Perl/Critic/Policy/Variables/ProhibitConditionalDeclarations.pm", "version" : "1.126" }, "Perl::Critic::Policy::Variables::ProhibitEvilVariables" : { "file" : "lib/Perl/Critic/Policy/Variables/ProhibitEvilVariables.pm", "version" : "1.126" }, "Perl::Critic::Policy::Variables::ProhibitLocalVars" : { "file" : "lib/Perl/Critic/Policy/Variables/ProhibitLocalVars.pm", "version" : "1.126" }, "Perl::Critic::Policy::Variables::ProhibitMatchVars" : { "file" : "lib/Perl/Critic/Policy/Variables/ProhibitMatchVars.pm", "version" : "1.126" }, "Perl::Critic::Policy::Variables::ProhibitPackageVars" : { "file" : "lib/Perl/Critic/Policy/Variables/ProhibitPackageVars.pm", "version" : "1.126" }, "Perl::Critic::Policy::Variables::ProhibitPerl4PackageNames" : { "file" : "lib/Perl/Critic/Policy/Variables/ProhibitPerl4PackageNames.pm", "version" : "1.126" }, "Perl::Critic::Policy::Variables::ProhibitPunctuationVars" : { "file" : "lib/Perl/Critic/Policy/Variables/ProhibitPunctuationVars.pm", "version" : "1.126" }, "Perl::Critic::Policy::Variables::ProhibitReusedNames" : { "file" : "lib/Perl/Critic/Policy/Variables/ProhibitReusedNames.pm", "version" : "1.126" }, "Perl::Critic::Policy::Variables::ProhibitUnusedVariables" : { "file" : "lib/Perl/Critic/Policy/Variables/ProhibitUnusedVariables.pm", "version" : "1.126" }, "Perl::Critic::Policy::Variables::ProtectPrivateVars" : { "file" : "lib/Perl/Critic/Policy/Variables/ProtectPrivateVars.pm", "version" : "1.126" }, "Perl::Critic::Policy::Variables::RequireInitializationForLocalVars" : { "file" : "lib/Perl/Critic/Policy/Variables/RequireInitializationForLocalVars.pm", "version" : "1.126" }, "Perl::Critic::Policy::Variables::RequireLexicalLoopIterators" : { "file" : "lib/Perl/Critic/Policy/Variables/RequireLexicalLoopIterators.pm", "version" : "1.126" }, "Perl::Critic::Policy::Variables::RequireLocalizedPunctuationVars" : { "file" : "lib/Perl/Critic/Policy/Variables/RequireLocalizedPunctuationVars.pm", "version" : "1.126" }, "Perl::Critic::Policy::Variables::RequireNegativeIndices" : { "file" : "lib/Perl/Critic/Policy/Variables/RequireNegativeIndices.pm", "version" : "1.126" }, "Perl::Critic::PolicyConfig" : { "file" : "lib/Perl/Critic/PolicyConfig.pm", "version" : "1.126" }, "Perl::Critic::PolicyFactory" : { "file" : "lib/Perl/Critic/PolicyFactory.pm", "version" : "1.126" }, "Perl::Critic::PolicyListing" : { "file" : "lib/Perl/Critic/PolicyListing.pm", "version" : "1.126" }, "Perl::Critic::PolicyParameter" : { "file" : "lib/Perl/Critic/PolicyParameter.pm", "version" : "1.126" }, "Perl::Critic::PolicyParameter::Behavior" : { "file" : "lib/Perl/Critic/PolicyParameter/Behavior.pm", "version" : "1.126" }, "Perl::Critic::PolicyParameter::Behavior::Boolean" : { "file" : "lib/Perl/Critic/PolicyParameter/Behavior/Boolean.pm", "version" : "1.126" }, "Perl::Critic::PolicyParameter::Behavior::Enumeration" : { "file" : "lib/Perl/Critic/PolicyParameter/Behavior/Enumeration.pm", "version" : "1.126" }, "Perl::Critic::PolicyParameter::Behavior::Integer" : { "file" : "lib/Perl/Critic/PolicyParameter/Behavior/Integer.pm", "version" : "1.126" }, "Perl::Critic::PolicyParameter::Behavior::String" : { "file" : "lib/Perl/Critic/PolicyParameter/Behavior/String.pm", "version" : "1.126" }, "Perl::Critic::PolicyParameter::Behavior::StringList" : { "file" : "lib/Perl/Critic/PolicyParameter/Behavior/StringList.pm", "version" : "1.126" }, "Perl::Critic::ProfilePrototype" : { "file" : "lib/Perl/Critic/ProfilePrototype.pm", "version" : "1.126" }, "Perl::Critic::Statistics" : { "file" : "lib/Perl/Critic/Statistics.pm", "version" : "1.126" }, "Perl::Critic::TestUtils" : { "file" : "lib/Perl/Critic/TestUtils.pm", "version" : "1.126" }, "Perl::Critic::Theme" : { "file" : "lib/Perl/Critic/Theme.pm", "version" : "1.126" }, "Perl::Critic::ThemeListing" : { "file" : "lib/Perl/Critic/ThemeListing.pm", "version" : "1.126" }, "Perl::Critic::UserProfile" : { "file" : "lib/Perl/Critic/UserProfile.pm", "version" : "1.126" }, "Perl::Critic::Utils" : { "file" : "lib/Perl/Critic/Utils.pm", "version" : "1.126" }, "Perl::Critic::Utils::Constants" : { "file" : "lib/Perl/Critic/Utils/Constants.pm", "version" : "1.126" }, "Perl::Critic::Utils::DataConversion" : { "file" : "lib/Perl/Critic/Utils/DataConversion.pm", "version" : "1.126" }, "Perl::Critic::Utils::McCabe" : { "file" : "lib/Perl/Critic/Utils/McCabe.pm", "version" : "1.126" }, "Perl::Critic::Utils::POD" : { "file" : "lib/Perl/Critic/Utils/POD.pm", "version" : "1.126" }, "Perl::Critic::Utils::POD::ParseInteriorSequence" : { "file" : "lib/Perl/Critic/Utils/POD/ParseInteriorSequence.pm", "version" : "1.126" }, "Perl::Critic::Utils::PPI" : { "file" : "lib/Perl/Critic/Utils/PPI.pm", "version" : "1.126" }, "Perl::Critic::Utils::Perl" : { "file" : "lib/Perl/Critic/Utils/Perl.pm", "version" : "1.126" }, "Perl::Critic::Violation" : { "file" : "lib/Perl/Critic/Violation.pm", "version" : "1.126" }, "Test::Perl::Critic::Policy" : { "file" : "lib/Test/Perl/Critic/Policy.pm", "version" : "1.126" } }, "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" : "http://perlcritic.tigris.org/servlets/SummarizeList?listName=users" }, "version" : "1.126", "x_authority" : "cpan:CRITICRE" } META.yml000444000766000024 7420012562314714 14416 0ustar00jeffstaff000000000000Perl-Critic-1.126--- 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.4024' dynamic_config: 1 generated_by: 'Module::Build version 0.421, CPAN::Meta::Converter version 2.143240' 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.126' Perl::Critic::Annotation: file: lib/Perl/Critic/Annotation.pm version: '1.126' Perl::Critic::Command: file: lib/Perl/Critic/Command.pm version: '1.126' Perl::Critic::Config: file: lib/Perl/Critic/Config.pm version: '1.126' Perl::Critic::Document: file: lib/Perl/Critic/Document.pm version: '1.126' Perl::Critic::Exception: file: lib/Perl/Critic/Exception.pm version: '1.126' Perl::Critic::Exception::AggregateConfiguration: file: lib/Perl/Critic/Exception/AggregateConfiguration.pm version: '1.126' Perl::Critic::Exception::Configuration: file: lib/Perl/Critic/Exception/Configuration.pm version: '1.126' Perl::Critic::Exception::Configuration::Generic: file: lib/Perl/Critic/Exception/Configuration/Generic.pm version: '1.126' Perl::Critic::Exception::Configuration::NonExistentPolicy: file: lib/Perl/Critic/Exception/Configuration/NonExistentPolicy.pm version: '1.126' Perl::Critic::Exception::Configuration::Option: file: lib/Perl/Critic/Exception/Configuration/Option.pm version: '1.126' Perl::Critic::Exception::Configuration::Option::Global: file: lib/Perl/Critic/Exception/Configuration/Option/Global.pm version: '1.126' Perl::Critic::Exception::Configuration::Option::Global::ExtraParameter: file: lib/Perl/Critic/Exception/Configuration/Option/Global/ExtraParameter.pm version: '1.126' Perl::Critic::Exception::Configuration::Option::Global::ParameterValue: file: lib/Perl/Critic/Exception/Configuration/Option/Global/ParameterValue.pm version: '1.126' Perl::Critic::Exception::Configuration::Option::Policy: file: lib/Perl/Critic/Exception/Configuration/Option/Policy.pm version: '1.126' Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter: file: lib/Perl/Critic/Exception/Configuration/Option/Policy/ExtraParameter.pm version: '1.126' Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue: file: lib/Perl/Critic/Exception/Configuration/Option/Policy/ParameterValue.pm version: '1.126' Perl::Critic::Exception::Fatal: file: lib/Perl/Critic/Exception/Fatal.pm version: '1.126' Perl::Critic::Exception::Fatal::Generic: file: lib/Perl/Critic/Exception/Fatal/Generic.pm version: '1.126' Perl::Critic::Exception::Fatal::Internal: file: lib/Perl/Critic/Exception/Fatal/Internal.pm version: '1.126' Perl::Critic::Exception::Fatal::PolicyDefinition: file: lib/Perl/Critic/Exception/Fatal/PolicyDefinition.pm version: '1.126' Perl::Critic::Exception::IO: file: lib/Perl/Critic/Exception/IO.pm version: '1.126' Perl::Critic::Exception::Parse: file: lib/Perl/Critic/Exception/Parse.pm version: '1.126' Perl::Critic::OptionsProcessor: file: lib/Perl/Critic/OptionsProcessor.pm version: '1.126' Perl::Critic::Policy: file: lib/Perl/Critic/Policy.pm version: '1.126' Perl::Critic::Policy::BuiltinFunctions::ProhibitBooleanGrep: file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitBooleanGrep.pm version: '1.126' Perl::Critic::Policy::BuiltinFunctions::ProhibitComplexMappings: file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitComplexMappings.pm version: '1.126' Perl::Critic::Policy::BuiltinFunctions::ProhibitLvalueSubstr: file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitLvalueSubstr.pm version: '1.126' Perl::Critic::Policy::BuiltinFunctions::ProhibitReverseSortBlock: file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitReverseSortBlock.pm version: '1.126' Perl::Critic::Policy::BuiltinFunctions::ProhibitSleepViaSelect: file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitSleepViaSelect.pm version: '1.126' Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval: file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringyEval.pm version: '1.126' Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit: file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringySplit.pm version: '1.126' Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalCan: file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalCan.pm version: '1.126' Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa: file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalIsa.pm version: '1.126' Perl::Critic::Policy::BuiltinFunctions::ProhibitUselessTopic: file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUselessTopic.pm version: '1.126' Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep: file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidGrep.pm version: '1.126' Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap: file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidMap.pm version: '1.126' Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep: file: lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockGrep.pm version: '1.126' Perl::Critic::Policy::BuiltinFunctions::RequireBlockMap: file: lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockMap.pm version: '1.126' Perl::Critic::Policy::BuiltinFunctions::RequireGlobFunction: file: lib/Perl/Critic/Policy/BuiltinFunctions/RequireGlobFunction.pm version: '1.126' Perl::Critic::Policy::BuiltinFunctions::RequireSimpleSortBlock: file: lib/Perl/Critic/Policy/BuiltinFunctions/RequireSimpleSortBlock.pm version: '1.126' Perl::Critic::Policy::ClassHierarchies::ProhibitAutoloading: file: lib/Perl/Critic/Policy/ClassHierarchies/ProhibitAutoloading.pm version: '1.126' Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA: file: lib/Perl/Critic/Policy/ClassHierarchies/ProhibitExplicitISA.pm version: '1.126' Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless: file: lib/Perl/Critic/Policy/ClassHierarchies/ProhibitOneArgBless.pm version: '1.126' Perl::Critic::Policy::CodeLayout::ProhibitHardTabs: file: lib/Perl/Critic/Policy/CodeLayout/ProhibitHardTabs.pm version: '1.126' Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins: file: lib/Perl/Critic/Policy/CodeLayout/ProhibitParensWithBuiltins.pm version: '1.126' Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists: file: lib/Perl/Critic/Policy/CodeLayout/ProhibitQuotedWordLists.pm version: '1.126' Perl::Critic::Policy::CodeLayout::ProhibitTrailingWhitespace: file: lib/Perl/Critic/Policy/CodeLayout/ProhibitTrailingWhitespace.pm version: '1.126' Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines: file: lib/Perl/Critic/Policy/CodeLayout/RequireConsistentNewlines.pm version: '1.126' Perl::Critic::Policy::CodeLayout::RequireTidyCode: file: lib/Perl/Critic/Policy/CodeLayout/RequireTidyCode.pm version: '1.126' Perl::Critic::Policy::CodeLayout::RequireTrailingCommas: file: lib/Perl/Critic/Policy/CodeLayout/RequireTrailingCommas.pm version: '1.126' Perl::Critic::Policy::ControlStructures::ProhibitCStyleForLoops: file: lib/Perl/Critic/Policy/ControlStructures/ProhibitCStyleForLoops.pm version: '1.126' Perl::Critic::Policy::ControlStructures::ProhibitCascadingIfElse: file: lib/Perl/Critic/Policy/ControlStructures/ProhibitCascadingIfElse.pm version: '1.126' Perl::Critic::Policy::ControlStructures::ProhibitDeepNests: file: lib/Perl/Critic/Policy/ControlStructures/ProhibitDeepNests.pm version: '1.126' Perl::Critic::Policy::ControlStructures::ProhibitLabelsWithSpecialBlockNames: file: lib/Perl/Critic/Policy/ControlStructures/ProhibitLabelsWithSpecialBlockNames.pm version: '1.126' Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions: file: lib/Perl/Critic/Policy/ControlStructures/ProhibitMutatingListFunctions.pm version: '1.126' Perl::Critic::Policy::ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions: file: lib/Perl/Critic/Policy/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.pm version: '1.126' Perl::Critic::Policy::ControlStructures::ProhibitPostfixControls: file: lib/Perl/Critic/Policy/ControlStructures/ProhibitPostfixControls.pm version: '1.126' Perl::Critic::Policy::ControlStructures::ProhibitUnlessBlocks: file: lib/Perl/Critic/Policy/ControlStructures/ProhibitUnlessBlocks.pm version: '1.126' Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode: file: lib/Perl/Critic/Policy/ControlStructures/ProhibitUnreachableCode.pm version: '1.126' Perl::Critic::Policy::ControlStructures::ProhibitUntilBlocks: file: lib/Perl/Critic/Policy/ControlStructures/ProhibitUntilBlocks.pm version: '1.126' Perl::Critic::Policy::ControlStructures::ProhibitYadaOperator: file: lib/Perl/Critic/Policy/ControlStructures/ProhibitYadaOperator.pm version: '1.126' Perl::Critic::Policy::Documentation::PodSpelling: file: lib/Perl/Critic/Policy/Documentation/PodSpelling.pm version: '1.126' Perl::Critic::Policy::Documentation::RequirePackageMatchesPodName: file: lib/Perl/Critic/Policy/Documentation/RequirePackageMatchesPodName.pm version: '1.126' Perl::Critic::Policy::Documentation::RequirePodAtEnd: file: lib/Perl/Critic/Policy/Documentation/RequirePodAtEnd.pm version: '1.126' Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText: file: lib/Perl/Critic/Policy/Documentation/RequirePodLinksIncludeText.pm version: '1.126' Perl::Critic::Policy::Documentation::RequirePodSections: file: lib/Perl/Critic/Policy/Documentation/RequirePodSections.pm version: '1.126' Perl::Critic::Policy::ErrorHandling::RequireCarping: file: lib/Perl/Critic/Policy/ErrorHandling/RequireCarping.pm version: '1.126' Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval: file: lib/Perl/Critic/Policy/ErrorHandling/RequireCheckingReturnValueOfEval.pm version: '1.126' Perl::Critic::Policy::InputOutput::ProhibitBacktickOperators: file: lib/Perl/Critic/Policy/InputOutput/ProhibitBacktickOperators.pm version: '1.126' Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles: file: lib/Perl/Critic/Policy/InputOutput/ProhibitBarewordFileHandles.pm version: '1.126' Perl::Critic::Policy::InputOutput::ProhibitExplicitStdin: file: lib/Perl/Critic/Policy/InputOutput/ProhibitExplicitStdin.pm version: '1.126' Perl::Critic::Policy::InputOutput::ProhibitInteractiveTest: file: lib/Perl/Critic/Policy/InputOutput/ProhibitInteractiveTest.pm version: '1.126' Perl::Critic::Policy::InputOutput::ProhibitJoinedReadline: file: lib/Perl/Critic/Policy/InputOutput/ProhibitJoinedReadline.pm version: '1.126' Perl::Critic::Policy::InputOutput::ProhibitOneArgSelect: file: lib/Perl/Critic/Policy/InputOutput/ProhibitOneArgSelect.pm version: '1.126' Perl::Critic::Policy::InputOutput::ProhibitReadlineInForLoop: file: lib/Perl/Critic/Policy/InputOutput/ProhibitReadlineInForLoop.pm version: '1.126' Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen: file: lib/Perl/Critic/Policy/InputOutput/ProhibitTwoArgOpen.pm version: '1.126' Perl::Critic::Policy::InputOutput::RequireBracedFileHandleWithPrint: file: lib/Perl/Critic/Policy/InputOutput/RequireBracedFileHandleWithPrint.pm version: '1.126' Perl::Critic::Policy::InputOutput::RequireBriefOpen: file: lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm version: '1.126' Perl::Critic::Policy::InputOutput::RequireCheckedClose: file: lib/Perl/Critic/Policy/InputOutput/RequireCheckedClose.pm version: '1.126' Perl::Critic::Policy::InputOutput::RequireCheckedOpen: file: lib/Perl/Critic/Policy/InputOutput/RequireCheckedOpen.pm version: '1.126' Perl::Critic::Policy::InputOutput::RequireCheckedSyscalls: file: lib/Perl/Critic/Policy/InputOutput/RequireCheckedSyscalls.pm version: '1.126' Perl::Critic::Policy::InputOutput::RequireEncodingWithUTF8Layer: file: lib/Perl/Critic/Policy/InputOutput/RequireEncodingWithUTF8Layer.pm version: '1.126' Perl::Critic::Policy::Miscellanea::ProhibitFormats: file: lib/Perl/Critic/Policy/Miscellanea/ProhibitFormats.pm version: '1.126' Perl::Critic::Policy::Miscellanea::ProhibitTies: file: lib/Perl/Critic/Policy/Miscellanea/ProhibitTies.pm version: '1.126' Perl::Critic::Policy::Miscellanea::ProhibitUnrestrictedNoCritic: file: lib/Perl/Critic/Policy/Miscellanea/ProhibitUnrestrictedNoCritic.pm version: '1.126' Perl::Critic::Policy::Miscellanea::ProhibitUselessNoCritic: file: lib/Perl/Critic/Policy/Miscellanea/ProhibitUselessNoCritic.pm version: '1.126' Perl::Critic::Policy::Modules::ProhibitAutomaticExportation: file: lib/Perl/Critic/Policy/Modules/ProhibitAutomaticExportation.pm version: '1.126' Perl::Critic::Policy::Modules::ProhibitConditionalUseStatements: file: lib/Perl/Critic/Policy/Modules/ProhibitConditionalUseStatements.pm version: '1.126' Perl::Critic::Policy::Modules::ProhibitEvilModules: file: lib/Perl/Critic/Policy/Modules/ProhibitEvilModules.pm version: '1.126' Perl::Critic::Policy::Modules::ProhibitExcessMainComplexity: file: lib/Perl/Critic/Policy/Modules/ProhibitExcessMainComplexity.pm version: '1.126' Perl::Critic::Policy::Modules::ProhibitMultiplePackages: file: lib/Perl/Critic/Policy/Modules/ProhibitMultiplePackages.pm version: '1.126' Perl::Critic::Policy::Modules::RequireBarewordIncludes: file: lib/Perl/Critic/Policy/Modules/RequireBarewordIncludes.pm version: '1.126' Perl::Critic::Policy::Modules::RequireEndWithOne: file: lib/Perl/Critic/Policy/Modules/RequireEndWithOne.pm version: '1.126' Perl::Critic::Policy::Modules::RequireExplicitPackage: file: lib/Perl/Critic/Policy/Modules/RequireExplicitPackage.pm version: '1.126' Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage: file: lib/Perl/Critic/Policy/Modules/RequireFilenameMatchesPackage.pm version: '1.126' Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish: file: lib/Perl/Critic/Policy/Modules/RequireNoMatchVarsWithUseEnglish.pm version: '1.126' Perl::Critic::Policy::Modules::RequireVersionVar: file: lib/Perl/Critic/Policy/Modules/RequireVersionVar.pm version: '1.126' Perl::Critic::Policy::NamingConventions::Capitalization: file: lib/Perl/Critic/Policy/NamingConventions/Capitalization.pm version: '1.126' Perl::Critic::Policy::NamingConventions::ProhibitAmbiguousNames: file: lib/Perl/Critic/Policy/NamingConventions/ProhibitAmbiguousNames.pm version: '1.126' Perl::Critic::Policy::Objects::ProhibitIndirectSyntax: file: lib/Perl/Critic/Policy/Objects/ProhibitIndirectSyntax.pm version: '1.126' Perl::Critic::Policy::References::ProhibitDoubleSigils: file: lib/Perl/Critic/Policy/References/ProhibitDoubleSigils.pm version: '1.126' Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest: file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitCaptureWithoutTest.pm version: '1.126' Perl::Critic::Policy::RegularExpressions::ProhibitComplexRegexes: file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitComplexRegexes.pm version: '1.126' Perl::Critic::Policy::RegularExpressions::ProhibitEnumeratedClasses: file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitEnumeratedClasses.pm version: '1.126' Perl::Critic::Policy::RegularExpressions::ProhibitEscapedMetacharacters: file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitEscapedMetacharacters.pm version: '1.126' Perl::Critic::Policy::RegularExpressions::ProhibitFixedStringMatches: file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitFixedStringMatches.pm version: '1.126' Perl::Critic::Policy::RegularExpressions::ProhibitSingleCharAlternation: file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitSingleCharAlternation.pm version: '1.126' Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture: file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusedCapture.pm version: '1.126' Perl::Critic::Policy::RegularExpressions::ProhibitUnusualDelimiters: file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusualDelimiters.pm version: '1.126' Perl::Critic::Policy::RegularExpressions::ProhibitUselessTopic: file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitUselessTopic.pm version: '1.126' Perl::Critic::Policy::RegularExpressions::RequireBracesForMultiline: file: lib/Perl/Critic/Policy/RegularExpressions/RequireBracesForMultiline.pm version: '1.126' Perl::Critic::Policy::RegularExpressions::RequireDotMatchAnything: file: lib/Perl/Critic/Policy/RegularExpressions/RequireDotMatchAnything.pm version: '1.126' Perl::Critic::Policy::RegularExpressions::RequireExtendedFormatting: file: lib/Perl/Critic/Policy/RegularExpressions/RequireExtendedFormatting.pm version: '1.126' Perl::Critic::Policy::RegularExpressions::RequireLineBoundaryMatching: file: lib/Perl/Critic/Policy/RegularExpressions/RequireLineBoundaryMatching.pm version: '1.126' Perl::Critic::Policy::Subroutines::ProhibitAmpersandSigils: file: lib/Perl/Critic/Policy/Subroutines/ProhibitAmpersandSigils.pm version: '1.126' Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms: file: lib/Perl/Critic/Policy/Subroutines/ProhibitBuiltinHomonyms.pm version: '1.126' Perl::Critic::Policy::Subroutines::ProhibitExcessComplexity: file: lib/Perl/Critic/Policy/Subroutines/ProhibitExcessComplexity.pm version: '1.126' Perl::Critic::Policy::Subroutines::ProhibitExplicitReturnUndef: file: lib/Perl/Critic/Policy/Subroutines/ProhibitExplicitReturnUndef.pm version: '1.126' Perl::Critic::Policy::Subroutines::ProhibitManyArgs: file: lib/Perl/Critic/Policy/Subroutines/ProhibitManyArgs.pm version: '1.126' Perl::Critic::Policy::Subroutines::ProhibitNestedSubs: file: lib/Perl/Critic/Policy/Subroutines/ProhibitNestedSubs.pm version: '1.126' Perl::Critic::Policy::Subroutines::ProhibitReturnSort: file: lib/Perl/Critic/Policy/Subroutines/ProhibitReturnSort.pm version: '1.126' Perl::Critic::Policy::Subroutines::ProhibitSubroutinePrototypes: file: lib/Perl/Critic/Policy/Subroutines/ProhibitSubroutinePrototypes.pm version: '1.126' Perl::Critic::Policy::Subroutines::ProhibitUnusedPrivateSubroutines: file: lib/Perl/Critic/Policy/Subroutines/ProhibitUnusedPrivateSubroutines.pm version: '1.126' Perl::Critic::Policy::Subroutines::ProtectPrivateSubs: file: lib/Perl/Critic/Policy/Subroutines/ProtectPrivateSubs.pm version: '1.126' Perl::Critic::Policy::Subroutines::RequireArgUnpacking: file: lib/Perl/Critic/Policy/Subroutines/RequireArgUnpacking.pm version: '1.126' Perl::Critic::Policy::Subroutines::RequireFinalReturn: file: lib/Perl/Critic/Policy/Subroutines/RequireFinalReturn.pm version: '1.126' Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict: file: lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoStrict.pm version: '1.126' Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings: file: lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoWarnings.pm version: '1.126' Perl::Critic::Policy::TestingAndDebugging::ProhibitProlongedStrictureOverride: file: lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitProlongedStrictureOverride.pm version: '1.126' Perl::Critic::Policy::TestingAndDebugging::RequireTestLabels: file: lib/Perl/Critic/Policy/TestingAndDebugging/RequireTestLabels.pm version: '1.126' Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict: file: lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseStrict.pm version: '1.126' Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings: file: lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseWarnings.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::ProhibitCommaSeparatedStatements: file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitCommaSeparatedStatements.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::ProhibitComplexVersion: file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitComplexVersion.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::ProhibitConstantPragma: file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitConstantPragma.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::ProhibitEmptyQuotes: file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEmptyQuotes.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::ProhibitEscapedCharacters: file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEscapedCharacters.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::ProhibitImplicitNewlines: file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitImplicitNewlines.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::ProhibitInterpolationOfLiterals: file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitInterpolationOfLiterals.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros: file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLeadingZeros.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::ProhibitLongChainsOfMethodCalls: file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLongChainsOfMethodCalls.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::ProhibitMagicNumbers: file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMagicNumbers.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::ProhibitMismatchedOperators: file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMismatchedOperators.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators: file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMixedBooleanOperators.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::ProhibitNoisyQuotes: file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitNoisyQuotes.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters: file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitQuotesAsQuotelikeOperatorDelimiters.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator: file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitSpecialLiteralHeredocTerminator.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::ProhibitVersionStrings: file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitVersionStrings.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::RequireConstantVersion: file: lib/Perl/Critic/Policy/ValuesAndExpressions/RequireConstantVersion.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars: file: lib/Perl/Critic/Policy/ValuesAndExpressions/RequireInterpolationOfMetachars.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::RequireNumberSeparators: file: lib/Perl/Critic/Policy/ValuesAndExpressions/RequireNumberSeparators.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::RequireQuotedHeredocTerminator: file: lib/Perl/Critic/Policy/ValuesAndExpressions/RequireQuotedHeredocTerminator.pm version: '1.126' Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator: file: lib/Perl/Critic/Policy/ValuesAndExpressions/RequireUpperCaseHeredocTerminator.pm version: '1.126' Perl::Critic::Policy::Variables::ProhibitAugmentedAssignmentInDeclaration: file: lib/Perl/Critic/Policy/Variables/ProhibitAugmentedAssignmentInDeclaration.pm version: '1.126' Perl::Critic::Policy::Variables::ProhibitConditionalDeclarations: file: lib/Perl/Critic/Policy/Variables/ProhibitConditionalDeclarations.pm version: '1.126' Perl::Critic::Policy::Variables::ProhibitEvilVariables: file: lib/Perl/Critic/Policy/Variables/ProhibitEvilVariables.pm version: '1.126' Perl::Critic::Policy::Variables::ProhibitLocalVars: file: lib/Perl/Critic/Policy/Variables/ProhibitLocalVars.pm version: '1.126' Perl::Critic::Policy::Variables::ProhibitMatchVars: file: lib/Perl/Critic/Policy/Variables/ProhibitMatchVars.pm version: '1.126' Perl::Critic::Policy::Variables::ProhibitPackageVars: file: lib/Perl/Critic/Policy/Variables/ProhibitPackageVars.pm version: '1.126' Perl::Critic::Policy::Variables::ProhibitPerl4PackageNames: file: lib/Perl/Critic/Policy/Variables/ProhibitPerl4PackageNames.pm version: '1.126' Perl::Critic::Policy::Variables::ProhibitPunctuationVars: file: lib/Perl/Critic/Policy/Variables/ProhibitPunctuationVars.pm version: '1.126' Perl::Critic::Policy::Variables::ProhibitReusedNames: file: lib/Perl/Critic/Policy/Variables/ProhibitReusedNames.pm version: '1.126' Perl::Critic::Policy::Variables::ProhibitUnusedVariables: file: lib/Perl/Critic/Policy/Variables/ProhibitUnusedVariables.pm version: '1.126' Perl::Critic::Policy::Variables::ProtectPrivateVars: file: lib/Perl/Critic/Policy/Variables/ProtectPrivateVars.pm version: '1.126' Perl::Critic::Policy::Variables::RequireInitializationForLocalVars: file: lib/Perl/Critic/Policy/Variables/RequireInitializationForLocalVars.pm version: '1.126' Perl::Critic::Policy::Variables::RequireLexicalLoopIterators: file: lib/Perl/Critic/Policy/Variables/RequireLexicalLoopIterators.pm version: '1.126' Perl::Critic::Policy::Variables::RequireLocalizedPunctuationVars: file: lib/Perl/Critic/Policy/Variables/RequireLocalizedPunctuationVars.pm version: '1.126' Perl::Critic::Policy::Variables::RequireNegativeIndices: file: lib/Perl/Critic/Policy/Variables/RequireNegativeIndices.pm version: '1.126' Perl::Critic::PolicyConfig: file: lib/Perl/Critic/PolicyConfig.pm version: '1.126' Perl::Critic::PolicyFactory: file: lib/Perl/Critic/PolicyFactory.pm version: '1.126' Perl::Critic::PolicyListing: file: lib/Perl/Critic/PolicyListing.pm version: '1.126' Perl::Critic::PolicyParameter: file: lib/Perl/Critic/PolicyParameter.pm version: '1.126' Perl::Critic::PolicyParameter::Behavior: file: lib/Perl/Critic/PolicyParameter/Behavior.pm version: '1.126' Perl::Critic::PolicyParameter::Behavior::Boolean: file: lib/Perl/Critic/PolicyParameter/Behavior/Boolean.pm version: '1.126' Perl::Critic::PolicyParameter::Behavior::Enumeration: file: lib/Perl/Critic/PolicyParameter/Behavior/Enumeration.pm version: '1.126' Perl::Critic::PolicyParameter::Behavior::Integer: file: lib/Perl/Critic/PolicyParameter/Behavior/Integer.pm version: '1.126' Perl::Critic::PolicyParameter::Behavior::String: file: lib/Perl/Critic/PolicyParameter/Behavior/String.pm version: '1.126' Perl::Critic::PolicyParameter::Behavior::StringList: file: lib/Perl/Critic/PolicyParameter/Behavior/StringList.pm version: '1.126' Perl::Critic::ProfilePrototype: file: lib/Perl/Critic/ProfilePrototype.pm version: '1.126' Perl::Critic::Statistics: file: lib/Perl/Critic/Statistics.pm version: '1.126' Perl::Critic::TestUtils: file: lib/Perl/Critic/TestUtils.pm version: '1.126' Perl::Critic::Theme: file: lib/Perl/Critic/Theme.pm version: '1.126' Perl::Critic::ThemeListing: file: lib/Perl/Critic/ThemeListing.pm version: '1.126' Perl::Critic::UserProfile: file: lib/Perl/Critic/UserProfile.pm version: '1.126' Perl::Critic::Utils: file: lib/Perl/Critic/Utils.pm version: '1.126' Perl::Critic::Utils::Constants: file: lib/Perl/Critic/Utils/Constants.pm version: '1.126' Perl::Critic::Utils::DataConversion: file: lib/Perl/Critic/Utils/DataConversion.pm version: '1.126' Perl::Critic::Utils::McCabe: file: lib/Perl/Critic/Utils/McCabe.pm version: '1.126' Perl::Critic::Utils::POD: file: lib/Perl/Critic/Utils/POD.pm version: '1.126' Perl::Critic::Utils::POD::ParseInteriorSequence: file: lib/Perl/Critic/Utils/POD/ParseInteriorSequence.pm version: '1.126' Perl::Critic::Utils::PPI: file: lib/Perl/Critic/Utils/PPI.pm version: '1.126' Perl::Critic::Utils::Perl: file: lib/Perl/Critic/Utils/Perl.pm version: '1.126' Perl::Critic::Violation: file: lib/Perl/Critic/Violation.pm version: '1.126' Test::Perl::Critic::Policy: file: lib/Test/Perl/Critic/Policy.pm version: '1.126' requires: B::Keywords: '1.05' Carp: '0' Config::Tiny: '2' Email::Address: '1.889' English: '0' Exception::Class: '1.23' Exporter: '5.63' File::Basename: '0' File::Find: '0' File::HomeDir: '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::Pluggable: '3.1' PPI: '1.220' PPI::Document: '1.220' PPI::Document::File: '1.220' PPI::Node: '1.220' PPI::Token::Quote::Single: '1.220' PPI::Token::Whitespace: '1.220' PPIx::Regexp: '0.027' 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.13' Task::Weaken: '0' Term::ANSIColor: '2.02' Test::Builder: '0.92' Text::ParseWords: '3' base: '0' charnames: '0' overload: '0' strict: '0' version: '0.77' warnings: '0' resources: MailingList: http://perlcritic.tigris.org/servlets/SummarizeList?listName=users 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.126' x_authority: cpan:CRITICRE README000444000766000024 7612112562314714 14031 0ustar00jeffstaff000000000000Perl-Critic-1.126NAME 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 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. INTERFACE SUPPORT This 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 warns 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 specificaly 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 "/github.com/Perl- Critic/Perl- Critic.git" in http:. 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 Email::Address Exception::Class File::HomeDir 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 mailing list; send a message to mailto:users-subscribe@perlcritic.tigris.org. To prevent spam, you may be required to register for a user account with Tigris.org before being allowed to post messages to the mailing list. See also the mailing list archives at http://perlcritic.tigris.org/servlets/SummarizeList?listName=users. At least one member of the development team is usually hanging around in irc://irc.perl.org/#perlcritic and you can follow Perl::Critic on Twitter, at https://twitter.com/perlcritic. 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 "/github.com/Perl-Critic /Perl-Critic/issues" in https:. 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. http://www.perlfoundation.org/april_1_2007_new_grant_awards AUTHOR Jeffrey Ryan Thalhammer 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. README.md000444000766000024 10230012562314714 14435 0ustar00jeffstaff000000000000Perl-Critic-1.126# 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). # INTERFACE SUPPORT This 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 specificaly 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 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 puting 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 ["/github.com/Perl- Critic/Perl- Critic.git" in http:](https://metacpan.org/pod/http:#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) [Email::Address](https://metacpan.org/pod/Email::Address) [Exception::Class](https://metacpan.org/pod/Exception::Class) [File::HomeDir](https://metacpan.org/pod/File::HomeDir) [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 mailing list; send a message to [mailto:users-subscribe@perlcritic.tigris.org](mailto:users-subscribe@perlcritic.tigris.org). To prevent spam, you may be required to regisgter for a user account with Tigris.org before being allowed to post messages to the mailing list. See also the mailing list archives at [http://perlcritic.tigris.org/servlets/SummarizeList?listName=users](http://perlcritic.tigris.org/servlets/SummarizeList?listName=users). 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 ["/github.com/Perl-Critic /Perl-Critic/issues" in https:](https://metacpan.org/pod/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) # AUTHOR Jeffrey Ryan Thalhammer # 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. TODO.pod000444000766000024 4522312562314713 14420 0ustar00jeffstaff000000000000Perl-Critic-1.126# 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 * Make color work on Windows. Use L like L. =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 : bin000755000766000024 012562314714 13535 5ustar00jeffstaff000000000000Perl-Critic-1.126perlcritic000444000766000024 12076012562314714 16023 0ustar00jeffstaff000000000000Perl-Critic-1.126/bin#!/usr/bin/perl package main; use 5.006001; use strict; use warnings; use Perl::Critic::Command qw< run >; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- # 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 perlcriticrc --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<--Safari> Report "Perl Best Practice" citations as section numbers from L instead of page numbers from the actual book. NOTE: This feature is not implemented yet. =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 and it only works on non-Windows environments. 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; send a message to L. To prevent spam, you may be required to register for a user account with Tigris.org before being allowed to post messages to the mailing list. See also the mailing list archives 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 : examples000755000766000024 012562314714 14603 5ustar00jeffstaff000000000000Perl-Critic-1.126generatestats000555000766000024 1465112562314714 17566 0ustar00jeffstaff000000000000Perl-Critic-1.126/examples#!/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 : loadanalysisdb000555000766000024 1775312562314714 17714 0ustar00jeffstaff000000000000Perl-Critic-1.126/examples#!/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 : perlcriticrc000444000766000024 2072312562314714 17374 0ustar00jeffstaff000000000000Perl-Critic-1.126/examples############################################################################## # 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] perlcriticrc-conway000444000766000024 1676312562314714 20703 0ustar00jeffstaff000000000000Perl-Critic-1.126/examples############################################################################## # 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 = 4extras000755000766000024 012562314714 14273 5ustar00jeffstaff000000000000Perl-Critic-1.126perlcritic.el000444000766000024 6170612562314714 17144 0ustar00jeffstaff000000000000Perl-Critic-1.126/extras;;; 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 inc000755000766000024 012562314713 13535 5ustar00jeffstaff000000000000Perl-Critic-1.126Devel000755000766000024 012562314714 14575 5ustar00jeffstaff000000000000Perl-Critic-1.126/incAssertOS.pm000444000766000024 406512562314714 17000 0ustar00jeffstaff000000000000Perl-Critic-1.126/inc/Devel# $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; CheckOS.pm000444000766000024 2256512562314713 16600 0ustar00jeffstaff000000000000Perl-Critic-1.126/inc/Devel# $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; AssertOS000755000766000024 012562314714 16300 5ustar00jeffstaff000000000000Perl-Critic-1.126/inc/DevelSolaris.pm000444000766000024 115112562314714 20405 0ustar00jeffstaff000000000000Perl-Critic-1.126/inc/Devel/AssertOS# $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; Perl000755000766000024 012562314713 14437 5ustar00jeffstaff000000000000Perl-Critic-1.126/incCritic000755000766000024 012562314714 15655 5ustar00jeffstaff000000000000Perl-Critic-1.126/inc/PerlBuildUtilities.pm000444000766000024 1233512562314714 21327 0ustar00jeffstaff000000000000Perl-Critic-1.126/inc/Perl/Criticpackage 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, 'Email::Address' => 1.889, 'English' => 0, 'Exception::Class' => 1.23, 'Exporter' => 5.63, 'File::Basename' => 0, 'File::Find' => 0, 'File::HomeDir' => 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::Pluggable' => 3.1, 'PPI' => '1.220', # https://github.com/adamkennedy/PPI/issues/92 'PPI::Document' => '1.220', 'PPI::Document::File' => '1.220', 'PPI::Node' => '1.220', 'PPI::Token::Quote::Single' => '1.220', 'PPI::Token::Whitespace' => '1.220', 'PPIx::Regexp' => '0.027', # Literal { deprecated in re '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.13, 'Task::Weaken' => 0, 'Term::ANSIColor' => '2.02', 'Test::Builder' => 0.92, 'Text::ParseWords' => 3, 'base' => 0, 'charnames' => 0, 'overload' => 0, '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 : PolicySummaryGenerator.pm000444000766000024 1240012562314714 23051 0ustar00jeffstaff000000000000Perl-Critic-1.126/inc/Perl/Criticpackage 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 : Module000755000766000024 012562314714 17102 5ustar00jeffstaff000000000000Perl-Critic-1.126/inc/Perl/CriticBuild.pm000444000766000024 666012562314714 20644 0ustar00jeffstaff000000000000Perl-Critic-1.126/inc/Perl/Critic/Modulepackage 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 : Build000755000766000024 012562314714 20141 5ustar00jeffstaff000000000000Perl-Critic-1.126/inc/Perl/Critic/ModuleStandard.pm000444000766000024 700212562314714 22373 0ustar00jeffstaff000000000000Perl-Critic-1.126/inc/Perl/Critic/Module/Buildpackage 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/author > ); $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 : lib000755000766000024 012562314713 13532 5ustar00jeffstaff000000000000Perl-Critic-1.126Perl000755000766000024 012562314713 14434 5ustar00jeffstaff000000000000Perl-Critic-1.126/libCritic.pm000444000766000024 11100612562314713 16403 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perlpackage 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.126'; 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 =for stopwords DGR INI-style API -params pbp refactored ActivePerl ben Jore Dolan's Twitter Alexandr Ciornii Ciornii's downloadable =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 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( [ -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 specificaly 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 L L =head1 CONTACTING THE DEVELOPMENT TEAM You are encouraged to subscribe to the mailing list; send a message to L. To prevent spam, you may be required to register for a user account with Tigris.org before being allowed to post messages to the mailing list. See also the mailing list archives 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-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 : Critic000755000766000024 012562314714 15652 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/PerlAnnotation.pm000444000766000024 3232012562314714 20477 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage 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.126'; 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 : Command.pm000444000766000024 5466112562314714 17757 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage 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.126'; #----------------------------------------------------------------------------- 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 Safari 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(); 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 : Config.pm000444000766000024 12103012562314714 17607 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage 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.126'; #----------------------------------------------------------------------------- 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<-criticsm-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 : CORE_DEVELOPER.pod000444000766000024 3215312562314714 20674 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic=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. ** You will need to be registered as a developer before you can actually change code. L only lets you register as an observer. I got promoted on registration, but if that doesn't happen, a note to the developers' mailing list might help. ** If you are working on an RT ticket, you should update the ticket to say that you are, to keep other people from duplicating your effort. * I personally would update RT at the point I was reasonably confident I could hack it, just to prevent myself from having to update RT again in a week or so saying "oops, bit off more than I could chew." But that's me talking. * Subversion (also known as svn, which is the command name) is a version control system. It provides a repository for the code being worked on. Developers check out the code into a local directory, work on that, and then commit changes back to the repository. Any previous version of the code is available from the repository - a bad change can be backed out, though the longer the bad change hangs around the harder it may be to deal with. * Install Subversion if you don't already have it. You can get it from L. The current version is Subversion 1.6, but as of mid-2009, the 1.4.4 client seems to be adequate. The O'Reilly book, "Version Control with Subversion", is available online at L. The English version of the 1.4 documentation may be still available at L. * Branching is essentially pulling off your own managed copy of the code to develop on. It is creating a "sandbox", if you will. You can commit changes back to the repository without affecting the main line of development (the "trunk"). The entire branch can be abandoned without affecting the trunk. The down side of branches is that it is a bit of a pain to merge them back into the trunk. Consult the developers' mailing list on whether you should branch or work directly against the trunk. ** The Perl Critic subversion repository on Tigris contains a bunch of stuff other than Perl::Critic. You probably do not need it all. But if you execute the 'svn checkout' command given on Tigris you get it all. This is not recommended. * Here is my "branch and checkout" cookbook: Name the branch after the ticket you are working on (e.g. rt25046). Issue the following commands (we assume '$ ' is your system prompt): $ svn copy http://perlcritic.tigris.org/svn/perlcritic/trunk/distributions/Perl-Critic http://perlcritic.tigris.org/svn/perlcritic/branches/rt25046 -m "Put your comment here" --username your_username $ svn checkout http://perlcritic.tigris.org/svn/perlcritic/branches/rt25046 --username your_username The 'svn copy' command is the one that does the branch. Each 'svn' command is one line, though sometimes (e.g. the 'branch') it's a huge one. The C commands above have been wrapped. A checkout from the trunk is also done with the C command, but specifying the trunk's URL. You can also specify, as a second argument to C, the directory you want the code to go into. ** 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 : DEVELOPER.pod000444000766000024 11410012562314714 20075 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic=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 L, there's a good chance that the entire file is missing L. 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 : Document.pm000444000766000024 6502312562314714 20151 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage 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.126'; #----------------------------------------------------------------------------- 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 { 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 : Exception.pm000444000766000024 364212562314714 20310 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage Perl::Critic::Exception; use 5.006001; use strict; use warnings; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : OptionsProcessor.pm000444000766000024 2700312562314714 21722 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage 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.126'; #----------------------------------------------------------------------------- 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 : Policy.pm000444000766000024 6154612562314714 17640 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage 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.126'; #----------------------------------------------------------------------------- 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 : PolicyConfig.pm000444000766000024 1751212562314714 20760 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage Perl::Critic::PolicyConfig; use 5.006001; use strict; use warnings; use Readonly; our $VERSION = '1.126'; 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 : PolicyFactory.pm000444000766000024 3022412562314714 21155 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage 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.126'; #----------------------------------------------------------------------------- # 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 : PolicyListing.pm000444000766000024 461212562314714 21141 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage 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.126'; #----------------------------------------------------------------------------- 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 : PolicyParameter.pm000444000766000024 2303612562314714 21471 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage 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.126'; 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 : PolicySummary.pod000444000766000024 6770212562314714 21364 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic =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 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 Provide text to display with your pod links. [Default severity 2] =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 ProfilePrototype.pm000444000766000024 1611712562314714 21721 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage 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.126'; #----------------------------------------------------------------------------- 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 : Statistics.pm000444000766000024 2230412562314714 20520 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage 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.126'; #----------------------------------------------------------------------------- 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 : TestUtils.pm000444000766000024 4647612562314714 20346 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage 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.126'; 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 ); #----------------------------------------------------------------------------- # 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 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 : Theme.pm000444000766000024 1503612562314713 17433 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage Perl::Critic::Theme; use 5.006001; use strict; use warnings; use English qw(-no_match_vars); use Readonly; use Exporter 'import'; use List::MoreUtils qw(any); 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.126'; #----------------------------------------------------------------------------- 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 : ThemeListing.pm000444000766000024 460112562314714 20742 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage 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.126'; #----------------------------------------------------------------------------- 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 : UserProfile.pm000444000766000024 2434112562314714 20630 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage 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.126'; #----------------------------------------------------------------------------- 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 { # Try using File::HomeDir if ( eval { require File::HomeDir } ) { return File::HomeDir->my_home(); } # Check usual environment vars for my $key (qw(HOME USERPROFILE HOMESHARE)) { next if not defined $ENV{$key}; return $ENV{$key} if -d $ENV{$key}; } # No home directory defined return; } #----------------------------------------------------------------------------- # !$%@$%^ 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 : Utils.pm000444000766000024 15275712562314714 17526 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic# 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::Spec qw(); use Scalar::Util qw( blessed ); use B::Keywords qw(); use PPI::Token::Quote::Single; 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.126'; #----------------------------------------------------------------------------- # 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 { # Recursively searches a list of directories and returns the paths # to files that seem to be Perl source code. This subroutine was # poached from Test::Perl::Critic. my @queue = @_; my @code_files = (); while (@queue) { my $file = shift @queue; if ( -d $file ) { opendir my ($dh), $file or next; my @newfiles = sort readdir $dh; closedir $dh; @newfiles = File::Spec->no_upwards(@newfiles); @newfiles = grep { not $SKIP_DIR{$_} } @newfiles; push @queue, map { File::Spec->catfile($file, $_) } @newfiles; } if ( (-f $file) && ! _is_backup($file) && _is_perl($file) ) { push @code_files, $file; } } return @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{ [.] 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 = shift; 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); # 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) = @_; 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 ('autodie' eq $include->pragma()) { 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>, 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. =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 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 : Violation.pm000444000766000024 4337312562314714 20343 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Criticpackage Perl::Critic::Violation; use 5.006001; use strict; use warnings; use English qw< -no_match_vars >; use Readonly; use File::Basename qw< basename >; use IO::String qw< >; use Pod::PlainText qw< >; 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.126'; 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 my @lines = split qr{ \n\s* }xms, $code_string; # 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 : Exception000755000766000024 012562314714 17610 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/CriticAggregateConfiguration.pm000444000766000024 1125012562314714 24740 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exceptionpackage 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.126'; #----------------------------------------------------------------------------- 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 : Configuration.pm000444000766000024 400312562314714 23107 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exceptionpackage Perl::Critic::Exception::Configuration; use 5.006001; use strict; use warnings; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : Fatal.pm000444000766000024 443112562314714 21334 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exceptionpackage Perl::Critic::Exception::Fatal; use 5.006001; use strict; use warnings; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : IO.pm000444000766000024 371512562314713 20617 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exceptionpackage 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.126'; #----------------------------------------------------------------------------- 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 : Parse.pm000444000766000024 357212562314713 21363 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exceptionpackage 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.126'; #----------------------------------------------------------------------------- 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 : Configuration000755000766000024 012562314714 22417 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/ExceptionGeneric.pm000444000766000024 413512562314714 24471 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exception/Configurationpackage Perl::Critic::Exception::Configuration::Generic; use 5.006001; use strict; use warnings; use Readonly; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : NonExistentPolicy.pm000444000766000024 440112562314714 26547 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exception/Configurationpackage Perl::Critic::Exception::Configuration::NonExistentPolicy; use 5.006001; use strict; use warnings; use Readonly; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : Option.pm000444000766000024 624012562314714 24364 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exception/Configurationpackage Perl::Critic::Exception::Configuration::Option; use 5.006001; use strict; use warnings; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : Option000755000766000024 012562314714 23667 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exception/ConfigurationGlobal.pm000444000766000024 324512562314714 25566 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exception/Configuration/Optionpackage Perl::Critic::Exception::Configuration::Option::Global; use 5.006001; use strict; use warnings; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : Policy.pm000444000766000024 405612562314713 25625 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exception/Configuration/Optionpackage Perl::Critic::Exception::Configuration::Option::Policy; use 5.006001; use strict; use warnings; use Perl::Critic::Utils qw{ &policy_short_name }; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : Global000755000766000024 012562314714 25067 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exception/Configuration/OptionExtraParameter.pm000444000766000024 513712562314714 30514 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exception/Configuration/Option/Globalpackage Perl::Critic::Exception::Configuration::Option::Global::ExtraParameter; use 5.006001; use strict; use warnings; use Readonly; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : ParameterValue.pm000444000766000024 567212562314714 30511 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exception/Configuration/Option/Globalpackage 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.126'; #----------------------------------------------------------------------------- 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 : Policy000755000766000024 012562314714 25126 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exception/Configuration/OptionExtraParameter.pm000444000766000024 535112562314714 30551 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exception/Configuration/Option/Policypackage Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter; use 5.006001; use strict; use warnings; use Readonly; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : ParameterValue.pm000444000766000024 607512562314713 30545 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exception/Configuration/Option/Policypackage 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.126'; #----------------------------------------------------------------------------- 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 : Fatal000755000766000024 012562314714 20637 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/ExceptionGeneric.pm000444000766000024 322112562314714 22704 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exception/Fatalpackage Perl::Critic::Exception::Fatal::Generic; use 5.006001; use strict; use warnings; use Readonly; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : Internal.pm000444000766000024 331612562314713 23110 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exception/Fatalpackage Perl::Critic::Exception::Fatal::Internal; use 5.006001; use strict; use warnings; use Readonly; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : PolicyDefinition.pm000444000766000024 324512562314714 24606 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Exception/Fatalpackage Perl::Critic::Exception::Fatal::PolicyDefinition; use 5.006001; use strict; use warnings; use Readonly; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : Policy000755000766000024 012562314714 17111 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/CriticBuiltinFunctions000755000766000024 012562314714 22410 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyProhibitBooleanGrep.pm000444000766000024 1053712562314714 27027 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/BuiltinFunctionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitComplexMappings.pm000444000766000024 767512562314714 27731 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/BuiltinFunctionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitLvalueSubstr.pm000444000766000024 656712562314714 27255 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/BuiltinFunctionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitReverseSortBlock.pm000444000766000024 701212562314714 30042 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/BuiltinFunctionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitSleepViaSelect.pm000444000766000024 536612562314714 27466 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/BuiltinFunctionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitStringyEval.pm000444000766000024 1243212562314714 27075 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/BuiltinFunctionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitStringySplit.pm000444000766000024 612212562314714 27260 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/BuiltinFunctionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitUniversalCan.pm000444000766000024 555512562314714 27210 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/BuiltinFunctionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitUniversalIsa.pm000444000766000024 573512562314714 27223 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/BuiltinFunctionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitUselessTopic.pm000444000766000024 1266212562314713 27254 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/BuiltinFunctionspackage 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.126'; ## 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; sub violates { my ( $self, $elem, undef ) = @_; 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 : ProhibitVoidGrep.pm000444000766000024 504112562314714 26323 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/BuiltinFunctionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitVoidMap.pm000444000766000024 503412562314713 26144 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/BuiltinFunctionspackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireBlockGrep.pm000444000766000024 546212562314714 26317 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/BuiltinFunctionspackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireBlockMap.pm000444000766000024 521612562314714 26134 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/BuiltinFunctionspackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireGlobFunction.pm000444000766000024 435512562314714 27040 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/BuiltinFunctionspackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireSimpleSortBlock.pm000444000766000024 575712562314714 27532 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/BuiltinFunctionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ClassHierarchies000755000766000024 012562314714 22325 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyProhibitAutoloading.pm000444000766000024 452012562314714 26770 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ClassHierarchiespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitExplicitISA.pm000444000766000024 432012562314714 26636 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ClassHierarchiespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitOneArgBless.pm000444000766000024 434612562314714 26674 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ClassHierarchiespackage 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.126'; #----------------------------------------------------------------------------- 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 : CodeLayout000755000766000024 012562314714 21161 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyProhibitHardTabs.pm000444000766000024 1120012562314714 25057 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/CodeLayoutpackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitParensWithBuiltins.pm000444000766000024 1774012562314714 27204 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/CodeLayoutpackage Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins; use 5.006001; use strict; use warnings; use Readonly; use List::MoreUtils qw{any}; use Perl::Critic::Utils qw{ :booleans :severities :data_conversion :classification :language }; use base 'Perl::Critic::Policy'; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : ProhibitQuotedWordLists.pm000444000766000024 1224712562314713 26516 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/CodeLayoutpackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitTrailingWhitespace.pm000444000766000024 701212562314713 27142 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/CodeLayoutpackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireConsistentNewlines.pm000444000766000024 617712562314714 27062 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/CodeLayoutpackage 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.126'; 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 : RequireTidyCode.pm000444000766000024 1424112562314714 24737 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/CodeLayoutpackage 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.126'; #----------------------------------------------------------------------------- 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 ); # Begining 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 : RequireTrailingCommas.pm000444000766000024 632012562314714 26123 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/CodeLayoutpackage 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.126'; #----------------------------------------------------------------------------- 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 : ControlStructures000755000766000024 012562314714 22635 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyProhibitCascadingIfElse.pm000444000766000024 625712562314713 30006 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ControlStructurespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitCStyleForLoops.pm000444000766000024 503412562314714 27722 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ControlStructurespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitDeepNests.pm000444000766000024 602012562314714 26721 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ControlStructurespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitLabelsWithSpecialBlockNames.pm000444000766000024 554012562314714 32333 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ControlStructurespackage 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.126'; 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 : ProhibitMutatingListFunctions.pm000444000766000024 2504712562314713 31375 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ControlStructurespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitNegativeExpressionsInUnlessAndUntilConditions.pm000444000766000024 1174612562314714 36241 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ControlStructurespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitPostfixControls.pm000444000766000024 1446212562314714 30240 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ControlStructurespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitUnlessBlocks.pm000444000766000024 502612562314714 27443 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ControlStructurespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitUnreachableCode.pm000444000766000024 1330612562314714 30060 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ControlStructurespackage 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.126'; 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 : ProhibitUntilBlocks.pm000444000766000024 501112562314714 27257 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ControlStructurespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitYadaOperator.pm000444000766000024 467212562314714 27434 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ControlStructurespackage 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.126'; #----------------------------------------------------------------------------- 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 but it is perfectly useful less critical environments. =head1 CONFIGURATION This Policy is not configurable except for the standard options. =head1 AUTHOR Alan Berndt =head1 COPYRIGHT Copyright (c) 2015 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 : Documentation000755000766000024 012562314714 21722 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyPodSpelling.pm000444000766000024 2561612562314714 24667 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Documentationpackage 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.126'; #----------------------------------------------------------------------------- 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(); return $FALSE if not $self->_run_spell_command( <<'END_TEST_CODE' ); =pod =head1 Test The Spell Command =cut END_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"; for (@words) { chomp; } # 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 stopword 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 : RequirePackageMatchesPodName.pm000444000766000024 632012562314714 30057 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Documentationpackage 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.126'; #----------------------------------------------------------------------------- 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 [CL]<(.*)>\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 : RequirePodAtEnd.pm000444000766000024 635512562314714 25421 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Documentationpackage 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.126'; #----------------------------------------------------------------------------- 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 : RequirePodLinksIncludeText.pm000444000766000024 2005312562314713 27665 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Documentationpackage Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText; use 5.006001; use strict; use warnings; use Readonly; use English qw{ -no_match_vars }; use Perl::Critic::Utils qw{ :booleans :characters :severities }; use base 'Perl::Critic::Policy'; use Perl::Critic::Utils::POD::ParseInteriorSequence; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- Readonly::Scalar my $EXPL => 'Without text, you are at the mercy of the POD translator'; #----------------------------------------------------------------------------- sub supported_parameters { return ( { name => 'allow_external_sections', description => 'Allow external sections without text', default_string => '1', behavior => 'boolean', }, { name => 'allow_internal_sections', description => 'Allow internal sections without text', default_string => '1', behavior => 'boolean', }, ); } sub default_severity { return $SEVERITY_LOW } sub default_themes { return qw(core maintenance) } sub applies_to { return 'PPI::Token::Pod' } #----------------------------------------------------------------------------- Readonly::Scalar my $INCREMENT_NESTING => 1; Readonly::Scalar my $DECREMENT_NESTING => -1; Readonly::Hash my %ESCAPE_NESTING => ( '<' => $INCREMENT_NESTING, '>' => $DECREMENT_NESTING, ); sub violates { my ( $self, $elem, $doc ) = @_; my @violations; =begin comment my $pod = $elem->content(); # We look for _any_ POD escape, not just L<>. This way we can avoid false # positives on constructions like C<< L >>. In an attempt to be # upward compatible (and at a slight (I hope!) risk of false negatives), # we accept any upper case letter as beginning a formatting sequence, not # just [IBCLEFSXZ]. SCAN_POD: while ( $pod =~ m/ ( [[:upper:]] ) ( <+ ) /smxg ) { # Collect the results of the match. my $formatter = $1; my $link_start = $LAST_MATCH_START[0]; my $content_start = $LAST_MATCH_END[0]; my $num_brkt = length $2; # The only way to handle arbitrarily-nested brackets before Perl # 5.10 is the (??{}) construction, which is _still_ marked # 'experimental' as of 5.12.3 and 5.13.9. Taking them at their # word, I'm going to find the end of the POD escape the hard # way. my $link_end = $link_start + 1; my $nest = 0; while ( 1 ) { $nest += $ESCAPE_NESTING{ substr $pod, $link_end++, 1 } || 0; $nest or last; $link_end < length $pod or last SCAN_POD; } # Manually advance past the end of the link so the regular # expression does not find any possible nested formatting. pos $pod = $link_end; # If it's not an 'L' formatter, we are not interested. 'L' eq $formatter or next; # Save both the link itself and its contents for further analysis. my $link = substr $pod, $link_start, $link_end - $link_start; my $content = substr $pod, $content_start, $link_end - $num_brkt - $content_start; # If the link is allowed, pass on to the next one. $self->_allowed_link( $content ) and next; # A-Hah! Gotcha! my $line_number = $elem->line_number() + ( substr( $pod, 0, $link_start ) =~ tr/\n/\n/ ); push @violations, $self->violation( "Link $link on line $line_number does not specify text", $EXPL, $elem ); } =end comment =cut my $parser = Perl::Critic::Utils::POD::ParseInteriorSequence->new(); $parser->errorsub( sub { return 1 } ); # Suppress error messages. foreach my $seq ( $parser->get_interior_sequences( $elem->content() ) ) { # Not interested in nested thing like C<< L >>. I think. $seq->nested() and next; # Not interested in anything but L<...>. 'L' eq $seq->cmd_name() or next; # If the link is allowed, pass on to the next one. $self->_allowed_link( $seq ) and next; # A-Hah! Gotcha! my $line_number = $elem->line_number() + ( $seq->file_line() )[1] - 1; push @violations, $self->violation( join( $SPACE, 'Link', $seq->raw_text(), "on line $line_number does not specify text" ), $EXPL, $elem ); } return @violations; } sub _allowed_link { =begin comment my ( $self, $content ) = @_; =end comment =cut my ( $self, $pod_seq ) = @_; # Extract the content of the sequence. my $content = $pod_seq->raw_text(); $content = substr $content, 0, - length $pod_seq->right_delimiter(); $content = substr $content, length( $pod_seq->cmd_name() ) + length( $pod_seq->left_delimiter() ); # Not interested in hyperlinks. $content =~ m{ \A \w+ : (?! : ) }smx and return $TRUE; # Links with text specified are good. $content =~ m/ [|] /smx and return $TRUE; # Internal sections without text are either good or bad, depending on how # we are configured. $content =~ m{ \A [/"] }smx and return $self->{_allow_internal_sections}; # External sections without text are either good or bad, depending on how # we are configured. $content =~ m{ / }smx and return $self->{_allow_external_sections}; # Anything else without text is bad. return $FALSE; } 1; __END__ #----------------------------------------------------------------------------- =pod =for stopwords licence =head1 NAME Perl::Critic::Policy::Documentation::RequirePodLinksIncludeText - Provide text to display with your pod links. =head1 AFFILIATION This Policy is part of the core L distribution. =head1 DESCRIPTION This Policy requires your POD links to contain text to override your POD translator's default link text, where this is possible. Failure to provide your own text leaves you at the mercy of the POD translator, which may display something like C<< LEFoo> >> as C. By default, links that specify a documentation section (for example, C<< LEFoo/bar> >>, or C<< LE/bar> >>) are exempt from this Policy. =head1 CONFIGURATION This Policy has two boolean options to configure the handling of links that specify a documentation section. The C option configures the handling of links of the form C<< LEFoo/bar> >>. If true, such links are accepted even without a text specification. Such links tend to be turned into something like C. By default, this option is asserted. If you want to prohibit things like C<< LEFoo/bar> >> (while allowing things like C<<< LEE Foo->bar()|Foo/bar >> >>>), put something like this in your F<.perlcriticrc>: [Documentation::RequirePodLinksIncludeText] allow_external_sections = 0 The C option configures the handling of links of the form C<< LE/bar> >>. If true, such links are accepted even without a text specification. Such links tend to be turned into something like C. By default, this option is asserted. If you want to prohibit things like C<< LE/bar> >> (while allowing things like C<< LEbar()|/bar> >>), put something like this in your F<.perlcriticrc>: [Documentation::RequirePodLinksIncludeText] allow_internal_sections = 0 =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 : RequirePodSections.pm000444000766000024 3577412562314714 26244 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Documentationpackage 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.126'; #----------------------------------------------------------------------------- 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 : ErrorHandling000755000766000024 012562314714 21647 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyRequireCarping.pm000444000766000024 3701112562314713 25303 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ErrorHandlingpackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireCheckingReturnValueOfEval.pm000444000766000024 2733112562314714 30732 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ErrorHandlingpackage 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.126'; #----------------------------------------------------------------------------- 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_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 ); } #----------------------------------------------------------------------------- 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 possiblity 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 : InputOutput000755000766000024 012562314714 21431 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyProhibitBacktickOperators.pm000444000766000024 1000012562314714 27246 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/InputOutputpackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitBarewordFileHandles.pm000444000766000024 610312562314714 27471 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/InputOutputpackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitExplicitStdin.pm000444000766000024 633112562314714 26413 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/InputOutputpackage Perl::Critic::Policy::InputOutput::ProhibitExplicitStdin; 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitInteractiveTest.pm000444000766000024 373312562314714 26750 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/InputOutputpackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitJoinedReadline.pm000444000766000024 645112562314714 26507 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/InputOutputpackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitOneArgSelect.pm000444000766000024 475112562314714 26147 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/InputOutputpackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitReadlineInForLoop.pm000444000766000024 522412562314714 27143 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/InputOutputpackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitTwoArgOpen.pm000444000766000024 750212562314714 25656 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/InputOutputpackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireBracedFileHandleWithPrint.pm000444000766000024 777012562314713 30440 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/InputOutputpackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireBriefOpen.pm000444000766000024 2650112562314714 25356 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/InputOutputpackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireCheckedClose.pm000444000766000024 556712562314714 26012 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/InputOutputpackage 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.126'; #----------------------------------------------------------------------------- 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 () } 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 ); 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 This Policy is not configurable except for the standard options. =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 : RequireCheckedOpen.pm000444000766000024 573312562314714 25641 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/InputOutputpackage 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.126'; #----------------------------------------------------------------------------- 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 () } 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 ); 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 This Policy is not configurable except for the standard options. =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 : RequireCheckedSyscalls.pm000444000766000024 1476412562314714 26561 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/InputOutputpackage 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.126'; #----------------------------------------------------------------------------- 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', }, ); } 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 not is_unchecked_call( $elem ); 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. =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 : RequireEncodingWithUTF8Layer.pm000444000766000024 1250612562314714 27533 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/InputOutputpackage 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.126'; #----------------------------------------------------------------------------- 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 : Miscellanea000755000766000024 012562314714 21326 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyProhibitFormats.pm000444000766000024 447712562314714 25151 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Miscellaneapackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitTies.pm000444000766000024 435312562314714 24433 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Miscellaneapackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitUnrestrictedNoCritic.pm000444000766000024 1037512562314714 27656 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Miscellaneapackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitUselessNoCritic.pm000444000766000024 1203012562314714 26614 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Miscellaneapackage 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.126'; #----------------------------------------------------------------------------- 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 : Modules000755000766000024 012562314714 20521 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyProhibitAutomaticExportation.pm000444000766000024 775112562314714 27112 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Modulespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitConditionalUseStatements.pm000444000766000024 1241312562314714 27726 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Modulespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitEvilModules.pm000444000766000024 2542512562314714 25175 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Modulespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitExcessMainComplexity.pm000444000766000024 1104112562314714 27047 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Modulespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitMultiplePackages.pm000444000766000024 451212562314714 26151 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Modulespackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireBarewordIncludes.pm000444000766000024 674412562314714 26020 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Modulespackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireEndWithOne.pm000444000766000024 602312562314714 24556 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Modulespackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireExplicitPackage.pm000444000766000024 1252012562314713 25625 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Modulespackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireFilenameMatchesPackage.pm000444000766000024 1101012562314714 27063 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Modulespackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireNoMatchVarsWithUseEnglish.pm000444000766000024 1223312562314713 27601 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Modulespackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireVersionVar.pm000444000766000024 1357612562314714 24703 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Modulespackage 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.126'; #----------------------------------------------------------------------------- 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 : NamingConventions000755000766000024 012562314714 22550 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyCapitalization.pm000444000766000024 6642412562314714 26252 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/NamingConventionspackage Perl::Critic::Policy::NamingConventions::Capitalization; use 5.006001; use strict; use warnings; use English qw< -no_match_vars >; use Readonly; use List::MoreUtils qw< any >; 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.126'; #----------------------------------------------------------------------------- # 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 : ProhibitAmbiguousNames.pm000444000766000024 1153512562314714 27710 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/NamingConventionspackage 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.126'; #----------------------------------------------------------------------------- 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 : Objects000755000766000024 012562314714 20502 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyProhibitIndirectSyntax.pm000444000766000024 1063312562314714 25671 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Objectspackage 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.126'; #----------------------------------------------------------------------------- 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 : References000755000766000024 012562314714 21172 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyProhibitDoubleSigils.pm000444000766000024 466712562314714 25770 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Referencespackage 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.126'; #----------------------------------------------------------------------------- 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 : RegularExpressions000755000766000024 012562314714 22755 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyProhibitCaptureWithoutTest.pm000444000766000024 3317612562314714 31032 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/RegularExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 undefined. Therefore it's important to check the return value of a match before using those variables. 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-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 : ProhibitComplexRegexes.pm000444000766000024 1631612562314714 30132 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/RegularExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitEnumeratedClasses.pm000444000766000024 1270612562314714 30606 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/RegularExpressionspackage Perl::Critic::Policy::RegularExpressions::ProhibitEnumeratedClasses; use 5.006001; use strict; use warnings; use Carp qw(carp); 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitEscapedMetacharacters.pm000444000766000024 1131412562314713 31403 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/RegularExpressionspackage Perl::Critic::Policy::RegularExpressions::ProhibitEscapedMetacharacters; use 5.006001; use strict; use warnings; use English qw(-no_match_vars); use List::MoreUtils qw(any); use Readonly; use Perl::Critic::Utils qw{ :booleans :severities hashify }; use base 'Perl::Critic::Policy'; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : ProhibitFixedStringMatches.pm000444000766000024 1214212562314714 30724 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/RegularExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitSingleCharAlternation.pm000444000766000024 1012112562314714 31404 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/RegularExpressionspackage Perl::Critic::Policy::RegularExpressions::ProhibitSingleCharAlternation; use 5.006001; use strict; use warnings; use Carp; use English qw(-no_match_vars); use List::MoreUtils qw(all); use Readonly; use Perl::Critic::Utils qw{ :booleans :characters :severities }; use base 'Perl::Critic::Policy'; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : ProhibitUnusedCapture.pm000444000766000024 6461412562314714 27773 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/RegularExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitUnusualDelimiters.pm000444000766000024 657512562314714 30644 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/RegularExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitUselessTopic.pm000444000766000024 563712562314714 27606 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/RegularExpressionspackage 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.126'; ## 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 : RequireBracesForMultiline.pm000444000766000024 733012562314713 30540 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/RegularExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireDotMatchAnything.pm000444000766000024 540212562314714 30213 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/RegularExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireExtendedFormatting.pm000444000766000024 1217112562314714 30622 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/RegularExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireLineBoundaryMatching.pm000444000766000024 570112562314713 31055 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/RegularExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : Subroutines000755000766000024 012562314714 21433 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyProhibitAmpersandSigils.pm000444000766000024 760012562314714 26717 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Subroutinespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitBuiltinHomonyms.pm000444000766000024 642412562314714 26775 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Subroutinespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitExcessComplexity.pm000444000766000024 1027212562314714 27161 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Subroutinespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitExplicitReturnUndef.pm000444000766000024 754212562314714 27602 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Subroutinespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitManyArgs.pm000444000766000024 1171612562314714 25376 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Subroutinespackage Perl::Critic::Policy::Subroutines::ProhibitManyArgs; use 5.006001; use strict; use warnings; use Readonly; use File::Spec; use List::Util qw(first); use List::MoreUtils qw(uniq any); 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.126'; #----------------------------------------------------------------------------- Readonly::Scalar my $AT => q{@}; Readonly::Scalar my $AT_ARG => q{@_}; ## 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, }, ); } 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($elem->block->schildren); } if ($self->{_max_arguments} < $num_args) { return $self->violation( $DESC, $EXPL, $elem ); } return; # OK } sub _count_args { my @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(@elements); } elsif ($operand->isa('PPI::Token::Word') && 'shift' eq $operand->content()) { return 1 + _count_args(@statements); } return 0; } sub _count_list_elements { my @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; } return scalar split_nodes_on_comma(@inner); } 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 =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 TO DO Don't include C<$self> and C<$class> in the count. =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 : ProhibitNestedSubs.pm000444000766000024 503712562314713 25712 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Subroutinespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitReturnSort.pm000444000766000024 644712562314714 25771 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Subroutinespackage 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.126'; #----------------------------------------------------------------------------- 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 you 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! @sorted_list = sort @list; return @sort # 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-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 : ProhibitSubroutinePrototypes.pm000444000766000024 407612562314714 30106 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Subroutinespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitUnusedPrivateSubroutines.pm000444000766000024 3254412562314714 30720 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Subroutinespackage 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.126'; #----------------------------------------------------------------------------- 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_private_name_regex, }, { name => 'allow', description => q, default_string => $EMPTY, behavior => 'string list', }, { name => 'skip_when_using', description => q, default_string => $EMPTY, behavior => 'string list', }, ); } sub default_severity { return $SEVERITY_MEDIUM } sub default_themes { return qw( core maintenance certrec ) } sub applies_to { return 'PPI::Statement::Sub' } #----------------------------------------------------------------------------- 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, $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; # 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 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 : ProtectPrivateSubs.pm000444000766000024 1775512562314714 25775 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Subroutinespackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireArgUnpacking.pm000444000766000024 3226212562314714 26061 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Subroutinespackage 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 List::Util qw(first); use List::MoreUtils qw(uniq any); use Perl::Critic::Utils qw< :booleans :characters :classification hashify :severities words_from_string >; use base 'Perl::Critic::Policy'; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : RequireFinalReturn.pm000444000766000024 2463412562314714 25745 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Subroutinespackage 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.126'; #----------------------------------------------------------------------------- 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 ...> ], }, ); } 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 exists $self->{_terminal_funcs}->{$first_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 =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 : TestingAndDebugging000755000766000024 012562314714 22765 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyProhibitNoStrict.pm000444000766000024 1033512562314713 26747 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/TestingAndDebuggingpackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitNoWarnings.pm000444000766000024 1341412562314714 27271 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/TestingAndDebuggingpackage 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.126'; #----------------------------------------------------------------------------- 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/ (\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 : ProhibitProlongedStrictureOverride.pm000444000766000024 556712562314713 32533 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/TestingAndDebuggingpackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireTestLabels.pm000444000766000024 1030512562314714 27076 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/TestingAndDebuggingpackage 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.126'; 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 : RequireUseStrict.pm000444000766000024 1501612562314714 26765 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/TestingAndDebuggingpackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireUseWarnings.pm000444000766000024 1450512562314714 27307 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/TestingAndDebuggingpackage Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings; use 5.006001; use strict; use warnings; use Readonly; use List::Util qw(first); 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.126'; #----------------------------------------------------------------------------- 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 : ValuesAndExpressions000755000766000024 012562314714 23236 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyProhibitCommaSeparatedStatements.pm000444000766000024 1516312562314714 32415 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitComplexVersion.pm000444000766000024 2137312562314714 30435 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- Readonly::Scalar my $DOLLAR => q<$>; # All uses of the $DOLLAR variable below are to prevent false failures in # xt/author/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 : ProhibitConstantPragma.pm000444000766000024 441512562314714 30357 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitEmptyQuotes.pm000444000766000024 522512562314714 27735 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitEscapedCharacters.pm000444000766000024 476512562314714 31012 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitImplicitNewlines.pm000444000766000024 512512562314714 30714 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitInterpolationOfLiterals.pm000444000766000024 1306712562314714 32275 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitLeadingZeros.pm000444000766000024 1563712562314713 30053 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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_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_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 =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 : ProhibitLongChainsOfMethodCalls.pm000444000766000024 1145512562314714 32112 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitMagicNumbers.pm000444000766000024 5032012562314713 30025 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #---------------------------------------------------------------------------- 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 : ProhibitMismatchedOperators.pm000444000766000024 1401012562314713 31422 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitMixedBooleanOperators.pm000444000766000024 1010012562314714 31707 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitNoisyQuotes.pm000444000766000024 574412562314714 27746 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitQuotesAsQuotelikeOperatorDelimiters.pm000444000766000024 2050112562314714 34635 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitSpecialLiteralHeredocTerminator.pm000444000766000024 603012562314714 33665 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitVersionStrings.pm000444000766000024 530212562314714 30431 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireConstantVersion.pm000444000766000024 3660212562314713 30453 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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/author/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 : RequireInterpolationOfMetachars.pm000444000766000024 1363712562314714 32264 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars; use 5.006001; use strict; use warnings; use Readonly; use Email::Address; use Perl::Critic::Utils qw< :booleans :characters :severities >; use base 'Perl::Critic::Policy'; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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; } #----------------------------------------------------------------------------- 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 =~ $Email::Address::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 : RequireNumberSeparators.pm000444000766000024 632612562314714 30571 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireQuotedHeredocTerminator.pm000444000766000024 512312562314714 32067 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireUpperCaseHeredocTerminator.pm000444000766000024 512212562314714 32514 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/ValuesAndExpressionspackage 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.126'; #----------------------------------------------------------------------------- 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 : Variables000755000766000024 012562314714 21021 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyProhibitAugmentedAssignmentInDeclaration.pm000444000766000024 633112562314713 31616 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Variablespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitConditionalDeclarations.pm000444000766000024 546212562314714 30020 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Variablespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitEvilVariables.pm000444000766000024 3225412562314714 25773 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Variablespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitLocalVars.pm000444000766000024 677212562314714 25117 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Variablespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitMatchVars.pm000444000766000024 656512562314713 25120 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Variablespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitPackageVars.pm000444000766000024 1531412562314713 25427 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Variablespackage Perl::Critic::Policy::Variables::ProhibitPackageVars; use 5.006001; use strict; use warnings; use Readonly; use Carp qw( carp ); use List::MoreUtils qw(all); use Perl::Critic::Utils qw{ :booleans :characters :severities :data_conversion }; use base 'Perl::Critic::Policy'; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : ProhibitPerl4PackageNames.pm000444000766000024 601212562314714 26442 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Variablespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitPunctuationVars.pm000444000766000024 3323012562314714 26403 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Variablespackage 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 base 'Perl::Critic::Policy'; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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, undef ) = @_; if ( $elem->isa('PPI::Token::Magic') ) { return _violates_magic( $self, $elem ); } elsif ( $elem->isa('PPI::Token::HereDoc') ) { return _violates_heredoc( $self, $elem ); } #the remaining applies_to() classes are all interpolated strings return _violates_string( $self, $elem ); } #----------------------------------------------------------------------------- # Helper functions for the three types of violations: code, quotes, heredoc 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 } #----------------------------------------------------------------------------- # 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 : ProhibitReusedNames.pm000444000766000024 1252412562314714 25454 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Variablespackage 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.126'; #----------------------------------------------------------------------------- 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 : ProhibitUnusedVariables.pm000444000766000024 1111412562314714 26327 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Variablespackage Perl::Critic::Policy::Variables::ProhibitUnusedVariables; use 5.006001; use strict; use warnings; use Readonly; use List::MoreUtils qw< any >; use PPI::Token::Symbol; use Perl::Critic::Utils qw< :characters :severities >; use base 'Perl::Critic::Policy'; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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() }++; } 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 : ProtectPrivateVars.pm000444000766000024 453112562314714 25326 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Variablespackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireInitializationForLocalVars.pm000444000766000024 564712562314714 30332 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Variablespackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireLexicalLoopIterators.pm000444000766000024 1047412562314713 27206 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Variablespackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireLocalizedPunctuationVars.pm000444000766000024 1301212562314714 30062 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Variablespackage 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.126'; #----------------------------------------------------------------------------- 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 : RequireNegativeIndices.pm000444000766000024 1557512562314714 26147 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Policy/Variablespackage 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.126'; #----------------------------------------------------------------------------- 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 : PolicyParameter000755000766000024 012562314714 20752 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/CriticBehavior.pm000444000766000024 522212562314714 23205 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyParameterpackage Perl::Critic::PolicyParameter::Behavior; use 5.006001; use strict; use warnings; use Perl::Critic::Utils qw{ :characters }; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : Behavior000755000766000024 012562314714 22511 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyParameterBoolean.pm000444000766000024 457012562314714 24571 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyParameter/Behaviorpackage 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.126'; #----------------------------------------------------------------------------- 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 : Enumeration.pm000444000766000024 1613112562314714 25514 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyParameter/Behaviorpackage 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.126'; #----------------------------------------------------------------------------- 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 : Integer.pm000444000766000024 1267312562314714 24632 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyParameter/Behaviorpackage 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.126'; #----------------------------------------------------------------------------- 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 : String.pm000444000766000024 440112562314714 24451 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyParameter/Behaviorpackage 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.126'; #----------------------------------------------------------------------------- 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 : StringList.pm000444000766000024 1050312562314714 25325 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/PolicyParameter/Behaviorpackage 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.126'; #----------------------------------------------------------------------------- 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 : Utils000755000766000024 012562314714 16752 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/CriticConstants.pm000444000766000024 1350212562314713 21441 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Utilspackage 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.126'; #----------------------------------------------------------------------------- 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 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 : DataConversion.pm000444000766000024 456112562314714 22372 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Utilspackage 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.126'; #----------------------------------------------------------------------------- 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 : McCabe.pm000444000766000024 1242412562314714 20602 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Utilspackage 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.126'; #----------------------------------------------------------------------------- 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 : Perl.pm000444000766000024 353712562314714 20357 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Utilspackage Perl::Critic::Utils::Perl; use 5.006001; use strict; use warnings; use Exporter 'import'; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : POD.pm000444000766000024 4412312562314714 20113 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Utilspackage 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.126'; #----------------------------------------------------------------------------- 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 : PPI.pm000444000766000024 2726012562314714 20124 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Utilspackage 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.126'; #----------------------------------------------------------------------------- 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 : POD000755000766000024 012562314713 17373 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/UtilsParseInteriorSequence.pm000444000766000024 517112562314713 24351 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Perl/Critic/Utils/PODpackage Perl::Critic::Utils::POD::ParseInteriorSequence; use 5.006001; use strict; use warnings; use base qw{ Pod::Parser }; use IO::String; our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : Test000755000766000024 012562314713 14451 5ustar00jeffstaff000000000000Perl-Critic-1.126/libPerl000755000766000024 012562314713 15353 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/TestCritic000755000766000024 012562314713 16570 5ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Test/PerlPolicy.pm000444000766000024 3212112562314713 20541 0ustar00jeffstaff000000000000Perl-Critic-1.126/lib/Test/Perl/Criticpackage 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.126'; #----------------------------------------------------------------------------- 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. B This module is alpha code -- interfaces and implementation are subject to major changes. This module is an integral part of building and testing L itself, but you should not write any code against this module until it has stabilized. =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-2011 Andy Lester. 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 : t000755000766000024 012562314714 13230 5ustar00jeffstaff000000000000Perl-Critic-1.12600_modules.t000444000766000024 3171712562314714 15552 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!perl use 5.006001; use strict; use warnings; use English qw(-no_match_vars); use PPI::Document; use Perl::Critic::TestUtils qw(bundled_policy_names); use Test::More; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 ); # 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'); #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/00_modules.t_without_optional_dependencies.t 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 : 01_bad_perlcriticrc000444000766000024 172512562314713 17107 0ustar00jeffstaff000000000000Perl-Critic-1.126/t# 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 : 01_config.t000444000766000024 4740512562314714 15351 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!perl use 5.006001; use strict; use warnings; use English qw< -no_match_vars >; use File::Spec; use List::MoreUtils qw(all 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.126'; #----------------------------------------------------------------------------- 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'); } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/01_config.t_without_optional_dependencies.t 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 : 01_config_bad_perlcriticrc.t000444000766000024 1115212562314713 20711 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- 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; } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/01_config_bad_perlcriticrc.t_without_optional_dependencies.t 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 : 01_policy_config.t000444000766000024 1023312562314714 16715 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!perl use 5.006001; use strict; use warnings; use Carp qw< confess >; use Perl::Critic::PolicyConfig; use Test::More tests => 28; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- { 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; } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/01_policy_config.t_without_optional_dependencies.t 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 : 02_policy.t000444000766000024 1144212562314714 15374 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!perl use 5.006001; use strict; use warnings; use English qw<-no_match_vars>; use Test::More tests => 29; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- # 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'); #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/02_policy.t_without_optional_dependencies.t 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 : 03_annotations.t000444000766000024 1672112562314714 16440 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!perl use 5.006001; use strict; use warnings; use English qw(-no_match_vars); use PPI::Document; use Perl::Critic::Annotation; use Perl::Critic::TestUtils qw(bundled_policy_names); use Test::More; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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]; } } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/00_modules.t_without_optional_dependencies.t 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 : 03_pragmas.t000444000766000024 4420312562314714 15531 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!perl use 5.006001; use strict; use warnings; use Test::More (tests => 32); use Perl::Critic::PolicyFactory (-test => 1); # common P::C testing tools use Perl::Critic::TestUtils qw(critique); #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 supressed. =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 supressed. =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' ); #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/03_pragmas.t_without_optional_dependencies.t 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 : 04_options_processor.t000444000766000024 2141612562314714 17673 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- { # 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', ); } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/04_defaults.t_without_optional_dependencies.t 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 : 05_utils.t000444000766000024 4150712562314713 15244 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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 => 153; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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) ) { ok( Perl::Critic::Utils::_is_perl($_), qq{Is perl: '$_'} ); } for ( qw(foo.doc foo.txt foo.conf foo) ) { 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; } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/05_utils.t_without_optional_dependencies.t 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 : 05_utils_perl.t000444000766000024 212012562314714 16233 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!perl use 5.006001; use strict; use warnings; use Readonly; use Perl::Critic::Utils::Perl qw< :all >; use Test::More tests => 7; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- # 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)", ); } } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/05_utils_ppi.t_without_optional_dependencies.t 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 : 05_utils_pod.t000444000766000024 3310612562314714 16103 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- 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; } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/05_utils_pod.t_without_optional_dependencies.t 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 : 05_utils_ppi.t000444000766000024 3037712562314714 16120 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!perl use 5.006001; use strict; use warnings; use Readonly; 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.126'; #----------------------------------------------------------------------------- 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 } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/05_utils_ppi.t_without_optional_dependencies.t 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 : 06_violation.t000444000766000024 2503012562314714 16103 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- 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; } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/06_violation.t_without_optional_dependencies.t 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 : 07_command.t000444000766000024 1733212562314714 15524 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- 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', ); } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/07_command.t_without_optional_dependencies.t 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 : 07_perlcritic.t000444000766000024 152612562314714 16224 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!perl use 5.006001; use strict; use warnings; use File::Spec; use Test::More tests => 1; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- my $perlcritic = File::Spec->catfile( qw(blib script perlcritic) ); if (not -e $perlcritic) { $perlcritic = File::Spec->catfile( qw(bin perlcritic) ) } require_ok($perlcritic); #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/07_perlcritic.t_without_optional_dependencies.t 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 : 08_document.t000444000766000024 1410712562314714 15722 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- 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.' ); #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/08_document.t_without_optional_dependencies.t 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 : 09_theme.t000444000766000024 2501712562314714 15211 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- 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(); } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/09_theme.t_without_optional_dependencies.t 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 : 10_user_profile.t000444000766000024 2404312562314713 16572 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- # 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'); } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/10_userprofile.t_without_optional_dependencies.t 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 : 11_policy_factory.t000444000766000024 1055612562314714 17130 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- 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{}; } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/11_policyfactory.t_without_optional_dependencies.t 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 : 12_policy_listing.t000444000766000024 371612562314714 17113 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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::PolicyListing; use Test::More; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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'); } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/12_policylisting.t_without_optional_dependencies.t 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 : 12_theme_listing.t000444000766000024 274112562314713 16712 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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::ThemeListing; use Test::More tests => 1; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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.' ); #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/12_themelisting.t_without_optional_dependencies.t 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 : 13_bundled_policies.t000444000766000024 245712562314714 17371 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- 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 ); #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/13_bundled_policies.t_without_optional_dependencies.t 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 : 14_policy_parameter_behavior_boolean.t000444000766000024 546012562314713 22777 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- 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 : 14_policy_parameter_behavior_enumeration.t000444000766000024 1245312562314714 23727 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- 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 : 14_policy_parameter_behavior_integer.t000444000766000024 1254012562314714 23033 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- 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 : 14_policy_parameter_behavior_list_string.t000444000766000024 1270212562314714 23737 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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 => 28; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : 14_policy_parameter_behavior_string.t000444000766000024 334012562314714 22662 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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 => 4; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 : 14_policy_parameters.t000444000766000024 1050412562314714 17620 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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); #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- use Test::More; #plan set below! 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; } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/14_policy_parameters.t_without_optional_dependencies.t 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 : 15_statistics.t000444000766000024 514112562314714 16252 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!perl use 5.006001; use strict; use warnings; use English qw(-no_match_vars); use Perl::Critic::PolicyFactory (-test => 1); use Perl::Critic::Statistics; use Perl::Critic::TestUtils; use Test::More tests => 24; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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"); } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/15_statistics.t_without_optional_dependencies.t 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 : 16_roundtrip_defaults.t000444000766000024 1710612562314714 20022 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!perl use 5.006001; use strict; use warnings; use English qw(-no_match_vars); 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.126'; #----------------------------------------------------------------------------- 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 : 20_policies.t000444000766000024 205512562314714 15664 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!perl use 5.006001; use strict; use warnings; use Test::Perl::Critic::Policy qw< all_policies_ok >; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- # 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); #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # 20_policies.t_without_optional_dependencies.t 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 : 20_policy_pod_spelling.t000444000766000024 661012562314714 20114 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- 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 #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/20_policy_pod_spelling.t_without_optional_dependencies.t 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 : 20_policy_prohibit_evil_modules.t000444000766000024 202312562314714 22016 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- 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 : 20_policy_prohibit_hard_tabs.t000444000766000024 731712562314714 21271 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- 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 : 20_policy_prohibit_trailing_whitespace.t000444000766000024 327612562314714 23367 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- 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 : 20_policy_require_consistent_newlines.t000444000766000024 360612562314714 23270 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!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.126'; #----------------------------------------------------------------------------- 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' ); } # ensure we return true if this test is loaded by # 20_policy_require_consistent_newlines.t_without_optional_dependencies.t 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 : 20_policy_require_tidy_code.t000444000766000024 504612562314714 21136 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!perl use 5.006001; use strict; use warnings; use Perl::Critic::TestUtils qw(pcritique); use Test::More tests => 6; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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', ); #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/20_policy_requiretidycode.t_without_optional_dependencies.t 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 : 92_memory_leaks.t000444000766000024 476112562314714 16563 0ustar00jeffstaff000000000000Perl-Critic-1.126/t#!perl use 5.006001; use strict; use warnings; use English qw< -no_match_vars >; 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.126'; #----------------------------------------------------------------------------- Perl::Critic::TestUtils::block_perlcriticrc(); eval 'use Test::Memory::Cycle; 1' or plan skip_all => 'Test::Memory::Cycle requried 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 ); memory_cycle_ok( $critic ); foreach my $violation (@violations) { memory_cycle_ok($_); } } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/92_memory_leaks.t.without_optional_dependencies.t 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 : 06_violation.d000755000766000024 012562314714 15763 5ustar00jeffstaff000000000000Perl-Critic-1.126/tlib000755000766000024 012562314714 16531 5ustar00jeffstaff000000000000Perl-Critic-1.126/t/06_violation.dViolationTest.pm000444000766000024 127512562314714 22035 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/06_violation.d/libpackage 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 : ViolationTest2.pm000444000766000024 104612562314714 22113 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/06_violation.d/libpackage 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 : Perl000755000766000024 012562314714 17433 5ustar00jeffstaff000000000000Perl-Critic-1.126/t/06_violation.d/libCritic000755000766000024 012562314714 20650 5ustar00jeffstaff000000000000Perl-Critic-1.126/t/06_violation.d/lib/PerlPolicy000755000766000024 012562314714 22107 5ustar00jeffstaff000000000000Perl-Critic-1.126/t/06_violation.d/lib/Perl/CriticTest.pm000444000766000024 114712562314714 23524 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/06_violation.d/lib/Perl/Critic/Policypackage 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 : source000755000766000024 012562314714 17263 5ustar00jeffstaff000000000000Perl-Critic-1.126/t/06_violation.dLine.pm000444000766000024 3312562314714 20601 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/06_violation.d/sourcefoo #line 57 Thingy.pm bar 20_policy_pod_spelling.d000755000766000024 012562314714 20011 5ustar00jeffstaff000000000000Perl-Critic-1.126/tstop-words.txt000444000766000024 7612562314714 22773 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/20_policy_pod_spelling.d# It's a comment! foo arglbargl # Some other comment. bar BuiltinFunctions000755000766000024 012562314714 16527 5ustar00jeffstaff000000000000Perl-Critic-1.126/tProhibitBooleanGrep.run000444000766000024 547412562314714 23322 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/BuiltinFunctions## 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 : ProhibitComplexMappings.run000444000766000024 254612562314713 24227 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/BuiltinFunctions## 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 : ProhibitLvalueSubstr.run000444000766000024 250412562314713 23546 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/BuiltinFunctions## 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 : ProhibitReverseSortBlock.run000444000766000024 251412562314713 24352 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/BuiltinFunctions## 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 : ProhibitSleepViaSelect.run000444000766000024 334012562314714 23763 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/BuiltinFunctions## 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 : ProhibitStringyEval.run000444000766000024 572112562314714 23367 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/BuiltinFunctions## 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 : ProhibitStringySplit.run000444000766000024 342412562314714 23571 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/BuiltinFunctions## 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 : ProhibitUniversalCan.run000444000766000024 110112562314714 23476 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/BuiltinFunctions## 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 : ProhibitUniversalIsa.run000444000766000024 106212562314713 23516 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/BuiltinFunctions## 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 : ProhibitUselessTopic.run000444000766000024 356512562314714 23546 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/BuiltinFunctions## 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 : ProhibitVoidGrep.run000444000766000024 315112562314714 22632 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/BuiltinFunctions## 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 : ProhibitVoidMap.run000444000766000024 311712562314714 22454 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/BuiltinFunctions## 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 : RequireBlockGrep.run000444000766000024 167512562314714 22630 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/BuiltinFunctions## 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 : RequireBlockMap.run000444000766000024 156312562314714 22444 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/BuiltinFunctions## 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 : RequireGlobFunction.run000444000766000024 151312562314714 23340 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/BuiltinFunctions## 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 : RequireSimpleSortBlock.run000444000766000024 241312562314714 24023 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/BuiltinFunctions## 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 : ClassHierarchies000755000766000024 012562314714 16444 5ustar00jeffstaff000000000000Perl-Critic-1.126/tProhibitAutoloading.run000444000766000024 133012562314714 23273 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ClassHierarchies## 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 : ProhibitExplicitISA.run000444000766000024 103712562314714 23147 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ClassHierarchies## 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 : ProhibitOneArgBless.run000444000766000024 150212562314714 23172 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ClassHierarchies## 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 : CodeLayout000755000766000024 012562314714 15300 5ustar00jeffstaff000000000000Perl-Critic-1.126/tProhibitParensWithBuiltins.run000444000766000024 661412562314714 23471 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/CodeLayout## 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 : ProhibitQuotedWordLists.run000444000766000024 436612562314714 23011 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/CodeLayout## 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 : RequireTrailingCommas.run000444000766000024 355512562314714 22441 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/CodeLayout## 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 : ControlStructures000755000766000024 012562314714 16754 5ustar00jeffstaff000000000000Perl-Critic-1.126/tProhibitCascadingIfElse.run000444000766000024 207112562314714 24304 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ControlStructures## 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 : ProhibitCStyleForLoops.run000444000766000024 122212562314713 24223 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ControlStructures## 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 : ProhibitDeepNests.run000444000766000024 500212562314713 23226 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ControlStructures## 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 : ProhibitLabelsWithSpecialBlockNames.run000444000766000024 170112562314714 26635 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ControlStructures## 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 : ProhibitMutatingListFunctions.run000444000766000024 1225112562314714 25676 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ControlStructures## 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 : ProhibitNegativeExpressionsInUnlessAndUntilConditions.run.PL000444000766000024 1360712562314714 33060 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ControlStructures#!/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 >; our $VERSION = '1.121'; 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 : ProhibitPostfixControls.run000444000766000024 1145712562314713 24547 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ControlStructures## 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 : ProhibitUnlessBlocks.run000444000766000024 107012562314714 23745 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ControlStructures## 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 : ProhibitUnreachableCode.run000444000766000024 451312562314714 24347 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ControlStructures## 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 : ProhibitUntilBlocks.run000444000766000024 107112562314714 23570 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ControlStructures## 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 : ProhibitYadaOperator.run000444000766000024 136212562314714 23734 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ControlStructures## 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 : Documentation000755000766000024 012562314714 16041 5ustar00jeffstaff000000000000Perl-Critic-1.126/tRequirePackageMatchesPodName.run000444000766000024 615012562314714 24367 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Documentation## 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 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 : RequirePodAtEnd.run000444000766000024 323712562314714 21724 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Documentation## 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 : RequirePodLinksIncludeText.run000444000766000024 640412562314714 24161 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Documentation## name No links ## failures 0 ## cut =head1 DOGGEREL The boy stood on the burning deck, His feet were full of blisters. A flame licked up and burned off his pants, And now he wears his sister's. =cut #----------------------------------------------------------------------------- ## name Complying links ## failures 0 ## cut =pod The L source may be found at L. =cut #----------------------------------------------------------------------------- ## name Non-complying links ## failures 1 ## cut =pod The L configuration file is F<~/.perlcriticrc> =cut #----------------------------------------------------------------------------- ## name Multiple brackets ## failures 0 ## cut =pod The L<< Perl::Critic->new()|Perl::Critic/new >> method creates an instance of the L<< Perl::Critic|Perl::Critic >> class. =cut #----------------------------------------------------------------------------- ## name If it is inside another formatter it is not really a link ## failures 0 ## cut =pod Constructions like C<< L >> should be avoided, since you never know what the POD translator is going to turn them into. You should use something like C<< L >> instead, to be sure of getting C in your output. Formatters of all sorts are recognized even if they cross line boundaries. C<< L >> is still not seen as a link. =cut #----------------------------------------------------------------------------- ## name External sections allowed ## failures 0 ## parms { allow_external_sections => '1' } ## cut =pod L critiques a file, returning any violations found. L<< $critic->critique()|Perl::Critic/critique >> critiques a file, returning any violations found. =cut #----------------------------------------------------------------------------- ## name External sections not allowed ## failures 1 ## parms { allow_external_sections => '0' } ## cut =pod L critiques a file, returning any violations found. L<< $critic->critique()|Perl::Critic/critique >> critiques a file, returning any violations found. =cut #----------------------------------------------------------------------------- ## name Internal sections allowed ## failures 0 ## parms { allow_internal_sections => '1' } ## cut =pod L critiques a file, returning any violations found. L critiques a file, returning any violations found. =cut #----------------------------------------------------------------------------- ## name Internal sections not allowed ## failures 1 ## parms { allow_internal_sections => '0' } ## cut =pod L critiques a file, returning any violations found. L critiques a file, returning any violations found. =cut #----------------------------------------------------------------------------- ## name Handle nested format codes RT 65569. ## failures 0 ## cut =pod See L|perldiag> for the gory details. =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 : RequirePodSections.run000444000766000024 472712562314713 22524 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Documentation## 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 : ErrorHandling000755000766000024 012562314714 15766 5ustar00jeffstaff000000000000Perl-Critic-1.126/tRequireCarping.run000444000766000024 3017512562314714 21617 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ErrorHandling## 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 : RequireCheckingReturnValueOfEval.run000444000766000024 1667712562314713 25253 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ErrorHandling## 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 }; #----------------------------------------------------------------------------- # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 78 # indent-tabs-mode: nil # c-indentation-style: bsd # End: # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : InputOutput000755000766000024 012562314714 15550 5ustar00jeffstaff000000000000Perl-Critic-1.126/tProhibitBacktickOperators.run000444000766000024 276012562314714 23553 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/InputOutput## 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 : ProhibitBarewordFileHandles.run000444000766000024 226512562314713 24004 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/InputOutput## 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 : ProhibitExplicitStdin.run000444000766000024 162412562314714 22722 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/InputOutput## 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 : ProhibitInteractiveTest.run000444000766000024 74712562314714 23241 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/InputOutput## 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 : ProhibitJoinedReadline.run000444000766000024 235512562314713 23014 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/InputOutput## 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 : ProhibitOneArgSelect.run000444000766000024 211612562314714 22447 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/InputOutput## 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 : ProhibitReadlineInForLoop.run000444000766000024 122212562314714 23444 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/InputOutput## 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 : ProhibitTwoArgOpen.run000444000766000024 460712562314714 22170 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/InputOutput## 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 : RequireBracedFileHandleWithPrint.run000444000766000024 1055412562314714 24762 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/InputOutput## 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 : RequireBriefOpen.run000444000766000024 1664512562314714 21675 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/InputOutput## 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 : RequireCheckedClose.run000444000766000024 724712562314714 22316 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/InputOutput## 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 : RequireCheckedOpen.run000444000766000024 1075712562314714 22172 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/InputOutput## 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 : RequireCheckedSyscalls.run000444000766000024 2132512562314714 23057 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/InputOutput## 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'; #----------------------------------------------------------------------------- # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 78 # indent-tabs-mode: nil # c-indentation-style: bsd # End: # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : RequireEncodingWithUTF8Layer.run000444000766000024 726712562314714 24032 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/InputOutput## 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 : Miscellanea000755000766000024 012562314714 15445 5ustar00jeffstaff000000000000Perl-Critic-1.126/tProhibitFormats.run000444000766000024 174112562314714 21447 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Miscellanea## 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 : ProhibitTies.run000444000766000024 160112562314713 20732 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Miscellanea## 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 : ProhibitUnrestrictedNoCritic.run000444000766000024 352312562314714 24142 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Miscellanea##---------------------------------------------------------------------------- ## 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 : Modules000755000766000024 012562314714 14640 5ustar00jeffstaff000000000000Perl-Critic-1.126/tProhibitAutomaticExportation.run000444000766000024 364212562314713 23413 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Modules## 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 : ProhibitConditionalUseStatements.run000444000766000024 4065212562314714 24243 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Modules## 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 : ProhibitEvilModules.run000444000766000024 714112562314713 21456 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Modules## 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 : ProhibitExcessMainComplexity.run000444000766000024 343012562314714 23341 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Modules## 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 : ProhibitMultiplePackages.run000444000766000024 120012562314714 22447 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Modules## 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 : RequireBarewordIncludes.run000444000766000024 177612562314714 22327 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Modules## 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 6 ## cut require 'Exporter'; require 'My/Module.pl'; use 'SomeModule'; use q{OtherModule.pm}; 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 : RequireEndWithOne.run000444000766000024 472712562314714 21076 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Modules## 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; #----------------------------------------------------------------------------- # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 78 # indent-tabs-mode: nil # c-indentation-style: bsd # End: # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : RequireExplicitPackage.run000444000766000024 555512562314714 22127 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Modules## 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 : RequireFilenameMatchesPackage.run000444000766000024 1347612562314713 23413 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Modules## 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 : RequireNoMatchVarsWithUseEnglish.run000444000766000024 1340512562314713 24112 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Modules## 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 : RequireVersionVar.run000444000766000024 457112562314714 21165 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Modules## 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 : ProhibitEvilModules.d000755000766000024 012562314714 21013 5ustar00jeffstaff000000000000Perl-Critic-1.126/t/Modulesmodules-no-regular-expressions.txt000444000766000024 36412562314714 27775 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Modules/ProhibitEvilModules.dEvil # 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. modules-regular-expressions.txt000444000766000024 47112562314714 27362 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Modules/ProhibitEvilModules.d/\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. NamingConventions000755000766000024 012562314714 16667 5ustar00jeffstaff000000000000Perl-Critic-1.126/tCapitalization.run.PL000444000766000024 6077012562314714 23071 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/NamingConventions#!/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 >; our $VERSION = '1.121'; 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 : ProhibitAmbiguousNames.run000444000766000024 471512562314714 24201 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/NamingConventions## 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 : Objects000755000766000024 012562314714 14621 5ustar00jeffstaff000000000000Perl-Critic-1.126/tProhibitIndirectSyntax.run000444000766000024 206012562314714 22153 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Objects## 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 : References000755000766000024 012562314714 15311 5ustar00jeffstaff000000000000Perl-Critic-1.126/tProhibitDoubleSigils.run000444000766000024 177012562314714 22267 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/References## 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 : RegularExpressions000755000766000024 012562314714 17074 5ustar00jeffstaff000000000000Perl-Critic-1.126/tProhibitCaptureWithoutTest.run000444000766000024 1473712562314714 25343 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/RegularExpressions## 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 : ProhibitComplexRegexes.run000444000766000024 505012562314714 24412 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/RegularExpressions## 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 : ProhibitEnumeratedClasses.run000444000766000024 326712562314714 25077 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/RegularExpressions## 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 : ProhibitEscapedMetacharacters.run000444000766000024 235712562314714 25702 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/RegularExpressions## 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 : ProhibitFixedStringMatches.run000444000766000024 327412562314714 25221 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/RegularExpressions## 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 : ProhibitSingleCharAlternation.run000444000766000024 232512562314714 25702 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/RegularExpressions## 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 : ProhibitUnusedCapture.run000444000766000024 2670112562314714 24275 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/RegularExpressions## 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 : ProhibitUselessTopic.run000444000766000024 517112562314714 24106 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/RegularExpressions## 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 : RequireBracesForMultiline.run000444000766000024 162312562314714 25047 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/RegularExpressions## 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 : RequireDotMatchAnything.run000444000766000024 506012562314714 24522 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/RegularExpressions## 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 : RequireExtendedFormatting.run000444000766000024 720012562314713 25105 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/RegularExpressions## 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 : RequireLineBoundaryMatching.run000444000766000024 505712562314714 25371 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/RegularExpressions## 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 : Subroutines000755000766000024 012562314714 15552 5ustar00jeffstaff000000000000Perl-Critic-1.126/tProhibitAmpersandSigils.run000444000766000024 346612562314714 23234 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Subroutines## 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 : ProhibitBuiltinHomonyms.run000444000766000024 162412562314713 23300 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Subroutines## 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 : ProhibitExcessComplexity.run000444000766000024 233512562314713 23450 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Subroutines## 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 : ProhibitExplicitReturnUndef.run000444000766000024 143712562314714 24106 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Subroutines## 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 : ProhibitManyArgs.run000444000766000024 456312562314714 21667 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Subroutines## 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 } #----------------------------------------------------------------------------- # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 78 # indent-tabs-mode: nil # c-indentation-style: bsd # End: # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : ProhibitNestedSubs.run000444000766000024 247312562314714 22223 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Subroutines## 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 : ProhibitReturnSort.run000444000766000024 255012562314714 22267 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Subroutines## 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 : ProhibitSubroutinePrototypes.run000444000766000024 101712562314714 24405 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Subroutines## 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 : ProhibitUnusedPrivateSubroutines.run000444000766000024 1167212562314714 25226 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Subroutines## 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"; } #----------------------------------------------------------------------------- # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 78 # indent-tabs-mode: nil # c-indentation-style: bsd # End: # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : ProtectPrivateSubs.run000444000766000024 771312562314714 22255 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Subroutines## 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 : RequireArgUnpacking.run000444000766000024 1765412562314714 22400 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Subroutines## 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 : RequireFinalReturn.run000444000766000024 1336512562314714 22253 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Subroutines## 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 terminals ## 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 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 : TestingAndDebugging000755000766000024 012562314714 17104 5ustar00jeffstaff000000000000Perl-Critic-1.126/tProhibitNoStrict.run000444000766000024 434412562314714 23242 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/TestingAndDebugging## 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 : ProhibitNoWarnings.run000444000766000024 567412562314714 23571 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/TestingAndDebugging## 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" ); #----------------------------------------------------------------------------- # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 78 # indent-tabs-mode: nil # c-indentation-style: bsd # End: # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : ProhibitProlongedStrictureOverride.run000444000766000024 261212562314714 27027 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/TestingAndDebugging## 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 : RequireTestLabels.run000444000766000024 416212562314714 23371 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/TestingAndDebugging## 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 : RequireUseStrict.run000444000766000024 1032012562314714 23265 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/TestingAndDebugging## 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 : RequireUseWarnings.run000444000766000024 1063512562314714 23616 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/TestingAndDebugging## 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 : ValuesAndExpressions000755000766000024 012562314714 17355 5ustar00jeffstaff000000000000Perl-Critic-1.126/tProhibitCommaSeparatedStatements.run000444000766000024 1532312562314714 26722 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 ## TODO PPI parses this code as blocks and not hash constructors. ## 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 : ProhibitComplexVersion.run000444000766000024 2305612562314713 24743 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : ProhibitConstantPragma.run000444000766000024 104512562314714 24662 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : ProhibitEmptyQuotes.run000444000766000024 150312562314714 24237 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : ProhibitEscapedCharacters.run000444000766000024 111312562314713 25300 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : ProhibitImplicitNewlines.run000444000766000024 144212562314714 25221 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : ProhibitInterpolationOfLiterals.run000444000766000024 621012562314714 26554 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : ProhibitLeadingZeros.run000444000766000024 625112562314714 24333 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 ); #----------------------------------------------------------------------------- # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 78 # indent-tabs-mode: nil # c-indentation-style: bsd # End: # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : ProhibitLongChainsOfMethodCalls.run000444000766000024 354712562314713 26403 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : ProhibitMagicNumbers.run000444000766000024 6513212562314714 24344 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : ProhibitMismatchedOperators.run000444000766000024 561112562314714 25721 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : ProhibitMixedBooleanOperators.run000444000766000024 407212562314714 26211 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : ProhibitNoisyQuotes.run000444000766000024 231112562314713 24237 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : ProhibitQuotesAsQuotelikeOperatorDelimiters.run000444000766000024 523312562314714 31131 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : ProhibitSpecialLiteralHeredocTerminator.run000444000766000024 360212562314713 30175 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 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 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__ #----------------------------------------------------------------------------- # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 78 # indent-tabs-mode: nil # c-indentation-style: bsd # End: # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : ProhibitVersionStrings.run000444000766000024 252512562314714 24744 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : RequireConstantVersion.run000444000766000024 3007212562314714 24756 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : RequireInterpolationOfMetachars.run000444000766000024 2032712562314714 26565 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : RequireNumberSeparators.run000444000766000024 335412562314714 25076 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : RequireQuotedHeredocTerminator.run000444000766000024 237212562314714 26401 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/ValuesAndExpressions## 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 : ProhibitConditionalDeclarations.run000444000766000024 416012562314714 24321 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variables## 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 : ProhibitEvilVariables.run000444000766000024 1227712562314714 22305 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variables## 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 : ProhibitLocalVars.run000444000766000024 151512562314714 21414 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variables## 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 : ProhibitMatchVars.run000444000766000024 121412562314713 21411 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variables## 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 : ProhibitPackageVars.run000444000766000024 606312562314714 21720 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variables## 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 : ProhibitPerl4PackageNames.run000444000766000024 1427312562314714 23001 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variables## 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 : ProhibitPunctuationVars.run000444000766000024 2200512562314714 22710 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variables## 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<\$+>; ## 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 : ProhibitReusedNames.run000444000766000024 754212562314714 21747 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variables## 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 : ProhibitUnusedVariables.run000444000766000024 617612562314713 22631 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variables## 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; #----------------------------------------------------------------------------- # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 78 # indent-tabs-mode: nil # c-indentation-style: bsd # End: # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : ProtectPrivateVars.run000444000766000024 120312562314713 21625 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variables## 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 : RequireInitializationForLocalVars.run000444000766000024 161212562314714 24625 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variables## 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 : RequireLexicalLoopIterators.run000444000766000024 315112562314714 23470 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variables## 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 : RequireLocalizedPunctuationVars.run.PL000444000766000024 1744412562314713 24717 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variables#!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 : RequireNegativeIndices.run000444000766000024 310612562314714 22421 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variables## 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 : ProhibitEvilVariables.d000755000766000024 012562314714 21613 5ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variablesvariables-no-regular-expressions.txt000444000766000024 45512562314714 31076 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variables/ProhibitEvilVariables.d$[ # 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. variables-regular-expressions.txt000444000766000024 56312562314714 30464 0ustar00jeffstaff000000000000Perl-Critic-1.126/t/Variables/ProhibitEvilVariables.d/\$\[/ # 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. tools000755000766000024 012562314714 14125 5ustar00jeffstaff000000000000Perl-Critic-1.126ppidump000555000766000024 333012562314714 15665 0ustar00jeffstaff000000000000Perl-Critic-1.126/tools#!/usr/bin/env perl use strict; use warnings; use PPI::Document; use PPI::Dumper; our $VERSION = '1.123'; 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 : xt000755000766000024 012562314713 13417 5ustar00jeffstaff000000000000Perl-Critic-1.126author000755000766000024 012562314714 14722 5ustar00jeffstaff000000000000Perl-Critic-1.126/xt40_criticize-code.t000444000766000024 431612562314714 20450 0ustar00jeffstaff000000000000Perl-Critic-1.126/xt/author#!perl # Self-compliance tests use strict; use warnings; use English qw( -no_match_vars ); 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, '-extra-test-policies' => [ qw{ ErrorHandling::RequireUseOfExceptions } ], ); use Test::More; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- use Test::Perl::Critic; #----------------------------------------------------------------------------- # Fall over if P::C::More isn't installed. use Perl::Critic::Policy::ErrorHandling::RequireUseOfExceptions; #----------------------------------------------------------------------------- # 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', 'author', '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 : 40_perlcriticrc-code000444000766000024 242612562314714 20706 0ustar00jeffstaff000000000000Perl-Critic-1.126/xt/authorprofile-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::RequirePodLinksIncludeText] [Documentation::PodSpelling] spell_command = aspell list -l en_US stop_words_file = xt/author/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 [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+ [Variables::ProhibitPackageVars] add_packages = Email::Address 40_stop_words000444000766000024 207112562314714 17510 0ustar00jeffstaff000000000000Perl-Critic-1.126/xt/authoraccessor 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 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 41_criticize-policies.t000444000766000024 327612562314714 21352 0ustar00jeffstaff000000000000Perl-Critic-1.126/xt/author#!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 English qw< -no_match_vars >; use File::Spec qw<>; use Perl::Critic::PolicyFactory ( '-test' => 1 ); use Test::More; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 author 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 : 41_perlcriticrc-policies000444000766000024 46412562314714 21564 0ustar00jeffstaff000000000000Perl-Critic-1.126/xt/authorprofile-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 42_criticize-tests.t000444000766000024 374512562314714 20707 0ustar00jeffstaff000000000000Perl-Critic-1.126/xt/author#!perl # Self-compliance tests use strict; use warnings; use English qw( -no_match_vars ); 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, '-extra-test-policies' => [ qw{ ErrorHandling::RequireUseOfExceptions } ], ); use Test::More; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- use Test::Perl::Critic; #----------------------------------------------------------------------------- # Fall over if P::C::More isn't installed. use Perl::Critic::Policy::ErrorHandling::RequireUseOfExceptions; #----------------------------------------------------------------------------- # 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', 'author', '42_perlcriticrc-tests' ); Test::Perl::Critic->import( -profile => $rcfile ); all_critic_ok( glob ('t/*.t'), glob ('xt/author/*.t'), 'generate_without_optional_dependencies_wrappers.PL', ); #----------------------------------------------------------------------------- # Local Variables: # mode: cperl # cperl-indent-level: 4 # fill-column: 78 # indent-tabs-mode: nil # c-indentation-style: bsd # End: # ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround : 42_perlcriticrc-tests000444000766000024 266412562314714 21144 0ustar00jeffstaff000000000000Perl-Critic-1.126/xt/authorprofile-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] 43_criticize-run-files.t000444000766000024 310612562314714 21441 0ustar00jeffstaff000000000000Perl-Critic-1.126/xt/author#!perl # Simple self-compliance tests for .run files. use strict; use warnings; use English qw< -no_match_vars >; use File::Spec qw<>; use Test::More; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 author 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 : 43_perlcriticrc-run-files000444000766000024 51212562314714 21655 0ustar00jeffstaff000000000000Perl-Critic-1.126/xt/authorprofile-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] [Editor::RequireEmacsFileVariables] 80_policysummary.t000444000766000024 607712562314714 20502 0ustar00jeffstaff000000000000Perl-Critic-1.126/xt/author#!perl use strict; use warnings; use English qw< -no_match_vars >; use Carp qw< confess >; use File::Spec; use List::MoreUtils qw(any); use Perl::Critic::PolicyFactory ( -test => 1 ); use Perl::Critic::TestUtils qw{ bundled_policy_names }; use Test::More; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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; } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/80_policysummary.t.without_optional_dependencies.t 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 : 81_ppi_problems.t000444000766000024 614212562314714 20252 0ustar00jeffstaff000000000000Perl-Critic-1.126/xt/author#!/usr/bin/perl use strict; use warnings; use PPI::Document; use Test::More tests => 4; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- # Things we're looking for from PPI. { local $TODO = q; can_ok 'PPI::Statement::Include', 'arguments'; } { local $TODO = q; can_ok 'PPI::Token::QuoteLike::Words', 'literal'; } { 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); } } { # PPI 1.206 correctly parses 'use constant { ONE => 1, TWO => 2 }' as a # PPI::Statement::Include consisting of two words followed by a # constructor. But it incorrectly parses 'use constant 1.16 { ONE => 1, # TWO => 2} as two words and a float followed by a block. We can remove # the test for 'PPI::Structure::Block' from # _constant_names_from_constant_pragma() in # Perl::Critic::PPIx::Utilities::Statement once this is fixed. my $code = 'use constant 1.16 { ONE => 1, TWO => 2 }'; local $TODO = q; my $doc = PPI::Document->new(\$code); my $stmt = $doc->schild(0); _test_class($stmt, 'PPI::Statement::Include') or last; my @kids = $stmt->schildren(); _test_class($kids[-1], 'PPI::Structure::Constructor') or last; pass( qq ); } sub _test_class { my ($elem, $want) = @_; $elem->isa($want) and return 1; my $class = ref $elem; fail( 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 : 93_version.t000444000766000024 333212562314713 17244 0ustar00jeffstaff000000000000Perl-Critic-1.126/xt/author#!perl use strict; use warnings; use English qw< -no_match_vars >; use Carp qw< confess >; use File::Find; use Test::More; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- plan 'no_plan'; my $last_version = undef; find({wanted => \&check_version, no_chdir => 1}, 'blib'); if (! defined $last_version) { fail('Failed to find any files with $VERSION'); ## no critic (RequireInterpolationOfMetachars) } sub check_version { return if (! m< blib/script/ >xms && ! m< [.] pm \z >xms); local $INPUT_RECORD_SEPARATOR = undef; my $fh; open $fh, '<', $_ or confess "$OS_ERROR"; my $content = <$fh>; close $fh or confess "$OS_ERROR"; # Skip POD $content =~ s/^__END__.*//xms; # 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($_); } for my $line (@version_lines) { if (!defined $last_version) { $last_version = shift @version_lines; pass($_); } else { is($line, $last_version, $_); } } 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 : 94_includes.t000444000766000024 547712562314713 17402 0ustar00jeffstaff000000000000Perl-Critic-1.126/xt/author#!perl use strict; use warnings; use Carp qw< confess >; use File::Find; use PPI::Document; use Test::More; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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); } #----------------------------------------------------------------------------- # ensure we return true if this test is loaded by # t/94_includes.t.t.without_optional_dependencies.t 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 : 95_kwalitee.t000444000766000024 115712562314714 17372 0ustar00jeffstaff000000000000Perl-Critic-1.126/xt/author#!/usr/bin/perl use strict; use warnings; use English qw< -no_match_vars >; use Test::More; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- eval 'use Test::Kwalitee 1.15 tests => [ qw{ -no_symlinks } ]; 1' or plan skip_all => 'Test::Kwalitee requried 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 : 98_pod_syntax.t000444000766000024 127712562314714 17763 0ustar00jeffstaff000000000000Perl-Critic-1.126/xt/author#!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.126'; #----------------------------------------------------------------------------- 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 : 99_pod_coverage.t000444000766000024 433512562314714 20227 0ustar00jeffstaff000000000000Perl-Critic-1.126/xt/author#!perl use 5.006001; use strict; use warnings; use English qw< -no_match_vars >; use Test::More; #----------------------------------------------------------------------------- our $VERSION = '1.126'; #----------------------------------------------------------------------------- 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 :