--- /dev/null
+#######################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/Build.PL $
+# $Date: 2008-06-17 14:27:21 -0500 (Tue, 17 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2450 $
+########################################################################
+
+use 5.006001;
+
+use strict;
+use warnings;
+
+use lib 'inc';
+use lib 't/tlib';
+
+use Module::Build;
+
+use Perl::Critic::BuildUtilities qw<
+ recommended_module_versions
+ test_wrappers_to_generate
+ get_PL_files
+ dump_unlisted_or_optional_module_versions
+ emit_tar_warning_if_necessary
+>;
+
+emit_tar_warning_if_necessary();
+
+
+my $class = Module::Build->subclass( code => <<'END_SUBCLASS' );
+
+ sub ACTION_test {
+ my ($self) = @_;
+
+ $self->depends_on('manifest');
+
+ return $self->SUPER::ACTION_test();
+ }
+
+ sub ACTION_authortest {
+ 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);
+
+ $self->depends_on('test');
+
+ return;
+ }
+
+ sub ACTION_distdir {
+ my ($self) = @_;
+
+ $self->depends_on('authortest');
+
+ return $self->SUPER::ACTION_distdir();
+ }
+
+END_SUBCLASS
+
+my $builder = $class->new(
+ module_name => 'Perl::Critic',
+ dist_author => 'Jeffrey Thalhammer <thaljef@cpan.org>',
+ dist_abstract => 'Critique Perl source code for best-practices.',
+ license => 'perl',
+ dynamic_config => 1,
+ create_readme => 1,
+ create_packlist => 1,
+ sign => 0,
+
+ requires => {
+ 'B::Keywords' => 1.05,
+ 'Carp' => 0,
+ 'Config::Tiny' => 2,
+ 'English' => 0,
+ 'Exception::Class' => 1.23,
+ 'Exporter' => 0,
+ 'File::Basename' => 0,
+ 'File::Find' => 0,
+ 'File::Path' => 0,
+ 'File::Spec' => 0,
+ 'File::Spec::Unix' => 0,
+ 'File::Temp' => 0,
+ 'Getopt::Long' => 0,
+ 'IO::String' => 0,
+ 'List::MoreUtils' => 0,
+ 'List::Util' => 0,
+ 'Module::Pluggable' => 3.1,
+ 'PPI' => 1.203,
+ 'PPI::Document' => 1.203,
+ 'PPI::Document::File' => 1.203,
+ 'PPI::Node' => 1.203,
+ 'PPI::Token::Quote::Single' => 1.203,
+ 'PPI::Token::Whitespace' => 1.203,
+ 'Pod::PlainText' => 0,
+ 'Pod::Select' => 0,
+ 'Pod::Usage' => 0,
+ 'Readonly' => 1.03,
+ 'Scalar::Util' => 0,
+ 'String::Format' => 1.13,
+ 'base' => 0,
+ 'charnames' => 0,
+ 'overload' => 0,
+ 'strict' => 0,
+ 'version' => 0,
+ 'warnings' => 0,
+ 'overload' => 0,
+ 'strict' => 0,
+ 'version' => 0,
+ 'warnings' => 0,
+ },
+
+ recommends => { recommended_module_versions() },
+
+ build_requires => {
+ 'lib' => 0,
+ 'Test::More' => 0,
+ },
+
+ PL_files => get_PL_files(),
+
+ script_files => ['bin/perlcritic'],
+
+ meta_merge => {
+ resources => {
+ homepage => 'http://perlcritic.com',
+ license => 'http://dev.perl.org/licenses/',
+ Repository => 'http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/',
+ MailingList => 'http://perlcritic.tigris.org/servlets/SummarizeList?listName=users',
+ },
+ no_index => {
+ file => [
+ qw<
+ TODO.pod
+ lib/Perl/Critic/PolicySummary.pod.PL
+ >
+ ],
+ directory => [
+ qw<
+ doc
+ >
+ ],
+ },
+ },
+
+ add_to_cleanup => [
+ qw<
+ lib/Perl/Critic/PolicySummary.pod
+ Makefile
+ Makefile.old
+ MANIFEST
+ MANIFEST.bak
+ META.yml
+ pm_to_blib
+ README
+ t/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.run
+ t/Variables/RequireLocalizedPunctuationVars.run
+ >,
+ test_wrappers_to_generate(),
+ ],
+);
+
+$builder->create_build_script();
+
+dump_unlisted_or_optional_module_versions();
+
+##############################################################################
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+[1.088] Released on 2008-07-03
+
+ 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] Released on 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] Released on 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] Released on 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 documentation updates.
+
+[1.084] Released on 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] Released on 2008-05-20
+[1.083_005] Released on 2008-05-19
+[1.083_004] Released on 2008-05-18
+[1.083_003] Released on 2008-05-17
+[1.083_002] Released on 2008-05-17
+[1.083_001] Released on 2008-04-13
+
+ Changes summarized into 1.084 above. For exact details, see Changes in
+ 1.083_006 on BackPAN.
+
+[1.082] Released on 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] Released on 2008-03-02
+[1.081_005] Released on 2007-12-29
+[1.081_004] Released on 2007-12-20
+[1.081_003] Released on 2007-12-16
+[1.081_002] Released on 2007-12-16
+[1.081_001] Released on 2007-12-15
+
+ Changes summarized into 1.082 above. For exact details, see Changes in
+ 1.081_006 on BackPAN.
+
+[1.080] Released on 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<local> 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] Released on 2007-10-22
+[1.079_002] Released on 2007-10-21
+[1.079_001] Released on 2007-10-09
+
+ Changes summarized into 1.080 above. For exact details, see Changes in
+ 1.079_003 on BackPAN.
+
+[1.078] Released on 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] Released on 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] Released on 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] Released on 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] Released on 2007-09-04
+
+ Bug Fixes:
+ Repeat the Makefile.PL change on
+ t/generate_without_optional_dependencies_wrappers.PL.
+ I love CPAN Testers.
+
+[1.073] Released on 2007-09-04
+
+ Bug Fixes:
+ Work around problems with the combination of Exporter & Readonly in
+ Makefile.PL on some machines.
+
+[1.072] Released on 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] Released on 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] Released on 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] Released on 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] Released on 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] Released on 2007-06-02
+
+ *DEVELOPMENT RELEASE*
+
+ Bug Fixes:
+ Fixed bug in 15_statustics.t test script, which caused the build
+ to fail on machines that don't have Perl::Tidy installed.
+
+[1.052] Released on 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] Released on 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] Released on 2007-03-19
+
+ Bug Fixes:
+ * 25557: t/20_policy_prohibittrailingwhitespace.t fails on Perl 5.8.0
+
+[1.04] Released on 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] Released on 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] Released on 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] Released on 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] Released on 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] Released on 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] Released on 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<split /\s+/>.
+
+[0.21] Released on 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] Released on 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] Released on 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] Released on 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<use overload '""'> 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] Released on 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] Released on 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] Released on 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] Released on 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] Released on 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] Released on 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] Released on 2006-03-26
+
+ Bug Fixes:
+ * 17964: Insists my code is not tidy (may not be fixed for all cases)
+
+[0.14_02] Released on 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] Released on 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] Released on 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
+
+[0.13_05] Not released
+
+ More documentation edits.
+
+ Implemented workaround for failing pod_coverage tests.
+
+ Bug Fixes:
+ * 16906: tr/// created false-postives with RegularExpression polices.
+
+[0.13_04] Released on 2005-12-31
+
+ Moved DEVELOPER.pod file into the Perl/Critic dir.
+
+ More documentation edits.
+
+[0.13_03] Released on 20051230
+
+ 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] Released on 2005-12-29
+
+ Fixed Config to recognize fully-qualified module names in the
+ .perlcriticrc file.
+
+ Various documentation edits.
+
+[0.13_01] Released on 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] Released on 2005-10-31
+
+ Official release of 0.12_03. No code major changes.
+
+[0.12_03] Not released
+
+ 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.
+
+ Name Changes:
+ * ProhibitUnpackagedCode => RequireExplicitPackage
+ * RequireQuotedWords => ProhibitQuotedWordLists
+
+ Improved error message when Perl::Critic dies because PPI can't
+ parsee the input code.
+
+ Changed output of -help to be more terse.
+
+ Edited POD.
+
+[0.12_02] Not released
+
+ 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.
+
+[0.12_01] Not released
+
+ 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 <cdolan@cpan.org>
+
+ 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 Policy modules:
+ * BuiltinFunctions::ProhibitLvalueSubstr
+ * BuiltinFunctions::ProhibitSleepViaSelect
+ * ClassHierarchies::ProhibitOneArgBless
+ * CodeLayout::RequireTrailingCommas
+ * CodeLayout::RequireQuotedWordLists
+ * InputOutput::ProhibitTwoArgOpen
+ * InputOutput::ProhibitOneArgSelect
+ * InputOutput::ProhibitBarewordFileHandles
+ * Miscellanea::RequireRcsKeywords
+ * Modules::RequireVersionVar
+ * RegularExpressions::RequireExtendedFormatting
+ * RegularExpressions::RequireLineBoundaryMatching
+
+
+ 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] Released 2005-10-10
+
+ 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.
+
+ Additional Prerequisites:
+ * String::Format
+
+[0.11] Not released
+
+ 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.
+
+ 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:
+ * IO::String
+ * Pod::PlainText
+
+[0.10] Released 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] Released 2005-10-04
+
+ Fixed several bugs:
+ * 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
+
+ Changed the syntax for the magic comments. Adam had the
+ idea of using a pragma-like notation. I liked it.
+
+[0.08_2] Released 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<prove>.
+
+ Edited more POD.
+
+[0.08_01] Not released
+
+ 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.
+
+[0.07] Released on 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] Released on 2005-09-17
+
+ Now called 'Perl::Critic'.
+
+ Added 4 new policy modules.
+
+ Fixed bugs in build process.
+
+ Added support for Module::Build.
+
+[0.05] Released on 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] Released on 2005-09-14
+
+ Version 0.03 was a bust because I uploaded the wrong tarball to PAUSE.
+
+[0.03] Released on 2005-09-13.
+
+ Fixed some POD links.
+
+ Removed test cases for missing policy module.
+
+[0.02] Released on 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] Released on 2005-08-16.
+
+ Initial version.
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/Changes $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+# ex: set ts=8 sts=4 sw=4 tw=78 ft= expandtab shiftround :
--- /dev/null
+#######################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/INSTALL $
+# $Date: 2007-07-25 10:34:04 -0500 (Wed, 25 Jul 2007) $
+# $Author: clonezone $
+# $Revision: 1790 $
+########################################################################
+
+NOTICE
+
+ The Perl::Critic distribution contains a fairly large number
+ of modules. And since it is still developing rapidly, some
+ of those modules may disappear or be renamed fron one release
+ to the next. Therefore, I suggest removing any existing
+ installation of Perl::Critic before installing a new one.
+
+INSTALLATION
+
+ To install Perl::Critic with C<make> give the following
+ commands to your favorite shell:
+
+ tar -zxf Perl-Critic-1.061.tar.gz
+ cd Perl-Critic-1.061
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+ Or if you prefer C<Module::Build>, try this:
+
+ tar -zxf Perl-Critic-1.061.tar.gz
+ cd Perl-Critic-1.061
+ perl Build.pl
+ ./Build
+ ./Build test
+ ./Build install
--- /dev/null
+Terms of Perl itself
+
+a) the GNU General Public License as published by the Free
+ Software Foundation; either version 1, or (at your option) any
+ later version, or
+b) the "Artistic License"
+
+----------------------------------------------------------------------------
+
+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
+
+
--- /dev/null
+bin/perlcritic
+Build.PL
+Changes
+examples/generatestats
+examples/loadanalysisdb
+examples/perlcriticrc
+examples/perlcriticrc-conway
+extras/KomodoIntegration.pod
+extras/perlcritic.el
+inc/Devel/AssertOS.pm
+inc/Devel/AssertOS/AIX.pm
+inc/Devel/AssertOS/Amiga.pm
+inc/Devel/AssertOS/Apple.pm
+inc/Devel/AssertOS/BeOS.pm
+inc/Devel/AssertOS/BSDOS.pm
+inc/Devel/AssertOS/Cygwin.pm
+inc/Devel/AssertOS/DEC.pm
+inc/Devel/AssertOS/DGUX.pm
+inc/Devel/AssertOS/DragonflyBSD.pm
+inc/Devel/AssertOS/Dynix.pm
+inc/Devel/AssertOS/FreeBSD.pm
+inc/Devel/AssertOS/HPUX.pm
+inc/Devel/AssertOS/Interix.pm
+inc/Devel/AssertOS/Irix.pm
+inc/Devel/AssertOS/Linux.pm
+inc/Devel/AssertOS/MachTen.pm
+inc/Devel/AssertOS/MacOSclassic.pm
+inc/Devel/AssertOS/MacOSX.pm
+inc/Devel/AssertOS/MicrosoftWindows.pm
+inc/Devel/AssertOS/MPEiX.pm
+inc/Devel/AssertOS/MSDOS.pm
+inc/Devel/AssertOS/MSWin32.pm
+inc/Devel/AssertOS/NetBSD.pm
+inc/Devel/AssertOS/Netware.pm
+inc/Devel/AssertOS/NeXT.pm
+inc/Devel/AssertOS/OpenBSD.pm
+inc/Devel/AssertOS/OS2.pm
+inc/Devel/AssertOS/OS390.pm
+inc/Devel/AssertOS/OS400.pm
+inc/Devel/AssertOS/OSF.pm
+inc/Devel/AssertOS/POSIXBC.pm
+inc/Devel/AssertOS/RISCOS.pm
+inc/Devel/AssertOS/SCO.pm
+inc/Devel/AssertOS/Solaris.pm
+inc/Devel/AssertOS/Sun.pm
+inc/Devel/AssertOS/SunOS.pm
+inc/Devel/AssertOS/SysVr4.pm
+inc/Devel/AssertOS/SysVr5.pm
+inc/Devel/AssertOS/Unicos.pm
+inc/Devel/AssertOS/Unix.pm
+inc/Devel/AssertOS/VMESA.pm
+inc/Devel/AssertOS/VMS.pm
+inc/Devel/AssertOS/VOS.pm
+inc/Devel/CheckOS.pm
+inc/Perl/Critic/BuildUtilities.pm
+INSTALL
+lib/Perl/Critic.pm
+lib/Perl/Critic/Config.pm
+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/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/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/Documentation/PodSpelling.pm
+lib/Perl/Critic/Policy/Documentation/RequirePackageMatchesPodName.pm
+lib/Perl/Critic/Policy/Documentation/RequirePodAtEnd.pm
+lib/Perl/Critic/Policy/Documentation/RequirePodSections.pm
+lib/Perl/Critic/Policy/ErrorHandling/RequireCarping.pm
+lib/Perl/Critic/Policy/ErrorHandling/RequireCheckingReturnValueOfEval.pm
+lib/Perl/Critic/Policy/InputOutput/ProhibitBacktickOperators.pm
+lib/Perl/Critic/Policy/InputOutput/ProhibitBarewordFileHandles.pm
+lib/Perl/Critic/Policy/InputOutput/ProhibitExplicitStdin.pm
+lib/Perl/Critic/Policy/InputOutput/ProhibitInteractiveTest.pm
+lib/Perl/Critic/Policy/InputOutput/ProhibitJoinedReadline.pm
+lib/Perl/Critic/Policy/InputOutput/ProhibitOneArgSelect.pm
+lib/Perl/Critic/Policy/InputOutput/ProhibitReadlineInForLoop.pm
+lib/Perl/Critic/Policy/InputOutput/ProhibitTwoArgOpen.pm
+lib/Perl/Critic/Policy/InputOutput/RequireBracedFileHandleWithPrint.pm
+lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm
+lib/Perl/Critic/Policy/InputOutput/RequireCheckedClose.pm
+lib/Perl/Critic/Policy/InputOutput/RequireCheckedOpen.pm
+lib/Perl/Critic/Policy/InputOutput/RequireCheckedSyscalls.pm
+lib/Perl/Critic/Policy/Miscellanea/ProhibitFormats.pm
+lib/Perl/Critic/Policy/Miscellanea/ProhibitTies.pm
+lib/Perl/Critic/Policy/Miscellanea/RequireRcsKeywords.pm
+lib/Perl/Critic/Policy/Modules/ProhibitAutomaticExportation.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/ProhibitAmbiguousNames.pm
+lib/Perl/Critic/Policy/NamingConventions/ProhibitMixedCaseSubs.pm
+lib/Perl/Critic/Policy/NamingConventions/ProhibitMixedCaseVars.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/RequireBracesForMultiline.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/ProhibitSubroutinePrototypes.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/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/ProhibitVersionStrings.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/ProhibitConditionalDeclarations.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/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.PL
+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/POD.pm
+lib/Perl/Critic/Utils/PPI.pm
+lib/Perl/Critic/Utils/PPIRegexp.pm
+lib/Perl/Critic/Violation.pm
+LICENSE
+Makefile.PL
+MANIFEST This list of files
+META.yml
+README
+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_pragmas.t
+t/04_optionsprocessor.t
+t/05_utils.t
+t/05_utils_pod.t
+t/05_utils_ppi.t
+t/06_violation.t
+t/07_perlcritic.t
+t/08_document.t
+t/09_theme.t
+t/10_userprofile.t
+t/11_policyfactory.t
+t/12_policylisting.t
+t/12_themelisting.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_podspelling.t
+t/20_policy_prohibithardtabs.t
+t/20_policy_prohibittrailingwhitespace.t
+t/20_policy_requireconsistentnewlines.t
+t/20_policy_requiretidycode.t
+t/92_memory_leaks.t
+t/98_pod_syntax.t
+t/99_pod_coverage.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/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/Documentation/RequirePackageMatchesPodName.run
+t/Documentation/RequirePodAtEnd.run
+t/Documentation/RequirePodSections.run
+t/ErrorHandling/RequireCarping.run
+t/ErrorHandling/RequireCheckingReturnValueOfEval.run
+t/generate_without_optional_dependencies_wrappers.PL
+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/Miscellanea/ProhibitFormats.run
+t/Miscellanea/ProhibitTies.run
+t/Miscellanea/RequireRcsKeywords.run
+t/Modules/ProhibitAutomaticExportation.run
+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/ProhibitAmbiguousNames.run
+t/NamingConventions/ProhibitMixedCaseSubs.run
+t/NamingConventions/ProhibitMixedCaseVars.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/RequireBracesForMultiline.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/ProhibitSubroutinePrototypes.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/tlib/Perl/Critic/Policy/Test.pm
+t/tlib/Perl/Critic/TestUtilitiesWithMinimalDependencies.pm
+t/tlib/ViolationTest.pm
+t/tlib/ViolationTest2.pm
+t/ValuesAndExpressions/ProhibitCommaSeparatedStatements.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/ProhibitVersionStrings.run
+t/ValuesAndExpressions/RequireInterpolationOfMetachars.run
+t/ValuesAndExpressions/RequireNumberSeparators.run
+t/ValuesAndExpressions/RequireQuotedHeredocTerminator.run
+t/ValuesAndExpressions/RequireUpperCaseHeredocTerminator.run
+t/Variables/ProhibitConditionalDeclarations.run
+t/Variables/ProhibitLocalVars.run
+t/Variables/ProhibitMatchVars.run
+t/Variables/ProhibitPackageVars.run
+t/Variables/ProhibitPerl4PackageNames.run
+t/Variables/ProhibitPunctuationVars.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
+tools/svnkeywords
+xt/author/40_criticize-code.t
+xt/author/40_perlcriticrc-code
+xt/author/41_criticize-policies.t
+xt/author/41_perlcriticrc-policies
+xt/author/80_policysummary.t
+xt/author/93_version.t
+xt/author/94_includes.t
+xt/author/95_kwalitee.t
--- /dev/null
+---
+name: Perl-Critic
+version: 1.088
+author:
+ - 'Jeffrey Thalhammer <thaljef@cpan.org>'
+abstract: Critique Perl source code for best-practices.
+license: perl
+resources:
+ MailingList: http://perlcritic.tigris.org/servlets/SummarizeList?listName=users
+ Repository: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/
+ homepage: http://perlcritic.com
+ license: http://dev.perl.org/licenses/
+requires:
+ B::Keywords: 1.05
+ Carp: 0
+ Config::Tiny: 2
+ English: 0
+ Exception::Class: 1.23
+ Exporter: 0
+ File::Basename: 0
+ File::Find: 0
+ File::Path: 0
+ File::Spec: 0
+ File::Spec::Unix: 0
+ File::Temp: 0
+ Getopt::Long: 0
+ IO::String: 0
+ List::MoreUtils: 0
+ List::Util: 0
+ Module::Pluggable: 3.1
+ PPI: 1.203
+ PPI::Document: 1.203
+ PPI::Document::File: 1.203
+ PPI::Node: 1.203
+ PPI::Token::Quote::Single: 1.203
+ PPI::Token::Whitespace: 1.203
+ Pod::PlainText: 0
+ Pod::Select: 0
+ Pod::Usage: 0
+ Readonly: 1.03
+ Scalar::Util: 0
+ String::Format: 1.13
+ base: 0
+ charnames: 0
+ overload: 0
+ strict: 0
+ version: 0
+ warnings: 0
+build_requires:
+ Test::More: 0
+ lib: 0
+recommends:
+ File::HomeDir: 0
+ File::Which: 0
+ IPC::Open2: 1
+ Perl::Tidy: 0
+ Pod::Spell: 1
+ Readonly::XS: 0
+ Regexp::Parser: 0.20
+ Term::ANSIColor: 0
+ Text::ParseWords: 3
+dynamic_config: 1
+provides:
+ Perl::Critic:
+ file: lib/Perl/Critic.pm
+ version: 1.088
+ Perl::Critic::Config:
+ file: lib/Perl/Critic/Config.pm
+ version: 1.088
+ Perl::Critic::Document:
+ file: lib/Perl/Critic/Document.pm
+ version: 1.088
+ Perl::Critic::Exception:
+ file: lib/Perl/Critic/Exception.pm
+ version: 1.088
+ Perl::Critic::Exception::AggregateConfiguration:
+ file: lib/Perl/Critic/Exception/AggregateConfiguration.pm
+ version: 1.088
+ Perl::Critic::Exception::Configuration:
+ file: lib/Perl/Critic/Exception/Configuration.pm
+ version: 1.088
+ Perl::Critic::Exception::Configuration::Generic:
+ file: lib/Perl/Critic/Exception/Configuration/Generic.pm
+ version: 1.088
+ Perl::Critic::Exception::Configuration::Option:
+ file: lib/Perl/Critic/Exception/Configuration/Option.pm
+ version: 1.088
+ Perl::Critic::Exception::Configuration::Option::Global:
+ file: lib/Perl/Critic/Exception/Configuration/Option/Global.pm
+ version: 1.088
+ Perl::Critic::Exception::Configuration::Option::Global::ExtraParameter:
+ file: lib/Perl/Critic/Exception/Configuration/Option/Global/ExtraParameter.pm
+ version: 1.088
+ Perl::Critic::Exception::Configuration::Option::Global::ParameterValue:
+ file: lib/Perl/Critic/Exception/Configuration/Option/Global/ParameterValue.pm
+ version: 1.088
+ Perl::Critic::Exception::Configuration::Option::Policy:
+ file: lib/Perl/Critic/Exception/Configuration/Option/Policy.pm
+ version: 1.088
+ Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter:
+ file: lib/Perl/Critic/Exception/Configuration/Option/Policy/ExtraParameter.pm
+ version: 1.088
+ Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue:
+ file: lib/Perl/Critic/Exception/Configuration/Option/Policy/ParameterValue.pm
+ version: 1.088
+ Perl::Critic::Exception::Fatal:
+ file: lib/Perl/Critic/Exception/Fatal.pm
+ version: 1.088
+ Perl::Critic::Exception::Fatal::Generic:
+ file: lib/Perl/Critic/Exception/Fatal/Generic.pm
+ version: 1.088
+ Perl::Critic::Exception::Fatal::Internal:
+ file: lib/Perl/Critic/Exception/Fatal/Internal.pm
+ version: 1.088
+ Perl::Critic::Exception::Fatal::PolicyDefinition:
+ file: lib/Perl/Critic/Exception/Fatal/PolicyDefinition.pm
+ version: 1.088
+ Perl::Critic::Exception::IO:
+ file: lib/Perl/Critic/Exception/IO.pm
+ version: 1.088
+ Perl::Critic::Exception::Parse:
+ file: lib/Perl/Critic/Exception/Parse.pm
+ version: 1.088
+ Perl::Critic::OptionsProcessor:
+ file: lib/Perl/Critic/OptionsProcessor.pm
+ version: 1.088
+ Perl::Critic::Policy:
+ file: lib/Perl/Critic/Policy.pm
+ version: 1.088
+ Perl::Critic::Policy::BuiltinFunctions::ProhibitBooleanGrep:
+ file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitBooleanGrep.pm
+ version: 1.088
+ Perl::Critic::Policy::BuiltinFunctions::ProhibitComplexMappings:
+ file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitComplexMappings.pm
+ version: 1.088
+ Perl::Critic::Policy::BuiltinFunctions::ProhibitLvalueSubstr:
+ file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitLvalueSubstr.pm
+ version: 1.088
+ Perl::Critic::Policy::BuiltinFunctions::ProhibitReverseSortBlock:
+ file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitReverseSortBlock.pm
+ version: 1.088
+ Perl::Critic::Policy::BuiltinFunctions::ProhibitSleepViaSelect:
+ file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitSleepViaSelect.pm
+ version: 1.088
+ Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval:
+ file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringyEval.pm
+ version: 1.088
+ Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit:
+ file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringySplit.pm
+ version: 1.088
+ Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalCan:
+ file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalCan.pm
+ version: 1.088
+ Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa:
+ file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalIsa.pm
+ version: 1.088
+ Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep:
+ file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidGrep.pm
+ version: 1.088
+ Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap:
+ file: lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidMap.pm
+ version: 1.088
+ Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep:
+ file: lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockGrep.pm
+ version: 1.088
+ Perl::Critic::Policy::BuiltinFunctions::RequireBlockMap:
+ file: lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockMap.pm
+ version: 1.088
+ Perl::Critic::Policy::BuiltinFunctions::RequireGlobFunction:
+ file: lib/Perl/Critic/Policy/BuiltinFunctions/RequireGlobFunction.pm
+ version: 1.088
+ Perl::Critic::Policy::BuiltinFunctions::RequireSimpleSortBlock:
+ file: lib/Perl/Critic/Policy/BuiltinFunctions/RequireSimpleSortBlock.pm
+ version: 1.088
+ Perl::Critic::Policy::ClassHierarchies::ProhibitAutoloading:
+ file: lib/Perl/Critic/Policy/ClassHierarchies/ProhibitAutoloading.pm
+ version: 1.088
+ Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA:
+ file: lib/Perl/Critic/Policy/ClassHierarchies/ProhibitExplicitISA.pm
+ version: 1.088
+ Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless:
+ file: lib/Perl/Critic/Policy/ClassHierarchies/ProhibitOneArgBless.pm
+ version: 1.088
+ Perl::Critic::Policy::CodeLayout::ProhibitHardTabs:
+ file: lib/Perl/Critic/Policy/CodeLayout/ProhibitHardTabs.pm
+ version: 1.088
+ Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins:
+ file: lib/Perl/Critic/Policy/CodeLayout/ProhibitParensWithBuiltins.pm
+ version: 1.088
+ Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists:
+ file: lib/Perl/Critic/Policy/CodeLayout/ProhibitQuotedWordLists.pm
+ version: 1.088
+ Perl::Critic::Policy::CodeLayout::ProhibitTrailingWhitespace:
+ file: lib/Perl/Critic/Policy/CodeLayout/ProhibitTrailingWhitespace.pm
+ version: 1.088
+ Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines:
+ file: lib/Perl/Critic/Policy/CodeLayout/RequireConsistentNewlines.pm
+ version: 1.088
+ Perl::Critic::Policy::CodeLayout::RequireTidyCode:
+ file: lib/Perl/Critic/Policy/CodeLayout/RequireTidyCode.pm
+ version: 1.088
+ Perl::Critic::Policy::CodeLayout::RequireTrailingCommas:
+ file: lib/Perl/Critic/Policy/CodeLayout/RequireTrailingCommas.pm
+ version: 1.088
+ Perl::Critic::Policy::ControlStructures::ProhibitCStyleForLoops:
+ file: lib/Perl/Critic/Policy/ControlStructures/ProhibitCStyleForLoops.pm
+ version: 1.088
+ Perl::Critic::Policy::ControlStructures::ProhibitCascadingIfElse:
+ file: lib/Perl/Critic/Policy/ControlStructures/ProhibitCascadingIfElse.pm
+ version: 1.088
+ Perl::Critic::Policy::ControlStructures::ProhibitDeepNests:
+ file: lib/Perl/Critic/Policy/ControlStructures/ProhibitDeepNests.pm
+ version: 1.088
+ Perl::Critic::Policy::ControlStructures::ProhibitLabelsWithSpecialBlockNames:
+ file: lib/Perl/Critic/Policy/ControlStructures/ProhibitLabelsWithSpecialBlockNames.pm
+ version: 1.088
+ Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions:
+ file: lib/Perl/Critic/Policy/ControlStructures/ProhibitMutatingListFunctions.pm
+ version: 1.088
+ Perl::Critic::Policy::ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions:
+ file: lib/Perl/Critic/Policy/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.pm
+ version: 1.088
+ Perl::Critic::Policy::ControlStructures::ProhibitPostfixControls:
+ file: lib/Perl/Critic/Policy/ControlStructures/ProhibitPostfixControls.pm
+ version: 1.088
+ Perl::Critic::Policy::ControlStructures::ProhibitUnlessBlocks:
+ file: lib/Perl/Critic/Policy/ControlStructures/ProhibitUnlessBlocks.pm
+ version: 1.088
+ Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode:
+ file: lib/Perl/Critic/Policy/ControlStructures/ProhibitUnreachableCode.pm
+ version: 1.088
+ Perl::Critic::Policy::ControlStructures::ProhibitUntilBlocks:
+ file: lib/Perl/Critic/Policy/ControlStructures/ProhibitUntilBlocks.pm
+ version: 1.088
+ Perl::Critic::Policy::Documentation::PodSpelling:
+ file: lib/Perl/Critic/Policy/Documentation/PodSpelling.pm
+ version: 1.088
+ Perl::Critic::Policy::Documentation::RequirePackageMatchesPodName:
+ file: lib/Perl/Critic/Policy/Documentation/RequirePackageMatchesPodName.pm
+ version: 1.088
+ Perl::Critic::Policy::Documentation::RequirePodAtEnd:
+ file: lib/Perl/Critic/Policy/Documentation/RequirePodAtEnd.pm
+ version: 1.088
+ Perl::Critic::Policy::Documentation::RequirePodSections:
+ file: lib/Perl/Critic/Policy/Documentation/RequirePodSections.pm
+ version: 1.088
+ Perl::Critic::Policy::ErrorHandling::RequireCarping:
+ file: lib/Perl/Critic/Policy/ErrorHandling/RequireCarping.pm
+ version: 1.088
+ Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval:
+ file: lib/Perl/Critic/Policy/ErrorHandling/RequireCheckingReturnValueOfEval.pm
+ version: 1.088
+ Perl::Critic::Policy::InputOutput::ProhibitBacktickOperators:
+ file: lib/Perl/Critic/Policy/InputOutput/ProhibitBacktickOperators.pm
+ version: 1.088
+ Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles:
+ file: lib/Perl/Critic/Policy/InputOutput/ProhibitBarewordFileHandles.pm
+ version: 1.088
+ Perl::Critic::Policy::InputOutput::ProhibitExplicitStdin:
+ file: lib/Perl/Critic/Policy/InputOutput/ProhibitExplicitStdin.pm
+ version: 1.088
+ Perl::Critic::Policy::InputOutput::ProhibitInteractiveTest:
+ file: lib/Perl/Critic/Policy/InputOutput/ProhibitInteractiveTest.pm
+ version: 1.088
+ Perl::Critic::Policy::InputOutput::ProhibitJoinedReadline:
+ file: lib/Perl/Critic/Policy/InputOutput/ProhibitJoinedReadline.pm
+ version: 1.088
+ Perl::Critic::Policy::InputOutput::ProhibitOneArgSelect:
+ file: lib/Perl/Critic/Policy/InputOutput/ProhibitOneArgSelect.pm
+ version: 1.088
+ Perl::Critic::Policy::InputOutput::ProhibitReadlineInForLoop:
+ file: lib/Perl/Critic/Policy/InputOutput/ProhibitReadlineInForLoop.pm
+ version: 1.088
+ Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen:
+ file: lib/Perl/Critic/Policy/InputOutput/ProhibitTwoArgOpen.pm
+ version: 1.088
+ Perl::Critic::Policy::InputOutput::RequireBracedFileHandleWithPrint:
+ file: lib/Perl/Critic/Policy/InputOutput/RequireBracedFileHandleWithPrint.pm
+ version: 1.088
+ Perl::Critic::Policy::InputOutput::RequireBriefOpen:
+ file: lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm
+ version: 1.088
+ Perl::Critic::Policy::InputOutput::RequireCheckedClose:
+ file: lib/Perl/Critic/Policy/InputOutput/RequireCheckedClose.pm
+ version: 1.088
+ Perl::Critic::Policy::InputOutput::RequireCheckedOpen:
+ file: lib/Perl/Critic/Policy/InputOutput/RequireCheckedOpen.pm
+ version: 1.088
+ Perl::Critic::Policy::InputOutput::RequireCheckedSyscalls:
+ file: lib/Perl/Critic/Policy/InputOutput/RequireCheckedSyscalls.pm
+ version: 1.088
+ Perl::Critic::Policy::Miscellanea::ProhibitFormats:
+ file: lib/Perl/Critic/Policy/Miscellanea/ProhibitFormats.pm
+ version: 1.088
+ Perl::Critic::Policy::Miscellanea::ProhibitTies:
+ file: lib/Perl/Critic/Policy/Miscellanea/ProhibitTies.pm
+ version: 1.088
+ Perl::Critic::Policy::Miscellanea::RequireRcsKeywords:
+ file: lib/Perl/Critic/Policy/Miscellanea/RequireRcsKeywords.pm
+ version: 1.088
+ Perl::Critic::Policy::Modules::ProhibitAutomaticExportation:
+ file: lib/Perl/Critic/Policy/Modules/ProhibitAutomaticExportation.pm
+ version: 1.088
+ Perl::Critic::Policy::Modules::ProhibitEvilModules:
+ file: lib/Perl/Critic/Policy/Modules/ProhibitEvilModules.pm
+ version: 1.088
+ Perl::Critic::Policy::Modules::ProhibitExcessMainComplexity:
+ file: lib/Perl/Critic/Policy/Modules/ProhibitExcessMainComplexity.pm
+ version: 1.088
+ Perl::Critic::Policy::Modules::ProhibitMultiplePackages:
+ file: lib/Perl/Critic/Policy/Modules/ProhibitMultiplePackages.pm
+ version: 1.088
+ Perl::Critic::Policy::Modules::RequireBarewordIncludes:
+ file: lib/Perl/Critic/Policy/Modules/RequireBarewordIncludes.pm
+ version: 1.088
+ Perl::Critic::Policy::Modules::RequireEndWithOne:
+ file: lib/Perl/Critic/Policy/Modules/RequireEndWithOne.pm
+ version: 1.088
+ Perl::Critic::Policy::Modules::RequireExplicitPackage:
+ file: lib/Perl/Critic/Policy/Modules/RequireExplicitPackage.pm
+ version: 1.088
+ Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage:
+ file: lib/Perl/Critic/Policy/Modules/RequireFilenameMatchesPackage.pm
+ version: 1.088
+ Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish:
+ file: lib/Perl/Critic/Policy/Modules/RequireNoMatchVarsWithUseEnglish.pm
+ version: 1.088
+ Perl::Critic::Policy::Modules::RequireVersionVar:
+ file: lib/Perl/Critic/Policy/Modules/RequireVersionVar.pm
+ version: 1.088
+ Perl::Critic::Policy::NamingConventions::ProhibitAmbiguousNames:
+ file: lib/Perl/Critic/Policy/NamingConventions/ProhibitAmbiguousNames.pm
+ version: 1.088
+ Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseSubs:
+ file: lib/Perl/Critic/Policy/NamingConventions/ProhibitMixedCaseSubs.pm
+ version: 1.088
+ Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseVars:
+ file: lib/Perl/Critic/Policy/NamingConventions/ProhibitMixedCaseVars.pm
+ version: 1.088
+ Perl::Critic::Policy::References::ProhibitDoubleSigils:
+ file: lib/Perl/Critic/Policy/References/ProhibitDoubleSigils.pm
+ version: 1.088
+ Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest:
+ file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitCaptureWithoutTest.pm
+ version: 1.088
+ Perl::Critic::Policy::RegularExpressions::ProhibitComplexRegexes:
+ file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitComplexRegexes.pm
+ version: 1.088
+ Perl::Critic::Policy::RegularExpressions::ProhibitEnumeratedClasses:
+ file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitEnumeratedClasses.pm
+ version: 1.088
+ Perl::Critic::Policy::RegularExpressions::ProhibitEscapedMetacharacters:
+ file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitEscapedMetacharacters.pm
+ version: 1.088
+ Perl::Critic::Policy::RegularExpressions::ProhibitFixedStringMatches:
+ file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitFixedStringMatches.pm
+ version: 1.088
+ Perl::Critic::Policy::RegularExpressions::ProhibitSingleCharAlternation:
+ file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitSingleCharAlternation.pm
+ version: 1.088
+ Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture:
+ file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusedCapture.pm
+ version: 1.088
+ Perl::Critic::Policy::RegularExpressions::ProhibitUnusualDelimiters:
+ file: lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusualDelimiters.pm
+ version: 1.088
+ Perl::Critic::Policy::RegularExpressions::RequireBracesForMultiline:
+ file: lib/Perl/Critic/Policy/RegularExpressions/RequireBracesForMultiline.pm
+ version: 1.088
+ Perl::Critic::Policy::RegularExpressions::RequireExtendedFormatting:
+ file: lib/Perl/Critic/Policy/RegularExpressions/RequireExtendedFormatting.pm
+ version: 1.088
+ Perl::Critic::Policy::RegularExpressions::RequireLineBoundaryMatching:
+ file: lib/Perl/Critic/Policy/RegularExpressions/RequireLineBoundaryMatching.pm
+ version: 1.088
+ Perl::Critic::Policy::Subroutines::ProhibitAmpersandSigils:
+ file: lib/Perl/Critic/Policy/Subroutines/ProhibitAmpersandSigils.pm
+ version: 1.088
+ Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms:
+ file: lib/Perl/Critic/Policy/Subroutines/ProhibitBuiltinHomonyms.pm
+ version: 1.088
+ Perl::Critic::Policy::Subroutines::ProhibitExcessComplexity:
+ file: lib/Perl/Critic/Policy/Subroutines/ProhibitExcessComplexity.pm
+ version: 1.088
+ Perl::Critic::Policy::Subroutines::ProhibitExplicitReturnUndef:
+ file: lib/Perl/Critic/Policy/Subroutines/ProhibitExplicitReturnUndef.pm
+ version: 1.088
+ Perl::Critic::Policy::Subroutines::ProhibitManyArgs:
+ file: lib/Perl/Critic/Policy/Subroutines/ProhibitManyArgs.pm
+ version: 1.088
+ Perl::Critic::Policy::Subroutines::ProhibitNestedSubs:
+ file: lib/Perl/Critic/Policy/Subroutines/ProhibitNestedSubs.pm
+ version: 1.088
+ Perl::Critic::Policy::Subroutines::ProhibitSubroutinePrototypes:
+ file: lib/Perl/Critic/Policy/Subroutines/ProhibitSubroutinePrototypes.pm
+ version: 1.088
+ Perl::Critic::Policy::Subroutines::ProtectPrivateSubs:
+ file: lib/Perl/Critic/Policy/Subroutines/ProtectPrivateSubs.pm
+ version: 1.088
+ Perl::Critic::Policy::Subroutines::RequireArgUnpacking:
+ file: lib/Perl/Critic/Policy/Subroutines/RequireArgUnpacking.pm
+ version: 1.088
+ Perl::Critic::Policy::Subroutines::RequireFinalReturn:
+ file: lib/Perl/Critic/Policy/Subroutines/RequireFinalReturn.pm
+ version: 1.088
+ Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict:
+ file: lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoStrict.pm
+ version: 1.088
+ Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings:
+ file: lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoWarnings.pm
+ version: 1.088
+ Perl::Critic::Policy::TestingAndDebugging::ProhibitProlongedStrictureOverride:
+ file: lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitProlongedStrictureOverride.pm
+ version: 1.088
+ Perl::Critic::Policy::TestingAndDebugging::RequireTestLabels:
+ file: lib/Perl/Critic/Policy/TestingAndDebugging/RequireTestLabels.pm
+ version: 1.088
+ Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict:
+ file: lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseStrict.pm
+ version: 1.088
+ Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings:
+ file: lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseWarnings.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::ProhibitCommaSeparatedStatements:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitCommaSeparatedStatements.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::ProhibitConstantPragma:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitConstantPragma.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::ProhibitEmptyQuotes:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEmptyQuotes.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::ProhibitEscapedCharacters:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEscapedCharacters.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::ProhibitImplicitNewlines:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitImplicitNewlines.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::ProhibitInterpolationOfLiterals:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitInterpolationOfLiterals.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLeadingZeros.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::ProhibitLongChainsOfMethodCalls:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLongChainsOfMethodCalls.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::ProhibitMagicNumbers:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMagicNumbers.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::ProhibitMismatchedOperators:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMismatchedOperators.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMixedBooleanOperators.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::ProhibitNoisyQuotes:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitNoisyQuotes.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitQuotesAsQuotelikeOperatorDelimiters.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::ProhibitVersionStrings:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitVersionStrings.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/RequireInterpolationOfMetachars.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::RequireNumberSeparators:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/RequireNumberSeparators.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::RequireQuotedHeredocTerminator:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/RequireQuotedHeredocTerminator.pm
+ version: 1.088
+ Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator:
+ file: lib/Perl/Critic/Policy/ValuesAndExpressions/RequireUpperCaseHeredocTerminator.pm
+ version: 1.088
+ Perl::Critic::Policy::Variables::ProhibitConditionalDeclarations:
+ file: lib/Perl/Critic/Policy/Variables/ProhibitConditionalDeclarations.pm
+ version: 1.088
+ Perl::Critic::Policy::Variables::ProhibitLocalVars:
+ file: lib/Perl/Critic/Policy/Variables/ProhibitLocalVars.pm
+ version: 1.088
+ Perl::Critic::Policy::Variables::ProhibitMatchVars:
+ file: lib/Perl/Critic/Policy/Variables/ProhibitMatchVars.pm
+ version: 1.088
+ Perl::Critic::Policy::Variables::ProhibitPackageVars:
+ file: lib/Perl/Critic/Policy/Variables/ProhibitPackageVars.pm
+ version: 1.088
+ Perl::Critic::Policy::Variables::ProhibitPerl4PackageNames:
+ file: lib/Perl/Critic/Policy/Variables/ProhibitPerl4PackageNames.pm
+ version: 1.088
+ Perl::Critic::Policy::Variables::ProhibitPunctuationVars:
+ file: lib/Perl/Critic/Policy/Variables/ProhibitPunctuationVars.pm
+ version: 1.088
+ Perl::Critic::Policy::Variables::ProhibitUnusedVariables:
+ file: lib/Perl/Critic/Policy/Variables/ProhibitUnusedVariables.pm
+ version: 1.088
+ Perl::Critic::Policy::Variables::ProtectPrivateVars:
+ file: lib/Perl/Critic/Policy/Variables/ProtectPrivateVars.pm
+ version: 1.088
+ Perl::Critic::Policy::Variables::RequireInitializationForLocalVars:
+ file: lib/Perl/Critic/Policy/Variables/RequireInitializationForLocalVars.pm
+ version: 1.088
+ Perl::Critic::Policy::Variables::RequireLexicalLoopIterators:
+ file: lib/Perl/Critic/Policy/Variables/RequireLexicalLoopIterators.pm
+ version: 1.088
+ Perl::Critic::Policy::Variables::RequireLocalizedPunctuationVars:
+ file: lib/Perl/Critic/Policy/Variables/RequireLocalizedPunctuationVars.pm
+ version: 1.088
+ Perl::Critic::Policy::Variables::RequireNegativeIndices:
+ file: lib/Perl/Critic/Policy/Variables/RequireNegativeIndices.pm
+ version: 1.088
+ Perl::Critic::PolicyConfig:
+ file: lib/Perl/Critic/PolicyConfig.pm
+ version: 1.088
+ Perl::Critic::PolicyFactory:
+ file: lib/Perl/Critic/PolicyFactory.pm
+ version: 1.088
+ Perl::Critic::PolicyListing:
+ file: lib/Perl/Critic/PolicyListing.pm
+ version: 1.088
+ Perl::Critic::PolicyParameter:
+ file: lib/Perl/Critic/PolicyParameter.pm
+ version: 1.088
+ Perl::Critic::PolicyParameter::Behavior:
+ file: lib/Perl/Critic/PolicyParameter/Behavior.pm
+ version: 1.088
+ Perl::Critic::PolicyParameter::Behavior::Boolean:
+ file: lib/Perl/Critic/PolicyParameter/Behavior/Boolean.pm
+ version: 1.088
+ Perl::Critic::PolicyParameter::Behavior::Enumeration:
+ file: lib/Perl/Critic/PolicyParameter/Behavior/Enumeration.pm
+ version: 1.088
+ Perl::Critic::PolicyParameter::Behavior::Integer:
+ file: lib/Perl/Critic/PolicyParameter/Behavior/Integer.pm
+ version: 1.088
+ Perl::Critic::PolicyParameter::Behavior::String:
+ file: lib/Perl/Critic/PolicyParameter/Behavior/String.pm
+ version: 1.088
+ Perl::Critic::PolicyParameter::Behavior::StringList:
+ file: lib/Perl/Critic/PolicyParameter/Behavior/StringList.pm
+ version: 1.088
+ Perl::Critic::ProfilePrototype:
+ file: lib/Perl/Critic/ProfilePrototype.pm
+ version: 1.088
+ Perl::Critic::Statistics:
+ file: lib/Perl/Critic/Statistics.pm
+ version: 1.088
+ Perl::Critic::TestUtils:
+ file: lib/Perl/Critic/TestUtils.pm
+ version: 1.088
+ Perl::Critic::Theme:
+ file: lib/Perl/Critic/Theme.pm
+ version: 1.088
+ Perl::Critic::ThemeListing:
+ file: lib/Perl/Critic/ThemeListing.pm
+ version: 1.088
+ Perl::Critic::UserProfile:
+ file: lib/Perl/Critic/UserProfile.pm
+ version: 1.088
+ Perl::Critic::Utils:
+ file: lib/Perl/Critic/Utils.pm
+ version: 1.088
+ Perl::Critic::Utils::Constants:
+ file: lib/Perl/Critic/Utils/Constants.pm
+ version: 1.088
+ Perl::Critic::Utils::DataConversion:
+ file: lib/Perl/Critic/Utils/DataConversion.pm
+ version: 1.088
+ Perl::Critic::Utils::McCabe:
+ file: lib/Perl/Critic/Utils/McCabe.pm
+ version: 1.088
+ Perl::Critic::Utils::POD:
+ file: lib/Perl/Critic/Utils/POD.pm
+ version: 1.088
+ Perl::Critic::Utils::PPI:
+ file: lib/Perl/Critic/Utils/PPI.pm
+ version: 1.088
+ Perl::Critic::Utils::PPIRegexp:
+ file: lib/Perl/Critic/Utils/PPIRegexp.pm
+ version: 1.088
+ Perl::Critic::Violation:
+ file: lib/Perl/Critic/Violation.pm
+ version: 1.088
+generated_by: Module::Build version 0.280801
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.2.html
+ version: 1.2
+no_index:
+ directory:
+ - doc
+ file:
+ - TODO.pod
+ - lib/Perl/Critic/PolicySummary.pod.PL
--- /dev/null
+#######################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/Makefile.PL $
+# $Date: 2008-06-17 14:27:21 -0500 (Tue, 17 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2450 $
+########################################################################
+
+use 5.006001;
+
+use strict;
+use warnings;
+
+use lib 'inc';
+use lib 'lib';
+
+use ExtUtils::MakeMaker;
+
+use Perl::Critic::BuildUtilities qw<
+ test_wrappers_to_generate
+ get_PL_files
+ dump_unlisted_or_optional_module_versions
+ emit_tar_warning_if_necessary
+>;
+
+
+emit_tar_warning_if_necessary();
+
+
+# An attempt was made by Elliot to get the "resources" META.yml entry going
+# here, but he failed. The version in Build.PL works. See the Makefile.PL
+# in the ack distribution for an example.
+
+WriteMakefile(
+ NAME => 'Perl::Critic',
+ AUTHOR => 'Jeffrey Thalhammer <thaljef@cpan.org>',
+ ABSTRACT_FROM => 'lib/Perl/Critic.pm',
+ VERSION_FROM => 'lib/Perl/Critic.pm',
+ EXE_FILES => ['bin/perlcritic'],
+ PL_FILES => get_PL_files(),
+ PREREQ_PM => {
+ 'B::Keywords' => 1.05,
+ 'Carp' => 0,
+ 'Config::Tiny' => 2,
+ 'English' => 0,
+ 'Exception::Class' => 1.23,
+ 'Exporter' => 0,
+ 'File::Basename' => 0,
+ 'File::Find' => 0,
+ 'File::Path' => 0,
+ 'File::Spec' => 0,
+ 'File::Spec::Unix' => 0,
+ 'File::Temp' => 0,
+ 'Getopt::Long' => 0,
+ 'IO::String' => 0,
+ 'List::MoreUtils' => 0,
+ 'List::Util' => 0,
+ 'Module::Pluggable' => 3.1,
+ 'PPI' => 1.203,
+ 'PPI::Document' => 1.203,
+ 'PPI::Document::File' => 1.203,
+ 'PPI::Node' => 1.203,
+ 'PPI::Token::Quote::Single' => 1.203,
+ 'PPI::Token::Whitespace' => 1.203,
+ 'Pod::PlainText' => 0,
+ 'Pod::Select' => 0,
+ 'Pod::Usage' => 0,
+ 'Readonly' => 1.03,
+ 'Scalar::Util' => 0,
+ 'String::Format' => 1.13,
+ 'base' => 0,
+ 'charnames' => 0,
+ 'overload' => 0,
+ 'strict' => 0,
+ 'version' => 0,
+ 'warnings' => 0,
+ 'overload' => 0,
+ 'strict' => 0,
+ 'version' => 0,
+ 'warnings' => 0,
+
+ 'lib' => 0,
+ 'Test::More' => 0,
+ },
+ realclean => {
+ FILES =>
+ join
+ q< >,
+ 'lib/Perl/Critic/PolicySummary.pod',
+ test_wrappers_to_generate(),
+ 't/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.run',
+ 't/Variables/RequireLocalizedPunctuationVars.run',
+ },
+);
+
+sub MY::postamble {
+ return <<"MAKE_FRAG";
+.PHONY: tags
+
+tags:
+\tctags -f tags \\
+\t\t--recurse \\
+\t\t--totals \\
+\t\t\\
+\t\t--exclude=blib/ \\
+\t\t--exclude=t/lib \\
+\t\t--exclude=.svn \\
+\t\t--exclude='*~' \\
+\t\t\\
+\t\t--languages=Perl \\
+\t\t--langmap=Perl:+.t
+MAKE_FRAG
+}
+
+dump_unlisted_or_optional_module_versions();
+
+##############################################################################
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+NAME
+ Perl::Critic - Critique Perl source code for best-practices.
+
+SYNOPSIS
+ use Perl::Critic;
+ my $file = shift;
+ my $critic = Perl::Critic->new();
+ my @violations = $critic->critique($file);
+ print @violations;
+
+DESCRIPTION
+ Perl::Critic is an extensible framework for creating and applying coding
+ standards to Perl source code. Essentially, it is a static source code
+ analysis engine. Perl::Critic is distributed with a number of
+ Perl::Critic::Policy modules that attempt to enforce various coding
+ guidelines. Most Policy modules are based on Damian Conway's book Perl
+ Best Practices. However, Perl::Critic is not limited to PBP and will
+ even support Policies that contradict Conway. You can enable, disable,
+ and customize those Polices through the Perl::Critic interface. You can
+ also create new Policy modules that suit your own tastes.
+
+ For a command-line interface to Perl::Critic, see the documentation for
+ perlcritic. If you want to integrate Perl::Critic with your build
+ process, Test::Perl::Critic provides an interface that is suitable for
+ test scripts. 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.
+
+ Win32 and ActivePerl users can find PPM distributions of Perl::Critic at
+ <http://theoryx5.uwinnipeg.ca/ppms/>.
+
+ 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. You can also invoke the perlcritic web-service from the
+ command-line by doing an HTTP-post, such as one of these:
+
+ $> POST http://perlcritic.com/perl/critic.pl < MyModule.pm
+ $> lwp-request -m POST http://perlcritic.com/perl/critic.pl < MyModule.pm
+ $> wget -q -O - --post-file=MyModule.pm http://perlcritic.com/perl/critic.pl
+
+ Please note that the perlcritic web-service is still alpha code. The URL
+ and interface to the service are subject to change.
+
+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, -criticism-fatal => $B)"
+ "new( -config => Perl::Critic::Config->new() )"
+ "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) to 5 (most severe). 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
+
+ -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/imx" 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/imx" 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/imx" will be used. Policies that do not match will be
+ excluded. This option has precedence over the "-severity", "-theme",
+ "-include", "-exclude", and "-only" options. You can set the default
+ value for this option in your .perlcriticrc file.
+
+ -top is the maximum number of Violations to return when ranked by
+ their severity levels. This must be a positive integer. Violations
+ are still returned in the order that they occur within the file.
+ Unless the "-severity" option is explicitly given, setting "-top"
+ silently causes the "-severity" to be set to 1. You can set the
+ default value for this option in your .perlcriticrc file.
+
+ -only is a boolean value. If set to a true value, Perl::Critic will
+ only choose from Policies that are mentioned in the user's profile.
+ If set to a false value (which is the default), then Perl::Critic
+ chooses from all the Policies that it finds at your site. You can
+ set the default value for this option in your .perlcriticrc file.
+
+ -profile-strictness is an enumerated value, one of
+ "$PROFILE_STRICTNESS_WARN" in Perl::Critic::Utils::Constants (the
+ default), "$PROFILE_STRICTNESS_FATAL" in
+ Perl::Critic::Utils::Constants, and "$PROFILE_STRICTNESS_QUIET" in
+ Perl::Critic::Utils::Constants. If set to
+ "$PROFILE_STRICTNESS_FATAL" in Perl::Critic::Utils::Constants,
+ Perl::Critic will make certain warnings about problems found in a
+ .perlcriticrc or file specified via the -profile option fatal. For
+ example, Perl::Critic normally only "warn"s about profiles referring
+ to non-existent Policies, but this value makes this situation fatal.
+ Correspondingly, "$PROFILE_STRICTNESS_QUIET" in
+ Perl::Critic::Utils::Constants makes Perl::Critic shut up about
+ these things.
+
+ -force is a boolean value that controls whether Perl::Critic
+ observes the magical "## no critic" pseudo-pragmas 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 comments. 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.
+
+ -color is 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.
+
+ -config is a reference to a Perl::Critic::Config object. If you have
+ created your own Config object for some reason, you can pass it in
+ here instead of having Perl::Critic create one for you. Using the
+ "-config" option causes all the other options to be silently
+ ignored.
+
+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
+
+ 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
+
+ "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::ProhibitMixedCaseVars]
+ [-NamingConventions::ProhibitMixedCaseSubs]
+
+ #--------------------------------------------------------------
+ # 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/imx"
+
+ 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 scripts. 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 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 scripts
+
+ 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 Altertative 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 pseudo-pragmas:
+
+ 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" comments direct Perl::Critic to ignore the remaining
+ lines of code until the end of the current block, or until a ""## use
+ critic"" comment is found (whichever comes first). If the "## no critic"
+ comment 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"
+ comments, use the "-force" option.
+
+ A bare "## no critic" comment 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" comment (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::ProhibitMixedCaseVars
+ my $camelHumpVar = 'foo';
+
+ # Now exempt from NamingConventions::ProhibitMixedCaseSubs
+ 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" pragmas can be nested, and Policies named by an inner pragma
+ will be disabled along with those already disabled an outer pragma.
+
+ Some Policies like "Subroutines::ProhibitExcessComplexity" apply to an
+ entire block of code. In those cases, "## no critic" 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. But if the
+ file requires a shebang line, it is impossible to put "## 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 .perlcriticrc file. But
+ beware that this will affect the analysis of all files.
+
+ Use this feature wisely. "## 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 "## 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
+ "<thaljef@cpan.org>" and I'll be happy to put them into the Perl::Critic
+ distribution. Or if you would like to work on the Perl::Critic project
+ directly, check out our repository at <http://perlcritic.tigris.org>. To
+ subscribe to our mailing list, send a message to
+ "<dev-subscribe@perlcritic.tigris.org>".
+
+ 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 "<thaljef@cpan.org>".
+
+PREREQUISITES
+ Perl::Critic requires the following modules:
+
+ B::Keywords
+
+ Config::Tiny
+
+ Exception::Class
+
+ File::Spec
+
+ File::Spec::Unix
+
+ IO::String
+
+ List::MoreUtils
+
+ List::Util
+
+ Module::Pluggable
+
+ PPI
+
+ Pod::PlainText
+
+ Pod::Usage
+
+ Readonly
+
+ Scalar::Util
+
+ String::Format
+
+ version
+
+ The following modules are optional, but recommended for complete
+ testing:
+
+ File::HomeDir
+
+ File::Which
+
+ IO::String
+
+ IPC::Open2
+
+ Perl::Tidy
+
+ Pod::Spell
+
+ Test::Pod
+
+ Test::Pod::Coverage
+
+ Text::ParseWords
+
+CONTACTING THE DEVELOPMENT TEAM
+ You are encouraged to subscribe to the mailing list; send a message to
+ "<users-subscribe@perlcritic.tigris.org>". See also the archives. You
+ can also contact the author at "<thaljef@cpan.org>".
+
+ At least one member of the development team has started hanging around
+ in <irc://irc.perl.org/#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 are also a couple of distributions that will install all the
+ Perl::Critic related modules known to the development team:
+
+ Bundle::Perl::Critic
+
+ Task::Perl::Critic
+
+ If you want to make sure you have absolutely everything, you can use
+ these:
+
+ Bundle::Perl::Critic::IncludingOptionalDependencies
+
+ Task::Perl::Critic::IncludingOptionalDependencies
+
+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 to
+ <http://rt.cpan.org/NoAuth/Bugs.html?Dist=Perl-Critic>. Thanks.
+
+ Most policies will produce false-negatives if they cannot understand a
+ particular block of code.
+
+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 <thaljef@cpan.org>
+
+COPYRIGHT
+ Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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.
+
--- /dev/null
+# best viewed via "perldoc TODO.pod"
+
+=pod
+
+=for stopwords LHS RHS REFACTORINGS FH SVN stopwords
+
+=head1 NAME
+
+Perl::Critic::TODO - Things for Perl::Critic developers to do
+
+
+=head1 SOURCE
+
+ #######################################################################
+ # $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/TODO.pod $
+ # $Date: 2008-07-03 09:36:05 -0500 (Thu, 03 Jul 2008) $
+ # $Author: clonezone $
+ # $Revision: 2487 $
+ #######################################################################
+
+
+=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 Safari sections in addition to book page numbers.
+
+
+=item * Add --files-with-violations/-l and --files-without-violations/-L options to F<perlcritic>.
+
+Just print out file names. I could have used this at work when combined with
+C<--single-policy>.
+
+ gvim `perlcritic --single-policy QuotedWordLists -l`
+
+
+=item * Add a file 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<perlcritic>.
+
+List Policies based upon severity, theme, and (what I want this second)
+applies_to.
+
+=item * Add --prohibit-unrestricted-no-critic option to F<perlcritic>.
+
+Requires C<## no critic> to take an argument:
+
+ ## no critic (SomePolicyPattern) # ok
+ ## no critic # not ok
+
+Can't be done as a regular Policy because any line that violated it would disable it.
+
+
+=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<blib> directory.
+
+
+=item * Enhance statistics.
+
+- Blank line count
+
+- POD line count
+
+- Comment line count
+
+- Data section count
+
+
+=item * Detect 5.10 source and enable stuff for that.
+
+For example, treat C<say> as equivalent to C<print>.
+
+
+=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]>".
+
+
+=back
+
+
+=head1 BUGS/LIMITATIONS
+
+=over
+
+=item * NamingConventions::ProhibitAmbiguousNames
+
+Don't allow compound names with forbidden words, like "last_record".
+Allow forbidden words in RHS of variable declarations
+
+Also, we should make it easeir to add (or delete) words from the
+forbbiden list.
+
+
+=item * Subroutines::ProtectPrivateSubs
+
+Doesn't forbid C<< $pkg->_foo() >> because it can't tell the
+difference between that and C<< $self->_foo() >>
+
+
+=item * ErrorHandling::RequireCarping
+
+This should not complain about using C<warn> or C<die> if it's not in a
+function, or if it's in main::.
+
+Also, should allow C<die> when it is obvious that the "message" is a reference.
+
+
+=item * RegularExpressions::ProhibitCaptureWithoutTest
+
+Allow this construct:
+
+ for ( ... ) {
+ next unless /(....)/;
+ if ( $1 ) {
+ ....
+ }
+ }
+
+Right now, P::C thinks that the C<$1> isn't legal to use because it's
+"outside" of the match. The thing is, we can only get to the C<if>
+if the regex matched.
+ while ( $str =~ /(expression)/ )
+
+
+=item * CodeLayout::ProhibitParensWithBuiltins
+
+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 expempt
+from the policy.
+
+
+=item * ValuesAndExpressions::ProhibitCommaSeparatedStatements
+
+Needs to check for C<scalar( something, something )>.
+
+
+=item * Variables::ProhibitPunctuationVars
+
+Needs to look inside strings. RT #35970.
+
+
+=item * TestingAndDebugging::RequireUseWarnings
+
+Check for -w on the shbang line.
+
+
+=item * Change formatting in Violation to eliminate double periods.
+
+
+=back
+
+
+=head1 OTHER PBP POLICIES THAT SEEM FEASIBLE TO IMPLEMENT
+
+=over
+
+=item * Modules::RequireUseVersion [405-406]
+
+=item * Modules::RequireThreePartVersion [405-406]
+
+=item * RegularExpressions::RequireDotMatchAnything [240-241]
+
+=back
+
+
+=head1 NON-PBP POLICIES WANTED
+
+=over
+
+=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::RequireLocalizingEvalErrorInDESTROY
+
+Prevent 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<http://use.perl.org/~Ovid/journal/36767>.
+
+=item * Expressions::ProhibitDecimalWithBitwiseOperator
+
+=item * Expressions::ProhibitStringsWithBitwiseOperator
+
+
+=item * InputOutput::ProhibitMagicDiamond
+
+Steal the idea from L<B::Lint>.
+
+
+=item * TBD::AllProgramsNeedShebangs
+
+Anything that is a program should have a shebang line. This includes .t files.
+
+
+=item * BuiltInFunctions::RequireConstantSprintfFormat
+
+
+=item * BuiltInFunctions::RequireConstantUnpackFormat
+
+L<http://diotalevi.isa-geek.net/~josh/yapc-lint/slides/slide5.html>
+
+
+=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 * Modules::RequireExplicitImporting
+
+Require every C<use> statement to have an explicit import list. You could
+still get around this by calling C<import> directly.
+
+
+=item * Modules::ForbidImporting
+
+Require every C<use> 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<do "foo.pl">. Not sure about this policy name.
+
+
+=item * Variables::ProhibitUseVars
+
+Disallow C<use vars qw(...)> and require C<our $foo> instead. This
+contradicts Miscellanea::Prohibit5006isms. Maybe verify C<use 5.6>
+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<split> instead of C<m/\s*\w*\s*\w*\s*/>. From MJD's Red Flags.
+
+
+=item * VariablesAndExpressions::RequireConstantVersion (low severity)
+
+
+=item * VariablesAndExpressions::ProhibitComplexVersion (medium severity)
+
+L<http://rt.cpan.org/Ticket/Display.html?id=20439>
+
+
+=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 (althought 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<http://search.cpan.org/src/JJORE/Carp-Clan-5.8/t/04boilerplate.t>
+
+
+=item * BuiltinFunctions::ProhibitExtraneousScalarCall
+
+Recommend that C<if (scalar @array)> be rewritten as C<if (@array)>.
+
+
+=item * RegularExpressions::ProhibitMixedDelimiters
+
+Ban s{foo}(bar)
+
+
+=item * RegularExpressions::ProhibitScalarAsRegexp
+
+Ban naked srtings 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.
+
+
+=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<perlreref>.
+
+
+=item * Steal ideas from L<Dunce::Files>.
+
+Can someone expand this entry, please?
+
+=item * ControlStructures::ProhibitAssigmentInConditional
+
+=item * ValuesAndExpressions::RequireConstantBeforeEquals
+
+=item * ValuesAndExpressions::RequireConstantBeforeOperator
+
+L<http://use.perl.org/~stu42j/journal/36412>
+
+Just about everyone has been bitten by C<if ($x = 10) { ... }> 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<if (($x=10)){}> or C<while ($x=$y=$z){}>), 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<eq>, 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<exit()> in files that lack a shebang. Inspired by
+L<http://use.perl.org/~Ovid/journal/36746> and an analgous checker in
+FindBugs.
+
+=back
+
+
+=head1 REFACTORINGS and ENHANCEMENTS
+
+=over
+
+=item * Create constants for the PPI location array elements.
+
+
+=item * MOVE THE LINE-DISABLING INTO P::C::Document
+
+All the code that deals with finding all the '##no critic' comments and noting
+which policies are disabled at each line seems like it would be better placed
+in Perl::Critic::Document. P::C::Document could then provide methods to
+indicate if a policy is disabled at a particular line. So the basic algorithm
+in Perl::Critic might look something like this:
+
+ foreach $element (@PPI_ELEMENTS) {
+ foreach $policy (@POLICIES) {
+ $line = $element->location->[0];
+ next if $doc->policy_is_disabled_at_line( $policy, $line );
+ push @violations, $policy->violates( $elem, $doc );
+ }
+ }
+
+
+=item * Some means of detecting "runnaway" 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<perlcritic> 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<bin/perlcritic> does now.
+
+
+=item * Add C<-cache> flag to F<bin/perlcritic>
+
+If enabled, this turns on L<PPI::Cache>:
+
+ 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 cachedir should perhaps include the PPI version number! At least
+until PPI incorporates its own version number in the cache.
+
+(see F<t/40_criticize.t> for a more robust implementation)
+
+
+=item * Use hash-lookup instead of C<List::MoreUtils::any> function.
+
+In several places, Perl::Critic uses C<List::MoreUtils::any> 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] }; }
+
+Why?
+
+
+=item * Allow color output to work through a pipe.
+
+http://rt.cpan.org/Ticket/Display.html?id=30140
+
+F<ack> now supports this.
+
+
+=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 mixde 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.
+
+
+=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 :
--- /dev/null
+#!/usr/bin/perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/bin/perlcritic $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+## no critic (ErrorHandling::RequireUseOfExceptions)
+package main;
+
+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 >;
+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::Violation qw<>;
+
+#-----------------------------------------------------------------------------
+
+our $VERSION = '1.088';
+
+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;
+
+#-----------------------------------------------------------------------------
+# Begin script. Don't run when loaded as a library
+
+my @FILES = ();
+my $CRITIC = undef;
+exit run() if not caller;
+
+#-----------------------------------------------------------------------------
+# Begin subroutines
+
+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} = q{};
+ }
+
+ # 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 _parse_command_line {
+ my %opts = ( -color => 1 );
+ my @opt_specs = _get_option_specification();
+ Getopt::Long::Configure('no_ignore_case');
+ GetOptions( \%opts, @opt_specs ) || pod2usage(); #Exits
+ return %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} ) { print "$VERSION\n"; exit 0; } #Exits
+ if ( $opts{list} ) { render_policy_listing(); } #Exits
+ if ( $opts{'list-themes'} ) { render_theme_listing(); } #Exits
+ if ( $opts{'profile-proto'} ) { render_profile_prototype(); } #Exits
+ if ( $opts{doc} ) { policy_docs( $opts{doc} ); } #Exits
+ return 1;
+}
+
+#-----------------------------------------------------------------------------
+
+sub _validate_options {
+ my (%opts) = @_;
+ my $msg = q{};
+
+
+ if ( $opts{noprofile} && $opts{profile} ) {
+ $msg .= qq{Warning: Cannot use -noprofile with -profile option.\n};
+ }
+
+ if ( $opts{verbose} && $opts{verbose} !~ m{(?: \d+ | %[mfFlcedrpPs] )}mx) {
+ $msg .= qq<Warning: --verbose arg "$opts{verbose}" looks odd. >;
+ $msg .= qq<Perhaps you meant to say "--verbose 3 $opts{verbose}"\n>;
+ }
+
+ if ( exists $opts{top} && $opts{top} < 0 ) {
+ $msg .= qq<Warning: --top argument "$opts{top}" is negative. >;
+ $msg .= qq<Perhaps you meant to say "$opts{top} --top".\n>;
+ }
+
+ if (
+ exists $opts{severity}
+ && (
+ $opts{severity} < $SEVERITY_LOWEST
+ || $opts{severity} > $SEVERITY_HIGHEST
+ )
+ ) {
+ $msg .= qq<Warning: --severity arg "$opts{severity}" out of range. >;
+ $msg .= qq<Severities range from "$SEVERITY_LOWEST" (lowest) to >;
+ $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; <STDIN> };
+
+ # Notice if STDIN was closed (pipe error, etc)
+ if ( ! defined $code_string ) {
+ $code_string = q{};
+ }
+
+ $code_string =~ m{ \S+ }mx || 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 $nonexistant = first { ! -e $_ } @args ) {
+ my $msg = qq{No such file or directory: '$nonexistant'};
+ 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 ) = @_;
+ @files || 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";
+
+ my $number_of_violations = undef;
+ my $had_error_in_file = 0;
+
+ for my $file (@files) {
+
+ 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<Problem while critiquing "$file": $EVAL_ERROR\n>;
+ }
+ elsif ($EVAL_ERROR) {
+ # P::C::Exception::Fatal includes the stack trace in its
+ # stringification.
+ die qq<Fatal error while critiquing "$file": $EVAL_ERROR\n>;
+ }
+ else {
+ die qq<Fatal error while critiquing "$file". Unfortunately, >,
+ q<$@/$EVAL_ERROR >, ## no critic (RequireInterpolationOfMetachars)
+ qq<is empty, so the reason can't be shown.\n>;
+ }
+ }
+ }
+
+ 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 number of violations, if asked.
+ my $number_of_violations = scalar @violations;
+ if( $opts_ref->{-count} ){
+ ref $file || print "$file: ";
+ print "$number_of_violations\n";
+ return $number_of_violations;
+ }
+
+ # Hail all-clear unless we should shut up.
+ if( !@violations && !$opts_ref->{-quiet} ) {
+ ref $file || print "$file ";
+ print "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]}{STDIN}mx; } #HACK!
+ Perl::Critic::Violation::set_format( $fmt );
+
+ my $color = $CRITIC->config->color();
+ print $color ? _colorize_by_severity(@violations) : @violations;
+
+ return $number_of_violations;
+}
+
+#-----------------------------------------------------------------------------
+
+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()
+ )
+ ) {
+ print "\n"; # There's prior output that we want to separate from.
+ }
+
+ print _commaify($statistics->modules()), " files.\n";
+ print _commaify($statistics->subs()), " subroutines/methods.\n";
+ print _commaify($statistics->statements_other_than_subs()), " statements.\n";
+ print _commaify($statistics->lines()), " lines.\n";
+
+ my $average_sub_mccabe = $statistics->average_sub_mccabe();
+ if (defined $average_sub_mccabe) {
+ printf
+ "\nAverage McCabe score of subroutines was %.2f.\n",
+ $average_sub_mccabe;
+ }
+
+ print "\n";
+
+ print _commaify($statistics->total_violations()), " violations.\n";
+
+ my $violations_per_file = $statistics->violations_per_file();
+ if (defined $violations_per_file) {
+ printf
+ "Violations per file was %.3f.\n",
+ $violations_per_file;
+ }
+ my $violations_per_statement = $statistics->violations_per_statement();
+ if (defined $violations_per_statement) {
+ printf
+ "Violations per statement was %.3f.\n",
+ $violations_per_statement;
+ }
+ my $violations_per_line = $statistics->violations_per_line_of_code();
+ if (defined $violations_per_line) {
+ printf
+ "Violations per line of code was %.3f.\n",
+ $violations_per_line;
+ }
+
+ if ( $statistics->total_violations() ) {
+ print "\n";
+
+ my %severity_violations = %{ $statistics->violations_by_severity() };
+ foreach my $severity ( reverse sort keys %severity_violations ) {
+ print
+ _commaify($severity_violations{$severity}),
+ " severity $severity violations.\n";
+ }
+
+ print "\n";
+
+ my %policy_violations = %{ $statistics->violations_by_policy() };
+ foreach my $policy ( sort keys %policy_violations ) {
+ print
+ _commaify($policy_violations{$policy}),
+ ' violations of ',
+ policy_short_name($policy),
+ ".\n";
+ }
+ }
+
+ 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-themes
+ man
+ color|colour!
+ noprofile
+ only!
+ options
+ profile=s
+ profile-proto
+ quiet
+ severity=i
+ single-policy=s
+ stern
+ statistics!
+ statistics-only!
+ profile-strictness=s
+ theme=s
+ top:i
+ verbose=s
+ );
+}
+
+#-----------------------------------------------------------------------------
+
+sub _colorize_by_severity {
+ my (@violations) = @_;
+ return @violations if not _at_tty();
+ return @violations if _this_is_windows();
+ return @violations if not eval { require Term::ANSIColor };
+
+ my %color_of = (
+ $SEVERITY_HIGHEST => 'bold red',
+ $SEVERITY_HIGH => 'yellow',
+ );
+ return map { _colorize( "$_", $color_of{$_->severity()} ) } @violations;
+
+}
+
+#-----------------------------------------------------------------------------
+
+sub _colorize {
+ my ($string, $color) = @_;
+ return $string if not defined $color;
+ return Term::ANSIColor::colored( $string, $color );
+}
+
+#-----------------------------------------------------------------------------
+
+sub _this_is_windows {
+ return 1 if $OSNAME =~ m/MSWin32/mx;
+ return 0;
+}
+
+#-----------------------------------------------------------------------------
+
+sub _at_tty {
+ return -t STDOUT; ##no critic 'InteractiveTest';
+}
+
+#-----------------------------------------------------------------------------
+
+sub render_policy_listing {
+
+ require Perl::Critic::PolicyListing;
+ require Perl::Critic;
+
+ my %pc_params = (-profile => $EMPTY, -severity => $SEVERITY_LOWEST);
+ my @policies = Perl::Critic->new( %pc_params )->policies();
+ my $listing = Perl::Critic::PolicyListing->new( -policies => \@policies );
+ print $listing;
+ exit 0;
+}
+
+#-----------------------------------------------------------------------------
+
+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 );
+ print $listing;
+ exit 0;
+}
+
+#-----------------------------------------------------------------------------
+
+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 );
+ print $prototype;
+ exit 0;
+}
+
+#-----------------------------------------------------------------------------
+
+sub policy_docs {
+
+ my $pattern = shift;
+ require Perl::Critic;
+
+ my %pc_params = (-profile => $EMPTY, -severity => $SEVERITY_LOWEST);
+ my @policies = Perl::Critic::Config->new( %pc_params )->policies();
+ my @matches = grep { $_ =~ m/$pattern/imx } @policies;
+
+ for my $matching_policy ( @matches ) {
+ my @perldoc_cmd = qw(perldoc -T); #-T means don't send to pager
+ system @perldoc_cmd, ref $matching_policy;
+ }
+ exit 0;
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=for stopwords DGR INI-style vim-fu minibuffer -noprofile API -singlepolicy
+singlepolicy -profileproto -profile-proto ben Jore formatter Peshak pbp Komodo
+screenshots tty emacs gVIM plugin Perlish templating ActiveState
+
+=head1 NAME
+
+C<perlcritic> - Command-line interface to critique Perl source.
+
+=head1 SYNOPSIS
+
+ perlcritic [-12345 | --brutal | --cruel | --harsh | --stern | --gentle]
+ [--severity number | name] [--profile file | --noprofile]
+ [--top [ number ]] [--theme expression] [--include pattern]
+ [--exclude pattern] [--single-policy pattern] [--only | --noonly]
+ [--profile-strictness {warn|fatal|quiet}] [--force | --noforce]
+ [--statistics] [--statistics-only] [--verbose {number | format}]
+ [--color | --nocolor] [--quiet] {FILE | DIRECTORY | STDIN}
+
+ perlcritic --profile-proto
+
+ perlcritic { --list | --list-themes | --doc pattern [...] }
+
+ perlcritic { --help | --options | --man | --version }
+
+=head1 DESCRIPTION
+
+C<perlcritic> is a Perl source code analyzer. It is the executable
+front-end to the L<Perl::Critic> 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<Perl
+Best Practices>. However, C<perlcritic> is B<not> 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, including how to persistently configure this
+command so that you don't have to say so much on the command-line,
+see the documentation for L<Perl::Critic> 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/ix
+ 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<perlcritic>
+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<Getopt::Long>). Option names
+are also case-sensitive.
+
+=over 8
+
+=item C<--profile FILE>
+
+Directs C<perlcritic> 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<Perl::Critic/"CONFIGURATION"> for more information.
+
+=item C<--noprofile>
+
+Directs C<perlcritic> not to load any configuration file, thus reverting
+to the default configuration for all Policies.
+
+=item C<--severity N>
+
+Directs C<perlcritic> to only apply Policies with a severity greater than
+C<N>. 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<severity> 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<perlcritic> 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<perlcritic> to apply only Policies with themes that satisfy the
+C<RULE>. Themes are arbitrary names for groups of related policies. You can
+combine theme names with boolean operators to create an arbitrarily complex
+C<RULE>. 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<Perl::Critic/"POLICY THEMES">
+for more information about themes.
+
+=item C<--include PATTERN>
+
+Directs C<perlcritic> to apply additional Policies that match the regex
+C</PATTERN/imx>. 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<perlcritic> to apply all the C<CodeLayout::*> 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<perlcritic> to not apply any Policy that matches the regex
+C</PATTERN/imx>. 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<perlcritic> to not apply the C<RequireUseStrict> and
+C<ProhibitNoStrict> 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>
+
+Directs C<perlcritic> to apply just one Policy module matching the regex
+C</PATTERN/imx>, 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<perlcritic> to apply just the C<ProhibitNoWarnings> 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<perlcritic> to report only the top C<N> Policy violations in each
+file, ranked by their severity. If C<N> 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<perlcritic> will interpret it as the number of violations to
+report.
+
+=item C<--force>
+
+Directs C<perlcritic> to ignore the magical C<"## no critic"> pseudo-pragmas
+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<N>), C<perlcritic> reports violations using one of the predefined
+formats described below. If given a string (C<FORMAT>), 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<perlcritic>. 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<sprintf> works. See L<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. See
+L<"EDITOR INTEGRATION"> for more information about that.
+
+=item C<--list>
+
+Displays a condensed listing of all the L<Perl::Critic::Policy> modules that
+are found on this machine. 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<Perl::Critic::Policy> modules that
+are found on this machine.
+
+=item C<--profile-proto>
+
+Displays an expanded listing of all the L<Perl::Critic::Policy> 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<warn> (the default), C<fatal>, and C<quiet>. 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<http://safari.oreilly.com> instead of page numbers from the actual book.
+NOTE: This feature is not implemented yet.
+
+=item C<--color>
+
+This option is on by default. When set, Severity 5 and 4 are colored red and
+yellow, respectively. Colorization only happens if STDOUT is a tty and
+L<Term::ANSIColor> 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.
+
+Can also be specified as C<--colour>.
+
+=item C<--doc PATTERN>
+
+Displays the perldoc for all L<Perl::Critic::Policy> modules that match
+C<m/PATTERN/imx>. 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::RequireUpperCaseHeredocTerminator">
+at the command prompt.
+
+=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<perlcritic> manual and exits.
+
+=item C<--version>
+
+=item C<-V>
+
+Displays the version number of C<perlcritic> 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<perlcritic> will look for this file in the current
+directory first, and then in your home directory. Alternatively, you can set
+the C<PERLCRITIC> 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<before the first named
+block.> 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<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 B<Perl Best Practices>. For brevity, you can omit the
+C<'Perl::Critic::Policy'> part of the module name.
+
+C<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 C<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
+
+C<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 L<"POLICY THEMES"> for more
+information.
+
+C<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 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::ProhibitMixedCaseVars]
+ [-NamingConventions::ProhibitMixedCaseSubs]
+
+ #--------------------------------------------------------------
+ # 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<perlcriticrc> file that is
+included in this F<examples> directory of this distribution.
+
+Damian Conway's own Perl::Critic configuration is also included in this
+distribution as F<examples/perlcriticrc-conway>.
+
+=head1 THE POLICIES
+
+A large number of Policy modules are distributed with Perl::Critic. They are
+described briefly in the companion document L<Perl::Critic::PolicySummary> 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<m/PATTERN/imx>
+
+There are a number of distributions of additional policies on CPAN. If
+L<Perl::Critic> doesn't contain a policy that you want, some one may have
+already written it. See L<Perl::Critic/"SEE ALSO"> 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
+scripts. 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
+ 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 scripts
+
+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 pseudo-pragmas:
+
+ 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"> comments direct Perl::Critic to ignore the remaining
+lines of code until the end of the current block, or until a C<"## use
+critic"> comment is found (whichever comes first). If the C<"## no critic">
+comment 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"> comments,
+use the C<--force> option.
+
+A bare C<"## no critic"> comment 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<ProhibitEmptyQuotes> and
+C<ProhibitPostfixControls> policies until the end of the block or until the
+next C<"## use critic"> comment (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::ProhibitMixedCaseVars
+ my $camelHumpVar = 'foo';
+
+ # Now exempt from NamingConventions::ProhibitMixedCaseSubs
+ 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">
+pragmas can be nested, and Policies named by an inner pragma will be disabled
+along with those already disabled an outer pragma.
+
+Some Policies like C<Subroutines::ProhibitExcessComplexity> 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<Documentation::RequirePodSections> 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<all> 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<perlcritic> can be integrated with your favorite text
+editor. The output-formatting capabilities of C<perlcritic> are specifically
+intended for use with the "grep" or "compile" modes available in editors like
+C<emacs> and C<vim>. 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<extras> directory inside this distribution.
+
+=head2 VIM
+
+Scott Peshak has published F<perlchecker.vim>, which is available at
+L<http://www.vim.org/scripts/script.php?script_id=1731>.
+
+=head2 gVIM
+
+Fritz Mehner recently added support for C<perlcritic> to his fantastic gVIM
+plugin. In addition to providing a very Perlish IDE, Fritz's plugin enables
+one-click access to C<perlcritic> and many other very useful utilities. And
+all is seamlessly integrated into the editor. See
+L<http://lug.fh-swf.de/vim/vim-perl/screenshots-en.html> for complete details.
+
+=head2 EPIC
+
+EPIC is an open source Perl IDE based on the Eclipse platform. Features
+supported are syntax highlighting, on-the-fly syntax check, content assist,
+perldoc support, source formatter, templating support and a Perl debugger. Go
+to L<http://e-p-i-c.sourceforge.net> for more information about EPIC.
+
+The EPIC team is currently working on integration with Perl::Critic. In the
+meantime, you can use the L<criticism> pragma and EPIC will highlight
+violations whenever it does a syntax check on your code. I haven't tried this
+myself, but other folks say it works.
+
+=head2 BBEdit
+
+Josh Clark has produced an excellent Perl-Critic plugin for BBEdit. A copy is
+included in this distribution at F<extras/perl_critic_for_bbedit-1_0.zip>. See
+L<http://beta.bigmedium.com/projects/bbedit-perl-critic/index.shtml> for
+screenshots and additional installation info. Apple users rejoice!
+
+=head2 Komodo
+
+Komodo is a proprietary IDE for Perl and several other dynamic languages.
+Free trial copies of Komodo can be obtained from the ActiveState website at
+L<http://www.activestate.com>. For instructions on integrating F<perlcritic>
+with Komodo, see F<extras/KomodoIntegration.pod> in this distribution.
+
+=head1 EXIT STATUS
+
+If C<perlcritic> has any errors itself, exits with status == 1. If there are
+no errors, but C<perlcritic> 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<Perl::Critic> 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<PPI>, but most
+Policy modules are pretty straightforward and only require about 20 lines of
+code, and half of those lines are simple use statements and simple
+declarations.. Please see the L<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
+C<< <thaljef@cpan.org> >> and I'll be happy to put them into the Perl::Critic
+distribution. Or if you would like to work on the Perl::Critic project
+directly, check out our repository at L<http://perlcritic.tigris.org>. To
+subscribe to our mailing list, send a message to
+C<< <dev-subscribe@perlcritic.tigris.org> >>.
+
+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<before>
+they go into production. To discuss your needs with the Perl::Critic team,
+just contact C<< <thaljef@cpan.org> >>.
+
+=head1 CONTACTING THE DEVELOPMENT TEAM
+
+You are encouraged to subscribe to the mailing list; send a message to
+C<< <users-subscribe@perlcritic.tigris.org> >>. See also
+L<the archives|http://perlcritic.tigris.org/servlets/SummarizeList?listName=users>.
+You can also contact the author at C<< <thaljef@cpan.org> >>.
+
+At least one member of the development team has started hanging around in
+L<irc://irc.perl.org/#perlcritic>.
+
+=head1 SEE ALSO
+
+There are a number of distributions of additional Policies available. A few
+are listed here:
+
+L<Perl::Critic::More>
+L<Perl::Critic::Bangs>
+L<Perl::Critic::Lax>
+L<Perl::Critic::StricterSubs>
+L<Perl::Critic::Swift>
+
+These distributions enable you to use Perl::Critic in your unit tests:
+
+L<Test::Perl::Critic>
+L<Test::Perl::Critic::Progressive>
+
+There are also a couple of distributions that will install all the
+Perl::Critic related modules known to the development team:
+
+L<Bundle::Perl::Critic>
+L<Task::Perl::Critic>
+
+=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 to
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Perl-Critic>. Thanks.
+
+Most policies will produce false-negatives if they cannot understand a
+particular block of code.
+
+=head1 CREDITS
+
+Adam Kennedy - For creating L<PPI>, the heart and soul of L<Perl::Critic>.
+
+Damian Conway - For writing B<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.
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+libperl-critic-perl (1.088-1) unstable; urgency=low
+
+ * New upstream release
+ + Adjust (build-)dependencies:
+ - add perl-modules
+ - bump libppi-perl's version to 1.203
+ - add perl-modules (>= 5.10) | libversion-perl
+ * add libtest-deep-perl to B-D-I for additional tests
+ * remove manpages-whatis.patch; fixed upstream
+ + drop quilt from B-D and rules
+ * minimize debian/rules with debhelper 7
+ * Standards-Version: 3.8.0 (no changes needed)
+
+ -- Damyan Ivanov <dmn@debian.org> Mon, 07 Jul 2008 13:25:48 +0300
+
+libperl-critic-perl (1.082-1) unstable; urgency=low
+
+ * New upstream release.
+ * debian/copyright: update years of copyright.
+ * debian/control: use a versioned dependency on quilt because we use
+ quilt.make in debian/rules.
+ * Refresh and extend manpages-whatis.patch.
+
+ -- gregor herrmann <gregor+debian@comodo.priv.at> Sun, 16 Mar 2008 03:32:47 +0100
+
+libperl-critic-perl (1.080-2) unstable; urgency=low
+
+ * debian/rules: delete /usr/lib/perl5 only if it exists (closes: #468002).
+ * debian/watch: adapt regexp for matching upstream releases.
+ * debian/rules:
+ - create install-stamp target
+ - introduce PERL and TMP variables
+ - use $@ for touching stamp-files
+ - use dh_clean for removing them
+ - use DESTDIR and PREFIX for make install
+ - don't create usr/lib directory, which we delete afterwards anyway
+ * Set Standards-Version to 3.7.3 (no changes).
+ * Set debhelper compatibility level to 6.
+
+ -- gregor herrmann <gregor+debian@comodo.priv.at> Sun, 02 Mar 2008 01:35:54 +0100
+
+libperl-critic-perl (1.080-1) unstable; urgency=low
+
+ [ gregor herrmann ]
+ * debian/control: Added: Vcs-Svn field (source stanza); Vcs-Browser
+ field (source stanza); Homepage field (source stanza). Removed: XS-
+ Vcs-Svn fields.
+ * Remove empty /usr/lib/perl5 directory.
+ * Move dh_clean before make distclean.
+ * Add libreadonly-perl to (build-)dependecies (only recommended, not
+ depended upon by libreadonly-xs-perl).
+
+ [ Damyan Ivanov ]
+ * New upstream release
+ * Fixed debian/watch to use search.cpan.org/dist/-based URL
+ * Remove unused dh_link from debian/rules
+ * Wrap long fields in debian/control
+ * Add libfile-homedir-perl, libfile-which-perl, perltidy,
+ libpod-spell-perl, libexception-class-perl and libreadonly-xs-perl to
+ (build-)dependencies
+ * Bump libppi-perl (build-)dependency to 1.201
+ * Add manpages-whatis.patch fixing whatis lintian warnings of 120 modules
+ Add quilt as a build-dependency
+ * debian/copyright:
+ + refreshed info, added two more copyright holders
+ + use direct search.cpan.org/dist/ URL as download location
+ * Add myself to Uploaders
+ * Add libtest-pod-perl and libtest-pod-coverage-perl to B-D-I
+
+ -- Damyan Ivanov <dmn@debian.org> Thu, 15 Nov 2007 21:30:16 +0200
+
+libperl-critic-perl (1.061-1) unstable; urgency=low
+
+ * First release.
+ * Depend on libppi-perl 1.116, for PPI::Document::File.
+
+ -- Joey Hess <joeyh@debian.org> Tue, 14 Aug 2007 20:44:42 -0400
--- /dev/null
+Source: libperl-critic-perl
+Section: perl
+Priority: optional
+Build-Depends-Indep: perl (>= 5.8), libb-keywords-perl, libconfig-tiny-perl,
+ libfile-spec-perl, libio-string-perl, liblist-moreutils-perl,
+ libmodule-pluggable-perl, libppi-perl (>= 1.203), libstring-format-perl,
+ libfile-homedir-perl, libfile-which-perl, perltidy,
+ libpod-spell-perl, libreadonly-xs-perl, libreadonly-perl,
+ libexception-class-perl, libtest-pod-perl, libtest-pod-coverage-perl,
+ libtest-deep-perl
+Build-Depends: debhelper7
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Uploaders: gregor herrmann <gregor+debian@comodo.priv.at>,
+ Damyan Ivanov <dmn@debian.org>
+Standards-Version: 3.8.0
+Homepage: http://search.cpan.org/dist/Perl-Critic/
+Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libperl-critic-perl/
+Vcs-Browser: http://svn.debian.org/wsvn/pkg-perl/trunk/libperl-critic-perl/
+
+Package: libperl-critic-perl
+Architecture: all
+Depends: ${perl:Depends}, ${misc:Depends}, perl-modules, libb-keywords-perl,
+ libconfig-tiny-perl, libfile-spec-perl, libio-string-perl,
+ liblist-moreutils-perl, libmodule-pluggable-perl, libppi-perl (>= 1.203),
+ libstring-format-perl, libfile-homedir-perl, libfile-which-perl,
+ perltidy, libpod-spell-perl, libreadonly-xs-perl, libreadonly-perl,
+ libexception-class-perl, perl-modules (>= 5.10) | libversion-perl
+Description: Critique Perl source code for best-practices
+ 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.
+ .
+ A command-line interface to Perl::Critic is included in the perlcritic
+ program.
+ .
+ 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. Its 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.
--- /dev/null
+Source: libperl-critic-perl
+Section: perl
+Priority: optional
+Build-Depends-Indep: perl (>= 5.8), perl-modules, libb-keywords-perl, libconfig-tiny-perl,
+ libfile-spec-perl, libio-string-perl, liblist-moreutils-perl,
+ libmodule-pluggable-perl, libppi-perl (>= 1.203), libstring-format-perl,
+ libfile-homedir-perl, libfile-which-perl, perltidy,
+ libpod-spell-perl, libreadonly-xs-perl, libreadonly-perl,
+ libexception-class-perl, libtest-pod-perl, libtest-pod-coverage-perl,
+ perl-modules (>= 5.10) | libversion-perl, libtest-deep-perl
+Build-Depends: debhelper (>= 7)
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Uploaders: gregor herrmann <gregor+debian@comodo.priv.at>,
+ Damyan Ivanov <dmn@debian.org>
+Standards-Version: 3.8.0
+Homepage: http://search.cpan.org/dist/Perl-Critic/
+Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libperl-critic-perl/
+Vcs-Browser: http://svn.debian.org/wsvn/pkg-perl/trunk/libperl-critic-perl/
+
+Package: libperl-critic-perl
+Architecture: all
+Depends: ${perl:Depends}, ${misc:Depends}, perl-modules, libb-keywords-perl,
+ libconfig-tiny-perl, libfile-spec-perl, libio-string-perl,
+ liblist-moreutils-perl, libmodule-pluggable-perl, libppi-perl (>= 1.203),
+ libstring-format-perl, libfile-homedir-perl, libfile-which-perl,
+ perltidy, libpod-spell-perl, libreadonly-xs-perl, libreadonly-perl,
+ libexception-class-perl, perl-modules (>= 5.10) | libversion-perl
+Description: Critique Perl source code for best-practices
+ 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.
+ .
+ A command-line interface to Perl::Critic is included in the perlcritic
+ program.
+ .
+ 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. Its 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.
--- /dev/null
+This is a Debian prepackaged version of the perl critic.
+
+This package was put together by Joey Hess <joeyh@debian.org>, using
+sources from CPAN, http://search.cpan.org/dist/Perl-Critic/
+
+The following copyright applies to this package:
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. All rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+Some individual modules are individually copyright by other authors/years:
+
+Copyright (C) 2006 Jeffrey Ryan Thalhammer. All rights reserved.
+Copyright (C) 2005-2007 Graham TerMarsch. All rights reserved.
+Copyright (c) 2005-2007 Chris Dolan and Jeffrey Ryan Thalhammer. All rights reserved.
+Copyright (c) 2005-2007 Chris Dolan. All rights reserved.
+Copyright (c) 2006 Chris Dolan. All rights reserved.
+Copyright (c) 2007 Chris Dolan. Many rights reserved.
+Copyright (c) 2006 Peter Guzis. All rights reserved.
+Copyright (c) 2007 Andrew Moore. All rights reserved.
+Copyright (c) 2007 Elliot Shank. All rights reserved.
+Copyright (C) 2005-2007 Graham TerMarsch. All rights reserved.
+Copyright (c) 2007 Ricardo SIGNES.
+
+Each of these modules are also licensed under the same terms as Perl itself.
+
+(Those terms are either of the Artistic license or the GPL; both licenses
+can be found in full in /usr/share/common-licenses/)
--- /dev/null
+TODO.pod extras/*
--- /dev/null
+examples/*
--- /dev/null
+#!/usr/bin/make -f
+%:
+ dh $@
--- /dev/null
+version=3
+# no developer versions
+http://search.cpan.org/dist/Perl-Critic/ .*/Perl-Critic-v?(\d[\d.]+)\.(?:tar(?:\.gz|\.bz2)?|tgz|zip)
--- /dev/null
+#!/usr/bin/perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/examples/generatestats $
+# $Date: 2008-05-18 23:24:38 -0500 (Sun, 18 May 2008) $
+# $Author: clonezone $
+# $Revision: 2376 $
+##############################################################################
+
+## no critic (ErrorHandling::RequireUseOfExceptions)
+use 5.008001;
+use strict;
+use warnings;
+
+use version; our $VERSION = qv('1.002');
+
+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 = '<program>';
+ }
+
+ $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
+
+=head1 NAME
+
+C<generatestats> - 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<Perl::Critic> 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<Perl::Critic>
+L<Perl6::Say>
+L<Readonly>
+
+
+=head1 INCOMPATIBILITIES
+
+None reported.
+
+
+=head1 BUGS AND LIMITATIONS
+
+This is an example program and thus does minimal error handling.
+
+
+=head1 AUTHOR
+
+Elliot Shank C<< <perl@galumph.com> >>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2007, Elliot Shank C<< <perl@galumph.com> >>. All rights
+reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself. See L<perlartistic>.
+
+
+=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 :
--- /dev/null
+#!/usr/bin/perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/examples/loadanalysisdb $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+## no critic (ErrorHandling::RequireUseOfExceptions)
+use 5.008001;
+use strict;
+use warnings;
+
+use version; our $VERSION = qv('1.002');
+
+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 analyses
+
+=head1 NAME
+
+C<loadanalysisdb> - 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<Perl::Critic::Violation> 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<Perl::Critic::Violation> 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<DBI>.
+
+
+=head1 EXIT STATUS
+
+0
+
+
+=head1 CONFIGURATION
+
+None.
+
+
+=head1 DEPENDENCIES
+
+L<Perl::Critic>
+L<DBD::SQLite>
+L<Perl6::Say>
+L<Readonly>
+
+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<< <perl@galumph.com> >>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2007, Elliot Shank C<< <perl@galumph.com> >>. All rights
+reserved.
+
+This module is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself. See L<perlartistic>.
+
+
+=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 :
--- /dev/null
+##############################################################################
+# 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
+
+##############################################################################
+# 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::ProhibitMixedCaseVars]
+[-NamingConventions::ProhibitMixedCaseSubs]
+[-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]
+
+
--- /dev/null
+##############################################################################
+# This Perl::Critic configuration file sets the Policy severity levels
+# according to Damian Conway's own personal recommendations. Feel free to
+# use this as your own, or make modifications.
+##############################################################################
+
+[Perl::Critic::Policy::BuiltinFunctions::ProhibitLvalueSubstr]
+severity = 3
+
+[Perl::Critic::Policy::BuiltinFunctions::ProhibitReverseSortBlock]
+severity = 1
+
+[Perl::Critic::Policy::BuiltinFunctions::ProhibitSleepViaSelect]
+severity = 5
+
+[Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval]
+severity = 5
+
+[Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit]
+severity = 2
+
+[Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalCan]
+severity = 4
+
+[Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa]
+severity = 4
+
+[Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep]
+severity = 3
+
+[Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap]
+severity = 3
+
+[Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep]
+severity = 4
+
+[Perl::Critic::Policy::BuiltinFunctions::RequireBlockMap]
+severity = 4
+
+[Perl::Critic::Policy::BuiltinFunctions::RequireGlobFunction]
+severity = 5
+
+[Perl::Critic::Policy::BuiltinFunctions::RequireSimpleSortBlock]
+severity = 3
+
+[Perl::Critic::Policy::ClassHierarchies::ProhibitAutoloading]
+severity = 3
+
+[Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA]
+severity = 4
+
+[Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless]
+severity = 5
+
+[Perl::Critic::Policy::CodeLayout::ProhibitHardTabs]
+severity = 3
+
+[Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins]
+severity = 1
+
+[Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists]
+severity = 2
+
+[Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines]
+severity = 4
+
+[Perl::Critic::Policy::CodeLayout::RequireTidyCode]
+severity = 1
+
+[Perl::Critic::Policy::CodeLayout::RequireTrailingCommas]
+severity = 3
+
+[Perl::Critic::Policy::ControlStructures::ProhibitCStyleForLoops]
+severity = 3
+
+[Perl::Critic::Policy::ControlStructures::ProhibitCascadingIfElse]
+severity = 3
+
+[Perl::Critic::Policy::ControlStructures::ProhibitDeepNests]
+severity = 3
+
+[Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions]
+severity = 5
+
+[Perl::Critic::Policy::ControlStructures::ProhibitPostfixControls]
+severity = 4
+
+[Perl::Critic::Policy::ControlStructures::ProhibitUnlessBlocks]
+severity = 4
+
+[Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode]
+severity = 4
+
+[Perl::Critic::Policy::ControlStructures::ProhibitUntilBlocks]
+severity = 4
+
+[Perl::Critic::Policy::Documentation::RequirePodAtEnd]
+severity = 2
+
+[Perl::Critic::Policy::Documentation::RequirePodSections]
+severity = 2
+
+[Perl::Critic::Policy::ErrorHandling::RequireCarping]
+severity = 4
+
+[Perl::Critic::Policy::InputOutput::ProhibitBacktickOperators]
+severity = 3
+
+[Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles]
+severity = 5
+
+[Perl::Critic::Policy::InputOutput::ProhibitInteractiveTest]
+severity = 4
+
+[Perl::Critic::Policy::InputOutput::ProhibitOneArgSelect]
+severity = 4
+
+[Perl::Critic::Policy::InputOutput::ProhibitReadlineInForLoop]
+severity = 5
+
+[Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen]
+severity = 4
+
+[Perl::Critic::Policy::InputOutput::RequireBracedFileHandleWithPrint]
+severity = 3
+
+[Perl::Critic::Policy::Miscellanea::ProhibitFormats]
+severity = 3
+
+[Perl::Critic::Policy::Miscellanea::ProhibitTies]
+severity = 4
+
+[-Perl::Critic::Policy::Miscellanea::RequireRcsKeywords]
+
+[Perl::Critic::Policy::Modules::ProhibitAutomaticExportation]
+severity = 4
+
+[Perl::Critic::Policy::Modules::ProhibitEvilModules]
+severity = 5
+
+[Perl::Critic::Policy::Modules::ProhibitMultiplePackages]
+severity = 4
+
+[Perl::Critic::Policy::Modules::RequireBarewordIncludes]
+severity = 5
+
+[Perl::Critic::Policy::Modules::RequireEndWithOne]
+severity = 4
+
+[Perl::Critic::Policy::Modules::RequireExplicitPackage]
+severity = 4
+
+[Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage]
+severity = 5
+
+[Perl::Critic::Policy::Modules::RequireVersionVar]
+severity = 4
+
+[Perl::Critic::Policy::NamingConventions::ProhibitAmbiguousNames]
+severity = 3
+
+[Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseSubs]
+severity = 1
+
+[Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseVars]
+severity = 1
+
+[Perl::Critic::Policy::References::ProhibitDoubleSigils]
+severity = 4
+
+[Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest]
+severity = 4
+
+[Perl::Critic::Policy::RegularExpressions::RequireExtendedFormatting]
+severity = 5
+
+[Perl::Critic::Policy::RegularExpressions::RequireLineBoundaryMatching]
+severity = 5
+
+[Perl::Critic::Policy::Subroutines::ProhibitAmpersandSigils]
+severity = 2
+
+[Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms]
+severity = 4
+
+[Perl::Critic::Policy::Subroutines::ProhibitExcessComplexity]
+severity = 3
+
+[Perl::Critic::Policy::Subroutines::ProhibitExplicitReturnUndef]
+severity = 5
+
+[Perl::Critic::Policy::Subroutines::ProhibitSubroutinePrototypes]
+severity = 4
+
+[Perl::Critic::Policy::Subroutines::ProtectPrivateSubs]
+severity = 3
+
+[Perl::Critic::Policy::Subroutines::RequireFinalReturn]
+severity = 5
+
+[Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict]
+severity = 5
+
+[Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings]
+severity = 4
+
+[Perl::Critic::Policy::TestingAndDebugging::ProhibitProlongedStrictureOverride]
+severity = 4
+
+[Perl::Critic::Policy::TestingAndDebugging::RequireTestLabels]
+severity = 3
+
+[Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict]
+severity = 5
+
+[Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings]
+severity = 4
+
+[Perl::Critic::Policy::ValuesAndExpressions::ProhibitConstantPragma]
+severity = 4
+
+[Perl::Critic::Policy::ValuesAndExpressions::ProhibitEmptyQuotes]
+severity = 2
+
+[Perl::Critic::Policy::ValuesAndExpressions::ProhibitEscapedCharacters]
+severity = 2
+
+[Perl::Critic::Policy::ValuesAndExpressions::ProhibitInterpolationOfLiterals]
+severity = 1
+
+[Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros]
+severity = 5
+
+[Perl::Critic::Policy::ValuesAndExpressions::ProhibitMismatchedOperators]
+severity = 2
+
+[Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators]
+severity = 4
+
+[Perl::Critic::Policy::ValuesAndExpressions::ProhibitNoisyQuotes]
+severity = 2
+
+[Perl::Critic::Policy::ValuesAndExpressions::ProhibitVersionStrings]
+severity = 3
+
+[Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars]
+severity = 1
+
+[Perl::Critic::Policy::ValuesAndExpressions::RequireNumberSeparators]
+severity = 2
+
+[Perl::Critic::Policy::ValuesAndExpressions::RequireQuotedHeredocTerminator]
+severity = 4
+
+[Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator]
+severity = 4
+
+[Perl::Critic::Policy::Variables::ProhibitConditionalDeclarations]
+severity = 5
+
+[Perl::Critic::Policy::Variables::ProhibitLocalVars]
+severity = 2
+
+[Perl::Critic::Policy::Variables::ProhibitMatchVars]
+severity = 4
+
+[Perl::Critic::Policy::Variables::ProhibitPackageVars]
+severity = 3
+
+[Perl::Critic::Policy::Variables::ProhibitPunctuationVars]
+severity = 2
+
+[Perl::Critic::Policy::Variables::ProtectPrivateVars]
+severity = 3
+
+[Perl::Critic::Policy::Variables::RequireInitializationForLocalVars]
+severity = 5
+
+[Perl::Critic::Policy::Variables::RequireLexicalLoopIterators]
+severity = 5
+
+[Perl::Critic::Policy::Variables::RequireNegativeIndices]
+severity = 4
\ No newline at end of file
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/extras/KomodoIntegration.pod $
+# $Date: 2008-06-22 11:08:37 -0700 (Sun, 22 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2467 $
+##############################################################################
+
+=head1 NAME
+
+KomodoIntegration - Integrating perlcritic and Komodo.
+
+=head1 DESCRIPTION
+
+This document describes the steps for integrating F<perlcritic> with Komodo 4.0
+from ActiveState. More information about Komodo can be found at
+L<http://www.activestate.com>
+
+These instructions assume that F<perlcritic> has been installed somewhere in
+your C<$PATH>. If it is not in your C<$PATH>, you must give the full path to
+F<perlcritic> instead of using the C<-S> switch. Also, I'm assuming that you
+have installed Perl-Critic with the same Perl that Komodo is using. If that
+is not the case, you'll probably have to give a full path to F<perl> instead
+of using the C<%perl> placeholder.
+
+=over 4
+
+=item * Start Komodo.
+
+=item * Select C<< Toolbox -> Add -> New Command... >> from the menu.
+
+=item * Enter a name for the command (e.g. "perlcritic").
+
+=item * In the C<Command:> field, enter the following:
+
+ %perl -S perlcritic --severity=%(ask:Severity level [1-5]?:5) --verbose=1 %F
+
+=item * Uncheck the C<Insert output> and C<Pass selection as input> boxes.
+
+=item * In the C<Run in:> drop-down list, select C<Command Output Tab>.
+
+=item * Uncheck the C<Do not open output pane> box.
+
+=item * Check the C<Parse output with:> box, and type this into the field:
+
+ ^(?P<file>.+):(?P<line>.+):(?P<column>.+):(?P<content>.+)$
+
+=item * Check the C<Show parsed output as a list> box.
+
+=item * Click the C<Key Binding> tab.
+
+=item * Click the C<New Key Sequence> text field, and press C<Ctrl-Alt-p>.
+
+=item * Click the C<Add> button.
+
+=item * Click the C<OK> button.
+
+=back
+
+Now to run F<perlcritic> on the current file, just press C<Ctrl-Alt-p>, or
+select C<perlcritic> from the C<Toolbox> menu. Each time, you will be
+prompted to enter the minimum severity level (defaulting to 5). After a few
+moments, the output will appear in the C<Command Output> pane. By
+double-clicking on the output messages, you can navigate to the appropriate
+point in the code.
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+;;; perlcritic.el --- minor mode for Perl::Critic integration
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/extras/perlcritic.el $
+;;; $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+;;; $Author: clonezone $
+;;; $Revision: 2187 $
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;;; 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 <jjore@cpan.org>
+;;
+;; This program is free software; you can redistribute it and/or
+;; modify it under the same terms as Perl itself
+
+
+
+\f
+;;; 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."
+ ;; FIXME: My GNU Emacs doesn't show a radio widget or a menu here.
+ :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))
+ :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-compilation-error-regexp-alist
+ '(;; Verbose level 1
+ ;; "%f:%l:%c:%m\n"
+ ("^\\([^\n]+\\):\\([0-9]+\\):\\([0-9]+\\)" 1 2 3)
+
+ ;; Verbose level 2
+ ;; "%f: (%l:%c) %m\n"
+ ("^\\([^\n]+\\): (\\([0-9]+\\):\\([0-9]+\\))" 1 2 3)
+
+ ;; Verbose level 3
+ ;; "%m at %f line %l\n"
+ ("^[^\n]+ at \\([^\n]+\\) line \\([0-9]+\\)" 1 2)
+ ;; "%m at line %l, column %c. %e. (Severity: %s)\n"
+ ("^[^\n]+ at line\\( \\)\\([0-9]+\\), column \\([0-9]+\\)." 1 2 3)
+
+ ;; Verbose level 4
+ ;; "%m at line %l, column %c. %e. (Severity: %s)\n"
+ ("^[^\n]+ at line\\( \\)\\([0-9]+\\), column \\([0-9]+\\)." 1 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]+\\)," 1 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]+\\)" 1 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]+\\)" 1 2 3)
+
+ ;; Verbose level 8
+ ;; "[%p] %m at line %l, column %c. (Severity: %s)\n"
+ ("^\\[[^\n]+\\] [^\n]+ at line\\( \\)\\([0-9]+\\), column \\([0-9]+\\)" 1 2 3)
+ ;; "[%p] %m at line %l, near '%r'. (Severity: %s)\n"
+ ("^\\[[^\n]+\\] [^\n]+ at line\\( \\)\\([0-9]+\\)" 1 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]+\\)" 1 2 3)
+ ;; "[%p] %m at line %l, near '%r'. (Severity: %s)\n"
+ ("^\\[[^\n]+\\] [^\n]+ at line\\( \\)\\([0-9]+\\)" 1 2)
+
+ ;; Verbose level 10
+ ;; "%m at line %l, near '%r'.\n %p (Severity: %s)\n%d\n"
+ ("^[^\n]+ at line\\( \\)\\([0-9]+\\)" 1 2)
+ ;; "%m at line %l, column %c.\n %p (Severity: %s)\n%d\n"
+ ("^[^\n]+ at line\\( \\)\\([0-9]+\\), column \\([0-9]+\\)" 1 2 3)
+
+ ;; Verbose level 11
+ ;; "%m at line %l, near '%r'.\n %p (Severity: %s)\n%d\n"
+ ("^[^\n]+ at line\\( \\)\\([0-9]+\\)" 1 2)
+ )
+ "Alist that specified how to match errors in perlcritic output.")
+
+
+\f
+;; The Emacs Lisp manual says to do this with the cl library.
+(eval-when-compile (require 'cl))
+
+;;;###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*.
+ (compilation-mode "perlcritic")
+ (set (make-local-variable 'perlcritic-buffer) src-buf)
+ (set (make-local-variable 'compilation-error-regexp-alist)
+ perlcritic-compilation-error-regexp-alist)
+ (ad-activate #'compilation-find-file)
+ ; (ad-deactivate #'compilation-find-file)
+ (display-buffer err-buf))
+
+ ;; Return our success or failure.
+ perlcritic-ok))))))
+
+
+
+\f
+;;; 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))
+
+
+
+
+\f
+;; 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)))
+
+ (make-local-hook 'write-file-hooks)
+ (if perlcritic-mode
+ (add-hook 'write-file-hooks 'perlcritic-write-hook)
+ (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
--- /dev/null
+# $Id: AssertOS.pm,v 1.2 2007/09/28 16:30:11 drhyde Exp $
+
+package Devel::AssertOS;
+
+use Devel::CheckOS qw(die_if_os_isnt);
+
+use strict;
+
+use vars qw($VERSION);
+
+$VERSION = '1.0';
+
+# 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<import()> 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(@_);
+ die_if_os_isnt(@_);
+}
+
+=head1 BUGS and FEEDBACK
+
+I welcome feedback about my code, including constructive criticism.
+Bug reports should be made using L<http://rt.cpan.org/> 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<http://www.cantrell.org.uk/david/wishlist/>
+
+=head1 SEE ALSO
+
+$^O in L<perlvar>
+
+L<perlport>
+
+L<Devel::CheckOS>
+
+L<Devel::AssertOS::Extending>
+
+=head1 AUTHOR
+
+David Cantrell E<lt>F<david@cantrell.org.uk>E<gt>
+
+Thanks to David Golden for suggesting that I add this utility module.
+
+=head1 COPYRIGHT and LICENCE
+
+Copyright 2007 David Cantrell
+
+This module is free-as-in-speech software, and may be used, distributed,
+and modified under the same conditions as perl itself.
+
+=head1 CONSPIRACY
+
+This module is also free-as-in-mason software.
+
+=cut
+
+$^O;
--- /dev/null
+# $Id: AIX.pm,v 1.1 2007/09/27 16:41:24 drhyde Exp $
+
+package Devel::AssertOS::AIX;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'aix' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: Amiga.pm,v 1.1 2007/09/27 16:41:24 drhyde Exp $
+
+package Devel::AssertOS::Amiga;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'amigaos' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: Apple.pm,v 1.2 2007/09/28 14:35:08 drhyde Exp $
+
+package Devel::AssertOS::Apple;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O =~ /^(darwin|MacOS)/ ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
--- /dev/null
+# $Id: BSDOS.pm,v 1.1 2007/09/27 16:41:24 drhyde Exp $
+
+package Devel::AssertOS::BSDOS;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'bsdos' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: BeOS.pm,v 1.1 2007/09/27 16:41:24 drhyde Exp $
+
+package Devel::AssertOS::BeOS;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'beos' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: Cygwin.pm,v 1.1 2007/09/27 16:41:24 drhyde Exp $
+
+package Devel::AssertOS::Cygwin;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'cygwin' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: DEC.pm,v 1.2 2007/09/28 14:35:08 drhyde Exp $
+
+package Devel::AssertOS::DEC;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O =~ /^(VMS|dec_osf)$/ ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
--- /dev/null
+# $Id: DGUX.pm,v 1.1 2007/09/27 16:41:24 drhyde Exp $
+
+package Devel::AssertOS::DGUX;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'dgux' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: DragonflyBSD.pm,v 1.1 2007/09/27 16:41:24 drhyde Exp $
+
+package Devel::AssertOS::DragonflyBSD;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'dragonfly' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: Dynix.pm,v 1.1 2007/09/27 16:41:24 drhyde Exp $
+
+package Devel::AssertOS::Dynix;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'dynixptx' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: FreeBSD.pm,v 1.3 2007/09/27 16:41:24 drhyde Exp $
+
+package Devel::AssertOS::FreeBSD;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'freebsd' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: HPUX.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::HPUX;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'hpux' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: Interix.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::Interix;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'interix' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: Irix.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::Irix;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'irix' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: Linux.pm,v 1.3 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::Linux;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'linux' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: MPEiX.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::MPEiX;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'mpeix' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: MSDOS.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::MSDOS;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'dos' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: MSWin32.pm,v 1.1 2007/09/28 14:35:08 drhyde Exp $
+
+package Devel::AssertOS::MSWin32;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'MSWin32' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
--- /dev/null
+# $Id: MacOSX.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::MacOSX;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'darwin' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: MacOSclassic.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::MacOSclassic;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'MacOS' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: MachTen.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::MachTen;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'machten' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: MicrosoftWindows.pm,v 1.3 2007/09/28 14:35:08 drhyde Exp $
+
+package Devel::AssertOS::MicrosoftWindows;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O =~ /^(cygwin|MSWin32)$/ ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
--- /dev/null
+# $Id: NeXT.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::NeXT;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'next' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: NetBSD.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::NetBSD;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'netbsd' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: Netware.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::Netware;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'netware' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: OS2.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::OS2;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'os2' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: OS390.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::OS390;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'os390' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: OS400.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::OS400;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'os400' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: OSF.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::OSF;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'dec_osf' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: OpenBSD.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::OpenBSD;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'openbsd' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: POSIXBC.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::POSIXBC;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'posix-bc' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: RISCOS.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::RISCOS;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'riscos' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: SCO.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::SCO;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'sco_sv' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: Solaris.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::Solaris;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'solaris' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: Sun.pm,v 1.2 2007/09/28 14:35:08 drhyde Exp $
+
+package Devel::AssertOS::Sun;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O =~ /^(sunos|solaris)$/ ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
--- /dev/null
+# $Id: SunOS.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::SunOS;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'sunos' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: SysVr4.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::SysVr4;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'svr4' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: SysVr5.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::SysVr5;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'svr5' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: Unicos.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::Unicos;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O =~ /^unicos(mk)?$/ ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
--- /dev/null
+# $Id: Unix.pm,v 1.4 2007/09/28 14:35:08 drhyde Exp $
+
+package Devel::AssertOS::Unix;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+# list of OSes lifted from Module::Build 0.2808
+#
+sub os_is {
+ $^O =~ /^(
+ aix |
+ bsdos |
+ dgux |
+ dragonfly |
+ dynixptx |
+ freebsd |
+ linux |
+ hpux |
+ irix |
+ darwin |
+ machten |
+ openbsd |
+ netbsd |
+ dec_osf |
+ svr4 |
+ svr5 |
+ sco_sv |
+ unicos |
+ unicosmk |
+ solaris |
+ sunos |
+ interix
+ )$/x ? 1 : 0;
+}
+
+die_unsupported() unless(os_is());
+
+1;
--- /dev/null
+# $Id: VMESA.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::VMESA;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'vmesa' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: VMS.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::VMS;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'VMS' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: VOS.pm,v 1.1 2007/09/27 16:41:25 drhyde Exp $
+
+package Devel::AssertOS::VOS;
+
+use Devel::CheckOS qw(die_unsupported);
+
+$VERSION = '1.0';
+
+sub os_is { $^O eq 'VOS' ? 1 : 0; }
+
+die_unsupported() unless(os_is());
+
+1;
\ No newline at end of file
--- /dev/null
+# $Id: CheckOS.pm,v 1.13 2007/10/04 20:15:05 drhyde Exp $
+
+package Devel::CheckOS;
+
+use strict;
+use Exporter;
+
+use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS);
+
+$VERSION = '1.2';
+
+# 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);
+%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
+
+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.
+
+=head1 SYNOPSIS
+
+ use Devel::CheckOS;
+ print "Hey, I know this, it's a Unix system\n" if(os_is('Unix'));
+
+=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<use Devel::CheckOS>. 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 = @_;
+ foreach my $target (@targets) {
+ die("Devel::CheckOS: $target isn't a legal OS name\n")
+ unless($target =~ /^\w+$/);
+ eval "use Devel::AssertOS::$target";
+ if(!$@) {
+ no strict 'refs';
+ return 1 if(&{"Devel::AssertOS::${target}::os_is"}());
+ }
+ }
+ return 0;
+}
+
+=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 = @_;
+ foreach my $target (@targets) {
+ return 0 if(os_is($target));
+ }
+ return 1;
+}
+
+=head2 Fatal functions
+
+=head3 die_if_os_isnt
+
+As C<os_is()>, 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<os_isnt()>, 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
+
+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.
+
+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
+
+sub list_platforms {
+ eval " # only load these if needed
+ use File::Find::Rule;
+ use File::Spec;
+ ";
+
+ die($@) if($@);
+ return sort { $a cmp $b } map {
+ s/^.*\///g;
+ s/\.pm$//gi;
+ $_;
+ } File::Find::Rule->file()->name('*.pm')->in(
+ grep { -d }
+ map { File::Spec->catdir($_, qw(Devel AssertOS)) }
+ @INC
+ );
+}
+
+=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<perlport> and a few other places.
+
+The following OS 'families' are supported 'out of the box':
+
+ Apple (Mac OS, both classic and OS X)
+ DEC
+ MicrosoftWindows (this matches either MSWin32 or Cygwin)
+ Sun
+ Unix
+
+If you want to add your own OSes or families, see L<Devel::AssertOS::Extending>
+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<http://rt.cpan.org/> 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<http://www.cantrell.org.uk/david/wishlist/>
+
+=head1 SEE ALSO
+
+$^O in L<perlvar>
+
+L<perlport>
+
+L<Devel::AssertOS>
+
+L<Devel::AssertOS::Extending>
+
+=head1 AUTHOR
+
+David Cantrell E<lt>F<david@cantrell.org.uk>E<gt>
+
+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<Module::Build> 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.
+
+=head1 COPYRIGHT and LICENCE
+
+Copyright 2007 David Cantrell
+
+This module is free-as-in-speech software, and may be used, distributed,
+and modified under the same conditions as perl itself.
+
+=head1 CONSPIRACY
+
+This module is also free-as-in-mason software.
+
+=cut
+
+$^O;
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/inc/Perl/Critic/BuildUtilities.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::BuildUtilities;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English q<-no_match_vars>;
+
+our $VERSION = '1.088';
+
+use base qw{ Exporter };
+
+our @EXPORT_OK = qw<
+ recommended_module_versions
+ test_wrappers_to_generate
+ get_PL_files
+ dump_unlisted_or_optional_module_versions
+ emit_tar_warning_if_necessary
+>;
+
+
+use lib 't/tlib';
+
+use Devel::CheckOS qw< os_is >;
+
+
+sub recommended_module_versions {
+ return (
+ 'File::HomeDir' => 0,
+ 'Perl::Tidy' => 0,
+ 'Readonly::XS' => 0,
+ 'Regexp::Parser' => '0.20',
+ 'Term::ANSIColor' => 0,
+
+ # All of these are for Documentation::PodSpelling
+ 'File::Which' => 0,
+ 'IPC::Open2' => 1,
+ 'Pod::Spell' => 1,
+ 'Text::ParseWords' => 3,
+ );
+}
+
+
+sub test_wrappers_to_generate {
+ my @tests_to_be_wrapped = qw<
+ t/00_modules.t
+ t/01_config.t
+ t/01_config_bad_perlcriticrc.t
+ t/01_policy_config.t
+ t/02_policy.t
+ t/03_pragmas.t
+ t/04_optionsprocessor.t
+ t/05_utils.t
+ t/05_utils_ppi.t
+ t/05_utils_pod.t
+ t/06_violation.t
+ t/07_perlcritic.t
+ t/08_document.t
+ t/09_theme.t
+ t/10_userprofile.t
+ t/11_policyfactory.t
+ t/12_policylisting.t
+ t/12_themelisting.t
+ t/13_bundled_policies.t
+ t/14_policy_parameters.t
+ t/15_statistics.t
+ t/20_policy_podspelling.t
+ t/20_policy_requiretidycode.t
+ xt/author/80_policysummary.t
+ t/92_memory_leaks.t
+ xt/author/94_includes.t
+ >;
+
+ return
+ map
+ { "xt/author/generated/${_}_without_optional_dependencies.t" }
+ @tests_to_be_wrapped;
+}
+
+my @TARGET_FILES = qw<
+ lib/Perl/Critic/PolicySummary.pod
+ t/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.run
+ t/Variables/RequireLocalizedPunctuationVars.run
+>;
+
+sub get_PL_files {
+ my %PL_files = map { ( "$_.PL" => $_ ) } @TARGET_FILES;
+
+ $PL_files{'t/generate_without_optional_dependencies_wrappers.PL'} =
+ [ test_wrappers_to_generate() ];
+
+ return \%PL_files;
+}
+
+sub dump_unlisted_or_optional_module_versions {
+ print
+ "\nVersions of optional/unlisted/indirect dependencies:\n\n";
+
+ my @unlisted_modules = (
+ qw<
+ >,
+ keys %{ { recommended_module_versions() } },
+ );
+
+ foreach my $module (sort @unlisted_modules) {
+ my $version;
+
+ if ($module eq 'Readonly::XS') {
+ eval 'use Readonly; use Readonly::XS; $version = $Readonly::XS::VERSION;';
+ }
+ else {
+ eval "use $module; \$version = \$${module}::VERSION;";
+ }
+ if ($EVAL_ERROR) {
+ $version = 'not installed';
+ } elsif (not defined $version) {
+ $version = 'undef';
+ }
+
+ print " $module = $version\n";
+ }
+
+ print "\n";
+
+ return;
+}
+
+sub emit_tar_warning_if_necessary {
+ if ( os_is( qw<Solaris> ) ) {
+ 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<recommended_module_versions()>
+
+Returns a hash mapping between recommended (but not required) modules
+for Perl::Critic and the minimum version required of each module,
+
+
+=item C<test_wrappers_to_generate()>
+
+Returns a list of test wrappers to be generated by
+F<t/generate_without_optional_dependencies_wrappers.PL>.
+
+
+=item C<get_PL_files()>
+
+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<Module::Build::API/"PL_files"> or
+L<ExtUtils::MakeMaker/"PL_FILES">. May print to C<STDOUT> messages
+about what it is doing.
+
+
+=item C<dump_unlisted_or_optional_module_versions()>
+
+Prints to C<STDOUT> a list of all the unlisted (e.g. things in core
+like L<Exporter>), optional (e.g. L<File::Which>), or potentially
+indirect (e.g. L<Readonly::XS>) dependencies, plus their versions, if
+they're installed.
+
+
+=item C<emit_tar_warning_if_necessary()>
+
+On some Solaris systems, C<tar(1)> 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<< <perl@galumph.com> >>
+
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2007, Elliot Shank C<< <perl@galumph.com> >>. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw(-no_match_vars);
+use Readonly;
+
+use base qw(Exporter);
+
+use File::Spec;
+use Scalar::Util qw(blessed);
+
+use PPI::Document;
+use PPI::Document::File;
+
+use Perl::Critic::Exception::Configuration::Generic;
+use Perl::Critic::Exception::Parse qw{ throw_parse };
+use Perl::Critic::Config;
+use Perl::Critic::Violation;
+use Perl::Critic::Document;
+use Perl::Critic::Statistics;
+use Perl::Critic::Utils qw{ :characters };
+
+#-----------------------------------------------------------------------------
+
+our $VERSION = '1.088';
+
+Readonly::Array our @EXPORT_OK => qw(critique);
+
+#-----------------------------------------------------------------------------
+
+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 $doc = $self->_create_perl_critic_document($source_code);
+
+ if ( 0 == $self->policies() ) {
+ Perl::Critic::Exception::Configuration::Generic->throw(
+ message => 'There are no enabled policies.',
+ )
+ }
+
+ return $self->_gather_violations($doc);
+}
+
+#=============================================================================
+# PRIVATE functions
+
+sub _create_perl_critic_document {
+ my ($self, $source_code) = @_;
+
+ # $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 $doc = _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 $doc ) {
+ my $errstr = PPI::Document::errstr();
+ my $file = ref $source_code ? undef : $source_code;
+ throw_parse
+ message => qq<Can't parse code: $errstr>,
+ file_name => $file;
+ }
+
+ # Pre-index location of each node (for speed)
+ $doc->index_locations();
+
+ # Wrap the doc in a caching layer
+ return Perl::Critic::Document->new($doc);
+}
+
+#-----------------------------------------------------------------------------
+
+sub _gather_violations {
+ my ($self, $doc) = @_;
+
+ # Disable the magic shebang fix
+ my %is_line_disabled = _unfix_shebang($doc);
+
+ # Filter exempt code, if desired
+ if ( not $self->config->force() ) {
+ my @site_policies = $self->config->site_policy_names();
+ %is_line_disabled = ( %is_line_disabled,
+ _filter_code($doc, @site_policies) );
+ }
+
+ # Evaluate each policy
+ my @policies = $self->config->policies();
+ my @violations =
+ map { _critique( $_, $doc, \%is_line_disabled) } @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);
+}
+
+#-----------------------------------------------------------------------------
+
+sub _is_ppi_doc {
+ my ($ref) = @_;
+ return blessed($ref) && $ref->isa('PPI::Document');
+}
+
+#-----------------------------------------------------------------------------
+
+sub _critique {
+
+ my ($policy, $doc, $is_line_disabled) = @_;
+ my @violations = ();
+ my $maximum_violations = $policy->get_maximum_violations_per_document();
+
+ if (defined $maximum_violations && $maximum_violations == 0) {
+ return;
+ }
+
+ my $policy_name = $policy->get_long_name();
+
+ TYPE:
+ for my $type ( $policy->applies_to() ) {
+
+ ELEMENT:
+ for my $element ( @{ $doc->find($type) || [] } ) {
+
+ # 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 (exists $is_line_disabled->{$line}) {
+ next VIOLATION if $is_line_disabled->{$line}->{$policy_name};
+ next VIOLATION if $is_line_disabled->{$line}->{ALL};
+ }
+
+ push @violations, $violation;
+ if (
+ defined $maximum_violations
+ and @violations >= $maximum_violations
+ ) {
+ last TYPE;
+ }
+ }
+ }
+ }
+
+ return @violations;
+}
+
+#-----------------------------------------------------------------------------
+
+sub _filter_code {
+
+ my ($doc, @site_policies)= @_;
+
+ my $nodes_ref = $doc->find('PPI::Token::Comment') || return;
+ my %disabled_lines;
+
+ _filter_shebang_line($nodes_ref, \%disabled_lines, \@site_policies);
+ _filter_other_lines($nodes_ref, \%disabled_lines, \@site_policies);
+ return %disabled_lines;
+}
+
+sub _filter_shebang_line {
+ my ($nodes_ref, $disabled_lines, $site_policies) = @_;
+
+ my $shebang_no_critic = qr{\A [#]! .*? [#][#] \s* no \s+ critic}mx;
+
+ # Special case for the very beginning of the file: allow "##no critic" after the shebang
+ if (0 < @{$nodes_ref}) {
+ my $loc = $nodes_ref->[0]->location;
+ if (1 == $loc->[0] && 1 == $loc->[1] && $nodes_ref->[0] =~ $shebang_no_critic) {
+ my $pragma = shift @{$nodes_ref};
+ for my $policy (_parse_nocritic_import($pragma, $site_policies)) {
+ $disabled_lines->{ 1 }->{$policy} = 1;
+ }
+ }
+ }
+ return;
+}
+
+sub _filter_other_lines {
+ my ($nodes_ref, $disabled_lines, $site_policies) = @_;
+
+ my $no_critic = qr{\A \s* [#][#] \s* no \s+ critic}mx;
+ my $use_critic = qr{\A \s* [#][#] \s* use \s+ critic}mx;
+
+ PRAGMA:
+ for my $pragma ( grep { $_ =~ $no_critic } @{$nodes_ref} ) {
+
+ # Parse out the list of Policy names after the
+ # 'no critic' pragma. I'm thinking of this just
+ # like a an C<import> argument for real pragmas.
+ my @no_policies = _parse_nocritic_import($pragma, $site_policies);
+
+ # Grab surrounding nodes to determine the context.
+ # This determines whether the pragma applies to
+ # the current line or the block that follows.
+ my $parent = $pragma->parent();
+ my $grandparent = $parent ? $parent->parent() : undef;
+ my $sib = $pragma->sprevious_sibling();
+
+
+ # Handle single-line usage on simple statements
+ if ( $sib && $sib->location->[0] == $pragma->location->[0] ) {
+ my $line = $pragma->location->[0];
+ for my $policy ( @no_policies ) {
+ $disabled_lines->{ $line }->{$policy} = 1;
+ }
+ next PRAGMA;
+ }
+
+
+ # Handle single-line usage on compound statements
+ if ( ref $parent eq 'PPI::Structure::Block' ) {
+ if ( ref $grandparent eq 'PPI::Statement::Compound'
+ || ref $grandparent eq 'PPI::Statement::Sub' ) {
+ if ( $parent->location->[0] == $pragma->location->[0] ) {
+ my $line = $grandparent->location->[0];
+ for my $policy ( @no_policies ) {
+ $disabled_lines->{ $line }->{$policy} = 1;
+ }
+ next PRAGMA;
+ }
+ }
+ }
+
+
+ # Handle multi-line usage. This is either a "no critic" ..
+ # "use critic" region or a block where "no critic" persists
+ # 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 $start = $pragma;
+ my $end = $pragma;
+
+ SIB:
+ while ( my $sib = $end->next_sibling() ) {
+ $end = $sib; # keep track of last sibling encountered in this scope
+ last SIB
+ if $sib->isa('PPI::Token::Comment') && $sib =~ $use_critic;
+ }
+
+ # We either found an end or hit the end of the scope.
+ # Flag all intervening lines
+ for my $line ( $start->location->[0] .. $end->location->[0] ) {
+ for my $policy ( @no_policies ) {
+ $disabled_lines->{ $line }->{$policy} = 1;
+ }
+ }
+ }
+
+ return;
+}
+
+#-----------------------------------------------------------------------------
+
+sub _parse_nocritic_import {
+
+ my ($pragma, $site_policies) = @_;
+
+ my $module = qr{ [\w:]+ }mx;
+ my $delim = qr{ \s* [,\s] \s* }mx;
+ my $qw = qr{ (?: qw )? }mx;
+ my $qualifier = qr{ $qw [(]? \s* ( $module (?: $delim $module)* ) \s* [)]? }mx;
+ my $no_critic = qr{ \#\# \s* no \s+ critic \s* $qualifier }mx; ##no critic(EscapedMetacharacters)
+
+ if ( my ($module_list) = $pragma =~ $no_critic ) {
+ my @modules = split $delim, $module_list;
+
+ # Compose the specified modules into a regex alternation. Wrap each
+ # in a no-capturing group to permit "|" in the modules specification
+ # (backward compatibility)
+ my $re = join q{|}, map {"(?:$_)"} @modules;
+ return grep {m/$re/imx} @{$site_policies};
+ }
+
+ # Default to disabling ALL policies.
+ return qw(ALL);
+}
+
+#-----------------------------------------------------------------------------
+sub _unfix_shebang {
+
+ # When you install a script 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 script using a shell,
+ # like `sh my_script`. Unfortunately, this code causes several Policy
+ # violations, so we just disable it as if a "## no critic" comment had
+ # been attached.
+
+ my $doc = shift;
+ my $first_stmnt = $doc->schild(0) || return;
+
+ # Different versions of MakeMaker and Build use slightly differnt 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.+;}m; ##no critic(RequireExtendedFormatting)
+ if ( $first_stmnt =~ $fixin_rx ) {
+ my $line = $first_stmnt->location()->[0];
+ return ( $line => {ALL => 1}, $line + 1 => {ALL => 1} );
+ }
+
+ #No magic shebang was found!
+ return;
+}
+
+#-----------------------------------------------------------------------------
+
+1;
+
+#-----------------------------------------------------------------------------
+
+__END__
+
+=pod
+
+=for stopwords DGR INI-style API -params pbp refactored ActivePerl
+ben Jore Dolan's
+
+=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<Perl::Critic::Policy> modules that attempt to enforce various coding
+guidelines. Most Policy modules are based on Damian Conway's book B<Perl Best
+Practices>. However, Perl::Critic is B<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
+L<perlcritic>. If you want to integrate Perl::Critic with your build process,
+L<Test::Perl::Critic> provides an interface that is suitable for test scripts.
+Also, L<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 L<criticism> pragma.
+
+Win32 and ActivePerl users can find PPM distributions of Perl::Critic at
+L<http://theoryx5.uwinnipeg.ca/ppms/>.
+
+If you'd like to try L<Perl::Critic> without installing anything, there is a
+web-service available at L<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. You can
+also invoke the perlcritic web-service from the command-line by doing an
+HTTP-post, such as one of these:
+
+ $> POST http://perlcritic.com/perl/critic.pl < MyModule.pm
+ $> lwp-request -m POST http://perlcritic.com/perl/critic.pl < MyModule.pm
+ $> wget -q -O - --post-file=MyModule.pm http://perlcritic.com/perl/critic.pl
+
+Please note that the perlcritic web-service is still alpha code. The URL and
+interface to the service are subject to change.
+
+
+=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, -criticism-fatal => $B) >>
+
+=item C<< new( -config => Perl::Critic::Config->new() ) >>
+
+=item C<< new() >>
+
+Returns a reference to a new Perl::Critic object. Most arguments are just
+passed directly into L<Perl::Critic::Config>, 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<PERLCRITIC> 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) to 5 (most severe). 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
+
+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<m/$PATTERN/imx> 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<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 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<m/$PATTERN/imx> 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<RequireUseStrict> and
+C<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
+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<PATTERN>. Only one policy that matches
+C<m/$PATTERN/imx> 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<Perl::Critic::Utils::Constants/"$PROFILE_STRICTNESS_WARN"> (the
+default),
+L<Perl::Critic::Utils::Constants/"$PROFILE_STRICTNESS_FATAL">, and
+L<Perl::Critic::Utils::Constants/"$PROFILE_STRICTNESS_QUIET">. If set
+to L<Perl::Critic::Utils::Constants/"$PROFILE_STRICTNESS_FATAL">,
+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 C<warn>s about profiles
+referring to non-existent Policies, but this value makes this
+situation fatal. Correspondingly,
+L<Perl::Critic::Utils::Constants/"$PROFILE_STRICTNESS_QUIET"> 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"> pseudo-pragmas 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 comments.
+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<Perl::Critic::Violation> for an explanation of format
+specifications. You can set the default value for this option in your
+F<.perlcriticrc> file.
+
+B<-color> is not used by Perl::Critic but is provided for the benefit of
+L<perlcritic>.
+
+B<-criticism-fatal> is not used by Perl::Critic but is provided for the
+benefit of L<criticism>.
+
+B<-config> is a reference to a L<Perl::Critic::Config> object. If you have
+created your own Config object for some reason, you can pass it in here
+instead of having Perl::Critic create one for you. Using the C<-config>
+option causes all the other options to be silently ignored.
+
+=back
+
+
+=head1 METHODS
+
+=over
+
+=item C<critique( $source_code )>
+
+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<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
+L<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.
+
+=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<Perl::Critic::Policy> 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<Perl::Critic::Config> object that was created for or given
+to this Critic.
+
+=item C< statistics() >
+
+Returns the L<Perl::Critic::Statistics> 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<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 C<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.
+
+
+=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<PERLCRITIC> 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<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
+
+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<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 B<Perl Best Practices>. For brevity, you can omit the
+C<'Perl::Critic::Policy'> part of the module name.
+
+C<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 C<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
+
+C<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 L<"POLICY THEMES"> for more
+information.
+
+C<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 L<"POLICY THEMES"> for more information.
+
+C<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 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::ProhibitMixedCaseVars]
+ [-NamingConventions::ProhibitMixedCaseSubs]
+
+ #--------------------------------------------------------------
+ # For all other Policies, I accept the default severity,
+ # so no additional configuration is required for them.
+
+For additional configuration examples, see the F<perlcriticrc> file
+that is included in this F<examples> directory of this distribution.
+
+Damian Conway's own Perl::Critic configuration is also included in this
+distribution as F<examples/perlcriticrc-conway>.
+
+
+=head1 THE POLICIES
+
+A large number of Policy modules are distributed with Perl::Critic. They are
+described briefly in the companion document L<Perl::Critic::PolicySummary> 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<m/PATTERN/imx>
+
+There are a number of distributions of additional policies on CPAN. If
+L<Perl::Critic> doesn't contain a policy that you want, some one may have
+already written it. See the L</"SEE ALSO"> 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
+scripts. 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 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 scripts
+
+
+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 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 (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 pseudo-pragmas:
+
+ 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"> comments direct Perl::Critic to ignore the remaining
+lines of code until the end of the current block, or until a C<"## use
+critic"> comment is found (whichever comes first). If the C<"## no critic">
+comment 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"> comments,
+use the C<-force> option.
+
+A bare C<"## no critic"> comment 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<ProhibitEmptyQuotes> and
+C<ProhibitPostfixControls> policies until the end of the block or until the
+next C<"## use critic"> comment (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::ProhibitMixedCaseVars
+ my $camelHumpVar = 'foo';
+
+ # Now exempt from NamingConventions::ProhibitMixedCaseSubs
+ 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 C<"## no critic">
+pragmas can be nested, and Policies named by an inner pragma will be disabled
+along with those already disabled an outer pragma.
+
+Some Policies like C<Subroutines::ProhibitExcessComplexity> 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...
+ }
+
+Policies such as C<Documentation::RequirePodSections> 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<all> 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 THE L<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.
+
+
+=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<PPI>, but most
+Policy modules are pretty straightforward and only require about 20 lines of
+code. Please see the L<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 C<<
+<thaljef@cpan.org> >> and I'll be happy to put them into the Perl::Critic
+distribution. Or if you would like to work on the Perl::Critic project
+directly, check out our repository at L<http://perlcritic.tigris.org>. To
+subscribe to our mailing list, send a message to C<<
+<dev-subscribe@perlcritic.tigris.org> >>.
+
+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<before>
+they go into production. To discuss your needs with the Perl::Critic team,
+just contact C<< <thaljef@cpan.org> >>.
+
+
+=head1 PREREQUISITES
+
+Perl::Critic requires the following modules:
+
+L<B::Keywords>
+
+L<Config::Tiny>
+
+L<Exception::Class>
+
+L<File::Spec>
+
+L<File::Spec::Unix>
+
+L<IO::String>
+
+L<List::MoreUtils>
+
+L<List::Util>
+
+L<Module::Pluggable>
+
+L<PPI>
+
+L<Pod::PlainText>
+
+L<Pod::Usage>
+
+L<Readonly>
+
+L<Scalar::Util>
+
+L<String::Format>
+
+L<version>
+
+
+The following modules are optional, but recommended for complete
+testing:
+
+L<File::HomeDir>
+
+L<File::Which>
+
+L<IO::String>
+
+L<IPC::Open2>
+
+L<Perl::Tidy>
+
+L<Pod::Spell>
+
+L<Test::Pod>
+
+L<Test::Pod::Coverage>
+
+L<Text::ParseWords>
+
+
+=head1 CONTACTING THE DEVELOPMENT TEAM
+
+You are encouraged to subscribe to the mailing list; send a message to
+C<< <users-subscribe@perlcritic.tigris.org> >>. See also
+L<the archives|http://perlcritic.tigris.org/servlets/SummarizeList?listName=users>.
+You can also contact the author at C<< <thaljef@cpan.org> >>.
+
+At least one member of the development team has started hanging around in
+L<irc://irc.perl.org/#perlcritic>.
+
+
+=head1 SEE ALSO
+
+There are a number of distributions of additional Policies available. A few
+are listed here:
+
+L<Perl::Critic::More>
+
+L<Perl::Critic::Bangs>
+
+L<Perl::Critic::Lax>
+
+L<Perl::Critic::StricterSubs>
+
+L<Perl::Critic::Swift>
+
+L<Perl::Critic::Tics>
+
+These distributions enable you to use Perl::Critic in your unit tests:
+
+L<Test::Perl::Critic>
+
+L<Test::Perl::Critic::Progressive>
+
+There are also a couple of distributions that will install all the
+Perl::Critic related modules known to the development team:
+
+L<Bundle::Perl::Critic>
+
+L<Task::Perl::Critic>
+
+If you want to make sure you have absolutely everything, you can use these:
+
+L<Bundle::Perl::Critic::IncludingOptionalDependencies>
+
+L<Task::Perl::Critic::IncludingOptionalDependencies>
+
+
+=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 to
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Perl-Critic>. Thanks.
+
+Most policies will produce false-negatives if they cannot understand a
+particular block of code.
+
+
+=head1 CREDITS
+
+Adam Kennedy - For creating L<PPI>, the heart and soul of L<Perl::Critic>.
+
+Damian Conway - For writing B<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.
+L<http://www.perlfoundation.org/april_1_2007_new_grant_awards>
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Config.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Config;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw(-no_match_vars);
+use Readonly;
+
+use List::MoreUtils qw(any none apply);
+use Scalar::Util qw(blessed);
+
+use Perl::Critic::Exception::AggregateConfiguration;
+use Perl::Critic::Exception::Configuration;
+use Perl::Critic::Exception::Configuration::Option::Global::ParameterValue;
+use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal };
+use Perl::Critic::PolicyFactory;
+use Perl::Critic::Theme qw( $RULE_INVALID_CHARACTER_REGEX cook_rule );
+use Perl::Critic::UserProfile qw();
+use Perl::Critic::Utils qw{
+ :booleans :characters :severities :internal_lookup :classification
+};
+use Perl::Critic::Utils::Constants qw{ :profile_strictness };
+use Perl::Critic::Utils::DataConversion qw{ boolean_to_number dor };
+
+#-----------------------------------------------------------------------------
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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_verbosity($args{-verbose}, $errors);
+ $self->_validate_and_save_severity($args{-severity}, $errors);
+ $self->_validate_and_save_top($args{-top}, $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->{_criticism_fatal} =
+ boolean_to_number(dor( $args{'-criticism_fatal'}, $options_processor->criticism_fatal() ) );
+ }
+
+ $self->_validate_and_save_theme($args{-theme}, $errors);
+
+ # 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->{_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 doesn't have }
+ . q{a value for its config attribute.};
+
+ if ( $policy_object->initialize_if_enabled( $config ) ) {
+ push @{ $self->{_policies} }, $policy_object;
+ }
+
+ 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;
+ }
+
+ # 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/$_/imx } @inclusions;
+}
+
+#-----------------------------------------------------------------------------
+
+sub _policy_is_excluded {
+ my ($self, $policy) = @_;
+ my $policy_long_name = ref $policy;
+ my @exclusions = $self->exclude();
+ return any { $policy_long_name =~ m/$_/imx } @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/$_/imx } @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 { my $test = qr/$regex/imx; }
+ or do {
+ my $cleaned_error = $EVAL_ERROR || '<unknown reason>';
+ $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;
+}
+
+#-----------------------------------------------------------------------------
+# Begin ACCESSSOR methods
+
+sub _profile {
+ my $self = shift;
+ return $self->{_profile};
+}
+
+#-----------------------------------------------------------------------------
+
+sub policies {
+ my $self = shift;
+ return @{ $self->{_policies} };
+}
+
+#-----------------------------------------------------------------------------
+
+sub exclude {
+ my $self = shift;
+ return @{ $self->{_exclude} };
+}
+
+#-----------------------------------------------------------------------------
+
+sub force {
+ my $self = shift;
+ return $self->{_force};
+}
+
+#-----------------------------------------------------------------------------
+
+sub include {
+ my $self = shift;
+ return @{ $self->{_include} };
+}
+
+#-----------------------------------------------------------------------------
+
+sub only {
+ my $self = shift;
+ return $self->{_only};
+}
+
+#-----------------------------------------------------------------------------
+
+sub profile_strictness {
+ my $self = shift;
+ return $self->{_profile_strictness};
+}
+
+#-----------------------------------------------------------------------------
+
+sub severity {
+ my $self = shift;
+ return $self->{_severity};
+}
+
+#-----------------------------------------------------------------------------
+
+sub single_policy {
+ my $self = shift;
+ return @{ $self->{_single_policy} };
+}
+
+#-----------------------------------------------------------------------------
+
+sub theme {
+ my $self = shift;
+ return $self->{_theme};
+}
+
+#-----------------------------------------------------------------------------
+
+sub top {
+ my $self = shift;
+ return $self->{_top};
+}
+
+#-----------------------------------------------------------------------------
+
+sub verbose {
+ my $self = shift;
+ return $self->{_verbose};
+}
+
+#-----------------------------------------------------------------------------
+
+sub color {
+ my $self = shift;
+ return $self->{_color};
+}
+
+#-----------------------------------------------------------------------------
+
+sub criticism_fatal {
+ my $self = shift;
+ return $self->{_criticism_fatal};
+}
+
+#-----------------------------------------------------------------------------
+
+sub site_policy_names {
+ return Perl::Critic::PolicyFactory::site_policy_names();
+}
+
+1;
+
+#-----------------------------------------------------------------------------
+
+__END__
+
+=pod
+
+=for stopwords -params INI-style
+
+=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<Perl::Critic>. 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 CONSTRUCTOR
+
+=over 8
+
+=item C<< new( [ -profile => $FILE, -severity => $N, -theme => $string, -include => \@PATTERNS, -exclude => \@PATTERNS, -single-policy => $PATTERN, -top => $N, -only => $B, -profile-strictness => $PROFILE_STRICTNESS_{WARN|FATAL|QUIET}, -force => $B, -verbose => $N, -color => $B, -criticism-fatal => $B] ) >>
+
+=item C<< new() >>
+
+Returns a reference to a new Perl::Critic::Config object. 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<PERLCRITIC> 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 loaded into this Config.
+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 result in more Policy violations. Users can
+redefine the severity level for any Policy in their F<.perlcriticrc>
+file. See L<"CONFIGURATION"> for more information.
+
+B<-theme> is special string that defines a set of Policies based on
+their respective themes. If C<-theme> is given, only policies that
+are members of that set will be loaded. See the L<"POLICY THEMES">
+section for more information about themes. Unless the C<-severity>
+option is explicitly given, setting C<-theme> causes the C<-severity>
+to be set to 1.
+
+B<-include> is a reference to a list of string C<@PATTERNS>. Policies
+that match at least one C<m/$PATTERN/imx> will be loaded into this
+Config, irrespective of the severity settings. 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.
+
+B<-exclude> is a reference to a list of string C<@PATTERNS>. Polices
+that match at least one C<m/$PATTERN/imx> will not be loaded into this
+Config, irrespective of the severity settings. 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.
+
+B<-single-policy> is a string C<PATTERN>. Only the policy that matches
+C<m/$PATTERN/imx> will be used. This value overrides the
+C<-severity>, C<-theme>, C<-include>, C<-exclude>, and C<-only>
+options.
+
+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.
+
+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.
+
+B<-profile-strictness> is an enumerated value, one of
+L<Perl::Critic::Utils::Constants/"$PROFILE_STRICTNESS_WARN"> (the
+default),
+L<Perl::Critic::Utils::Constants/"$PROFILE_STRICTNESS_FATAL">, and
+L<Perl::Critic::Utils::Constants/"$PROFILE_STRICTNESS_QUIET">. If set
+to L<Perl::Critic::Utils::Constants/"$PROFILE_STRICTNESS_FATAL">,
+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 C<warn>s about profiles
+referring to non-existent Policies, but this value makes this
+situation fatal. Correspondingly,
+L<Perl::Critic::Utils::Constants/"$PROFILE_STRICTNESS_QUIET"> makes
+Perl::Critic shut up about these things.
+
+B<-force> controls whether Perl::Critic observes the magical C<"## no
+critic"> pseudo-pragmas 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
+comments. See L<Perl::Critic/"BENDING THE RULES"> for more
+information.
+
+B<-verbose> can be a positive integer (from 1 to 10), or a literal
+format specification. See L<Perl::Critic::Violations> for an
+explanation of format specifications.
+
+B<-color> is not used by Perl::Critic but is provided for the benefit
+of L<perlcritic>.
+
+B<-criticism-fatal> is not used by Perl::Critic but is provided for the benefit
+of L<criticism>.
+
+
+
+=back
+
+=head1 METHODS
+
+=over 8
+
+=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<Perl::Critic::Policy> 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 Config. Objects will be in the order that
+they were loaded.
+
+=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<Perl::Critic::Theme> 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< criticism_fatal() >
+
+Returns the value of the C<-criticsm-fatal> attribute for this Config.
+
+=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 8
+
+=item C<site_policy_names()>
+
+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<Perl::Critic::Config> will look
+for this file in the current directory first, and then in your home
+directory. Alternatively, you can set the C<PERLCRITIC> 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<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 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
+
+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<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 B<Perl Best Practices>. For
+brevity, you can omit the C<'Perl::Critic::Policy'> part of the
+module name.
+
+C<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.
+
+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::ProhibitMixedCaseVars]
+ [-NamingConventions::ProhibitMixedCaseSubs]
+
+ #--------------------------------------------------------------
+ # 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<perlcriticrc> file
+that is included in this F<t/examples> 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<Perl::Critic::PolicySummary> 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
+scripts. 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 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 scripts
+
+
+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<http://en.wikipedia.org/wiki/Set> for a discussion on set theory.
+
+=head1 SEE ALSO
+
+L<Perl::Critic::OptionsProcessor>, L<Perl::Critic::UserProfile>
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/DEVELOPER.pod $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+=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<Perl::Critic>.
+Although the Perl::Critic distribution already includes a number of
+Policies based on Damian Conway's book I<Perl Best Practices> (which
+will be referred to via "I<PBP>" 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<Perl::Critic::Policy> subclass, which may
+require as little as 10 lines of code.
+
+
+=head1 BACKGROUND
+
+The heart of Perl::Critic is L<PPI>, 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<PPI::Token::Operator> or L<PPI::Token::Word>, and then organized
+into structure classes, like L<PPI::Statement::Expression> and
+L<PPI::Structure::Subroutine>. The root node of the hierarchy is the
+L<PPI::Document>.
+
+The L<Perl::Critic> engine traverses each node in the L<PPI::Document>
+tree and invokes each of the L<Perl::Critic::Policy> 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 that a coding standard has been violated, it returns one
+or more L<Perl::Critic::Violation> 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<RequireBlockGrep.pm> Policy is
+relatively simple and demonstrates most of the important issues. The
+goal of this Policy is to enforce that every call to C<grep> uses a
+block for the first argument and not an expression. The reasons for
+this Policy are discussed in detail in I<PBP>.
+
+
+=head1 EXAMPLE POLICY
+
+First, the Policy module needs to have a name. Perl::Critic uses
+L<Module::Pluggable> to automatically discover all modules in the
+C<Perl::Critic::Policy> namespace. Also, we've adopted the convention
+of grouping Policies into directories according to the chapters of
+I<PBP>. Since the goal of this Policy is to enforce the use of block
+arguments to C<grep> and it comes from the "Builtin Functions" chapter
+of I<PBP>, 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<Perl::Critic::Policy> 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<use strict> and C<use warnings> 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<PBP>. We make them read-only because they never
+change. (See
+L<Perl::Critic::ValuesAndExpressions::ProhibitConstantPragma> for why
+we don't C<use constant>.)
+
+ Readonly::Scalar my $DESC => q{Expression form of "grep"};
+ Readonly::Scalar my $EXPL => [ 169 ];
+
+Most policies don't need to override the C<initialize_if_enabled()>
+method provided by L<Perl::Critic::Policy>. However, if your Policy
+is configurable via F<.perlcriticrc>, you should implement a
+C<supported_parameters()> method and need to implement
+C<initialize_if_enabled()> to examine the C<$config> values. Since
+this Policy isn't configurable, we'll declare that by providing an
+implementation of C<supported_parameters()> that returns an empty
+list.
+
+ sub supported_parameters { return () }
+
+Next, we define the C<default_severity()> 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<Perl::Critic::Utils> package exports several
+severity constants that you can use here via the C<:severities> tag.
+
+ sub default_severity { return $SEVERITY_HIGH }
+
+Likewise, the C<default_themes()> 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<grep> without blocks often leads to bugs, we include a
+C<"bugs"> theme. And since this Policy comes directly from I<PBP>,
+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<Perl::Critic::More> 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<PPI::Statement>,
+L<PPI::Token::Symbol>, L<PPI::Structure::Conditional> or
+L<PPI::Token::Pod> respectively. The applies_to() method returns a
+list of PPI package names. (You can get that list of available
+package names via C<perldoc PPI>.) As Perl::Critic traverses the
+document, it will call the C<violates()> 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<grep>. Since the token
+"grep" is a L<PPI::Token::Word>, we return that package name from the
+C<applies_to()> method.
+
+ sub applies_to { return 'PPI::Token::Word' }
+
+If your Policy needs to analyze several different types of elements,
+the C<applies_to> method may return the name of several PPI packages.
+If your Policy needs to examine the file as a whole, then the
+C<applies_to> method should return L<PPI::Document>. Since there is
+only one PPI::Document element, your Policy would only be invoked once
+per file.
+
+Now comes the interesting part. The C<violates()> 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<undef>.
+
+ sub violates {
+ my ( $self, $elem, undef ) = @_;
+
+The violates() 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<PPI::Token::Word> because that's what we declared
+back in the C<applies_to()> 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<content()> method.) So we make sure that this
+PPI::Token::Word is, in fact, "grep". If it's not, then we don't'
+need to bother examining it.
+
+ return if $elem ne 'grep';
+
+The C<PPI::Token::Word> 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<grep>. So we use one of handy utility functions from
+L<Perl::Critic::Utils> to make sure that this "grep" is actually in
+the right context. (The C<is_function_call()> 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<grep> 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<PPI>; after that, we'll show how
+this Policy actually uses facilities provided by
+L<Perl::Critic::Utils> 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<snext_sibling()> to get the next code-sibling (the "s" in
+C<snext_sibling> 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<PPI::Structure::List> object when
+parentheses are used. So if the sibling is a PPI::Structure::List, we
+pull out the first (significant) child of that list. This child will
+be the first argument to C<grep>. 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<Perl::Critic::Utils/"first_arg"> 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<grep>. If
+that argument is a block (i.e. something in curly braces), then it
+will be a L<PPI::Structure::Block>, 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<PPI::Structure::Block>, then we know that this
+call to C<grep> must be using the expression form, and that violates
+our Policy. So we create and return a new L<Perl::Critic::Violation>
+object via the L<Perl::Critic::Policy/"violation"> 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<grep> and C<map> 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<perlcritic> with a C<--verbose> parameter of C<10> or C<11> to see
+it along with the rest of the output for violations of your policy.
+
+
+=head1 MAKING YOUR POLICY CONFIGURABLE
+
+L<Perl::Critic> takes care of gathering configuration information for
+your Policy, from whatever source the user specifies. (See
+L<Perl::Critic/"CONFIGURATION"> 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<perlcritic> C<--profile-proto> option for an
+example.)
+
+You can look at
+L<Perl::Critic::Policy::ControlStructures::ProhibitCascadingIfElse>
+for a simple example of a configurable Policy and
+L<Perl::Critic::Policy::Documentation::RequirePodSections> for a more
+complex one.
+
+=head2 Do It All Yourself
+
+The C<initialize_if_enabled()> method for a Policy receives one
+argument: an instance of L<Perl::Critic::PolicyConfig>. 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<Perl::Critic::Policy::CodeLayout::RequireTidyCode> disables itself
+if L<Perl::Tidy> is not installed.
+
+A basic, do-nothing implementation of C<initialize_if_enabled()> 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<violates()> 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<selections> is supposed to be a list
+of integers. L<Perl::Critic::Utils> contains a number of functions
+that can help you with this. Assuming that C<violates()> wants to
+have C<selections> 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<selections> contains numbers, it may be desirable to change
+the assignment to look like
+
+ $self->{_selections} = [ map { $_ + 0 } words_from_string($selections) ];
+
+If C<violates()> needs to quickly determine whether a particular value
+is in C<selections>, 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<Perl::Critic::Policy::CodeLayout::RequireTidyCode>.
+
+
+=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 C<use>d,
+even if the Policy wasn't enabled, slowing things down. Also, this
+severely restricted the core of L<Perl::Critic>'s ability to enhance
+things. Use of constructors is deprecated and is incompatible with
+C<supported_parameters()> metadata below. Kindly use
+C<initialize_if_enabled()>, instead, to do any sort of set up that you
+need.
+
+
+
+=head2 Providing Basic Configuration Information Via C<supported_parameters()>
+
+As minimum for a well behaved Policy, you should implement
+C<supported_parameters()> in order to tell the rest of C<Perl::Critic>
+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<RequireBlockGrep> example above, this looked like
+
+ sub supported_parameters { return () }
+
+For the example being used in the C<initialize_if_enabled()> section
+above, this would be
+
+ sub supported_parameters { return qw< foo factor selections >; }
+
+Given this information, C<Perl::Critic> 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<.perlcritic> 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<supported_parameters()> be
+hash references instead of strings, with keys of C<name>,
+C<description>, and C<default_string>. 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<incompatible|/"Note On Constructors"> with specifying parameters in
+this way.
+
+
+=head2 Using C<supported_parameters()> to Get It Done For You
+
+The C<supported_parameters()> 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<initialize_if_enabled()> 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<behavior>. 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<violates()> 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<Perl::Critic>; for
+more on this, see L<Perl::Critic::PolicyParameter> and
+L<Perl::Critic::PolicyParameter::Behavior>.
+
+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<Perl::Critic::PolicyParameter::Behavior::String>.
+
+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<supported_parameters()> 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<Perl::Critic::PolicyParameter::Behavior::Boolean>.
+
+The value of the parameter will be either L<Perl::Critic::Utils/$TRUE>
+or L<Perl::Critic::Utils/$FALSE>.
+
+This behavior is not configurable.
+
+=head4 C<supported_parameters()> 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<Perl::Critic::PolicyParameter::Behavior::Integer>.
+
+The value is validated against C<m/ \A [-+]? [1-9] [\d_]* \z /xms>
+(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<integer_minimum> and
+C<integer_maximum>, which specify endpoints of an inclusive range to
+restrict the value to. Either, neither, or both may be specified.
+
+=head4 C<supported_parameters()> 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<Perl::Critic::PolicyParameter::Behavior::StringList>.
+
+The values will be derived by splitting the input string on blanks.
+(See L<Perl::Critic::Utils/"words_from_string">.) The parameter will
+be stored as a reference to a hash, with the values being the keys.
+
+This takes one optional option, C<always_present_values>, 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<supported_parameters()> example
+
+ sub supported_parameters {
+ return (
+ {
+ name => 'a_string_list',
+ description => 'An example list.',
+ default_string => 'red pink blue',
+ behavior => 'string 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<Perl::Critic::PolicyParameter::Behavior::Enumeration>.
+
+The values will be derived by splitting the input string on blanks.
+(See L<Perl::Critic::Utils/"words_from_string">.) Depending upon the
+value of the C<enumeration_allow_multiple_values> 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<enumeration_values> of a reference to an array of valid strings
+is required. A true value can be specified for
+C<enumeration_allow_multiple_values> to allow the user to pick more
+than one value, but this defaults to false.
+
+=head4 C<supported_parameters()> 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<initialize_if_enabled()> is
+that it allows you to use a behavior to provide its extra
+functionality and it provides a means for a C<Perl::Critic>
+configuration program, e.g. an IDE that integrates C<Perl::Critic>, 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<parser> 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<Perl::Critic::Policy> that
+takes two parameters: the L<Perl::Critic::PolicyParameter> 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<violates()> method.
+
+An example parser (without enough error handling) for the above
+example declaration:
+
+ use File::Slurp qw< slurp >;
+
+ 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 = slurp $config_string;
+ }
+
+ $self->{_thingies} = \@thingies;
+
+ return;
+ }
+
+Note that, if the value for the parameter is not valid, an instance of
+L<Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue>
+is thrown. This allows C<Perl::Critic> to include that problem along
+with any other problems found with the user's configuration in a
+single error message.
+
+
+=head2 Using Both C<supported_parameters()> and C<initialize_if_enabled()>
+
+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<initialize_if_enabled()>. If you want to take
+advantage of the supplied parameter handling from within
+implementation of C<initialize_if_enabled()>, note that the
+information from C<supported_parameters()> will already have been
+used, with user-supplied parameter values validated and placed into
+the Policy by the time C<initialize_if_enabled()> 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<supported_parameters()>.
+
+
+=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<default_maximum_violations_per_document()>
+
+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<Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict>; if
+there's one line before L<use strict>, there's a good chance that the
+entire file is missing L<use strict>. 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<default_maximum_violations_per_document()|Perl::Critic::Policy/"default_maximum_violations_per_document()">
+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<Perl::Critic::Policy::ValuesAndExpressions::ProhibitMagicNumbers>
+and L<Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings>
+for examples.
+
+
+=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<Perl::Critic::I<something>>,
+e.g. L<Perl::Critic::More>.
+
+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<CPAN>/L<CPANPLUS>. 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<Perl::Critic> policies that will help you keep your code
+ nice and compliant.
+
+
+ =head1 DESCRIPTION
+
+ The included policies are:
+
+ =over
+
+ =item L<Perl::Critic::Policy::Documentation::Example>
+
+ Complains about some example documentation issues. [Severity: 3]
+
+
+ =item L<Perl::Critic::Policy::Variables::Example>
+
+ All modules must have at least one variable. [Severity: 3]
+
+
+ =back
+
+
+ =head1 CONFIGURATION AND ENVIRONMENT
+
+ All policies included are in the "example" theme. See the
+ L<Perl::Critic> documentation for how to make use of this.
+
+
+=head2 Themes
+
+Users can choose which policies to enable using themes. You should
+implement C<default_themes()> 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<CONFIGURATION AND ENVIRONMENT> POD section as shown above.
+
+ default_themes { return qw< example math > }
+
+If you're looking for ideas of what themes to do, have a look at the
+output of C<perlcritic --list-themes>.
+
+
+=head2 Documentation
+
+=head3 AFFILIATION
+
+Since all policies have to go somewhere under the
+C<Perl::Critic::Policy::> 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<AFFILIATION>
+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<Perl::Critic::Example>.
+
+
+=head3 CONFIGURATION
+
+In order to make it clear what can be done with a policy, you should
+always include a C<CONFIGURATION> section in your POD, even if it's
+only to say:
+
+ =head1 CONFIGURATION
+
+ This Policy is not configurable except for the standard options.
+
+
+=head1 HINT
+
+When you're trying to figure out what L<PPI> is going to hand you for
+a chunk of code, there is a F<tools/ppidump> program in the
+L<Perl::Critic> 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.
+
+
+=head1 VERSION
+
+This is part of L<Perl::Critic> version 1.088.
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Document.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Document;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use List::Util qw< max >;
+use PPI::Document;
+use Scalar::Util qw< weaken >;
+use version;
+
+#-----------------------------------------------------------------------------
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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, $doc) = @_;
+ return bless { _doc => $doc }, $class;
+}
+
+#-----------------------------------------------------------------------------
+
+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 filename {
+ my ($self) = @_;
+ return $self->{_doc}->can('filename') ? $self->{_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) {
+ $highest_explicit_perl_version =
+ max 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 _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
+ };
+}
+
+#-----------------------------------------------------------------------------
+
+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($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<PPI::Document::find()> method. To save some time, this class
+pre-caches a lot of the common C<find()> 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<PPI::Document> instance.
+
+
+=head1 CAVEATS
+
+This facade does not implement the overloaded operators from
+L<PPI::Document> (that is, the C<use overload ...> work). Therefore,
+users of this facade must not rely on that syntactic sugar. So, for
+example, instead of C<my $source = "$doc";> 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 CONSTRUCTOR
+
+=over
+
+=item C<< new($doc) >>
+
+Create a new instance referencing a PPI::Document instance.
+
+
+=back
+
+
+=head1 METHODS
+
+=over
+
+=item C<< new($doc) >>
+
+Create a new instance referencing a PPI::Document instance.
+
+
+=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) >>
+
+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<PPI::Document> instance.
+
+
+=item C<< filename() >>
+
+Returns the filename for the source code if applicable
+(PPI::Document::File) or C<undef> 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<version> object for the highest Perl version requirement declared
+in the document via a C<use> or C<require> statement. Returns nothing if
+there is no version statement.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception;
+
+use 5.006001;
+use strict;
+use warnings;
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+use Exception::Class (
+ 'Perl::Critic::Exception' => {
+ isa => 'Exception::Class::Base',
+ description => 'A problem discovered by Perl::Critic.',
+ },
+);
+
+use base 'Exporter';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic>.
+
+=head1 DESCRIPTION
+
+A base class for all problems discovered by L<Perl::Critic>. This
+exists to enable differentiating exceptions from L<Perl::Critic> code
+from those originating in other modules.
+
+This is an abstract class. It should never be instantiated.
+
+
+=head1 METHODS
+
+=over
+
+=item C<short_class_name()>
+
+Retrieve the name of the class of this object with C<'Perl::Critic::'>
+stripped off.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception/AggregateConfiguration.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception::AggregateConfiguration;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Carp qw{ confess };
+use English qw(-no_match_vars);
+use Readonly;
+
+use Perl::Critic::Utils qw{ :characters };
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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; ## no critic (RequireUseOfExceptions)
+
+ 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 (RequireUseOfExceptions, RequireCarping)
+ }
+
+ return;
+}
+
+#-----------------------------------------------------------------------------
+
+sub has_exceptions {
+ my ( $self ) = @_;
+
+ return @{ $self->exceptions() } ? 1 : 0;
+}
+
+#-----------------------------------------------------------------------------
+
+my $MESSAGE_PREFIX = $EMPTY;
+my $MESSAGE_SUFFIX = "\n";
+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 METHODS
+
+=over
+
+=item C<add_exception( $exception )>
+
+Accumulate the parameter with rest of the exceptions.
+
+
+=item C<add_exceptions_from( $aggregate )>
+
+Accumulate the exceptions from another instance of this class.
+
+
+=item C<exceptions()>
+
+Returns a reference to an array of the collected exceptions.
+
+
+=item C<add_exception_or_rethrow( $eval_error )>
+
+If the parameter is an instance of
+L<Perl::Critic::Exception::Configuration> or
+L<Perl::Critic::Exception::AggregateConfiguration>, add it.
+Otherwise, C<die> with the parameter, if it is a reference, or
+C<confess> with it. If the parameter is false, simply returns.
+
+
+=item C<has_exceptions()>
+
+Answer whether any configuration problems have been found.
+
+
+=item C<full_message()>
+
+Concatenate the exception messages. See
+L<Exception::Class/"full_message">.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception/Configuration.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception::Configuration;
+
+use 5.006001;
+use strict;
+use warnings;
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> configuration.
+
+=head1 DESCRIPTION
+
+A representation of a problem found with the configuration of
+L<Perl::Critic>, whether from a F<.perlcriticrc>, another profile
+file, or command line.
+
+This is an abstract class. It should never be instantiated.
+
+
+=head1 METHODS
+
+=over
+
+=item C<source()>
+
+Where the configuration information came from, if it could be determined.
+
+
+=back
+
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Exception::Configuration::Generic>
+L<Perl::Critic::Exception::Configuration::Option>
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception/Configuration/Generic.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception::Configuration::Generic;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> configuration that doesn't involve an option.
+
+=head1 DESCRIPTION
+
+A representation of a problem found with the configuration of L<Perl::Critic>,
+whether from a F<.perlcriticrc>, another profile file, or command line.
+
+This covers things like file reading and parsing errors.
+
+
+=head1 CLASS METHODS
+
+=over
+
+=item C<< throw( message => $message, source => $source ) >>
+
+See L<Exception::Class/"throw">.
+
+
+=item C<< new( message => $message, source => $source ) >>
+
+See L<Exception::Class/"new">.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception/Configuration/Option.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception::Configuration::Option;
+
+use 5.006001;
+use strict;
+use warnings;
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> configuration.
+
+=head1 DESCRIPTION
+
+A representation of a problem found with an option in the
+configuration of L<Perl::Critic>, whether from a F<.perlcriticrc>,
+another profile file, or command line.
+
+This is an abstract class. It should never be instantiated.
+
+
+=head1 METHODS
+
+=over
+
+=item C<option_name()>
+
+The name of the option that was found to be in error.
+
+
+=item C<option_value()>
+
+The value of the option that was found to be in error.
+
+
+=item C<message_suffix()>
+
+Any text that should be applied to end of the standard message for
+this kind of exception.
+
+
+=item C<message()>
+
+=item C<error()>
+
+Overridden to call C<full_message()>. I.e. any message string in the
+superclass is ignored.
+
+
+=item C<full_message()>
+
+Overridden to turn it into an abstract method to force subclasses to
+implement it.
+
+
+=back
+
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Exception::Configuration::Option::Global>
+L<Perl::Critic::Exception::Configuration::Option::Policy>
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception/Configuration/Option/Global.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception::Configuration::Option::Global;
+
+use 5.006001;
+use strict;
+use warnings;
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> global configuration.
+
+=head1 DESCRIPTION
+
+A representation of a problem found with the global configuration of
+L<Perl::Critic>, whether from a F<.perlcriticrc>, another profile
+file, or command line.
+
+This is an abstract class. It should never be instantiated.
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception/Configuration/Option/Global/ExtraParameter.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception::Configuration::Option::Global::ExtraParameter;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> doesn't have, whether from a
+F<.perlcriticrc>, another profile file, or command line.
+
+
+=head1 CLASS METHODS
+
+=over
+
+=item C<< throw( option_name => $option_name, source => $source ) >>
+
+See L<Exception::Class/"throw">.
+
+
+=item C<< new( option_name => $option_name, source => $source ) >>
+
+See L<Exception::Class/"new">.
+
+
+=back
+
+
+=head1 METHODS
+
+=over
+
+=item C<full_message()>
+
+Provide a standard message for values for non-existent parameters for
+policies. See L<Exception::Class/"full_message">.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception/Configuration/Option/Global/ParameterValue.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception::Configuration::Option::Global::ParameterValue;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+use Perl::Critic::Utils qw{ :characters };
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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
+ : '<undef>';
+ 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 CLASS METHODS
+
+=over
+
+=item C<< throw( option_name => $option_name, option_value => $option_value, source => $source, message_suffix => $message_suffix ) >>
+
+See L<Exception::Class/"throw">.
+
+
+=item C<< new( option_name => $option_name, option_value => $option_value, source => $source, message_suffix => $message_suffix ) >>
+
+See L<Exception::Class/"new">.
+
+
+=back
+
+
+=head1 METHODS
+
+=over
+
+=item C<full_message()>
+
+Provide a standard message for global configuration problems. See
+L<Exception::Class/"full_message">.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception/Configuration/Option/Policy.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception::Configuration::Option::Policy;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Perl::Critic::Utils qw{ &policy_short_name };
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic::Policy>, whether from a F<.perlcriticrc>, another
+profile file, or command line.
+
+This is an abstract class. It should never be instantiated.
+
+
+=head1 METHODS
+
+=over
+
+=item C<policy()>
+
+The short name of the policy that had configuration problems.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception/Configuration/Option/Policy/ExtraParameter.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic::Policy> doesn't have, whether
+from a F<.perlcriticrc>, another profile file, or command line.
+
+
+=head1 CLASS METHODS
+
+=over
+
+=item C<< throw( policy => $policy, option_name => $option_name, source => $source ) >>
+
+See L<Exception::Class/"throw">.
+
+
+=item C<< new( policy => $policy, option_name => $option_name, source => $source ) >>
+
+See L<Exception::Class/"new">.
+
+
+=back
+
+
+=head1 METHODS
+
+=over
+
+=item C<full_message()>
+
+Provide a standard message for values for non-existent parameters for
+policies. See L<Exception::Class/"full_message">.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception/Configuration/Option/Policy/ParameterValue.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+use Perl::Critic::Utils qw{ :characters };
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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
+ : '<undef>';
+ 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<Perl::Critic::Policy>, whether from a F<.perlcriticrc>, another
+profile file, or command line.
+
+
+=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<Exception::Class/"throw">.
+
+
+=item C<< new( policy => $policy, option_name => $option_name, option_value => $option_value, source => $source, message_suffix => $message_suffix ) >>
+
+See L<Exception::Class/"new">.
+
+
+=back
+
+
+=head1 METHODS
+
+=over
+
+=item C<full_message()>
+
+Provide a standard message for policy parameter value problems. See
+L<Exception::Class/"full_message">.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception/Fatal.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception::Fatal;
+
+use 5.006001;
+use strict;
+use warnings;
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> 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<Exception::Class/"show_trace"> to
+force stack-traces to be included in the standard stringification.
+
+This is an abstract class. It should never be instantiated.
+
+
+=head1 METHODS
+
+=over
+
+=item C<full_message()>
+
+Overrides L<Exception::Class/"full_message"> to include extra information.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception/Fatal/Generic.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception::Fatal::Generic;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 METHODS
+
+Only inherited ones.
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception/Fatal/Internal.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception::Fatal::Internal;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> implementation, i.e. a bug.
+
+=head1 DESCRIPTION
+
+A representation of a bug found in the code of L<Perl::Critic>.
+
+
+=head1 METHODS
+
+Only inherited ones.
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception/Fatal/PolicyDefinition.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception::Fatal::PolicyDefinition;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 METHODS
+
+Only inherited ones.
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception/IO.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception::IO;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Carp qw{ confess };
+use English qw(-no_match_vars);
+use Readonly;
+
+use Perl::Critic::Utils qw{ :characters };
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 METHODS
+
+=over
+
+=item C<file_name()>
+
+Returns the name of the file that the problem was found with, if available.
+
+
+=item C<errno()>
+
+The value of C<$ERRNO>/C<$!> at the time the problem was found.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Exception/Parse.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Exception::Parse;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw< -no_match_vars >;
+use Carp qw< confess >;
+use Readonly;
+
+use Perl::Critic::Utils qw< :characters >;
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 METHODS
+
+=over
+
+=item C<file_name()>
+
+Returns the name of the file that the problem was found with, if available.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/OptionsProcessor.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::OptionsProcessor;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw(-no_match_vars);
+
+use Perl::Critic::Exception::AggregateConfiguration;
+use Perl::Critic::Exception::Configuration::Option::Global::ExtraParameter;
+use Perl::Critic::Utils qw<
+ :booleans :characters :severities :data_conversion $DEFAULT_VERBOSITY
+>;
+use Perl::Critic::Utils::Constants qw< $PROFILE_STRICTNESS_DEFAULT >;
+use Perl::Critic::Utils::DataConversion qw< dor >;
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 ) ];
+
+ # 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->{_color} = dor(delete $args{color}, dor(delete $args{colour}, $TRUE));
+
+ # 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 criticism_fatal {
+ my ($self) = @_;
+ return $self->{_criticism_fatal};
+}
+
+#-----------------------------------------------------------------------------
+
+sub force {
+ my ($self) = @_;
+ return $self->{_force};
+}
+
+#-----------------------------------------------------------------------------
+
+sub top {
+ my ($self) = @_;
+ return $self->{_top};
+}
+
+
+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<Perl::Critic::Config> object. There are no
+user-serviceable parts here.
+
+=head1 CONSTRUCTOR
+
+=over 8
+
+=item C< new( %DEFAULT_PARAMS ) >
+
+Returns a reference to a new C<Perl::Critic::OptionsProcessor> 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<Perl::Critic::UserProfile>, which
+passes in the global values from a F<.perlcriticrc> file. This object
+contains no information for individual Policies.
+
+=back
+
+=head1 METHODS
+
+=over 8
+
+=item C< exclude() >
+
+Returns a reference to a list of the default exclusion patterns. If
+there are no default exclusion patterns, then the list will be empty.
+
+=item C< force() >
+
+Returns the default value of the C<force> 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<only> flag (Either 1 or 0).
+
+=item C< profile_strictness() >
+
+Returns the default value of C<profile_strictness> as an unvalidated
+string.
+
+=item C< single_policy() >
+
+Returns the default C<single-policy> pattern. (As a string.)
+
+=item C< severity() >
+
+Returns the default C<severity> setting. (1..5).
+
+=item C< theme() >
+
+Returns the default C<theme> setting. (As a string).
+
+=item C< top() >
+
+Returns the default C<top> setting. (Either 0 or a positive integer).
+
+=item C< verbose() >
+
+Returns the default C<verbose> setting. (Either a number or format
+string).
+
+=item C< color() >
+
+Returns the default C<color> setting. (Either 1 or 0).
+
+=item C< criticism_fatal() >
+
+Returns the default C<criticism-fatal> setting (Either 1 or 0).
+
+=back
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Config>, L<Perl::Critic::UserProfile>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw< -no_match_vars >;
+use Readonly;
+
+use File::Spec ();
+use String::Format qw< stringf >;
+
+use overload ( q<""> => 'to_string', cmp => '_compare' );
+
+use Perl::Critic::Utils qw<
+ :characters
+ :booleans
+ :severities
+ :data_conversion
+ interpolate
+ is_integer
+ policy_long_name
+ policy_short_name
+ severity_to_number
+>;
+use Perl::Critic::Utils::DataConversion qw< dor >;
+use Perl::Critic::Utils::POD qw<
+ get_module_abstract_for_module
+ get_raw_module_abstract_for_module
+>;
+use Perl::Critic::Exception::AggregateConfiguration;
+use Perl::Critic::Exception::Configuration;
+use Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter;
+use Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue;
+use Perl::Critic::Exception::Fatal::PolicyDefinition
+ qw< throw_policy_definition >;
+use Perl::Critic::PolicyConfig qw<>;
+use Perl::Critic::PolicyParameter qw<>;
+use Perl::Critic::Violation qw<>;
+
+use Exception::Class; # this must come after "use P::C::Exception::*"
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $NO_LIMIT => 'no_limit';
+
+#-----------------------------------------------------------------------------
+
+my $FORMAT = "%p\n"; #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) {
+ $self->_validate_config_keys($errors, $config_object);
+ }
+
+ if ( $errors->has_exceptions() ) {
+ $errors->rethrow();
+ }
+
+ return $self;
+}
+
+#-----------------------------------------------------------------------------
+
+sub initialize_if_enabled {
+ return $TRUE;
+}
+
+#-----------------------------------------------------------------------------
+
+sub _validate_config_keys {
+ my ( $self, $errors, $config ) = @_;
+
+ for my $offered_param ( $config->get_parameter_names() ) {
+ $errors->add_exception(
+ Perl::Critic::Exception::Configuration::Option::Policy::ExtraParameter->new(
+ policy => $self->get_short_name(),
+ option_name => $offered_param,
+ source => undef,
+ )
+ );
+ }
+
+ return;
+}
+
+#-----------------------------------------------------------------------------
+
+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 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) = @_;
+ return sort @{ $self->{_themes} } if defined $self->{_themes};
+ return sort $self->default_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($FORMAT, %fspec);
+}
+
+sub _format_parameters {
+ my ($self, $format) = @_;
+
+ return $EMPTY if not $self->parameter_metadata_available();
+
+ my $separator;
+ if ($format) {
+ $separator = $EMPTY;
+ } else {
+ $separator = $SPACE;
+ $format = '%n';
+ }
+
+ return
+ join
+ $separator,
+ map { $_->to_formatted_string($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.';
+}
+
+sub _get_source_file {
+ my ($self) = @_;
+
+ my $relative_path =
+ File::Spec->catfile( split m/::/xms, ref $self ) . '.pm';
+
+ return $INC{$relative_path};
+}
+
+
+#-----------------------------------------------------------------------------
+# 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<cmp> 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<Perl::Critic> engine, your implementation must behave as described
+below. For a detailed explanation on how to make new Policy modules,
+please see the L<Perl::Critic::DEVELOPER> document included in this
+distribution.
+
+
+=head1 METHODS
+
+=over
+
+=item C<< new(key1 => value1, key2 => value2 ... ) >>
+
+Returns a reference to a new subclass of Perl::Critic::Policy. If your
+Policy requires any special arguments, they will be passed in here as
+key-value pairs. Users of L<perlcritic> can specify these in their
+config file. Unless you override the C<new> method, the default
+method simply returns a reference to an empty hash that has been
+blessed into your subclass. However, you really should not override
+this; override C<initialize_if_enabled()> instead.
+
+This constructor is always called regardless of whether the user has
+enabled this Policy or not.
+
+
+=item C<< initialize_if_enabled( { key1 => value1, key2 => value2 ... } ) >>
+
+This receives the same parameters as C<new()>, but as a reference to a
+hash, 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< violates( $element, $document ) >
+
+Given a L<PPI::Element> and a L<PPI::Document>, returns one or more
+L<Perl::Critic::Violation> 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<croak> with an
+error message and let the caller decide how to handle it.
+
+C<violates()> 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<must> override this method.
+
+
+=item C< violation( $description, $explanation, $element ) >
+
+Returns a reference to a new C<Perl::Critic::Violation> 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<PPI> element that caused
+the violation.
+
+These are the same as the constructor to L<Perl::Critic::Violation>,
+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<Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue>
+for this Policy.
+
+
+=item C< throw_parameter_value_exception( $option_name, $option_value, $source, $message_suffix ) >
+
+Create and throw a
+L<Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue>.
+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< applies_to() >
+
+Returns a list of the names of PPI classes that this Policy cares
+about. By default, the result is C<PPI::Element>. 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<set_maximum_violations_per_document()> has not been invoked, then
+L<default_maximum_violations_per_document()> 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<Perl::Critic::Utils> 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<set_severity>, then the
+C<default_severity> is returned. See the C<$SEVERITY> constants in
+L<Perl::Critic::Utils> 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<default_severity>. See the C<$SEVERITY> constants in
+L<Perl::Critic::Utils> 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<Perl::Critic::PolicyParameter>.
+
+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<parameter_metadata_available()>.
+
+
+=item C< get_parameter( $parameter_name ) >
+
+Returns the L<Perl::Critic::PolicyParameter> with the specified name.
+
+
+=item C<set_format( $FORMAT )>
+
+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<get_format()>
+
+Class method. Returns the current format for all Policy objects when
+they are evaluated in string context.
+
+
+=item C<to_string()>
+
+Returns a string representation of the policy. The content of the
+string depends on the current value of the C<$FORMAT> package
+variable. See L<"OVERLOADS"> for the details.
+
+
+=back
+
+
+=head1 DOCUMENTATION
+
+When your Policy module first C<use>s L<Perl::Critic::Violation>, 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. The format depends
+on the current value of the C<$FORMAT> package variable.
+
+Formats are a combination of literal and escape characters similar to
+the way C<sprintf> works. If you want to know the specific formatting
+capabilities, look at L<String::Format>. Valid escape characters are:
+
+
+=over
+
+=item C<%P>
+
+Name of the Policy module.
+
+
+=item C<%p>
+
+Name of the Policy without the C<Perl::Critic::Policy::> prefix.
+
+
+=item C<%a>
+
+The policy abstract.
+
+
+=item C<%O>
+
+List of supported policy parameters. Takes an option of a format
+string for L<Perl::Critic::PolicyParameter/"to_formatted_string">.
+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<parameter_metadata_available()> 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 <thaljef@cpan.org>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitBooleanGrep.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::BuiltinFunctions::ProhibitBooleanGrep;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification hashify };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 ) }
+sub applies_to { return 'PPI::Token::Word' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+
+ return if $elem 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<List::MoreUtils::any> instead of C<grep> in boolean context.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Using C<grep> 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<grep> still checks all of the rest of the elements needlessly.
+Instead, a better solution is to use the C<any> function from
+L<List::MoreUtils>, 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 <cdolan@cpan.org>
+
+=head1 CREDITS
+
+Initial development of this policy was supported by a grant from the Perl
+Foundation.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitComplexMappings.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::BuiltinFunctions::ProhibitComplexMappings;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 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<Perl::Critic> 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 <cdolan@cpan.org>
+
+=head1 CREDITS
+
+Initial development of this policy was supported by a grant from the Perl Foundation.
+
+=head1 COPYRIGHT
+
+Copyright (C) 2007 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitLvalueSubstr.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::BuiltinFunctions::ProhibitLvalueSubstr;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Lvalue form of "substr" used};
+Readonly::Scalar my $EXPL => [ 165 ];
+
+#-----------------------------------------------------------------------------
+
+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 violates {
+ my ($self, $elem, undef) = @_;
+
+ return if $elem ne 'substr';
+ return if ! is_function_call($elem);
+
+ my $sib = $elem;
+ while ($sib = $sib->snext_sibling()) {
+ if ( $sib->isa( 'PPI::Token::Operator') && $sib eq q{=} ) {
+ return $self->violation( $DESC, $EXPL, $sib );
+ }
+ }
+ return; #ok!
+}
+
+1;
+
+#-----------------------------------------------------------------------------
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::BuiltinFunctions::ProhibitLvalueSubstr - Use 4-argument C<substr> instead of writing C<substr($foo, 2, 6) = $bar>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Conway discourages the use of C<substr()> as an lvalue, instead
+recommending that the 4-argument version of C<substr()> be used instead.
+
+ substr($something, 1, 2) = $newvalue; # not ok
+ substr($something, 1, 2, $newvalue); # ok
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 AUTHOR
+
+Graham TerMarsch <graham@howlingfrog.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2005-2007 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitReverseSortBlock.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::BuiltinFunctions::ProhibitReverseSortBlock;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Forbid $b before $a in sort blocks}; ## no critic (Interpolation)
+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 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
+ my $sev = $self->get_severity();
+ return $self->violation( $DESC, $EXPL, $elem, $sev );
+ }
+ }
+ }
+ }
+ 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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Conway says that it is much clearer to use C<reverse> than to flip C<$a> and
+C<$b> around in a C<sort> block. He also suggests that, in newer perls,
+C<reverse> is specifically looked for and optimized, and in the case of a
+simple reversed string C<sort>, using C<reverse> with a C<sort> 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 <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2006 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitSleepViaSelect.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::BuiltinFunctions::ProhibitSleepViaSelect;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification :ppi };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{"select" used to emulate "sleep"};
+Readonly::Scalar my $EXPL => [168];
+Readonly::Scalar my $UNDEFS_IN_SLEEP_SELECT => 3;
+
+#-----------------------------------------------------------------------------
+
+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 ne 'select');
+ return if ! is_function_call($elem);
+
+ if (
+ $UNDEFS_IN_SLEEP_SELECT
+ == grep { $_->[0] eq 'undef' } parse_arg_list($elem)
+ ) {
+ return $self->violation( $DESC, $EXPL, $elem );
+ }
+ return; #ok!
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::BuiltinFunctions::ProhibitSleepViaSelect - Use L<Time::HiRes> instead of something like C<select(undef, undef, undef, .05)>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Conway discourages the use of C<select()> for performing non-integer
+sleeps. Although documented in L<perlfunc>, it's something that
+generally requires the reader to read C<perldoc -f select> to figure
+out what it should be doing. Instead, Conway recommends that you use
+the C<Time::HiRes> 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<Time::HiRes>.
+
+=head1 AUTHOR
+
+Graham TerMarsch <graham@howlingfrog.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2005-2007 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringyEval.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval;
+
+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.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Expression form of "eval"};
+Readonly::Scalar my $EXPL => [ 161 ];
+
+#-----------------------------------------------------------------------------
+
+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 ne 'eval';
+ 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::ProhibitStringyEval - Write C<eval { my $foo; bar($foo) }> instead of C<eval "my $foo; bar($foo);">.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+The string form of C<eval> 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
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::ControlStrucutres::RequireBlockGrep>
+
+L<Perl::Critic::Policy::ControlStrucutres::RequireBlockMap>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitStringySplit.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::BuiltinFunctions::ProhibitStringySplit;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :characters :severities :classification :ppi };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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) }
+sub applies_to { return 'PPI::Token::Word' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+
+ return if $elem 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<split /-/, $string> instead of C<split '-', $string>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+The C<split> 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<split> 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<Perl::Critic::Policy::ControlStrucutres::RequireBlockGrep>
+
+L<Perl::Critic::Policy::ControlStrucutres::RequireBlockMap>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalCan.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalCan;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 ) }
+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<UNIVERSAL::can($foo, $name)>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<undef> or an unblessed scalar. However, the
+functional form makes it impossible for packages to override C<can()>,
+a technique which is crucial for implementing mock objects and some
+facades.
+
+See the CPAN module L<UNIVERSAL::can> for a more thorough discussion
+of this topic.
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa>
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitUniversalIsa.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalIsa;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 ) }
+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<UNIVERSAL::isa($foo, $pkg)>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<UNIVERSAL::isa> 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<undef> or an unblessed scalar. However, the
+functional form makes it impossible for packages to override C<isa()>,
+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<UNIVERSAL::isa> for an incendiary discussion of
+this topic.
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::BuiltinFunctions::ProhibitUniversalCan>
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidGrep.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidGrep;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification is_in_void_context };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 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<grep> in void contexts.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+C<map> and C<grep> are intended to be pure functions, not mutators.
+If you want to iterate with side-effects, then you should use a proper
+C<for> or C<foreach> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/BuiltinFunctions/ProhibitVoidMap.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::BuiltinFunctions::ProhibitVoidMap;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification is_in_void_context };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 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<map> in void contexts.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+C<map> and C<grep> are intended to be pure functions, not mutators.
+If you want to iterate with side-effects, then you should use a proper
+C<for> or C<foreach> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockGrep.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep;
+
+# DEVELOPER NOTE: this module is used as an example in DEVELOPER.pod.
+# If you make changes in here, please reflect those changes in the
+# examples.
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification :ppi };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 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<grep { $_ =~ /$pattern/ } @list> instead of C<grep /$pattern/, @list>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+The expression forms of C<grep> and C<map> 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<Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval>
+
+L<Perl::Critic::Policy::BuiltinFunctions::RequireBlockMap>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/BuiltinFunctions/RequireBlockMap.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::BuiltinFunctions::RequireBlockMap;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification :ppi };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<map { $_ =~ /$pattern/ } @list> instead of C<map /$pattern/, @list>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+The expression forms of C<grep> and C<map> 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<Perl::Critic::Policy::BuiltinFunctions::ProhibitStringyEval>
+
+L<Perl::Critic::Policy::BuiltinFunctions::RequireBlockGrep>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/BuiltinFunctions/RequireGlobFunction.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::BuiltinFunctions::RequireGlobFunction;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $GLOB_RX => qr{ [*?] }mx;
+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<glob q{*}> instead of <*>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<glob()> 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 <graham@howlingfrog.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2005-2007 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/BuiltinFunctions/RequireSimpleSortBlock.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::BuiltinFunctions::RequireSimpleSortBlock;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 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<Perl::Critic> 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<N log N> times
+instead of just C<N> 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 <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2006 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ClassHierarchies/ProhibitAutoloading.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ClassHierarchies::ProhibitAutoloading;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Declaring a subroutine with the name C<"AUTOLOAD"> will violate this
+Policy. The C<AUTOLOAD> 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<AUTOLOAD> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2006 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ClassHierarchies/ProhibitExplicitISA.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{@ISA used instead of "use base"}; ##no critic; #for @ in string
+Readonly::Scalar my $EXPL => [ 360 ];
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters { return () }
+sub default_severity { return $SEVERITY_MEDIUM }
+sub default_themes { return qw( core maintenance pbp ) }
+sub applies_to { return 'PPI::Token::Symbol' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ($self, $elem, undef) = @_;
+
+ if( $elem eq q{@ISA} ) { ##no critic; #for @ in string
+ return $self->violation( $DESC, $EXPL, $elem );
+ }
+ return; #ok!
+}
+
+1;
+
+#-----------------------------------------------------------------------------
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::ClassHierarchies::ProhibitExplicitISA - Employ C<use base> instead of C<@ISA>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Conway recommends employing C<use base qw(Foo)> instead of the usual
+C<our @ISA = qw(Foo)> because the former happens at compile time and
+the latter at runtime. The C<base> pragma also automatically loads
+C<Foo> for you so you save a line of easily-forgotten code.
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2006 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ClassHierarchies/ProhibitOneArgBless.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ClassHierarchies::ProhibitOneArgBless;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :booleans :severities :classification :ppi };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 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<bless {}, $class;> instead of just C<bless {};>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Always use the two-argument form of C<bless> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2005-2007 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/CodeLayout/ProhibitHardTabs.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::CodeLayout::ProhibitHardTabs;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :booleans :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Hard tabs used};
+Readonly::Scalar my $EXPL => [ 20 ];
+
+my $DEFAULT_ALLOW_LEADING_TABS = $TRUE;
+
+#-----------------------------------------------------------------------------
+
+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 ) }
+sub applies_to { return 'PPI::Token' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+ $elem =~ m{ \t }mx || return;
+
+ # The __DATA__ element is exempt
+ return if $elem->parent->isa('PPI::Statement::Data');
+
+ # Permit leading tabs, if allowed
+ return if $self->_allow_leading_tabs() && $elem->location->[1] == 1;
+
+ # Must be a violation...
+ return $self->violation( $DESC, $EXPL, $elem );
+}
+
+#-----------------------------------------------------------------------------
+
+sub _allow_leading_tabs {
+ my ( $self ) = @_;
+
+ return $self->{_allow_leading_tabs};
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=head1 NAME
+
+Perl::Critic::Policy::CodeLayout::ProhibitHardTabs - Use spaces instead of tabs.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<Perl::Tidy>
+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
+
+Tabs in a leading position are allowed, but if you want to forbid all tabs
+everywhere, put 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/CodeLayout/ProhibitParensWithBuiltins.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{
+ :booleans :severities :data_conversion :classification :language
+};
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Array my @ALLOW => qw( my our local return );
+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_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_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 = <STDIN> );
+
+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;
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=for stopwords disambiguates
+
+=head1 NAME
+
+Perl::Critic::Policy::CodeLayout::ProhibitParensWithBuiltins - Write C<open $handle, $path> instead of C<open($handle, $path)>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<my>, C<local>, and C<our> 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<unnecessary> 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 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/CodeLayout/ProhibitQuotedWordLists.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::CodeLayout::ProhibitQuotedWordLists;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :characters :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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,
+ },
+ );
+}
+
+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 $sib = $elem->sprevious_sibling();
+ return if !$sib;
+ return if $sib->isa('PPI::Token::Word');
+ return if $sib->isa('PPI::Token::Symbol');
+
+ #Get the list elements
+ my $expr = $elem->schild(0);
+ return if !$expr;
+ my @children = $expr->schildren();
+ return if !@children;
+
+ my $count = 0;
+ for my $child ( @children ) {
+ next if $child->isa('PPI::Token::Operator') && $child eq $COMMA;
+
+ #All elements must be literal strings,
+ #of non-zero length, with no whitespace
+
+ return if ! _is_literal($child);
+
+ my $string = $child->string();
+ return if $string =~ m{ \s }mx;
+ return if $string eq $EMPTY;
+ $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<qw(foo bar baz)> instead of C<('foo', 'bar', 'baz')>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Conway doesn't mention this, but I think C<qw()> is an underused
+feature of Perl. Whenever you need to declare a list of one-word
+literals, the C<qw()> 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
+
+=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<min_elements> 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.
+
+=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<qw()>. 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<RequireQuotedWords> which seemed a
+little counter-intuitive. If you get lots of "Cannot load policy
+module" errors, then you probably need to change C<RequireQuotedWords>
+to C<ProhibitQuotedWordLists> in your F<.perlcriticrc> file.
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. All rights reserved.
+
+=head1 COPYRIGHT
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself. The full text of this license
+can be found in the LICENSE file included with this module.
+
+=cut
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/CodeLayout/ProhibitTrailingWhitespace.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::CodeLayout::ProhibitTrailingWhitespace;
+
+use 5.006001;
+use strict;
+use warnings;
+use English qw(-no_match_vars);
+use Readonly;
+
+use charnames qw{};
+
+use PPI::Token::Whitespace;
+use Perl::Critic::Utils qw{ :characters :severities };
+
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 ) = @_;
+
+ # There is at most one linefeed per Whitespace token, and it will always
+ # be the last character, if present. If the code has two consecutive
+ # blank lines, PPI will produce two Whitespace tokens, each consisting
+ # of a single linefeed. Thus, any Whitespace token consisting of a single
+ # character cannot contain trailing whitespace.
+ my $content = $token->content();
+ return if length($content) < 2;
+ return if qq{\n} ne chop $content;
+
+ my $description = q{Found "};
+ $description .= join $EMPTY, map { _escape($_) } split $EMPTY, $content;
+ $description .= q{" at the end of the line};
+
+ return $self->violation( $description, $EXPL, $token );
+}
+
+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<viacode> function, and newer versions of the module are
+ # not distributed separately from perl itself So if the C<viacode> 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<Perl::Critic> 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<< <perl@galumph.com> >>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/CodeLayout/RequireConsistentNewlines.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::CodeLayout::RequireConsistentNewlines;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use PPI::Token::Whitespace;
+use English qw(-no_match_vars);
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+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 );
+ $token->{_location} = [$line, $col, $col];
+ 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 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=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 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2006 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/CodeLayout/RequireTidyCode.pm $
+# $Date: 2008-07-04 10:33:13 -0500 (Fri, 04 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2490 $
+##############################################################################
+
+package Perl::Critic::Policy::CodeLayout::RequireTidyCode;
+
+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';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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) = @_;
+
+ # workaround for Test::Without::Module v0.11
+ local $EVAL_ERROR = undef;
+
+ # If Perl::Tidy is missing, bow out.
+ eval { require Perl::Tidy; } or return $FALSE;
+
+ #Set configuration if defined
+ if (defined $self->{_perltidyrc} && $self->{_perltidyrc} eq $EMPTY) {
+ $self->{_perltidyrc} = \$EMPTY;
+ }
+
+ 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}mx;
+
+ # 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 = qr<eval [ ] 'exec [ ] [^\015\012]* [ ] \$0 [ ] \${1[+]"\$@"}'
+ [ \t]*[\012\015]+ [ \t]* if [^\015\012]+ [\015\012]+ >xms;
+ $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.
+ local @ARGV = qw(-nst -nse); ## no critic
+
+ # Trap Perl::Tidy errors, just in case it dies
+ my $eval_worked = eval {
+ Perl::Tidy::perltidy(
+ source => \$source,
+ destination => \$dest,
+ stderr => \$stderr,
+ 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
+
+=head1 NAME
+
+Perl::Critic::Policy::CodeLayout::RequireTidyCode - Must run code through L<perltidy>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<Perl::Tidy>. 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<perltidyrc> 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<perltidyrc> 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 NOTES
+
+L<Perl::Tidy> is not included in the Perl::Critic distribution. The
+latest version of Perl::Tidy can be downloaded from CPAN. If
+Perl::Tidy is not installed, this policy is silently ignored.
+
+=head1 SEE ALSO
+
+L<Perl::Tidy>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/CodeLayout/RequireTrailingCommas.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::CodeLayout::RequireTrailingCommas;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :characters :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 }mx || return;
+
+ # Is it an assignment of some kind?
+ my $sib = $elem->sprevious_sibling();
+ return if !$sib;
+ $sib->isa('PPI::Token::Operator') && $sib =~ m{ = }mx || 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<Perl::Critic> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ControlStructures/ProhibitCStyleForLoops.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ControlStructures::ProhibitCStyleForLoops;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :characters :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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::ForLoop' }
+
+#-----------------------------------------------------------------------------
+
+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<for(0..20)> instead of C<for($i=0; $i<=20; $i++)>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+The 3-part C<for> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ControlStructures/ProhibitCascadingIfElse.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ControlStructures::ProhibitCascadingIfElse;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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') && $_ 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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Long C<if-elsif> 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. See L<Switch> for another approach.
+
+ 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<elsif> alternatives
+to allow. The default is 2. This can be specified via a C<max_elsif> item in
+the F<.perlcriticrc> file:
+
+ [ControlStructures::ProhibitCascadingIfElse]
+ max_elsif = 3
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ControlStructures/ProhibitDeepNests.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ControlStructures::ProhibitDeepNests;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> 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<max_nests> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ControlStructures/ProhibitLabelsWithSpecialBlockNames.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ControlStructures::ProhibitLabelsWithSpecialBlockNames;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities hashify };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+Readonly::Hash my %SPECIAL_BLOCK_NAMES =>
+ hashify( qw< BEGIN END INIT CHECK UNITCHECK > );
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q<Special block name used as label.>;
+Readonly::Scalar my $EXPL =>
+ q<Use a label that cannot be confused with BEGIN, END, CHECK, INIT, or UNITCHECK blocks.>;
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+When using one of the special Perl blocks C<BEGIN>, C<END>, C<CHECK>,
+C<INIT>, and C<UNITCHECK>, 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
+
+L<Perl Buzz article|http://perlbuzz.com/2008/05/colons-invalidate-your-begin-and-end-blocks.html>
+on this issue.
+
+
+=head1 ACKNOWLEDGMENT
+
+Randy Lauen for identifying the problem.
+
+
+=head1 AUTHOR
+
+Mike O'Regan
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ControlStructures/ProhibitMutatingListFunctions.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ControlStructures::ProhibitMutatingListFunctions;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use List::MoreUtils qw( none any );
+
+use Perl::Critic::Utils qw{
+ :booleans :characters :severities :data_conversion :classification :ppi
+};
+
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 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) }
+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 _has_topic_side_effect( $first_arg );
+
+ # Must be a violation
+ return $self->violation( $DESC, $EXPL, $elem );
+}
+
+#-----------------------------------------------------------------------------
+
+sub _has_topic_side_effect {
+ my $node = shift;
+
+ # 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 _is_topic_mutating_regex( $elem );
+ 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 $elem = shift;
+ return if ! ( $elem->isa('PPI::Token::Regexp::Substitute')
+ || $elem->isa('PPI::Token::Regexp::Transliterate') );
+
+ # 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 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 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 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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+C<map>, C<grep> 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<map> or C<grep> 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<values(%ENV)>! Instead authors
+should restrict in-place array modification to C<for(@array) { ... }>
+constructs instead, or use C<List::MoreUtils::apply()>.
+
+=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<for (@array) { ... }> or
+C<List::MoreUtils::apply()>.
+
+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<sort> and the like. That's beyond the
+scope of this policy.
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+Michael Wolf <MichaelRWolf@att.net>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2006 Chris Dolan. 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
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
+
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions;
+
+use 5.006001;
+use strict;
+use warnings;
+use English qw(-no_match_vars);
+use Readonly;
+
+use Perl::Critic::Utils qw< :characters :severities :classification hashify >;
+
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $EXPL => [99];
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters { return qw< > }
+sub default_severity { return $SEVERITY_MEDIUM }
+sub default_themes { return qw( core maintenance ) }
+sub applies_to { return 'PPI::Token::Word' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $token, undef ) = @_;
+
+ return if $token ne 'until' && $token 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 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<Found "$operator" in condition for an "$control_structure">,
+ $EXPL,
+ $control_structure,
+ );
+}
+
+1;
+
+#-----------------------------------------------------------------------------
+
+__END__
+
+=pod
+
+=for stopwords
+
+=head1 NAME
+
+Perl::Critic::Policy::ControlStructures::ProhibitNegativeExpressionsInUnlessAndUntilConditions - Don't use operators like C<not>, C<!~>, and C<le> within C<until> and C<unless>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<unless> and C<until> are both negative
+constructs, so any negative (e.g. C<!~>) or reversible operators (e.g.
+C<le>) included in their conditional expressions are double negations.
+Conway considers the following operators to be difficult to understand
+within C<unless> and C<until>:
+
+ ! not
+ !~ ne !=
+ < > <= >= <=>
+ lt gt le ge cmp
+
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::ControlStructures::ProhibitUnlessBlocks>
+
+=head1 AUTHOR
+
+Elliot Shank C<< <perl@galumph.com> >>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ControlStructures/ProhibitPostfixControls.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ControlStructures::ProhibitPostfixControls;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :characters :severities :data_conversion :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Hash my %PAGES_OF => (
+ if => [ 93, 94 ],
+ unless => [ 96, 97 ],
+ until => [ 96, 97 ],
+ for => [ 96 ],
+ foreach => [ 96 ],
+ while => [ 96 ],
+);
+
+# These functions can have postfix 'if'.
+my @DEFAULT_FLOW_CONTROL = qw( warn die carp croak cluck confess goto exit );
+
+#-----------------------------------------------------------------------------
+
+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};
+
+ # Skip Compound variety (these are good)
+ my $stmnt = $elem->statement();
+ return if !$stmnt;
+ return if $stmnt->isa('PPI::Statement::Compound');
+
+ # Handle special cases
+ if ( $elem eq 'if' ) {
+ # 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) };
+ }
+
+ # If we get here, it must be postfix.
+ my $desc = qq{Postfix control "$elem" used};
+ return $self->violation( $desc, $expl, $elem );
+}
+
+1;
+
+__END__
+
+=pod
+
+=for stopwords flowcontrol
+
+=head1 NAME
+
+Perl::Critic::Policy::ControlStructures::ProhibitPostfixControls - Write C<if($condition){ do_something() }> instead of C<do_something() if $condition>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Conway discourages using postfix control structures (C<if>, C<for>,
+C<unless>, C<until>, C<while>) because they hide control flow. The
+C<unless> and C<until> controls are particularly evil because they
+lead to double-negatives that are hard to comprehend. The only
+tolerable usage of a postfix C<if> is when it follows a loop break
+such as C<last>, C<next>, C<redo>, or C<continue>.
+
+ 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
+ }
+
+=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<if>, C<for>, C<unless>, C<until>, and/or C<while>. 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
+
+=head1 NOTES
+
+The C<die>, C<croak>, and C<confess> functions are frequently used as
+flow-controls just like C<next> or C<last>. So this Policy does
+permit you to use a postfix C<if> when the statement begins with one
+of those functions. It is also pretty common to use C<warn>, C<carp>,
+and C<cluck> with a postfix C<if>, so those are allowed too.
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ControlStructures/ProhibitUnlessBlocks.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ControlStructures::ProhibitUnlessBlocks;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<if(! $condition)> instead of C<unless($condition)>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Conway discourages using C<unless> because it leads to double-negatives
+that are hard to understand. Instead, reverse the logic and use C<if>.
+
+ 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<unless>. For the postfix
+variety, see C<ProhibitPostfixControls>.
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::ControlStructures::ProhibitPostfixControls>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ControlStructures/ProhibitUnreachableCode.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :data_conversion :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+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 ) }
+sub applies_to { return 'PPI::Token::Word' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+ return if ! is_function_call($elem);
+
+ my $stmnt = $elem->statement();
+ return if !$stmnt;
+ return if ( !exists $TERMINALS{$elem} ) &&
+ ( !$stmnt->isa('PPI::Statement::Break') );
+
+ # Scan the enclosing statement for conditional keywords or logical
+ # operators. If any are found, then this the folowing statements
+ # could _potentially_ be executed, so this policy is satisfied.
+
+ # NOTE: When the first operand in an boolean expression is
+ # C<croak> or C<die>, etc., the second operand is technically
+ # unreachable. But this policy doesn't catch that situation.
+
+ for my $child ( $stmnt->schildren() ) {
+ return if $child->isa('PPI::Token::Operator') && exists $OPERATORS{$child};
+ return if $child->isa('PPI::Token::Word') && exists $CONDITIONALS{$child};
+ }
+
+ # 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<goto>. Subroutine
+ # declarations are also exempt for the same reason. "use" and
+ # "our" statements are exempt because they happen at compile time.
+
+ my @viols = ();
+ while ( $stmnt = $stmnt->snext_sibling() ) {
+ my @children = $stmnt->schildren();
+ last if @children && $children[0]->isa('PPI::Token::Label');
+ next if $stmnt->isa('PPI::Statement::Sub');
+ next if $stmnt->isa('PPI::Statement::End');
+ next if $stmnt->isa('PPI::Statement::Data');
+
+ next if $stmnt->isa('PPI::Statement::Include') &&
+ $stmnt->type() ne 'require';
+
+ next if $stmnt->isa('PPI::Statement::Variable') &&
+ $stmnt->type() eq 'our';
+
+ push @viols, $self->violation( $DESC, $EXPL, $stmnt );
+ }
+
+ return @viols;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::ControlStructures::ProhibitUnreachableCode - Don't write code after an unconditional C<die, exit, or next>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+This policy prohibits code following a statement which unconditionally alters
+the program flow. This includes calls to C<exit>, C<die>, C<return>, C<next>,
+C<last> and C<goto>. Due to common usage, C<croak> and C<confess> from
+L<Carp> are also included.
+
+Code is reachable if any of the following conditions are true:
+
+=over 4
+
+=item * Flow-altering statement has a conditional attached to it
+
+=item * Statement is on the right side of an operator C<&&>, C<||>, C<//>, C<and>, C<or>, or C<err>.
+
+=item * Code is prefixed with a label (can potentially be reached via C<goto>)
+
+=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<Perl::Critic::Policy::ControlStructures::ProhibitPostfixControls>
+
+=head1 AUTHOR
+
+Peter Guzis <pguzis@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ControlStructures/ProhibitUntilBlocks.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ControlStructures::ProhibitUntilBlocks;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<while(! $condition)> instead of C<until($condition)>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Conway discourages using C<until> because it leads to double-negatives
+that are hard to understand. Instead, reverse the logic and use C<while>.
+
+ 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<until>. For the postfix
+variety, see C<ProhibitPostfixControls>.
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::ControlStructures::ProhibitPostfixControls>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Documentation/PodSpelling.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Documentation::PodSpelling;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw(-no_match_vars);
+use Readonly;
+
+use File::Spec;
+use File::Temp;
+use List::MoreUtils qw(uniq);
+
+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.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $POD_RX => qr{\A = (?: for|begin|end ) }mx;
+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',
+ },
+ );
+}
+
+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;
+ require Text::ParseWords;
+ require Pod::Spell;
+ require IO::String;
+ }
+ 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
+
+ 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 _set_spell_command {
+ my ( $self, $spell_command ) = @_;
+
+ $self->{_spell_command} = $spell_command;
+
+ return;
+}
+
+#-----------------------------------------------------------------------------
+
+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 _run_spell_command {
+ my ($self, $code) = @_;
+
+ my $infh = IO::String->new( $code );
+
+ my $outfh = File::Temp->new()
+ or throw_generic "Unable to create tempfile: $OS_ERROR";
+
+ 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 ];
+}
+
+#-----------------------------------------------------------------------------
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=for stopwords Hmm stopwords
+
+=head1 NAME
+
+Perl::Critic::Policy::Documentation::PodSpelling - Check your spelling.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<Test::Spelling>, 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 -- you don't have Pod::Spell installed or
+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<Pod::Spell>. 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
+
+The default spell command is C<aspell list> and it is interpreted as a
+shell command. We parse the individual arguments via
+L<Text::ParseWords> 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<File::Which> to convert it to
+an absolute path via the C<PATH> 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.
+
+=head1 NOTES
+
+L<Pod::Spell> is not included with Perl::Critic, nor is a spell
+checking program.
+
+=head1 CREDITS
+
+Initial development of this policy was supported by a grant from the Perl Foundation.
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Documentation/RequirePackageMatchesPodName.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Documentation::RequirePackageMatchesPodName;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $PKG_RX => qr{ [[:alpha:]](?:[\w:\']*\w)? }mx;
+Readonly::Scalar my $DESC => q{Pod NAME 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 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 ($pod_pkg) = $content =~ m{\G (\S+) }cgxms;
+
+ if (!$pod_pkg) {
+ return $self->violation( $DESC, q{Empty name declaration}, $elem );
+ }
+
+ # idea: force NAME to match the file name in scripts?
+ return if is_script($doc); # mismatch is normal in program entry points
+
+ # idea: worry about POD escapes?
+ $pod_pkg =~ s{\A [CL]<(.*)>\z}{$1}gxms; # unwrap
+ $pod_pkg =~ s{\'}{::}gxms; # perl4 -> perl5
+
+ my $pkgs = $doc->find('PPI::Statement::Package');
+ # no package statement means no possible match
+ my $pkg = $pkgs ? $pkgs->[0]->namespace : q{};
+ $pkg =~ s{\'}{::}gxms;
+
+ return if $pkg eq $pod_pkg;
+ return $self->violation( $DESC, $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<Perl::Critic> distribution.
+
+=head1 DESCRIPTION
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Documentation/RequirePodAtEnd.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Documentation::RequirePodAtEnd;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use List::Util qw(first);
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $POD_RX => qr{\A = (?: for|begin|end ) }mx;
+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<Perl::Critic> 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 succesful
+
+ =end comments
+
+ sub frobulate { ... }
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Documentation/RequirePodSections.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Documentation::RequirePodSections;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :booleans :characters :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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;
+
+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*/xm).',
+ default_string => $EMPTY,
+ parser => \&_parse_lib_sections,
+ },
+ {
+ name => 'script_sections',
+ description => 'The sections to require for programs (separated by qr/\s* [|] \s*/xm).',
+ 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* }mx, $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 = is_script($doc) ? @{ $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
+ for my $pod ( @{ $pods_ref } ) {
+ for my $found ( $pod =~ m{ ^ =head1 \s+ ( .+? ) \s* $ }gmx ) {
+ #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};
+ push @violations, $self->violation( $desc, $EXPL, $doc );
+ }
+ }
+
+ 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<Perl::Critic> 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<Module::Starter> 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<Perl
+Best Practices> book. Since the book has been published, Conway has
+released L<Module::Starter::PBP>, 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<source> and C<language>.
+
+The C<source> option has two generic values, C<book> and
+C<module_starter_pbp>, and two version-specific values,
+C<book_first_edition> and C<module_starter_pbp_0_0_3>. 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<language> option has a default, unnamed value but also accepts
+values of C<en_AU> and C<en_US>. 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<CONFIGURATION> instead
+of C<CONFIGURATION AND ENVIRONMENT>, the removal of C<VERSION>, and
+the addition of C<EXIT STATUS>. 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<en_AU> and C<en_US> is in how the
+word "licence" is spelled.
+
+The sections required for modules and programs can be independently
+customized, overriding any values for C<source> and C<language>, by
+giving values for C<script_sections> and C<lib_sections> 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.
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ErrorHandling/RequireCarping.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ErrorHandling::RequireCarping;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{
+ :booleans :characters :severities :classification :data_conversion
+};
+use Perl::Critic::Utils::PPI qw{ is_ppi_expression_or_generic_statement };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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',
+ },
+ );
+}
+
+sub default_severity { return $SEVERITY_MEDIUM }
+sub default_themes { return qw( core pbp maintenance ) }
+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);
+ }
+
+ 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);
+ if (
+ $last_flattened_argument
+ and (
+ $last_flattened_argument->isa('PPI::Token::Quote::Double')
+ or $last_flattened_argument->isa('PPI::Token::Quote::Interpolate')
+ )
+ ) {
+ return $TRUE if $last_flattened_argument =~ m{ [\\] n . \z }xmso;
+ }
+
+ 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<some_function( "foo\n" )> 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
+ };
+
+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::HereDoc
+ 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;
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::ErrorHandling::RequireCarping - Use functions from L<Carp> instead of C<warn> or C<die>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+The C<die> and C<warn> 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<your> code blew up.
+Instead, they want to know where B<their> code invoked the subroutine.
+The L<Carp> 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<die> or C<warn>, 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<Carp> 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
+
+If you give this policy an C<allow_messages_ending_with_newlines>
+option in your F<.perlcriticrc> with a false value, then this policy
+will disallow all uses of C<die> and C<warn>.
+
+ [ErrorHandling::RequireCarping]
+ allow_messages_ending_with_newlines = 0
+
+
+=head1 SEE ALSO
+
+L<Carp::Always>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ErrorHandling/RequireCheckingReturnValueOfEval.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ErrorHandling::RequireCheckingReturnValueOfEval;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+use Scalar::Util qw< refaddr >;
+
+use Perl::Critic::Utils qw< :booleans :characters :severities hashify >;
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => 'Return value of eval not tested.';
+## no critic (RequireInterpolationOfMetachars)
+Readonly::Scalar my $EXPL =>
+ q<You can't depend upon the value of $@/$EVAL_ERROR to tell whether an eval failed.>;
+## use critic
+
+Readonly::Hash my %BOOLEAN_OPERATORS => hashify qw< || && // or and >;
+Readonly::Hash my %POSTFIX_OPERATORS =>
+ hashify qw< for foreach if unless while until >;
+
+#-----------------------------------------------------------------------------
+
+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,
+ );
+
+ if (
+ $following
+ and $following->isa('PPI::Token::Operator')
+ and $BOOLEAN_OPERATORS{ $following->content() }
+ ) {
+ return;
+ }
+
+ 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() eq q<=>;
+ 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,
+ );
+ }
+
+ if ( $parent->isa('PPI::Structure::ForLoop') ) {
+ my @for_loop_components = $parent->schildren();
+
+ return $TRUE if 1 == @for_loop_components;
+ 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 $previous = $elem->sprevious_sibling();
+ while ($previous) {
+ if (
+ $previous->isa('PPI::Token::Word')
+ and $POSTFIX_OPERATORS{ $previous->content() }
+ ) {
+ return $TRUE
+ }
+ $previous = $previous->sprevious_sibling();
+ }
+
+ return;
+}
+
+#-----------------------------------------------------------------------------
+
+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<eval> failed.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+A common idiom in perl for dealing with possible errors is to use
+C<eval> 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<eval> and the C<if> 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<eval> block in C<main> is exited, C<Foo::DESTROY()> will be invoked,
+regardless of whether the C<eval> finished normally or not. If the
+C<eval> in C<main> fails, but the C<eval> in C<Foo::DESTROY()>
+succeeds, then C<$EVAL_ERROR> will be empty by the time that the C<if>
+is executed. Additional issues arise if you depend upon the exact
+contents of C<$EVAL_ERROR> and both C<eval>s fail, because the
+messages from both will be concatenated.
+
+Even if there isn't an C<eval> directly in the C<DESTROY()> method
+code, it may invoke code that does use C<eval> or otherwise affects
+C<$EVAL_ERROR>.
+
+The solution is to ensure that, upon normal exit, an C<eval> 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<defined> function to test the
+result; C<eval> returns an empty string on failure.
+
+"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<http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-06/msg00537.html>.
+
+
+=head1 AUTHOR
+
+Elliot Shank C<< <perl@galumph.com> >>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/InputOutput/ProhibitBacktickOperators.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::InputOutput::ProhibitBacktickOperators;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities is_in_void_context };
+
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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
+
+=head1 NAME
+
+Perl::Critic::Policy::InputOutput::ProhibitBacktickOperators - Discourage stuff like C<@files = `ls $directory`>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<system()> 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<qx{}>.
+
+See L<perlipc> for more discussion on using C<wait()> instead of
+C<$SIG{CHLD} = 'IGNORE'>.
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/InputOutput/ProhibitBarewordFileHandles.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification :ppi };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 ) }
+sub applies_to { return 'PPI::Token::Word' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ($self, $elem, undef) = @_;
+
+ return if $elem 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)$/mx ) ) {
+ return $self->violation( $DESC, $EXPL, $elem );
+ }
+ }
+ return; #ok!
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::InputOutput::ProhibitBarewordFileHandles - Write C<open my $fh, q{<}, $filename;> instead of C<open FH, q{<}, $filename;>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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 C<local>izing 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<IO::Handle> or
+L<IO::File> or L<FileHandle> 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<IO::Handle>
+
+L<IO::File>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2005-2007 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/InputOutput/ProhibitExplicitStdin.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package 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.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Use "<>" or "<ARGV>" or a prompting module instead of "<STDIN>"};
+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 '<STDIN>';
+ return $self->violation( $DESC, $EXPL, $elem );
+}
+
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::InputOutput::ProhibitExplicitStdin - Use "<>" or "<ARGV>" or a prompting module instead of "<STDIN>".
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<STDIN>. This is often written in
+one of the following two equivalent forms:
+
+ while (<ARGV>) {
+ # ... 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<IO::Prompt>.
+
+
+=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 '', <STDIN>;
+
+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 <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/InputOutput/ProhibitInteractiveTest.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::InputOutput::ProhibitInteractiveTest;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 ) }
+sub applies_to { return 'PPI::Token::Operator' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ($self, $elem, $doc) = @_;
+ return if $elem 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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+The C<-t> operator is fragile and complicated. When you are testing
+whether C<STDIN> is interactive, It's much more robust to use
+well-tested CPAN modules like L<IO::Interactive>.
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2006 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/InputOutput/ProhibitJoinedReadline.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::InputOutput::ProhibitJoinedReadline;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+use List::MoreUtils qw(any);
+
+use Perl::Critic::Utils qw{ :severities :classification parse_arg_list };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Use "local $/ = undef" or File::Slurp instead of joined readline}; ##no critic qw(Interpolation)
+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 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<local $/ = undef> or L<File::Slurp> instead of joined readline.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+It's really easy to slurp a whole filehandle in at once with C<join
+q{}, <$fh>>, 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<File::Slurp>, which is even faster.
+
+
+=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 <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/InputOutput/ProhibitOneArgSelect.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::InputOutput::ProhibitOneArgSelect;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification :ppi };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 ) }
+sub applies_to { return 'PPI::Token::Word' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ($self, $elem, undef) = @_;
+
+ return if $elem ne 'select';
+ 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::InputOutput::ProhibitOneArgSelect - Never write C<select($fh)>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Conway discourages the use of a raw C<select()> when setting
+autoflushes. We'll extend that further by simply prohibiting the
+one-argument form of C<select()> entirely; if you really need it you
+should know when/where/why that is. For performing autoflushes,
+Conway recommends the use of C<IO::Handle> 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<IO::Handle>.
+
+=head1 AUTHOR
+
+Graham TerMarsch <graham@howlingfrog.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2005-2007 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/InputOutput/ProhibitReadlineInForLoop.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::InputOutput::ProhibitReadlineInForLoop;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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::Structure::ForLoop) }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+
+ if ( my $rl = $elem->find_first('PPI::Token::QuoteLike::Readline') ) {
+ return $self->violation( $DESC, $EXPL, $rl );
+ }
+
+ 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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Using the readline operator in a C<for> or C<foreach> 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<while> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/InputOutput/ProhibitTwoArgOpen.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::InputOutput::ProhibitTwoArgOpen;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+use version;
+
+use Perl::Critic::Utils qw{ :severities :classification :ppi };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $STDIO_HANDLES_RX => qr/\b STD (?: IN | OUT | ERR \b)/mx;
+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) }
+sub applies_to { return 'PPI::Token::Word' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ($self, $elem, $document) = @_;
+
+ return if $elem 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 $self->violation( $DESC, $EXPL, $elem );
+ }
+
+ return; # ok!
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+The three-argument form of C<open> (introduced in Perl 5.6) prevents
+subtle bugs that occur when the filename starts with funny characters
+like '>' or '<'. The L<IO::File> 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<require 5.005> in it.
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 NOTES
+
+The only time you should use the two-argument form is when you re-open
+STDIN, STDOUT, or STDERR. But for now, this Policy doesn't provide
+that loophole.
+
+=head1 SEE ALSO
+
+L<IO::Handle>
+
+L<IO::File>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2005-2007 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/InputOutput/RequireBracedFileHandleWithPrint.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::InputOutput::RequireBracedFileHandleWithPrint;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification :data_conversion };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Array my @POSTFIX_WORDS => qw( if unless for );
+Readonly::Hash my %POSTFIX_WORDS => hashify( @POSTFIX_WORDS );
+
+Readonly::Scalar my $DESC => q{File handle for "print" 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 ne 'print';
+ 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 \$/mx)
+ || $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<print {$FH} $foo, $bar;> instead of C<print $FH $foo, $bar;>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+The C<print> function has 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<STDOUT>, C<STDERR>, and C<DATA>, you must the C<'*'> sigil or
+else it won't compile under C<use strict 'subs'>.
+
+ 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/InputOutput/RequireBriefOpen.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::InputOutput::RequireBriefOpen;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+use List::MoreUtils qw(any);
+
+use Perl::Critic::Utils qw{ :severities :classification :booleans parse_arg_list };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q<Close filehandles as soon as possible after opening them>;
+Readonly::Scalar my $EXPL => [209];
+
+Readonly::Scalar my $SCALAR_SIGIL => q<$>; ## no critic (InterpolationOfLiterals)
+Readonly::Scalar my $GLOB_SIGIL => q<*>;
+
+#-----------------------------------------------------------------------------
+
+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?
+ return if $elem ne 'open';
+ 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)) {
+ # 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) = @_;
+
+ my $parent = _get_scope($elem);
+ 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) = @_;
+ 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 1 if $candidate eq 'close' || $candidate eq 'return';
+ return 0;
+ });
+ return @{$closes || []};
+}
+
+sub _get_scope {
+ my ($elem) = @_;
+
+ while ($elem = $elem->parent) {
+ return $elem if $elem->scope;
+ }
+ return; # should never happen if we are in a PPI::Document
+}
+
+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 = 1;
+ $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 = 1;
+ $fh = $argument;
+ }
+ elsif ($GLOB_SIGIL eq $sigil) {
+ $is_lexical = 0;
+ $fh = $argument;
+ }
+ }
+ elsif ($argument->isa('PPI::Token::Word') && $argument eq uc $argument) {
+ $is_lexical = 0;
+ $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<Perl::Critic> 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<open()> where there is no matching
+C<close()> call within C<N> 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<open> instead of closing it. Just like the close, however, that
+C<return> 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<close()> invocations to be up to C<N> lines after their
+corresponding C<open()> calls, where C<N> defaults to 9. You can override
+this to set it to a different number with the C<lines> setting. To do this,
+put entries in a F<.perlcriticrc> file like this:
+
+ [InputOutput::RequireBriefOpen]
+ lines = 5
+
+
+=head1 CAVEATS
+
+=head2 C<IO::File-E<gt>new>
+
+This policy only looks for explicit C<open> calls. It does not detect calls
+to C<CORE::open> or C<IO::File-E<gt>new> 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 <cdolan@cpan.org>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/InputOutput/RequireCheckedClose.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::InputOutput::RequireCheckedClose;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 ) }
+sub applies_to { return 'PPI::Token::Word' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+
+ return if $elem ne 'close';
+ return if ! is_unchecked_call( $elem );
+
+ return $self->violation( $DESC, $EXPL, $elem );
+
+}
+
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+The perl builtin I/O function C<close> 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
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 AUTHOR
+
+Andrew Moore <amoore@mooresystems.com>
+
+=head1 ACKNOWLEDGMENTS
+
+This policy module is based heavily on policies written by Jeffrey Ryan
+Thalhammer <thaljef@cpan.org>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/InputOutput/RequireCheckedOpen.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::InputOutput::RequireCheckedOpen;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 ) }
+sub applies_to { return 'PPI::Token::Word' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+
+ return if $elem ne 'open';
+ return if ! is_unchecked_call( $elem );
+
+ return $self->violation( $DESC, $EXPL, $elem );
+
+}
+
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+The perl builtin I/O function C<open> 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
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 AUTHOR
+
+Andrew Moore <amoore@mooresystems.com>
+
+=head1 ACKNOWLEDGMENTS
+
+This policy module is based heavily on policies written by Jeffrey Ryan
+Thalhammer <thaljef@cpan.org>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/InputOutput/RequireCheckedSyscalls.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::InputOutput::RequireCheckedSyscalls;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :booleans :characters :severities :classification
+ hashify is_perl_bareword };
+
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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
+);
+# 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 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',
+ },
+ );
+}
+
+sub default_severity { return $SEVERITY_LOWEST }
+sub default_themes { return qw( core maintenance ) }
+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;
+ }
+ }
+
+ $self->{_functions} = { hashify(@resulting_functions) };
+
+ return $TRUE;
+}
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+
+ return if $self->{_functions}->{':all'} ? is_perl_bareword($elem) : !$self->{_functions}->{$elem};
+ return if ! is_unchecked_call( $elem );
+
+ return $self->violation( $DESC . ' - ' . $elem, $EXPL, $elem );
+}
+
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=for stopwords nyah
+
+=head1 NAME
+
+Perl::Critic::Policy::InputOutput::RequireCheckedSyscalls - Return value of flagged function ignored.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<Fatal> or C<Fatal::Exception>, 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
+
+=head1 CONFIGURATION
+
+This policy watches for a configurable list of function names. By
+default, it applies to C<open>, C<print> and C<close>. You can
+override this to set it to a different list of functions with the
+C<functions> setting. 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).
+
+The C<:all> is the insane case: you must check the return value of
+EVERY function call, even C<return> and C<exit>. 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 <amoore@mooresystems.com>.
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Miscellanea/ProhibitFormats.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Miscellanea::ProhibitFormats;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 ) }
+sub applies_to { return 'PPI::Token::Word' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+ return if $elem 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<format>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<Template> or try the L<Perl6::Form> module.
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Miscellanea/ProhibitTies.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Miscellanea::ProhibitTies;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 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<tie>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Conway discourages using C<tie> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Miscellanea/RequireRcsKeywords.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Miscellanea::RequireRcsKeywords;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use List::MoreUtils qw(none);
+
+use Perl::Critic::Utils qw{
+ :booleans :characters :severities :data_conversion
+};
+
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $EXPL => [ 441 ];
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters {
+ return (
+ {
+ name => 'keywords',
+ description => 'The keywords to require in all files.',
+ default_string => $EMPTY,
+ behavior => 'string list',
+ },
+ );
+}
+
+sub default_severity { return $SEVERITY_LOW }
+sub default_themes { return qw(core pbp cosmetic) }
+sub applies_to { return 'PPI::Document' }
+
+#-----------------------------------------------------------------------------
+
+sub initialize_if_enabled {
+ my ($self, $config) = @_;
+
+ # Any of these lists
+ $self->{_keyword_sets} = [
+
+ # Minimal svk/svn
+ [qw(Id)],
+
+ # Expansive svk/svn
+ [qw(Revision HeadURL Date)],
+
+ # cvs?
+ [qw(Revision Source Date)],
+ ];
+
+ # Set configuration, if defined.
+ my @keywords = keys %{ $self->{_keywords} };
+ if ( @keywords ) {
+ ## no critic ProhibitEmptyQuotes
+ $self->{_keyword_sets} = [ [ @keywords ] ];
+ }
+
+ return $TRUE;
+}
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, $doc ) = @_;
+ my @viols = ();
+
+ my $nodes = $doc->find( \&_wanted );
+ for my $keywordset_ref ( @{ $self->{_keyword_sets} } ) {
+ if ( not $nodes ) {
+ my $desc = 'RCS keywords '
+ . join( ', ', map {"\$$_\$"} @{$keywordset_ref} )
+ . ' not found';
+ push @viols, $self->violation( $desc, $EXPL, $doc );
+ }
+ else {
+ my @missing_keywords = grep {
+ my $keyword_rx = qr/\$$_.*\$/xms;
+ !!none {
+ /$keyword_rx/ ## no critic
+ }
+ @{$nodes}
+ } @{$keywordset_ref};
+
+ if (@missing_keywords) {
+
+ # Provisionally flag a violation. See below.
+ my $desc = 'RCS keywords '
+ . join( ', ', map {"\$$_\$"} @missing_keywords )
+ . ' not found';
+ push @viols, $self->violation( $desc, $EXPL, $doc );
+ }
+ else {
+
+ # Hey! I'm ignoring @viols for other keyword sets
+ # because this one is complete.
+ return;
+ }
+ }
+ }
+
+ return @viols;
+}
+
+sub _wanted {
+ my ( undef, $elem ) = @_;
+ return $elem->isa('PPI::Token::Pod')
+ || $elem->isa('PPI::Token::Comment')
+ || $elem->isa('PPI::Token::Quote::Single')
+ || $elem->isa('PPI::Token::Quote::Literal');
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=for stopwords RCS
+
+=head1 NAME
+
+Perl::Critic::Policy::Miscellanea::RequireRcsKeywords - Put source-control keywords in every file.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Every code file, no matter how small, should be kept in a
+source-control repository. Adding the magical RCS keywords to your
+file helps the reader know where the file comes from, in case he or
+she needs to modify it. This Policy scans your file for comments that
+look like this:
+
+ # $Revision: 2489 $
+ # $Source: /myproject/lib/foo.pm $
+
+A common practice is to use the C<Revision> keyword to automatically
+define the C<$VERSION> variable like this:
+
+ our ($VERSION) = '$Revision: 2489 $' =~ m{ \$Revision: \s+ (\S+) }x;
+
+=head1 CONFIGURATION
+
+By default, this policy only requires the C<Revision>, C<Source>, and C<Date>
+keywords. To specify alternate keywords, specify a value for C<keywords> of a
+whitespace delimited series of keywords (without the dollar-signs). This would
+look something like the following in a F<.perlcriticrc> file:
+
+ [Miscellanea::RequireRcsKeywords]
+ keywords = Revision Source Date Author Id
+
+See the documentation on RCS for a list of supported keywords. Many
+source control systems are descended from RCS, so the keywords
+supported by CVS and Subversion are probably the same.
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Modules/ProhibitAutomaticExportation.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Modules::ProhibitAutomaticExportation;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use List::MoreUtils qw(any);
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Symbols are exported by default};
+Readonly::Scalar my $EXPL => q{Use '@EXPORT_OK' or '%EXPORT_TAGS' instead}; ## no critic
+
+#-----------------------------------------------------------------------------
+
+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 !$includes_ref;
+ #This covers both C<use Exporter;> and C<use base 'Exporter';>
+ return scalar grep { m/ \b Exporter \b/mx } @{ $includes_ref };
+}
+
+#------------------
+
+sub _has_exports {
+ my ($doc) = @_;
+ my $wanted = sub {_our_EXPORT(@_) || _vars_EXPORT(@_) || _package_EXPORT(@_)};
+ return $doc->find_first( $wanted );
+}
+
+#------------------
+
+sub _our_EXPORT {
+ my (undef, $elem) = @_;
+ $elem->isa('PPI::Statement::Variable') || return 0;
+ $elem->type() eq 'our' || return 0;
+ return any { $_ eq '@EXPORT' } $elem->variables(); ## no critic(RequireInterpolationOfMetachars)
+}
+
+#------------------
+
+sub _vars_EXPORT {
+ my (undef, $elem) = @_;
+ $elem->isa('PPI::Statement::Include') || return 0;
+ $elem->pragma() eq 'vars' || return 0;
+ return $elem =~ m{ \@EXPORT \b }mx; #Crude, but usually works
+}
+
+#------------------
+
+sub _package_EXPORT {
+ my (undef, $elem) = @_;
+ $elem->isa('PPI::Token::Symbol') || return 0;
+ return $elem =~ m{ \A \@ \S+ ::EXPORT \z }mx;
+ #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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+When using L<Exporter>, 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 base qw(Exporter);
+ our @EXPORT = qw(&foo &bar); # not ok
+ our @EXPORT_OK = qw(&foo &bar); # ok
+ our %EXPORT_TAGS = ( all => [ qw(&foo &bar) ] ); # ok
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Modules/ProhibitEvilModules.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+package Perl::Critic::Policy::Modules::ProhibitEvilModules;
+
+use 5.006001;
+use strict;
+use warnings;
+use English qw(-no_match_vars);
+use Readonly;
+
+use List::MoreUtils qw(any);
+
+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.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $EXPL => q{Find an alternative module};
+Readonly::Scalar my $DESC => q{Prohibited module used};
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters {
+ return (
+ {
+ name => 'modules',
+ description => 'The names of or patterns for modules to forbid.',
+ default_string => $EMPTY,
+ behavior => 'string list',
+ },
+ );
+}
+
+sub default_severity { return $SEVERITY_HIGHEST }
+sub default_themes { return qw( core bugs ) }
+sub applies_to { return 'PPI::Statement::Include' }
+
+#-----------------------------------------------------------------------------
+
+sub initialize_if_enabled {
+ my ($self, $config) = @_;
+
+ $self->{_evil_modules} = {}; #Hash
+ $self->{_evil_modules_rx} = []; #Array
+
+ #Set config, if defined
+ if ( defined $self->{_modules} ) {
+ my @modules = sort keys %{ $self->{_modules} };
+ foreach my $module ( @modules ) {
+ if ( $module =~ m{ \A [/] (.+) [/] \z }mx ) {
+
+ # These are module name patterns (e.g. /Acme/)
+ my $re = $1; # Untainting
+ my $pattern = eval { qr/$re/ }; ##no critic (RegularExpressions::.*)
+
+ if ( $EVAL_ERROR ) {
+ throw_policy_value
+ policy => $self->get_short_name(),
+ option_name => 'modules',
+ option_value => ( join q{", "}, @modules ),
+ message_suffix =>
+ qq{contains an invalid regular expression: "$module"};
+ }
+
+ push @{ $self->{_evil_modules_rx} }, $pattern;
+ }
+ else {
+ # These are literal module names (e.g. Acme::Foo)
+ $self->{_evil_modules}->{$module} = 1;
+ }
+ }
+ }
+
+ return $TRUE;
+}
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+ my $module = $elem->module();
+ return if !$module;
+
+ if ( exists $self->{_evil_modules}->{ $module } ||
+ any { $module =~ $_ } @{ $self->{_evil_modules_rx} } ) {
+
+ return $self->violation( $DESC, $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<Perl::Critic> 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<modules> option. The
+value of C<modules> 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<m/pattern/> will be forbidden. For
+example:
+
+ [Modules::ProhibitEvilModules]
+ modules = /Acme::/
+
+would cause all modules that match C<m/Acme::/> to be forbidden. You can add
+any of the C<imxs> switches to the end of a pattern, but be aware that patterns
+cannot contain whitespace because the configuration file parser uses it to
+delimit the module names and patterns.
+
+By default, there are no prohibited modules (although I can think of a few that
+should be).
+
+=head1 NOTES
+
+Note that this policy doesn't apply to pragmas. Future versions may
+allow you to specify an alternative for each prohibited module, which
+can be suggested by L<Perl::Critic>.
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Modules/ProhibitExcessMainComplexity.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Modules::ProhibitExcessMainComplexity;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use Perl::Critic::Utils::McCabe qw{ calculate_mccabe_of_main };
+
+use base 'Perl::Critic::Policy';
+
+#-----------------------------------------------------------------------------
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<outside> of subroutines.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<http://www.sei.cmu.edu/str/descriptions/cyclomatic_body.html> for
+some discussion about the McCabe number and other complexity metrics.
+
+Whereas L<Perl::Critic::Policy::Subroutines::ProhibitExcessComplexity> scores
+the complexity of each subroutine, this Policy scores the total complexity of
+all the code that is B<outside> 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<max_mccabe>
+configuration item. If the sum of all code B<outside> 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<might> be a simpler
+way to get the job done.
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::Subroutines::ProhibitExcessComplexity>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Modules/ProhibitMultiplePackages.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Modules::ProhibitMultiplePackages;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Modules/RequireBarewordIncludes.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Modules::RequireBarewordIncludes;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<require Module> instead of C<require 'Module.pm'>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+When including another module (or library) via the C<require> or
+C<use> 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<ProhibitRequireStatements>, which
+completely banned the use of C<require> for the sake of eliminating
+the old '*.pl' libraries from Perl4. Upon further consideration, I
+realized that C<require> is quite useful and necessary to enable
+run-time loading. Thus, C<RequireBarewordIncludes> does allow you to
+use C<require>, 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<Perl::Critic> is an example of this). In that case, just attach
+the C<'## no critic'> pseudo-pragma like so:
+
+ require $module_name; ## no critic
+
+
+=head1 CREDITS
+
+Chris Dolan <cdolan@cpan.org> was instrumental in identifying the
+correct motivation for and behavior of this Policy. Thanks Chris.
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. All rights reserved.
+
+=head1 COPYRIGHT
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself. The full text of this license
+can be found in the LICENSE file included with this module.
+
+=cut
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Modules/RequireEndWithOne.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Modules::RequireEndWithOne;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 ) }
+sub applies_to { return 'PPI::Document' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, $doc ) = @_;
+ return if is_script($doc); #Must be a library or module.
+
+ # 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}mx );
+
+ # 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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+All files included via C<use> or C<require> 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<return "Club sandwich";>. 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<cdolan@cpan.org>
+
+Some portions cribbed from
+L<Perl::Critic::Policy::Modules::RequireExplicitPackage>.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Chris Dolan and Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Modules/RequireExplicitPackage.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Modules::RequireExplicitPackage;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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',
+ },
+ );
+}
+
+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 violates {
+ my ( $self, $elem, $doc ) = @_;
+
+ # You can configure this policy to exclude scripts
+ return if $self->{_exempt_scripts} && is_script($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 { !$_->isa('PPI::Statement::Package') } @{$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;
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::Modules::RequireExplicitPackage - Always make the C<package> explicit.
+
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+In general, the first statement of any Perl module or
+library should be a C<package> statement. Otherwise, all the code
+that comes before the C<package> 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<package> 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<main>, so
+this Policy doesn't apply to files that begin with a perl shebang. If you want
+to require an explicit C<package> declaration in all files, including programs,
+then add the following to your F<.perlcriticrc> file
+
+ [Modules::RequireExplicitPackage]
+ exempt_scripts = 0
+
+
+=head1 IMPORTANT CHANGES
+
+This policy was formerly called C<ProhibitUnpackagedCode> which sounded
+a bit odd. If you get lots of "Cannot load policy module" errors,
+then you probably need to change C<ProhibitUnpackagedCode> to
+C<RequireExplicitPackage> in your F<.perlcriticrc> file.
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Modules/RequireFilenameMatchesPackage.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Modules::RequireFilenameMatchesPackage;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use File::Spec;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 violates {
+ my ($self, $elem, $doc) = @_;
+
+ my $filename = $doc->filename;
+ return if !$filename;
+
+ # 'lib/Foo/Bar.pm' -> ('lib', 'Foo', 'Bar')
+ my @path = File::Spec->splitpath($filename);
+ $filename = $path[2];
+ $filename =~ s/[.]\w+\z//mx;
+ my @path_parts = grep {$_ ne q{}} File::Spec->splitdir($path[1]), $filename;
+
+ # 'Foo::Bar' -> ('Foo', 'Bar')
+ my $pkg_node = $doc->find_first('PPI::Statement::Package');
+ return if !$pkg_node;
+ my $pkg = $pkg_node->namespace;
+ return if $pkg eq 'main';
+ my @pkg_parts = split m/(?:\'|::)/mx, $pkg;
+
+ # 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/mx);
+
+ # 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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+The package declaration should always match the name of the file that
+contains it. For example, C<package Foo::Bar;> should be in a file
+called C<Bar.pm>.
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2006 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Modules/RequireNoMatchVarsWithUseEnglish.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+use Perl::Critic::Utils qw< :characters :severities >;
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<use English> must be passed a C<-no_match_vars> argument.
+
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Due to unfortunate history, if you use the L<English> 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. See the L<English> documentation for
+details.
+
+ use English; # not ok
+ use English '-no_match_vars'; # ok
+ use English qw< $ERRNO -no_match_vars>; # ok
+
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 AUTHOR
+
+Elliot Shank C<< <perl@galumph.com> >>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2008-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Modules/RequireVersionVar.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Modules::RequireVersionVar;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use List::MoreUtils qw(any);
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{No "VERSION" variable found};
+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 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
+}
+
+#-----------------------------------------------------------------------------
+
+sub _is_vars_VERSION {
+ my (undef, $elem) = @_;
+ $elem->isa('PPI::Statement::Include') || return 0;
+ $elem->pragma() eq 'vars' || return 0;
+ return $elem =~ m{ \$VERSION }mx; #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 }mx;
+ #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 }mx;
+
+ 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';
+}
+
+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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Every Perl file (modules, libraries, and programs) should have a
+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<strict>, so you'll
+have to declare it like one of these:
+
+ our $VERSION = 1.0611;
+ $MyPackage::VERSION = 1.061;
+ use vars qw($VERSION);
+
+A common practice is to use the C<$Revision: 2489 $> keyword to automatically
+define the C<$VERSION> variable like this:
+
+ our ($VERSION) = '$Revision: 2489 $' =~ m{ \$Revision: \s+ (\S+) }x;
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 NOTES
+
+Conway recommends using the C<version> 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 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/NamingConventions/ProhibitAmbiguousNames.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::NamingConventions::ProhibitAmbiguousNames;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :data_conversion };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 default_forbidden_words { return words_from_string( $DEFAULT_FORBID ) }
+
+#-----------------------------------------------------------------------------
+
+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<Ambiguously named subroutine "$name">,
+ $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<Ambiguously named variable "$name">,
+ $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<Perl::Critic> 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<forbid> of a series of
+forbidden words separated by spaces.
+
+For example, if you decide that C<bases> 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 METHODS
+
+=over
+
+=item default_forbidden_words()
+
+This can be called as a class or instance method. It returns the list
+of words that are forbidden by default.
+
+
+=back
+
+
+=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<last> incorrectly triggers a violation.
+
+ my $previous_record = $Foo::last;
+
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/NamingConventions/ProhibitMixedCaseSubs.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseSubs;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $UPPER_LOWER => qr/ [[:upper:]] [[:lower:]] /xm;
+Readonly::Scalar my $LOWER_UPPER => qr/ [[:lower:]] [[:upper:]] /xm;
+Readonly::Scalar my $MIXED_RX => qr{ $UPPER_LOWER | $LOWER_UPPER }xmo;
+Readonly::Scalar my $DESC => 'Mixed-case subroutine name';
+Readonly::Scalar my $EXPL => [ 44 ];
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters { return () }
+sub default_severity { return $SEVERITY_LOWEST }
+sub default_themes { return qw( core pbp cosmetic ) }
+sub applies_to { return 'PPI::Statement::Sub' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+ (my $name = $elem->name() ) =~ s/\A.*:://mx;
+ if ( $name =~ m/$MIXED_RX/xms ) {
+ return $self->violation( $DESC, $EXPL, $elem );
+ }
+ return; #ok!
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseSubs - Write C<sub my_function{}> instead of C<sub MyFunction{}>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+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.
+
+ sub foo_bar{} #ok
+ sub foo_BAR{} #ok
+ sub FOO_bar{} #ok
+ sub FOO_BAR{} #ok
+
+ sub Some::Class::foo{} #ok, grudgingly
+
+ sub FooBar {} #not ok
+ sub FOObar {} #not ok
+ sub fooBAR {} #not ok
+ sub fooBar {} #not ok
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseVars>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/NamingConventions/ProhibitMixedCaseVars.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseVars;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $PACKAGE_RX => qr/ :: /mx;
+Readonly::Scalar my $UPPER_LOWER => qr/ [[:upper:]] [[:lower:]] /xm;
+Readonly::Scalar my $LOWER_UPPER => qr/ [[:lower:]] [[:upper:]] /xm;
+Readonly::Scalar my $MIXED_RX => qr{ $UPPER_LOWER | $LOWER_UPPER }xmo;
+Readonly::Scalar my $DESC => 'Mixed-case variable name(s)';
+Readonly::Scalar my $EXPL => [ 44 ];
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters { return () }
+sub default_severity { return $SEVERITY_LOWEST }
+sub default_themes { return qw( core pbp cosmetic ) }
+sub applies_to { return 'PPI::Statement::Variable' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+ if ( _has_mixed_case_vars($elem) ) {
+ return $self->violation( $DESC, $EXPL, $elem );
+ }
+ return; #ok!
+}
+
+
+sub _has_mixed_case_vars {
+ my $elem = shift;
+ for my $variable_name ( $elem->variables() ) {
+
+ #Variables with fully qualified package names are exempt
+ #because we can't really be responsible for symbols that
+ #are defined in other packages.
+
+ next if $elem->type() eq 'local' && $variable_name =~ m/$PACKAGE_RX/xms;
+ return 1 if $variable_name =~ m/$MIXED_RX/xms;
+ }
+ return 0;
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseVars - Write C<$my_variable = 42> instead of C<$MyVariable = 42>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+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.
+
+ my $foo_bar #ok
+ my $foo_BAR #ok
+ my @FOO_bar #ok
+ my %FOO_BAR #ok
+
+ my $FooBar #not ok
+ my $FOObar #not ok
+ my @fooBAR #not ok
+ my %fooBar #not ok
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseSubs>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/References/ProhibitDoubleSigils.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::References::ProhibitDoubleSigils;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/RegularExpressions/ProhibitCaptureWithoutTest.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::RegularExpressions::ProhibitCaptureWithoutTest;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Capture variable used outside conditional};
+Readonly::Scalar my $EXPL => [ 253 ];
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters { return () }
+sub default_severity { return $SEVERITY_MEDIUM }
+sub default_themes { return qw(core pbp maintenance) }
+sub applies_to { return 'PPI::Token::Magic' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ($self, $elem, $doc) = @_;
+ return if $elem !~ m/\A \$[1-9] \z/mx;
+ return if _is_in_conditional_expression($elem);
+ return if _is_in_conditional_structure($elem);
+ return $self->violation( $DESC, $EXPL, $elem );
+}
+
+sub _is_in_conditional_expression {
+ my $elem = shift;
+
+ # simplistic check: is there one of qw(&& || ?) 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 ($op eq q{&&} || $op eq q{||} || $op eq q{?}) {
+ $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 $elem = shift;
+
+ 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')) { # skip tokens
+ return if $psib->find_any('PPI::Token::Regexp::Match'); # fail
+ return if $psib->find_any('PPI::Token::Regexp::Substitute'); # fail
+ }
+ $psib = $psib->sprevious_sibling;
+ }
+
+ # Check for an enclosing 'if', 'unless', 'endif', or 'else'
+ my $parent = $stmt->parent;
+ while ($parent) { # never false as long as we're inside a PPI::Document
+ if ($parent->isa('PPI::Statement::Compound')) {
+ return 1;
+ }
+ elsif ($parent->isa('PPI::Structure')) {
+ return 1 if _is_in_conditional_expression($parent);
+ return 1 if _is_in_conditional_structure($parent);
+ $parent = $parent->parent;
+ }
+ else {
+ last;
+ }
+ }
+
+ return; # fail
+}
+
+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<Perl::Critic> 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 capture variables are inside a
+conditional and do not follow an regexps.
+
+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.
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2006 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/RegularExpressions/ProhibitComplexRegexes.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::RegularExpressions::ProhibitComplexRegexes;
+
+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 Perl::Critic::Utils::PPIRegexp qw{ parse_regexp get_match_string get_modifiers };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Split long regexps into smaller qr// chunks};
+Readonly::Scalar my $EXPL => [261];
+
+#-----------------------------------------------------------------------------
+
+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, undef ) = @_;
+
+ # Optimization: if its short enough now, parsing won't make it longer
+ return if $self->{_max_characters} >= length get_match_string($elem);
+
+ # If it has an "x" flag, it might be shorter after comment and whitespace removal
+ my %modifiers = get_modifiers($elem);
+ if ($modifiers{x}) {
+ my $re = parse_regexp($elem);
+ return if !$re; # syntax error, abort
+ my $qr = $re->visual;
+
+ # HACK: Remove any (?xism:...) wrapper we may have added in the parse process...
+ $qr =~ s/\A [(][?][xism]+(?:-[xism]+)?: (.*) [)] \z/$1/xms;
+
+ # Hack: don't count long \p{...} expressions against us so badly
+ $qr =~ s/\\[pP][{]\w+[}]/\\p{...}/gmx;
+
+ return if $self->{_max_characters} >= length $qr;
+ }
+
+ 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<qr//> chunks.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<N>
+characters, where C<N> is a configurable value that defaults to 60.
+If the regexp uses the C<x> flag, then the length is computed after
+parsing out any comments or whitespace.
+
+=head1 CASE STUDY
+
+As an example, look at the regexp used to match email
+addresses in L<Email::Valid::Loose> (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<m//x> 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<N> characters long, where C<N>
+defaults to 60. You can override this to set it to a different number
+with the C<max_characters> 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 <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/RegularExpressions/ProhibitEnumeratedClasses.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::RegularExpressions::ProhibitEnumeratedClasses;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use English qw(-no_match_vars);
+use List::MoreUtils qw(all);
+use Carp qw(carp);
+
+use Perl::Critic::Utils qw{ :booleans :severities hashify };
+use Perl::Critic::Utils::PPIRegexp qw{ ppiify parse_regexp get_modifiers };
+
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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'], ##no critic (Interpolation)
+ ['A-Z','a-z','_'] => ['\\w', '\\W'],
+ ['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, undef ) = @_;
+
+ # optimization: don't bother parsing the regexp if there are no character classes
+ return if $elem !~ m/\[/xms;
+
+ my $re = ppiify(parse_regexp($elem));
+ return if !$re;
+
+ # Must pass a sub to find() because our node classes don't start with PPI::
+ my $anyofs = $re->find(sub {$_[1]->isa('Perl::Critic::PPIRegexp::anyof')});
+ return if !$anyofs;
+ for my $anyof (@{$anyofs}) {
+ my $violation = $self->_get_character_class_violations($elem, $anyof);
+ return $violation if $violation;
+ }
+ return; # OK
+}
+
+sub _get_character_class_violations {
+ my ($self, $elem, $anyof) = @_;
+
+ my %elements;
+ for my $element ($anyof->children) {
+ if ($element->isa('Perl::Critic::PPIRegexp::exact')) {
+ my @tokens = split m/(\\.[^\\]*)/xms, $element->content;
+ for my $token (map { split m/\A (\\[nrf])/xms, _fixup($_); } @tokens) { ##no critic(Comma) ## TODO: FALSE POSITIVE
+ $elements{$token} = 1;
+ }
+ } elsif ($element->isa('Perl::Critic::PPIRegexp::anyof_char') ||
+ $element->isa('Perl::Critic::PPIRegexp::anyof_range') ||
+ $element->isa('Perl::Critic::PPIRegexp::anyof_class')) {
+ for my $token (split m/\A (\\[nrf])/xms, _fixup($element->content)) {
+ $elements{$token} = 1;
+ }
+ } else {
+ # no known way to get to this branch; just for forward compatibility
+ carp 'Unexpected type inside a character class: ' . (ref $element) . " '$element'";
+ }
+ }
+ for (my $i = 0; $i < @PATTERNS; $i += 2) { ##no critic (CStyleForLoop)
+ if (all { exists $elements{$_} } @{$PATTERNS[$i]}) {
+ my $neg = $anyof->re->neg;
+ 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 %HEX => ( # Note: this is ASCII specific!
+ '0a' => '\\n', ##no critic (Interpolation)
+ '0c' => '\\f', ##no critic (Interpolation)
+ '0d' => '\\r', ##no critic (Interpolation)
+ '20' => q{ },
+);
+sub _fixup {
+ my ($chars) = @_;
+
+ # \x0a -> \x{0a}
+ $chars =~ s/\A \\x([\da-fA-F]{2})/\\x{$1}/gxms;
+
+ # '\ ' -> q{ }
+ $chars =~ s/\A \\[ ]/ /gxms;
+
+ # \012 -> \x{0a}
+ $chars =~ s/\A \\0([0-7]{2})/'\\x{'.(sprintf "%02x", oct $1).'}'/egxms;
+
+ # \x{0a} -> \n
+ $chars =~ s/\A (\\x [{] ([\da-fA-F]+) [}] ) /exists $HEX{$2} ? $HEX{$2} : $1/egxms;
+
+ return $chars;
+}
+
+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<Perl::Critic> 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<m/[A-Z]/> can be a source of bugs when you really meant
+C<m/\p{IsUpper}/>. This policy catches a selection of possible
+incorrect character class usage.
+
+Specifically, the patterns are:
+
+B<C<[\t\r\n\f\ ]>> vs. B<C<\s>>
+
+B<C<[\t\r\n\ ]>> vs. B<C<\s>> (because many people forget C<\f>)
+
+B<C<[A-Za-z_]>> vs. B<C<\w>>
+
+B<C<[A-Za-z]>> vs. B<C<\p{IsAlphabetic}>>
+
+B<C<[A-Z]>> vs. B<C<\p{IsUpper}>>
+
+B<C<[a-z]>> vs. B<C<\p{IsLower}>>
+
+B<C<[0-9]>> vs. B<C<\d>>
+
+B<C<[^\w]>> vs. B<C<\W>>
+
+B<C<[^\s]>> vs. B<C<\S>>
+
+
+=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 <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/RegularExpressions/ProhibitEscapedMetacharacters.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::RegularExpressions::ProhibitEscapedMetacharacters;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use English qw(-no_match_vars);
+use List::MoreUtils qw(any);
+
+use Perl::Critic::Utils qw{ :booleans :severities hashify };
+use Perl::Critic::Utils::PPIRegexp qw{ ppiify parse_regexp };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 m/ /xms, '{ } ( ) . * + ? |'; ##no critic(Interpolation)
+
+#-----------------------------------------------------------------------------
+
+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, undef ) = @_;
+
+ # optimization: don't bother parsing the regexp if there are no escapes
+ return if $elem !~ m/\\/xms;
+
+ my $re = ppiify(parse_regexp($elem));
+ return if !$re;
+
+ # Must pass a sub to find() because our node classes don't start with PPI::
+ my $exacts = $re->find(sub {$_[1]->isa('Perl::Critic::PPIRegexp::exact')});
+ return if !$exacts;
+ for my $exact (@{$exacts}) {
+ my @escapes = $exact =~ m/\\(.)/gxms;
+ return $self->violation( $DESC, $EXPL, $elem ) if any { $REGEXP_METACHARS{$_} } @escapes;
+ }
+
+ 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<Perl::Critic> 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<m{////}>
+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<Regexp::Common::net> 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</[5.008006/> 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<m/[#]/x> 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 <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/RegularExpressions/ProhibitFixedStringMatches.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::RegularExpressions::ProhibitFixedStringMatches;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use English qw(-no_match_vars);
+use Carp;
+
+use Perl::Critic::Utils qw{ :booleans :severities };
+use Perl::Critic::Utils::PPIRegexp qw{ get_match_string get_modifiers };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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, undef ) = @_;
+
+ my $re = get_match_string($elem);
+
+ # 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 %mods = get_modifiers($elem);
+ return if $mods{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<eq> or hash instead of fixed-pattern regexps.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<eq> 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};
+
+=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<m> 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<m//>, C<s///> and C<qr//>
+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 <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/RegularExpressions/ProhibitSingleCharAlternation.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::RegularExpressions::ProhibitSingleCharAlternation;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw(-no_match_vars);
+use Readonly;
+use Carp;
+
+use Perl::Critic::Utils qw{ :booleans :characters :severities };
+use Perl::Critic::Utils::PPIRegexp qw{ ppiify parse_regexp };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Use [abc] instead of a|b|c};
+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, undef ) = @_;
+
+ # optimization: don't bother parsing the regexp if there are no pipes
+ return if $elem !~ m/[|]/xms;
+
+ my $re = ppiify(parse_regexp($elem));
+ return if !$re;
+
+ # Must pass a sub to find() because our node classes don't start with PPI::
+ my $branches =
+ $re->find(sub {$_[1]->isa('Perl::Critic::PPIRegexp::branch')});
+ return if not $branches;
+ for my $branch (@{$branches}) {
+ my @singles =
+ grep
+ {
+ $_->isa('Perl::Critic::PPIRegexp::exact')
+ and 1 == length $_
+ }
+ $branch->children;
+ if (1 < @singles) {
+ my $description =
+ 'Use ['
+ . join( $EMPTY, @singles )
+ . '] instead of '
+ . join q<|>, @singles;
+ return $self->violation( $description, $EXPL, $elem );
+ }
+ }
+
+ return; # OK
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::RegularExpressions::ProhibitSingleCharAlternation - Use C<[abc]> instead of C<a|b|c>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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.
+
+
+=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 <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusedCapture.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::RegularExpressions::ProhibitUnusedCapture;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+use List::MoreUtils qw(none);
+use Scalar::Util qw(refaddr);
+
+use English qw(-no_match_vars);
+use Carp;
+
+use Perl::Critic::Utils qw{ :booleans :severities split_nodes_on_comma };
+use Perl::Critic::Utils::PPIRegexp qw{ parse_regexp get_match_string get_substitute_string get_modifiers };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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, undef ) = @_;
+
+ # optimization: don't bother parsing the regexp if there are no parens
+ return if $elem !~ m/[(]/xms;
+
+ my $re = parse_regexp($elem);
+ return if ! $re;
+ my $ncaptures = @{$re->captures};
+ return if 0 == $ncaptures;
+
+ my @captures; # List of expected captures
+ $#captures = $ncaptures - 1;
+
+ # Look for references to the capture in the regex itself
+ my $iter = $re->walker;
+ while (my $token = $iter->()) {
+ if ($token->isa('Regexp::Parser::ref')) {
+ my ($num) = $token->raw =~ m/ (\d+) /xms;
+ $captures[$num-1] = 1;
+ }
+ }
+ my $subst = get_substitute_string($elem);
+ if ($subst) {
+
+ # TODO: This is a quick hack. Really, we should parse the string. It could
+ # be false positive (s///e) or false negative (s/(.)/\$1/)
+
+ for my $num ($subst =~ m/\$(\d+)/xms) {
+ $captures[$num-1] = 1;
+ }
+ }
+ return if none {! defined $_} @captures;
+
+ my %modifiers = get_modifiers($elem);
+ if ($modifiers{g}) {
+ $ncaptures = $NUM_CAPTURES_FOR_GLOBAL;
+ $#captures = $ncaptures - 1;
+ }
+
+ return if _enough_assignments($elem, \@captures);
+ return if _is_in_slurpy_array_context($elem);
+ return if _enough_magic($elem, \@captures);
+
+ return $self->violation( $DESC, $EXPL, $elem );
+}
+
+sub _enough_assignments { ##no critic(ExcessComplexity) # TODO
+ 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;
+ return if q{!~} eq $psib;
+ }
+ $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 1 if _symbol_is_slurpy($psib);
+
+ } elsif ($psib->isa('PPI::Structure::Block')) {
+ # @{$foo} = m/(foo)/
+ # %{$foo} = m/(foo)/
+ return 1 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 1 if !@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 1 if _has_array_sigil($var);
+ }
+ }
+ $captures->[$i] = 1; # ith evariable captures
+ }
+ }
+
+ return none {! defined $_} @{$captures};
+}
+
+sub _symbol_is_slurpy {
+ my ($symbol) = @_;
+
+ return 1 if _has_array_sigil($symbol);
+ return 1 if _has_hash_sigil($symbol);
+ return 1 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 1 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 explict regex operator
+ my $psib = $elem->sprevious_sibling;
+ if ($psib && $psib 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 1 if $parent->isa('PPI::Structure::List');
+ return 1 if $parent->isa('PPI::Structure::Constructor');
+ if ($parent->isa('PPI::Structure::Block')) {
+ return 1 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 1 if q{,} eq $psib;
+ return;
+ }
+ return 1;
+}
+
+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, $captures) = @_;
+
+ _check_for_magic($elem, $captures);
+
+ return none {! defined $_} @{$captures};
+}
+
+# void return
+sub _check_for_magic {
+ my ($elem, $captures) = @_;
+
+ # 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!
+
+ return if ! _check_rest_of_statement($elem, $captures);
+
+ my $parent = $elem->parent;
+ while ($parent && ! $parent->isa('PPI::Statement::Sub')) {
+ return if ! _check_rest_of_statement($parent, $captures);
+ $parent = $parent->parent;
+ }
+
+ return;
+}
+
+# false if we hit another regexp
+sub _check_rest_of_statement {
+ my ($elem, $captures) = @_;
+
+ my $nsib = $elem->snext_sibling;
+ while ($nsib) {
+ return if $nsib->isa('PPI::Token::Regexp');
+ if ($nsib->isa('PPI::Node')) {
+ return if ! _check_node_children($nsib, $captures);
+ } else {
+ _mark_magic($nsib, $captures);
+ }
+ $nsib = $nsib->snext_sibling;
+ }
+ return 1;
+}
+
+# false if we hit another regexp
+sub _check_node_children {
+ my ($elem, $captures) = @_;
+
+ # caveat: this will descend into subroutine definitions...
+
+ for my $child ($elem->schildren) {
+ return if $child->isa('PPI::Token::Regexp');
+ if ($child->isa('PPI::Node')) {
+ return if ! _check_node_children($child, $captures);
+ } else {
+ _mark_magic($child, $captures);
+ }
+ }
+ return 1;
+}
+
+sub _mark_magic {
+ my ($elem, $captures) = @_;
+
+ # Record if we see $1, $2, $3, ...
+
+ if ($elem->isa('PPI::Token::Magic') && $elem =~ m/\A \$ (\d+) /xms) {
+ 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}) {
+ $captures->[$num-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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Perl regular expressions have multiple types of grouping syntax. The basic
+parentheses (e.g. C<m/(foo)/>) captures into the magic variable C<$1>.
+Non-capturing groups (e.g. C<m/(?:foo)/> 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 Regexp::Parser
+
+We use L<Regexp::Parser> to analyze the regular expression syntax. This is an
+optional module for Perl::Critic, so it will not be automatically installed by
+CPAN for you. If you wish to use this policy, you must install that module
+first.
+
+=head2 C<qr//> interpolation
+
+This policy can be confused by interpolation of C<qr//> 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.
+
+=head1 CREDITS
+
+Initial development of this policy was supported by a grant from the Perl Foundation.
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/RegularExpressions/ProhibitUnusualDelimiters.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::RegularExpressions::ProhibitUnusualDelimiters;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use English qw(-no_match_vars);
+use Carp;
+
+use Perl::Critic::Utils qw{ :booleans :severities hashify };
+use Perl::Critic::Utils::PPIRegexp qw{ get_delimiters };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q<Use only '//' or '{}' to delimit regexps>;
+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 (get_delimiters($elem)) {
+ 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<Perl::Critic> 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<allow_all_brackets>. 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 <cdolan@cpan.org>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/RegularExpressions/RequireBracesForMultiline.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::RegularExpressions::RequireBracesForMultiline;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use English qw(-no_match_vars);
+use Carp;
+
+use Perl::Critic::Utils qw{ :booleans :severities };
+use Perl::Critic::Utils::PPIRegexp qw{ get_match_string get_delimiters };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q<Use '{' and '}' to delimit multi-line regexps>;
+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 = get_match_string($elem);
+ return if $re !~ m/\n/xms;
+
+ my ($match_delim) = get_delimiters($elem);
+ 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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Long regular expressions are hard to read. A good practice is to use
+the C<x> 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<s///>
+regexp. Instead, try using C<{}> characters to delimit your
+expressions.
+
+Compare these:
+
+ s/
+ <a \s+ href="([^"]+)">
+ (.*?)
+ </a>
+ /link=$1, text=$2/xms;
+
+vs.
+
+ s{
+ <a \s+ href="([^"]+)">
+ (.*?)
+ </a>
+ }
+ {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<allow_all_brackets>. 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 <cdolan@cpan.org>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/RegularExpressions/RequireExtendedFormatting.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::RegularExpressions::RequireExtendedFormatting;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use Perl::Critic::Utils::PPIRegexp qw{ &get_modifiers };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Regular expression without "/x" flag};
+Readonly::Scalar my $EXPL => [ 236 ];
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters { return () }
+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, undef ) = @_;
+
+ my %mods = get_modifiers($elem);
+ if ( ! $mods{x} ) {
+ return $self->violation( $DESC, $EXPL, $elem );
+ }
+ return; #ok!;
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::RegularExpressions::RequireExtendedFormatting - Always use the C</x> modifier with regular expressions.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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
+
+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<Regex::Common> module. Also, be
+cautions about slapping modifier flags onto existing regular
+expressions, as they can drastically alter their meaning. See
+L<http://www.perlmonks.org/?node_id=484238> for an interesting
+discussion on the effects of blindly modifying regular expression
+flags.
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/RegularExpressions/RequireLineBoundaryMatching.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::RegularExpressions::RequireLineBoundaryMatching;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use Perl::Critic::Utils::PPIRegexp qw{ &get_modifiers };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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, undef ) = @_;
+
+ my %mods = get_modifiers($elem);
+ if ( ! $mods{m} ) {
+ return $self->violation( $DESC, $EXPL, $elem );
+ }
+ return; #ok!;
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::RegularExpressions::RequireLineBoundaryMatching - Always use the C</m> modifier with regular expressions.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Folks coming from a C<sed> or C<awk> background tend to assume that
+C<'$'> and C<'^'> match the beginning and and of the line, rather than
+then beginning and ed 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<Regex::Common> module. Also, be
+cautions about slapping modifier flags onto existing regular
+expressions, as they can drastically alter their meaning. See
+L<http://www.perlmonks.org/?node_id=484238> for an interesting
+discussion on the effects of blindly modifying regular expression
+flags.
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/ProhibitAmpersandSigils.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Subroutines::ProhibitAmpersandSigils;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Subroutine called with "&" sigil};
+Readonly::Scalar my $EXPL => [ 175 ];
+
+#-----------------------------------------------------------------------------
+
+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 $psib = $elem->sprevious_sibling();
+ if ( $psib ) {
+ #Sigil is allowed if taking a reference, e.g. "\&my_sub"
+ return if $psib->isa('PPI::Token::Cast') && $psib eq q{\\};
+ }
+
+ return if ( $elem !~ m{\A [&] }mx ); # ok
+
+ $psib = $elem->sprevious_sibling();
+ return if ( $psib eq 'goto'
+ or $psib eq 'exists'
+ or $psib eq 'defined' ); # ok
+
+ 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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Since Perl 5, the ampersand sigil is completely optional when invoking
+subroutines. And 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/ProhibitBuiltinHomonyms.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms;
+
+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.088';
+
+#-----------------------------------------------------------------------------
+
+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 function};
+Readonly::Scalar my $EXPL => [177];
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters { return () }
+sub default_severity { return $SEVERITY_HIGH }
+sub default_themes { return qw( core bugs pbp ) }
+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() };
+ if ( is_perl_builtin( $elem ) ) {
+ return $self->violation( $DESC, $EXPL, $elem );
+ }
+ return; #ok!
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::Subroutines::ProhibitBuiltinHomonyms - Don't declare your own C<open> function.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Common sense dictates that you shouldn't declare subroutines with the
+same name as one of Perl's built-in functions. See C<`perldoc
+perlfunc`> for a list of built-ins.
+
+ sub open {} #not ok
+ sub exit {} #not ok
+ sub print {} #not ok
+
+ #You get the idea...
+
+Exceptions are made for C<BEGIN>, C<END>, C<INIT> and C<CHECK> blocks,
+as well as C<AUTOLOAD>, C<DESTROY>, and C<import> subroutines.
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 CAVEATS
+
+It is reasonable to declare an B<object> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/ProhibitExcessComplexity.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Subroutines::ProhibitExcessComplexity;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :data_conversion :classification };
+use Perl::Critic::Utils::McCabe qw{ calculate_mccabe_of_sub };
+
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 = qq{Subroutine with high complexity score ($score)};
+ 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<Perl::Critic> 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<http://www.sei.cmu.edu/str/descriptions/cyclomatic_body.html>
+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<max_mccabe>
+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<might> be a simpler way to get the job done.
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/ProhibitExplicitReturnUndef.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Subroutines::ProhibitExplicitReturnUndef;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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) }
+sub applies_to { return 'PPI::Token::Word' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+ return if ($elem 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 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<return> instead of C<return undef>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Returning C<undef> upon failure from a subroutine is pretty common.
+But if the subroutine is called in list context, an explicit C<return
+undef;> 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<return> statement whenever you
+want to return failure. In list context, Perl will then give you an
+empty list (which is false), and C<undef> 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<undef> 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<die> or C<croak> with C<eval>, or the L<Error> module for a much
+more robust exception-handling model. Conway has a real nice
+discussion on error handling in chapter 13 of PBP.
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/ProhibitManyArgs.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package 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.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $AT => q{@}; ##no critic(Interpolation)
+Readonly::Scalar my $AT_ARG => q{@_}; ##no critic(Interpolation)
+
+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) {
+ # subtract two for the "()" on the prototype
+ $num_args = -2 + length $elem->prototype; ## no critic (ProhibitMagicNumbers)
+ } 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) {
+ $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;
+
+ if ($operand->isa('PPI::Token::Magic') && $AT_ARG eq $operand) {
+ return _count_list_elements(@elements);
+ } elsif ($operand->isa('PPI::Token::Word') && 'shift' eq $operand) {
+ 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<Perl::Critic> 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 CREDITS
+
+Initial development of this policy was supported by a grant from the Perl Foundation.
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/ProhibitNestedSubs.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Subroutines::ProhibitNestedSubs;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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) = @_;
+
+ my $inner = $elem->find_first('PPI::Statement::Sub');
+ 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<sub never { sub correct {} }>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+B<Attention would-be clever Perl writers (including Younger RJBS):>
+
+This does not do what you think:
+
+ sub do_something {
+ ...
+ sub do_subprocess {
+ ...
+ }
+ ...
+ }
+
+C<do_subprocess()> 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<Perl::Critic::Tics>.
+
+
+=head1 AUTHOR
+
+Ricardo SIGNES <rjbs@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/ProhibitSubroutinePrototypes.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Subroutines::ProhibitSubroutinePrototypes;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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) }
+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<sub my_function (@@) {}>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/ProtectPrivateSubs.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Subroutines::ProtectPrivateSubs;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Private subroutine/method 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 ) }
+sub applies_to { return 'PPI::Token::Word' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+
+ my $psib = $elem->sprevious_sibling;
+ my $psib_name = eval { $psib->content };
+ no warnings 'uninitialized'; ## no critic ProhibitNoWarnings
+ if ( $psib_name ne 'package'
+ && $psib_name ne 'require'
+ && $psib_name ne 'use'
+ && ( $self->_is_other_pkg_private_function($elem)
+ || $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 $elem =~ m{ (\w+)::_\w+ \z }xms
+ && $elem !~ m{ \A SUPER::_\w+ \z }xms;
+}
+
+sub _is_other_pkg_private_method {
+ my ( $self, $elem ) = @_;
+
+ # look for structures like "Some::Package->_foo()"
+ $elem =~ m{ \A _\w+ \z }xms || return;
+ my $op = $elem->sprevious_sibling() || return;
+ $op eq q{->} || return;
+ my $pkg = $op->sprevious_sibling() || return;
+ $pkg->isa('PPI::Token::Word') || return;
+ 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<Perl::Critic> 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<B::Lint>
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::Subroutines::ProtectPrivateSubs>
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/RequireArgUnpacking.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Subroutines::RequireArgUnpacking;
+
+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{ :severities words_from_string };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $AT => q{@}; ##no critic(Interpolation)
+Readonly::Scalar my $AT_ARG => q{@_}; ##no critic(Interpolation)
+
+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,
+ },
+ );
+}
+
+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 !$elem->block;
+
+ my @statements = $elem->block->schildren;
+
+ # empty sub?
+ return if !@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 = 0;
+ MAGIC:
+ for my $magic (@magic) {
+ if ($AT eq $magic->raw_type) { # this is '@_', not '$_[0]'
+ my $prev = $magic->sprevious_sibling;
+ my $next = $magic->snext_sibling;
+
+ # allow conditional checks on the size of @_
+ next MAGIC if _is_size_check($magic);
+
+ if ('unpacking' eq $state) {
+ if (_is_unpack($magic)) {
+ $saw_unpack = 1;
+ next MAGIC;
+ }
+ }
+ }
+ return $self->violation( $DESC, $EXPL, $elem );
+ }
+ if (!$saw_unpack) {
+ $state = 'post_unpacking';
+ }
+ }
+ return; # OK
+}
+
+sub _is_unpack {
+ my ($magic) = @_;
+
+ my $prev = $magic->sprevious_sibling;
+ my $next = $magic->snext_sibling;
+
+ return 1 if ($prev && $prev->isa('PPI::Token::Operator') && q{=} eq $prev &&
+ (!$next || ($next->isa('PPI::Token::Structure') && q{;} eq $next)));
+ return;
+}
+
+sub _is_size_check {
+ my ($magic) = @_;
+
+ my $prev = $magic->sprevious_sibling;
+ my $next = $magic->snext_sibling;
+
+ return 1 if !$next && $prev && $prev->isa('PPI::Token::Operator') &&
+ (q{==} eq $prev || q{!=} eq $prev);
+ return 1 if !$prev && $next && $next->isa('PPI::Token::Operator') &&
+ (q{==} eq $next || q{!=} eq $next);
+ return;
+}
+
+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 1 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 && $prev->isa('PPI::Token::Word') && 'sub' eq $prev;
+ }
+
+ return 0; # 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<Perl::Critic> 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<chop> or C<chomp>).
+
+=head1 CONFIGURATION
+
+This policy is lenient for subroutines which have C<N> or fewer top-level
+statements, where C<N> defaults to ZERO. You can override this to set it to a
+higher number with the C<short_subroutine_statements> 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
+
+=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 <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Subroutines/RequireFinalReturn.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Subroutines::RequireFinalReturn;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal };
+use Perl::Critic::Utils qw{ :characters :severities :data_conversion };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Subroutine does not end with "return"};
+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( exit die croak confess throw Carp::confess Carp::croak ) ],
+ },
+ );
+}
+
+sub default_severity { return $SEVERITY_HIGH }
+sub default_themes { return qw( core bugs pbp ) }
+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
+ 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_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 eq 'if' || $begin 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_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 eq 'return' || $first_token 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;
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::Subroutines::RequireFinalReturn - End every path through a subroutine with an explicit C<return> statement.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Require all subroutines to terminate explicitly with one of the following:
+C<return>, C<goto>, C<die>, C<exit>, C<throw>, C<carp> or C<croak>.
+
+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<return;> 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<return;> statement at the end of every subroutine.
+
+=head1 CONFIGURATION
+
+If you've created your own terminal functions that behave like C<die> or
+C<exit>, then you can configure Perl::Critic to recognize those functions as
+well. Just put something like this in your F<.perlcriticrc>:
+
+ [Subroutines::RequireFinalReturns]
+ terminal_funcs = quit abort bailout
+
+=head1 LIMITATIONS
+
+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<return
+foo ? 1 : bar ? 2 : 3>
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoStrict.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use List::MoreUtils qw(all);
+
+use Perl::Critic::Utils qw{ :characters :severities :data_conversion };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 ) }
+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+) /gmx );
+ $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:]]+) /gmx;
+ @words = grep { $_ ne 'qw' && $_ ne 'no' && $_ ne 'strict' } @words;
+ return if 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<no strict>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+There are good reasons for disabling certain kinds of strictures, But
+if you were wise enough to C<use strict> in the first place, then it
+doesn't make sense to disable it completely. By default, any C<no
+strict> statement will violate this policy. However, you can
+configure this Policy to allow certain types of strictures to be
+disabled (See L</CONFIGURATION>). A bare C<no strict> statement will
+always raise a violation.
+
+=head1 CONFIGURATION
+
+The permitted strictures can be configured via the C<allow> option.
+The value is a list of whitespace-delimited stricture types that you
+want to permit. These can be C<vars>, C<subs> and/or C<refs>. An
+example of this customization:
+
+ [TestingAndDebugging::ProhibitNoStrict]
+ allow = vars subs refs
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitNoWarnings.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings;
+
+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.088';
+
+#-----------------------------------------------------------------------------
+
+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,
+ },
+ );
+}
+
+sub default_severity { return $SEVERITY_HIGH }
+sub default_themes { return qw( core bugs pbp ) }
+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+) /gmx );
+ $self->{_allow} = \%allowed;
+ }
+
+ return;
+}
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+
+ my ( $self, $elem, undef ) = @_;
+
+ return if $elem->type() ne 'no';
+ return if $elem->pragma() ne 'warnings';
+
+ #Arguments to 'no warnings' 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:]]+) /gmx;
+ @words = grep { $_ ne 'qw' && $_ ne 'no' && $_ ne 'warnings' } @words;
+ return if 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::ProhibitNoWarnings - Prohibit various flavors of C<no warnings>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+There are good reasons for disabling certain kinds of warnings. But if you
+were wise enough to C<use warnings> in the first place, then it doesn't make
+sense to disable them completely. By default, any C<no warnings> 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<no
+warnings> statement will always raise a violation.
+
+=head1 CONFIGURATION
+
+The permitted warning types can be configured via the C<allow> option. The
+value is a list of whitespace-delimited warning types that you want to be able
+to disable. See L<perllexwarn> for a list of possible warning types. An
+example of this customization:
+
+ [TestingAndDebugging::ProhibitNoWarnings]
+ allow = uninitialized once
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::TestingAndDebugging::RequireUseWarnings>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/TestingAndDebugging/ProhibitProlongedStrictureOverride.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::TestingAndDebugging::ProhibitProlongedStrictureOverride;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 ) }
+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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Every agrees that C<use strict> is the first step to writing maintainable code
+in Perl. However, sometimes C<strict> is a little too strict. In those
+cases, you can turn it off briefly with a C<no strict> directive.
+
+This policy checks that C<no strict> is only in effect for a small number of
+statements.
+
+=head1 CONFIGURATION
+
+The default number of statements allowed per C<no strict> is three. To
+override this number, put the following in your F<.perlcriticrc>:
+
+ [TestingAndDebugging::ProhibitProlongedStrictureOverride]
+ statements = 5
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2006 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/TestingAndDebugging/RequireTestLabels.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::TestingAndDebugging::RequireTestLabels;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use List::MoreUtils qw(any);
+use Perl::Critic::Utils qw{
+ :characters :severities :data_conversion :classification :ppi
+};
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+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 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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Most Perl modules with regression tests use L<Test::More> 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<use Test::More> or
+C<require Test::More> 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<modules> 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<Test::More>.
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2006 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseStrict.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::TestingAndDebugging::RequireUseStrict;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Code before strictures are enabled};
+Readonly::Scalar my $EXPL => [ 429 ];
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters { return () }
+sub default_severity { return $SEVERITY_HIGHEST }
+sub default_themes { return qw( core pbp bugs ) }
+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( \&_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 = $doc->find( \&_isnt_include_or_package );
+ return if !$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 _is_use_strict {
+ my (undef, $elem) = @_;
+
+ return 0 if !$elem->isa('PPI::Statement::Include');
+ return 0 if $elem->type() ne 'use';
+
+ if (
+ $elem->pragma() ne 'strict'
+ and $elem->module() ne 'Moose'
+ and $elem->module() ne 'Moose::Role'
+ ) {
+ return 0;
+ }
+
+ return 1;
+}
+
+sub _isnt_include_or_package {
+ my (undef, $elem) = @_;
+
+ return 0 if ! $elem->isa('PPI::Statement');
+ 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<use strict>.
+
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<package>, C<require>, and other
+C<use> statements. Thus, all the code in the entire package will be affected.
+
+There are special exemptions for L<Moose> and L<Moose::Role> 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
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::TestingAndDebugging::ProhibitNoStrict>
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/TestingAndDebugging/RequireUseWarnings.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package 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 };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 () }
+sub default_severity { return $SEVERITY_HIGH }
+sub default_themes { return qw( core bugs pbp ) }
+sub applies_to { return 'PPI::Document' }
+
+sub default_maximum_violations_per_document { return 1; }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, $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( \&_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 = $document->find( \&_isnt_include_or_package );
+ 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 _is_use_warnings {
+ my (undef, $elem) = @_;
+
+ return 0 if !$elem->isa('PPI::Statement::Include');
+ return 0 if $elem->type() ne 'use';
+
+ if (
+ $elem->pragma() ne 'warnings'
+ and $elem->module() ne 'Moose'
+ and $elem->module() ne 'Moose::Role'
+ ) {
+ return 0;
+ }
+
+ return 1;
+}
+
+sub _isnt_include_or_package {
+ my (undef, $elem) = @_;
+ return 0 if ! $elem->isa('PPI::Statement');
+ 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<use warnings>.
+
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<package>, C<require>, and other C<use>
+statements. Thus, all the code in the entire package will be
+affected.
+
+There are special exemptions for L<Moose> and L<Moose::Role> because
+they enforces strictness; 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<require 5.005> in it.
+
+The maximum number of violations per document for this policy defaults
+to 1.
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::TestingAndDebugging::ProhibitNoWarnings>
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitCommaSeparatedStatements.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::ProhibitCommaSeparatedStatements;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+
+use Perl::Critic::Utils qw{ :booleans :characters :severities :classification };
+use Perl::Critic::Utils::PPI qw{ is_ppi_statement_subclass };
+
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 ) }
+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::ForLoop');
+
+ 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<Perl::Critic> 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<print>, 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<map>
+or C<grep> block to be comma separated. This is done via the
+C<allow_last_statement_to_be_comma_separated_in_map_and_grep> 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 AUTHOR
+
+Elliot Shank C<< <perl@galumph.com> >>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitConstantPragma.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::ProhibitConstantPragma;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Named constants are a good thing. But don't use the C<constant>
+pragma because barewords don't interpolate. Instead use the
+L<Readonly> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEmptyQuotes.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::ProhibitEmptyQuotes;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $EMPTY_RX => qr{\A ["|'] \s* ['|"] \z}mx;
+Readonly::Scalar my $DESC => q{Quotes used with an empty 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 '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<q{}> instead of C<''>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Don't use quotes for an empty string or any string that is pure whitespace.
+Instead, use C<q{}> to improve legibility. Better still, created named values
+like this. Use the C<x> 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<Perl::Critic::Policy::ValuesAndExpressions::ProhibitNoisyStrings>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitEscapedCharacters.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::ProhibitEscapedCharacters;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Numeric escapes in interpolated string};
+Readonly::Scalar my $EXPL => [ 56 ];
+
+#-----------------------------------------------------------------------------
+
+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/(?<!\\)(?:\\\\)*/mx;
+ my $hex = qr/\\x[\dA-Fa-f]{2}/mx;
+ my $widehex = qr/\\x[{][\dA-Fa-f]+[}]/mx;
+ my $oct = qr/\\[01][0-7]/mx;
+ if ($elem->content =~ m/$not_escaped (?:$hex|$widehex|$oct)/mxo) {
+ 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<Perl::Critic> 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 SEE ALSO
+
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitImplicitNewlines.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::ProhibitImplicitNewlines;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> 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 <cdolan@cpan.org>
+
+=head1 CREDITS
+
+Initial development of this policy was supported by a grant from the Perl
+Foundation.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitInterpolationOfLiterals.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::ProhibitInterpolationOfLiterals;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use List::MoreUtils qw(any);
+
+use Perl::Critic::Utils qw{ :characters :severities :data_conversion };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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,
+ },
+ );
+}
+
+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 }mx || ($_ = '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 }mx } @{ $self->{_allow} };
+
+ # Must be a violation
+ return $self->violation( $DESC, $EXPL, $elem );
+}
+
+#-----------------------------------------------------------------------------
+
+sub _has_interpolation {
+ my $elem = shift;
+ return $elem =~ m{ (?<!\\) [\$\@] \S+ }mx #Contains unescaped $. or @.
+ || $elem =~ m{ \\[tnrfbae0xcNLuLUEQ] }mx; #Containts escaped metachars
+}
+
+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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Don't use double-quotes or C<qq//> 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
+
+=head1 CONFIGURATION
+
+The types of quoting styles to exempt from this policy can be
+configured via the C<allow> option. This must be a
+whitespace-delimited combination of some or all of the following
+styles: C<qq{}>, C<qq()>, C<qq[]>, and C<qq//>.
+
+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<vim> to use SQL highlighting for
+everything that appears within C<qq{}> or C<qq[]> 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[]
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLeadingZeros.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::ProhibitLeadingZeros;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+use Perl::Critic::Utils qw{ :characters :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $LEADING_RX => qr<\A [+-]? (?: 0+ _* )+ [1-9]>mx;
+Readonly::Scalar my $EXPL => [ 58 ];
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters {
+ return (
+ {
+ name => 'strict',
+ description =>
+ q<Don't allow any leading zeros at all. Otherwise builtins that deal with Unix permissions, e.g. chmod, don't get flagged.>,
+ default_string => '0',
+ behavior => 'boolean',
+ },
+ );
+}
+
+sub default_severity { return $SEVERITY_HIGHEST }
+sub default_themes { return qw< core pbp bugs > }
+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<Integer with leading zeros: "$elem">,
+ $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<oct(755)> instead of C<0755>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Perl interprets numbers with leading zeros as octal. If that's what
+you really want, its better to use C<oct> 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<strict> to a true value in
+a F<.perlcriticrc> file.
+
+ [ValuesAndExpressions::ProhibitLeadingZeros]
+ strict = 1
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitLongChainsOfMethodCalls.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::ProhibitLongChainsOfMethodCalls;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :characters :severities };
+use Perl::Critic::Utils::PPI qw{ is_ppi_expression_or_generic_statement };
+
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> 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<max_chain_length> which controls how far
+the code is allowed to navigate. The default value is 3.
+
+
+=head1 AUTHOR
+
+Elliot Shank C<< <perl@galumph.com> >>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMagicNumbers.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::ProhibitMagicNumbers;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+use Perl::Critic::Utils qw{ :booleans :characters :severities :data_conversion };
+
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#----------------------------------------------------------------------------
+
+Readonly::Scalar my $EXPL =>
+ q{Unnamed numeric literals make code less maintainable};
+Readonly::Scalar my $USE_READONLY_OR_CONSTANT =>
+ ' Use the Readonly 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;
+
+# The regex is already simplified. There's just a lot of variable use.
+## no critic (ProhibitComplexRegexes)
+Readonly::Scalar my $RANGE =>
+ qr{
+ \A
+ ($SIGNED_NUMBER)
+ [$PERIOD] [$PERIOD]
+ ($SIGNED_NUMBER)
+ (?:
+ [$COLON] by [$LEFT_PAREN]
+ ($UNSIGNED_NUMBER)
+ [$RIGHT_PAREN]
+ )?
+ \z
+ }xms;
+## use critic
+
+Readonly::Scalar my $SPECIAL_ARRAY_SUBSCRIPT_EXEMPTION => -1;
+
+Readonly::Hash my %READONLY_SUBROUTINES =>
+ hashify(
+ qw{ Readonly Readonly::Scalar Readonly::Array Readonly::Hash }
+ );
+
+#----------------------------------------------------------------------------
+
+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,
+ },
+ );
+}
+
+sub default_severity { return $SEVERITY_LOW }
+sub default_themes { return qw( core maintenance ) }
+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;
+ } 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 ) = @_;
+
+ return if _element_is_in_an_include_readonly_or_version_statement($elem);
+ return if _element_is_in_a_plan_statement($elem);
+ return if _element_is_in_a_constant_subroutine($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_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 ($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 ( exists $READONLY_SUBROUTINES{$first_token} ) {
+ 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 not $following->content() eq $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 not $preceding->content() eq '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;
+}
+
+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<Perl::Critic> 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<constant> pragma or the L<Readonly> module 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<use> and C<require> statements to
+allow for things like Perl version restrictions and L<Test::More>
+plans. Declarations of C<$VERSION> package variables are permitted.
+Use of C<Readonly>, C<Readonly::Scalar>, C<Readonly::Array>, and
+C<Readonly::Hash> from the L<Readonly> module are obviously valid, but
+use of C<Readonly::Scalar1>, C<Readonly::Array1>, and
+C<Readonly::Hash1> are specifically not supported.
+
+Use of binary, exponential, hexadecimal, octal, and version numbers,
+even for C<0> and C<1>, outside of C<use>/C<require>/C<Readonly>
+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 two options: C<allowed_values> and C<allowed_types>.
+
+
+=head2 C<allowed_values>
+
+The C<allowed_values> parameter is a whitespace delimited set of
+permitted number I<values>; 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<all_integers> 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<allowed_types>
+
+The C<allowed_types> parameter is a whitespace delimited set of
+subclasses of L<PPI::Token::Number>.
+
+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<allowed_values>, 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<Float> 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<PPI>.
+
+
+=head1 BUGS
+
+There is currently no way to permit version numbers in regular code,
+even if you include them in the allowed_types. Some may actually
+consider this a feature.
+
+
+=head1 AUTHOR
+
+Elliot Shank C<< <perl@galumph.com> >>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMismatchedOperators.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::ProhibitMismatchedOperators;
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Mismatched operator};
+Readonly::Scalar my $EXPL => q{Numeric/string operators and operands should match};
+
+# operator types
+
+Readonly::Hash my %OP_TYPES => (
+ # numeric
+ (map { $_ => 0 } qw( == != > >= < <= + - * / += -= *= /= )),
+ # string
+ (map { $_ => 1 } qw( eq ne lt gt le ge . .= )),
+);
+
+# token compatibility [ numeric, string ]
+
+Readonly::Hash my %TOKEN_COMPAT => (
+ 'PPI::Token::Number' => [ 1, 0 ],
+ 'PPI::Token::Symbol' => [ 1, 1 ],
+ 'PPI::Token::Quote' => [ 0, 1 ],
+);
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters { return () }
+sub default_severity { return $SEVERITY_MEDIUM }
+sub default_themes { return qw( core bugs ) }
+sub applies_to { return 'PPI::Token::Operator' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem ) = @_;
+
+ my $elem_text = $elem->content;
+
+ return if !exists $OP_TYPES{$elem_text};
+
+ my $prev_elem = $elem->sprevious_sibling();
+ return if not $prev_elem;
+
+ my $next_elem = $elem->snext_sibling();
+ return if not $next_elem;
+
+ if ( $next_elem->isa('PPI::Token::Operator') ) {
+ $elem_text .= $next_elem;
+ $next_elem = $next_elem->snext_sibling();
+ }
+
+ return if !exists $OP_TYPES{$elem_text};
+ my $op_type = $OP_TYPES{$elem_text};
+
+ my $prev_compat = $self->_get_token_compat( $prev_elem );
+ my $next_compat = $self->_get_token_compat( $next_elem );
+
+ return if ( !defined $prev_compat || $prev_compat->[$op_type] )
+ && ( !defined $next_compat || $next_compat->[$op_type] );
+
+ return $self->violation( $DESC, $EXPL, $elem );
+}
+
+#-----------------------------------------------------------------------------
+
+# get token value compatibility
+
+sub _get_token_compat {
+ my ( $self, $elem ) = @_;
+ for my $class ( keys %TOKEN_COMPAT ) {
+ return $TOKEN_COMPAT{$class} if $elem->isa($class);
+ }
+ return;
+}
+
+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<Perl::Critic> 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<warnings> 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 our about them sooner.
+
+=head1 AUTHOR
+
+Peter Guzis <pguzis@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitMixedBooleanOperators.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::ProhibitMixedBooleanOperators;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :data_conversion };
+use base 'Perl::Critic::Policy';
+
+
+#-----------------------------------------------------------------------------
+
+our $VERSION = '1.088';
+#-----------------------------------------------------------------------------
+
+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 ) }
+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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Conway advises against combining the low-precedence booleans ( C<and
+or not> ) 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitNoisyQuotes.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::ProhibitNoisyQuotes;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $NOISE_RX => qr{\A ["|'] [^ \w () {} [\] <> ]{1,2} ['|"] \z}mx;
+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<q{}> or C<qq{}> instead of quotes for awkward-looking strings.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<q{}> or a named value. However, braces,
+parentheses, and brackets tend do 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<Perl::Critic::Policy::ValuesAndExpressions::ProhibitEmptyQuotes>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitQuotesAsQuotelikeOperatorDelimiters.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::ProhibitQuotesAsQuotelikeOperatorDelimiters;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{
+ :booleans :characters :severities :data_conversion
+};
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 MSCHWERN
+
+=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<Perl::Critic> 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<single_quote_allowed_operators>,
+C<double_quote_allowed_operators>, and
+C<back_quote_allowed_operators>, 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<m>, C<q>, C<qq>, C<qr>, C<qw>, C<qx>, C<s>, C<tr>,
+and C<y> 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<m>, C<qr>, C<qx>, and C<s> 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
+
+MSCHWERN
+
+
+=head1 AUTHOR
+
+Elliot Shank C<< <perl@galumph.com> >>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/ProhibitVersionStrings.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::ProhibitVersionStrings;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 ) = @_;
+ if (
+ (
+ $elem->type() eq 'use'
+ or $elem->type() eq 'require'
+ )
+ and $elem->module ne 'lib'
+ ) {
+ #This is a pretty crude way to verify that a version string is
+ #being used. But there are several permutations of the syntax
+ #for C<use> and C<require>. Also PPI doesn't parses strings
+ #like "5.6.1" as an integer that is being concatenated to a
+ #float. I'm not sure if this should be reported as a bug.
+
+ if ( $elem =~ m{ \b v? \d+ [.] \d+ [.] \d+ \b }mx ) {
+ return $self->violation( $DESC, $EXPL, $elem );
+ }
+ }
+ return; #ok!
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::ValuesAndExpressions::ProhibitVersionStrings - Don't use strings like C<v1.4> or C<1.4.5> when including other modules.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Whenever you C<use> or C<require> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireInterpolationOfMetachars.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::RequireInterpolationOfMetachars;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+#-----------------------------------------------------------------------------
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{String *may* require interpolation};
+Readonly::Scalar my $EXPL => [ 51 ];
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters { return () }
+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 violates {
+ my ( $self, $elem, undef ) = @_;
+ # The string() method strips off the quotes
+ return if not _needs_interpolation( $elem->string() );
+ return if _looks_like_email_address( $elem->string() );
+ return $self->violation( $DESC, $EXPL, $elem );
+}
+
+#-----------------------------------------------------------------------------
+
+sub _needs_interpolation {
+ my $string = shift;
+ return $string =~ m{ [\$\@] \S+ }mxo #Contains a $ or @
+ || $string =~ m{ \\[tnrfae0xcNLuLUEQ] }mxo; #Contains metachars
+}
+
+#-----------------------------------------------------------------------------
+
+sub _looks_like_email_address {
+ my $string = shift;
+ return $string =~ m{\A [^\@\s]+ \@ [\w\-.]+ \z}mxo;
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+This policy warns you if you use single-quotes or C<q//> 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.
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 NOTES
+
+Perl's own C<warnings> pragma also warns you about this.
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::ValuesAndExpressions::ProhibitInterpolationOfLiterals>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireNumberSeparators.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::RequireNumberSeparators;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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} }mx;
+ 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<Perl::Critic> 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<min_value> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireQuotedHeredocTerminator.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::RequireQuotedHeredocTerminator;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $HEREDOC_RX => qr/ \A << \s* ["|'] .* ['|"] \z /mx;
+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<Perl::Critic> 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 <<END_MESSAGE; #not ok
+ Hello World
+ END_MESSAGE
+
+ print <<'END_MESSAGE'; #ok
+ Hello World
+ END_MESSAGE
+
+ print <<"END_MESSAGE"; #ok
+ $greeting
+ END_MESSAGE
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/ValuesAndExpressions/RequireUpperCaseHeredocTerminator.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::ValuesAndExpressions::RequireUpperCaseHeredocTerminator;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $HEREDOC_RX => qr{ \A << \s* (["|']?) [[:upper:]_] [[:upper:]\d_]* \1 \z }mx;
+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<Perl::Critic> 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<Perl::Critic::Policy::ValuesAndExpressions::RequireQuotedHeredocTerminator>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Variables/ProhibitConditionalDeclarations.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Variables::ProhibitConditionalDeclarations;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification :data_conversion };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Variables/ProhibitLocalVars.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Variables::ProhibitLocalVars;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $PACKAGE_RX => qr/::/mx;
+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(Interpolat)
+ return if ! is_perl_global( $variable_name );
+ }
+ return 1;
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::Variables::ProhibitLocalVars - Use C<my> instead of C<local>, except when you have to.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Since Perl 5, there are very few reasons to declare C<local>
+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<English>
+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<local> is actually a pretty sensible thing to do. So
+Perl::Critic will not complain if you C<local>-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<Perl::Critic::Policy::Variables::ProhibitPunctuationVars>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Variables/ProhibitMatchVars.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Variables::ProhibitMatchVars;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities :data_conversion };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 bugs 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<Perl::Critic> 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<perldoc
+English> or PBP page 82 for more information.
+
+It used to forbid plain C<use English;> 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<Perl::Critic::Policy::Modules::RequireNoMatchVarsWithUseEnglish>,
+which addresses this situation directly.
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Variables/ProhibitPackageVars.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package 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.088';
+
+#-----------------------------------------------------------------------------
+
+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 => 'File::Find Data::Dumper',
+ 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) }
+
+Readonly::Array our @DEFAULT_PACKAGE_EXCEPTIONS =>
+ qw( File::Find Data::Dumper );
+
+#-----------------------------------------------------------------------------
+
+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 }mx;
+ 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<our> keyword, so we try to let
+ # people use the C<vars> 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+) }gmx;
+
+ return if !@varnames; # no valid variables specified
+ return if _all_upcase( @varnames );
+ return 1;
+}
+
+sub _all_upcase { ##no critic(ArgUnpacking)
+ return all { $_ eq uc $_ } @_;
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::Variables::ProhibitPackageVars - Eliminate globals declared with C<our> or C<use vars>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<strict vars> so that naked
+variable declarations are not package variables by default. Thus, it
+complains you declare a variable with C<our> or C<use vars>, 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 = File::Find Data::Dumper
+
+This is the default setting. Using C<packages => 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<main> to the list of packages, but that will
+only OK variables explicitly in the C<main> package.
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::Variables::ProhibitPunctuationVars>
+
+L<Perl::Critic::Policy::Variables::ProhibitLocalVars>
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Variables/ProhibitPerl4PackageNames.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Variables::ProhibitPerl4PackageNames;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :characters :severities :classification };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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) }
+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
+
+=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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Perl 5 kept single quotes (C<'>) as package component separators in
+order to remain backward compatible with prior C<perl>s, 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<perlmod>
+
+=head1 AUTHOR
+
+Elliot Shank C<< <perl@galumph.com> >>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Variables/ProhibitPunctuationVars.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Variables::ProhibitPunctuationVars;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :characters :severities :data_conversion };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Magic punctuation variable used};
+Readonly::Scalar my $EXPL => [ 79 ];
+
+#-----------------------------------------------------------------------------
+
+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 _ ) ],
+ },
+ );
+}
+
+sub default_severity { return $SEVERITY_LOW }
+sub default_themes { return qw(core pbp cosmetic) }
+sub applies_to { return 'PPI::Token::Magic' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+ if ( !exists $self->{_allow}->{$elem} ) {
+ return $self->violation( $DESC, $EXPL, $elem );
+ }
+ return; #ok!
+}
+
+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<Perl::Critic> 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<English> 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.
+
+You can add more exceptions to your configuration. In your
+perlcriticrc file, add a block like this:
+
+ [Variables::ProhibitPunctuationVars]
+ allow = $@ $!
+
+The C<allow> property should be a whitespace-delimited list of
+punctuation variables.
+
+
+=head1 BUGS
+
+This doesn't find punctuation variables in strings.
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Variables/ProhibitUnusedVariables.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Variables::ProhibitUnusedVariables;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+use List::MoreUtils qw< any >;
+use PPI::Token::Symbol;
+
+use Perl::Critic::Utils qw< :characters :severities >;
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $EXPL =>
+ q<Unused variables clutter code and make it harder to read>;
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters { return () }
+sub default_severity { return $SEVERITY_MEDIUM }
+sub default_themes { return qw< core maintenance > }
+sub applies_to { return qw< PPI::Document > }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, $document ) = @_;
+
+ my %symbol_usage = _get_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 { $_ 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 ($document) = @_;
+
+ my $symbols = $document->find('PPI::Token::Symbol');
+ return if not $symbols;
+
+ my %symbol_usage;
+ foreach my $symbol ( @{$symbols} ) {
+ $symbol_usage{ $symbol->symbol() }++;
+ }
+
+ return %symbol_usage;
+}
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> 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<< <perl@galumph.com> >>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Variables/ProtectPrivateVars.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Variables::ProtectPrivateVars;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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) }
+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<Perl::Critic> 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<B::Lint>
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Policy::Subroutines::ProtectPrivateSubs>
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Variables/RequireInitializationForLocalVars.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Variables::RequireInitializationForLocalVars;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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) }
+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<local $foo = $bar;> instead of just C<local $foo;>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> 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<local>-ize it, it defaults to C<undef>. 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Variables/RequireLexicalLoopIterators.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Variables::RequireLexicalLoopIterators;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $DESC => q{Loop iterator is not lexical};
+Readonly::Scalar my $EXPL => [ 108 ];
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters { return () }
+sub default_severity { return $SEVERITY_HIGHEST }
+sub default_themes { return qw(core pbp bugs) }
+sub applies_to { return 'PPI::Statement::Compound' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+
+ # First child will be 'for' or 'foreach' keyword
+ my $first_child = $elem->schild(0);
+ return if !$first_child;
+ return if $first_child ne 'for' and $first_child ne 'foreach';
+
+ # The second child could be the iteration list
+ my $second_child = $elem->schild(1);
+ return if !$second_child;
+ return if $second_child->isa('PPI::Structure::ForLoop');
+
+ return if $second_child eq 'my';
+
+ return $self->violation( $DESC, $EXPL, $elem );
+}
+
+#-----------------------------------------------------------------------------
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=head1 NAME
+
+Perl::Critic::Policy::Variables::RequireLexicalLoopIterators - Write C<for my $element (@list) {...}> instead of C<for $element (@list) {...}>.
+
+=head1 AFFILIATION
+
+This Policy is part of the core L<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+C<for>/C<foreach> loops I<always> create new lexical variables for named
+iterators. In other words
+
+ for $zed (...) {
+ ...
+ }
+
+is equivalent to
+
+ for my $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 different from the C<$bicycle>
+inside the loop. You may have freed your bicycle, but you can't remember
+which one it was.
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Variables/RequireLocalizedPunctuationVars.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Variables::RequireLocalizedPunctuationVars;
+
+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.088';
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $PACKAGE_RX => qr/::/mx;
+Readonly::Hash my %EXCEPTIONS => hashify(qw(
+ $_
+ $ARG
+ @_
+));
+Readonly::Scalar my $DESC => q{Magic variables should be assigned as "local"};
+Readonly::Scalar my $EXPL => [ 81, 82 ];
+
+#-----------------------------------------------------------------------------
+
+sub supported_parameters { return () }
+sub default_severity { return $SEVERITY_HIGH }
+sub default_themes { return qw(core pbp bugs) }
+sub applies_to { return 'PPI::Token::Operator' }
+
+#-----------------------------------------------------------------------------
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+
+ return if $elem ne q{=};
+
+ my $destination = $elem->sprevious_sibling;
+ return if !$destination; # huh? assignment in void context??
+
+ if (_is_non_local_magic_dest($destination)) {
+ return $self->violation( $DESC, $EXPL, $elem );
+ }
+ return; # OK
+}
+
+sub _is_non_local_magic_dest {
+ my $elem = shift;
+
+ #print "Test dest $elem, @{[ref $elem]}\n";
+
+ # Quick exit if in good form
+ my $modifier = $elem->sprevious_sibling;
+ return
+ if
+ $modifier
+ && $modifier->isa('PPI::Token::Word')
+ && ($modifier eq 'local' || $modifier eq 'my');
+
+ # Implementation note: Can't rely on PPI::Token::Magic,
+ # unfortunately, because we need English too
+
+ if ($elem->isa('PPI::Token::Symbol')) {
+ return _is_magic_var($elem);
+ } elsif ($elem->isa('PPI::Structure::List') || $elem->isa('PPI::Statement::Expression')) {
+ for my $child ($elem->schildren) {
+ return 1 if _is_non_local_magic_dest($child);
+ }
+ }
+
+ return;
+}
+
+#-----------------------------------------------------------------------------
+
+sub _is_magic_var {
+ my ($elem) = @_;
+
+ my $variable_name = "$elem";
+ return if $EXCEPTIONS{$variable_name};
+ return 1 if $elem->isa('PPI::Token::Magic'); # optimization(?), and helps with PPI 1.118 carat bug
+ return if ! 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<Perl::Critic> 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<File::Slurp>!) 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<my>. Perl prevents using C<my>
+with "proper" punctuation variables, but allows C<$a>, C<@ARGV>, the
+names declared by L<English>, etc. This is not a good coding
+practice, however it is not the concern of this specific policy to
+complain about that.
+
+
+=head1 CONFIGURATION
+
+This Policy is not configurable except for the standard options.
+
+
+=head1 CAVEATS
+
+The current PPI (v1.118) has a bug where $^ variables absorb following
+whitespace by mistake. This makes it harder to spot those as magic
+variables. Hopefully this will be fixed by PPI 1.200. In the
+meantime, we have a workaround in this module.
+
+Additionally, PPI v1.118 fails to recognize %! and %^H as magic
+variables. PPI instead sees the "%" as a modulus operator. We have
+no workaround for that bug right now.
+
+=head1 CREDITS
+
+Initial development of this policy was supported by a grant from the
+Perl Foundation.
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Policy/Variables/RequireNegativeIndices.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Policy::Variables::RequireNegativeIndices;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic> distribution.
+
+
+=head1 DESCRIPTION
+
+Conway points out that
+
+ $arr[$#arr];
+ $arr[$#arr-1];
+ $arr[@arr-1];
+ $arr[@arr-2];
+
+are equivalent to
+
+ $arr[-1];
+ $arr[-2];
+ $arr[-1];
+ $arr[-2];
+
+and the latter are more readable, performant and maintainable. The
+latter is because the programmer no longer needs to keep two variable
+names matched.
+
+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 <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2006 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/PolicyConfig.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::PolicyConfig;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+our $VERSION = '1.088';
+
+use Perl::Critic::Exception::AggregateConfiguration;
+use Perl::Critic::Exception::Configuration::Option::Policy::ParameterValue;
+use Perl::Critic::Utils qw< :booleans :characters severity_to_number >;
+
+#-----------------------------------------------------------------------------
+
+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;
+
+ 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 _validate_maximum_violations_per_document {
+ my ($self, $errors) = @_;
+
+ my $user_maximum_violations =
+ $self->get_maximum_violations_per_document();
+
+ if ( defined $user_maximum_violations ) {
+ if (
+ $user_maximum_violations =~ m/$NO_LIMIT/xmsio
+ or $user_maximum_violations eq $EMPTY
+ ) {
+ $user_maximum_violations = undef;
+ }
+ elsif ( 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;
+}
+
+#-----------------------------------------------------------------------------
+
+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};
+}
+
+#-----------------------------------------------------------------------------
+
+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 METHODS
+
+=over
+
+=item C<get_policy_short_name()>
+
+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<set_themes> in the user's F<.perlcriticrc>.
+
+
+=item C< get_add_themes() >
+
+The value of C<add_themes> in the user's F<.perlcriticrc>.
+
+
+=item C< get_severity() >
+
+The value of C<severity> in the user's F<.perlcriticrc>.
+
+
+=item C< is_maximum_violations_per_document_unlimited() >
+
+Answer whether the value of C<maximum_violations_per_document> should
+be considered to be unlimited.
+
+
+=item C< get_maximum_violations_per_document() >
+
+The value of C<maximum_violations_per_document> 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.
+
+
+=back
+
+
+=head1 SEE ALSO
+
+L<Perl::Critic::DEVELOPER/"MAKING YOUR POLICY CONFIGURABLE">
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/PolicyFactory.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::PolicyFactory;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw(-no_match_vars);
+
+use File::Spec::Unix qw();
+use List::MoreUtils qw(any);
+
+use Perl::Critic::Utils qw{
+ :characters
+ $POLICY_NAMESPACE
+ :data_conversion
+ policy_long_name
+ policy_short_name
+ :internal_lookup
+};
+use Perl::Critic::PolicyConfig;
+use Perl::Critic::Exception::AggregateConfiguration;
+use Perl::Critic::Exception::Configuration;
+use Perl::Critic::Exception::Fatal::Generic qw{ throw_generic };
+use Perl::Critic::Exception::Fatal::Internal qw{ throw_internal };
+use Perl::Critic::Exception::Fatal::PolicyDefinition
+ qw{ throw_policy_definition };
+use Perl::Critic::Utils::Constants qw{ :profile_strictness };
+
+use Exception::Class; # this must come after "use P::C::Exception::*"
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+# 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<Can't load Policies from namespace "$POLICY_NAMESPACE": $EVAL_ERROR>;
+ }
+
+ throw_generic
+ qq<Can't load Policies from namespace "$POLICY_NAMESPACE" for an unknown reason.>;
+ }
+
+ if ( not @SITE_POLICY_NAMES ) {
+ throw_generic
+ qq<No Policies found in namespace "$POLICY_NAMESPACE".>;
+ }
+ }
+
+ # In test mode, only load native policies, not third-party ones
+ 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;
+
+ 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 _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 {
+ return sort @SITE_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 ($policy_name, $policy_config) = @_;
+
+ 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<Unable to create policy "$policy_name": $eval_error>;
+ }
+
+ throw_policy_definition
+ qq<Unable to create policy "$policy_name" for an unknown reason.>;
+ }
+
+ 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_message( $message );
+ }
+ 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<Perl::Critic::Policy> objects with
+the user's preferred parameters. There are no user-serviceable parts here.
+
+=head1 CONSTRUCTOR
+
+=over 8
+
+=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<Perl::Critic::UserProfile> object. This
+argument is required.
+
+B<-errors> is a reference to an instance of L<Perl::Critic::ConfigErrors>.
+This argument is optional. If specified, than any problems found will be
+added to the object.
+
+=back
+
+=head1 METHODS
+
+=over 8
+
+=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<Perl::Critic::Policy> 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<Perl::Critic::UserProfile>.
+
+Note that the Policy will not have had
+L<Perl::Critic::Policy/"initialize_if_enabled"> invoked on it, so it may not
+yet be usable.
+
+=item C< create_all_policies() >
+
+Constructs and returns one instance of each L<Perl::Critic::Policy> 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<Perl::Critic::Policy/"initialize_if_enabled"> 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 8
+
+=item C<site_policy_names()>
+
+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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/PolicyListing.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::PolicyListing;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw(-no_match_vars);
+
+use Perl::Critic::Policy qw();
+
+use overload ( q<""> => 'to_string' );
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 CONSTRUCTOR
+
+=over 8
+
+=item C<< new( -policies => \@POLICY_OBJECTS ) >>
+
+Returns a reference to a new C<Perl::Critic::PolicyListing> object.
+
+=back
+
+=head1 METHODS
+
+=over 8
+
+=item to_string()
+
+Returns a string representation of this C<PolicyListing>. See
+L<"OVERLOADS"> for more information.
+
+=back
+
+=head1 OVERLOADS
+
+When a L<Perl::Critic::PolicyListing> is evaluated in string context,
+it produces a one-line summary of the default severity, policy name,
+and default themes for each L<Perl::Critic::Policy> object that was
+given to the constructor of this C<PolicyListing>.
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/PolicyParameter.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::PolicyParameter;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use base 'Exporter';
+
+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.088';
+
+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 METHODS
+
+=over
+
+=item C<get_name()>
+
+Return the name of the parameter. This is the key that will be looked
+for in the F<.perlcriticrc>.
+
+
+=item C<get_description()>
+
+Return an explanation of the significance of the parameter, as
+provided by the developer of the policy.
+
+
+=item C<get_default_string()>
+
+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<parse_and_validate_config_value( $parser, $config )>
+
+Extract the configuration value for this parameter from the overall
+configuration and initialize the policy based upon it.
+
+
+=item C<generate_full_description()>
+
+Produce a more complete explanation of the significance of this
+parameter than the value returned by C<get_description()>.
+
+If no description can be derived, returns the empty string.
+
+Note that the result may contain multiple lines.
+
+
+=item C<to_formatted_string( $format )>
+
+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<sprintf> works. If you want to know the specific
+formatting capabilities, look at L<String::Format>. 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<Perl::Critic::DEVELOPER/"MAKING YOUR POLICY CONFIGURABLE">
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/PolicyParameter/Behavior.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::PolicyParameter::Behavior;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Perl::Critic::Utils qw{ :characters };
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic::PolicyParameter> 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<Perl::Critic::PolicyParameter>.
+
+
+=head1 METHODS
+
+=over
+
+=item C<initialize_parameter( $parameter, $specification )>
+
+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<generate_parameter_description( $parameter )>
+
+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<undef> if the parameter itself doesn't
+have a description. Also, the returned value may include multiple
+lines.
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/PolicyParameter/Behavior/Boolean.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::PolicyParameter::Behavior::Boolean;
+
+use 5.006001;
+use strict;
+use warnings;
+use Perl::Critic::Utils;
+
+use base qw{ Perl::Critic::PolicyParameter::Behavior };
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Perl::Critic::PolicyParameter> 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<Perl::Critic::PolicyParameter>.
+
+
+=head1 METHODS
+
+=over
+
+=item C<initialize_parameter( $parameter, $specification )>
+
+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 <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/PolicyParameter/Behavior/Enumeration.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::PolicyParameter::Behavior::Enumeration;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Perl::Critic::Exception::Fatal::PolicyDefinition
+ qw{ &throw_policy_definition };
+use Perl::Critic::Utils qw{ :characters &words_from_string &hashify };
+
+use base qw{ Perl::Critic::PolicyParameter::Behavior };
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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) = @_;
+
+ 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) = @_;
+
+ 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<Perl::Critic::PolicyParameter> 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<Perl::Critic::PolicyParameter>.
+
+
+=head1 METHODS
+
+=over
+
+=item C<initialize_parameter( $parameter, $specification )>
+
+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<generate_parameter_description( $parameter )>
+
+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 <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/PolicyParameter/Behavior/Integer.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::PolicyParameter::Behavior::Integer;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Perl::Critic::Utils qw{ :characters };
+
+use base qw{ Perl::Critic::PolicyParameter::Behavior };
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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) = @_;
+
+ 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<Perl::Critic::PolicyParameter> 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<Perl::Critic::PolicyParameter>.
+
+
+=head1 METHODS
+
+=over
+
+=item C<initialize_parameter( $parameter, $specification )>
+
+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<generate_parameter_description( $parameter )>
+
+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 <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/PolicyParameter/Behavior/String.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::PolicyParameter::Behavior::String;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Perl::Critic::Utils;
+
+use base qw{ Perl::Critic::PolicyParameter::Behavior };
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+sub _parse {
+ my ($policy, $parameter, $config_string) = @_;
+
+ my $name = $parameter->get_name();
+ 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<Perl::Critic::PolicyParameter> 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<Perl::Critic::PolicyParameter>.
+
+
+=head1 METHODS
+
+=over
+
+=item C<initialize_parameter( $parameter, $specification )>
+
+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 <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/PolicyParameter/Behavior/StringList.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::PolicyParameter::Behavior::StringList;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Perl::Critic::Utils qw{ :characters &words_from_string &hashify };
+
+use base qw{ Perl::Critic::PolicyParameter::Behavior };
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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) = @_;
+
+ 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.
+
+NOTE: Do not instantiate this class. Use the singleton instance held
+onto by L<Perl::Critic::PolicyParameter>.
+
+
+=head1 DESCRIPTION
+
+Provides a standard set of functionality for a string list
+L<Perl::Critic::PolicyParameter> so that the developer of a policy
+does not have to provide it her/himself.
+
+
+=head1 METHODS
+
+=over
+
+=item C<initialize_parameter( $parameter, $specification )>
+
+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<generate_parameter_description( $parameter )>
+
+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 <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Elliot Shank. 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 :
--- /dev/null
+#!perl ## no critic (PodSpelling)
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/PolicySummary.pod.PL $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+# TODO: The "no critic" above is due to PodSpelling not being able to tell
+# that there is no POD in this program.
+
+
+use 5.006;
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw< -no_match_vars >;
+use Carp qw< confess >;
+
+# We need both because the blib directory may or may not be in @INC at the
+# time this is run.
+use lib qw< blib lib >;
+
+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.088';
+
+
+print "\n\nGenerating Perl::Critic::PolicySummary.\n";
+
+
+my $configuration =
+ Perl::Critic::Config->new(
+ -profile => $EMPTY,
+ -severity => 1,
+ -theme => 'core',
+ );
+my @policies = $configuration->policies();
+
+
+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<Perl::Critic> 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<Perl Best Practices>.
+Since most coding standards take the form "do this..." or "don't do
+that...", I have adopted the convention of naming each module
+C<RequireSomething> or C<ProhibitSomething>. 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. See the
+documentation of each module for its specific details.
+
+
+=head1 POLICIES
+
+END_HEADER
+
+
+my $format = <<'END_POLICY';
+=head2 L<%s>
+
+%s [Severity %d]
+
+END_POLICY
+
+eval {
+ foreach my $policy (@policies) {
+ my $module_abstract = $policy->get_raw_abstract();
+
+ printf
+ {$pod_file}
+ $format,
+ $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<Perl::Critic> version 1.088.
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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";
+
+
+##############################################################################
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/branches/Perl-Critic-With-Param-Validation/lib/Perl/Critic/PolicyListing.pm $
+# $Date: 2006-12-13 21:35:21 -0800 (Wed, 13 Dec 2006) $
+# $Author: thaljef $
+# $Revision: 1089 $
+##############################################################################
+
+package Perl::Critic::ProfilePrototype;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw(-no_match_vars);
+
+use Perl::Critic::Config qw{};
+use Perl::Critic::Policy qw{};
+use Perl::Critic::Utils qw{ :characters };
+use overload ( q{""} => 'to_string' );
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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{profile-strictness = };
+ $prototype .= $configuration->profile_strictness();
+ $prototype .= "\n";
+
+ $prototype .= $prefix;
+ $prototype .= q{color = };
+ $prototype .= $configuration->color();
+ $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";
+
+ Perl::Critic::Policy::set_format( $self->_proto_format() );
+
+ return $prototype . "\n" . join q{}, map { "$_" } @{ $self->_get_policies() };
+}
+
+#-----------------------------------------------------------------------------
+
+# 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<Perl::Critic> profile
+(e.g. a F<.perlcriticrc> file. There are no user-serviceable parts here.
+
+=head1 CONSTRUCTOR
+
+=over 8
+
+=item C<< new( -policies => \@POLICY_OBJECTS ) >>
+
+Returns a reference to a new C<Perl::Critic::ProfilePrototype> object.
+
+=back
+
+=head1 METHODS
+
+=over 8
+
+=item to_string()
+
+Returns a string representation of this C<ProfilePrototype>. See
+L<"OVERLOADS"> for more information.
+
+=back
+
+=head1 OVERLOADS
+
+When a L<Perl::Critic::ProfilePrototype> is evaluated in string context, it
+produces a multi-line summary of the policy name, default themes, and default
+severity for each L<Perl::Critic::Policy> object that was given to the
+constructor of this C<ProfilePrototype>. 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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Statistics.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Statistics;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw(-no_match_vars);
+
+use Perl::Critic::Utils::McCabe qw{ calculate_mccabe_of_sub };
+
+#-----------------------------------------------------------------------------
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+sub new {
+ my ( $class ) = @_;
+
+ my $self = bless {}, $class;
+
+ $self->{_modules} = 0;
+ $self->{_subs} = 0;
+ $self->{_statements} = 0;
+ $self->{_lines} = 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 (RequireExtendedFormatting, RequireLineBoundaryMatching)
+ my @lines = split /$INPUT_RECORD_SEPARATOR/, $doc->serialize();
+ ## use critic
+ $self->{_lines} += scalar @lines;
+
+ 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 _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 METHODS
+
+=over
+
+=item C<new()>
+
+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<modules()>
+
+The number of chunks of code (usually files) that have been analyzed.
+
+
+=item C<subs()>
+
+The total number of subroutines analyzed by this Critic.
+
+
+=item C<statements()>
+
+The total number of statements analyzed by this Critic.
+
+
+=item C<lines()>
+
+The total number of lines of code analyzed by this Critic.
+
+
+=item C<violations_by_severity()>
+
+The number of violations of each severity found by this Critic as a
+reference to a hash keyed by severity.
+
+
+=item C<violations_by_policy()>
+
+The number of violations of each policy found by this Critic as a
+reference to a hash keyed by full policy name.
+
+
+=item C<total_violations()>
+
+The the total number of violations found by this Critic.
+
+
+=item C<statements_other_than_subs()>
+
+The total number of statements minus the number of subroutines.
+Useful because a subroutine is considered a statement by PPI.
+
+
+=item C<average_sub_mccabe()>
+
+The average McCabe score of all scanned subroutines.
+
+
+=item C<violations_per_file()>
+
+The total violations divided by the number of modules.
+
+
+=item C<violations_per_statement()>
+
+The total violations divided by the number statements minus
+subroutines.
+
+
+=item C<violations_per_line_of_code()>
+
+The total violations divided by the lines of code.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank C<< <perl@galumph.com> >>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/TestUtils.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::TestUtils;
+
+use 5.006001;
+use strict;
+use warnings;
+use English qw(-no_match_vars);
+use Readonly;
+
+use base 'Exporter';
+
+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.088';
+
+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: $!";
+ }
+
+ # 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(@_);
+}
+
+sub subtests_in_tree {
+ my $start = shift;
+
+ my %subtests;
+
+ find( {wanted => sub {
+ return if ! -f $_;
+ my ($fileroot) = m{(.+)[.]run\z}mx;
+ return if !$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 @subtests = _subtests_from_file( $_ );
+ $subtests{ $policy } = [ @subtests ];
+ }, 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');
+}
+
+# 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 $subtest;
+ my $lineno;
+ while ( <$fh> ) {
+ ++$lineno;
+ chomp;
+ my $inheader = /^## name/ .. /^## cut/; ## no critic(RegularExpression)
+
+ my $line = $_;
+
+ if ( $inheader ) {
+ $line =~ m/\A [#]/mx or throw_internal "Code before cut: $test_file";
+ my ($key,$value) = $line =~ m/\A [#][#] [ ] (\S+) (?:\s+(.+))? /mx;
+ 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;
+ }
+ if ($incode) {
+ throw_internal "Header line found while still in code: $test_file";
+ }
+ $subtest->{$key} = $value;
+ }
+ elsif ( $subtest ) {
+ $incode = 1;
+ # Don't start a subtest if we're not in one
+ 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: $!";
+ 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 (RegularExpressions::)
+ 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}mx} keys %{$manifest};
+ my @policies = map { join q{::}, split m{/}mx, $_} @policy_paths;
+ return sort @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 subtest subtests
+
+=head1 NAME
+
+Perl::Critic::TestUtils - Utility functions for testing new Policies.
+
+=head1 SYNOPSIS
+
+ use Perl::Critic::TestUtils qw(critique pcritique fcritique);
+
+ my $code = '<<END_CODE';
+ package Foo::Bar;
+ $foo = frobulator();
+ $baz = $foo ** 2;
+ 1;
+ END_CODE
+
+ # Critique code against all loaded policies...
+ my $perl_critic_config = { -severity => 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<Perl::Critic> only for self-testing. It
+provides a few handy subroutines for testing new Perl::Critic::Policy
+modules. Look at the test scripts 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<undef> 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<undef> for the default). Returns the number of violations that occurred.
+
+=item pcritique_with_violations( $policy_name, $code_string_ref, $config_ref )
+
+Like C<critique_with_violations()>, but tests only a single policy instead of
+the whole bunch.
+
+=item pcritique( $policy_name, $code_string_ref, $config_ref )
+
+Like C<critique()>, 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<pcritique_with_violations()>, but pretends that the code was loaded
+from the specified filename. This is handy for testing policies like
+C<Modules::RequireFilenameMatchesPackage> 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<File::Temp> and will be
+automatically deleted.
+
+=item fcritique( $policy_name, $code_string_ref, $filename, $config_ref )
+
+Like C<pcritique()>, but pretends that the code was loaded from the specified
+filename. This is handy for testing policies like
+C<Modules::RequireFilenameMatchesPackage> 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<File::Temp> 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<Modules::RequireEndWithOne>. The inner
+hash specifies a single test to be handed to C<pcritique()> or C<fcritique()>,
+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<MANIFEST> for F<lib/Perl/Critic/Policy/*.pm> 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<like()> 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<fcritique> should be used like so (see C<fcritique> for more
+details):
+
+ ## filename lib/Foo/Bar.pm
+
+The value of C<parms> will get C<eval>ed and passed to C<pcritique()>,
+so be careful.
+
+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 <cdolan@cpan.org>
+and the rest of the L<Perl::Critic> team.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Chris Dolan. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Theme.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Theme;
+
+use 5.006001;
+use strict;
+use warnings;
+use English qw(-no_match_vars);
+use Readonly;
+
+use base qw{ Exporter };
+
+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.088';
+
+#-----------------------------------------------------------------------------
+
+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/gemx;
+ 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}{!}ixmg; # "not" -> "!"
+ $raw_rule =~ s{\b and \b}{&&}ixmg; # "and" -> "&&"
+ $raw_rule =~ s{\b or \b}{||}ixmg; # "or" -> "||"
+
+ #Translate algebra operators (for backward compatibility)
+ $raw_rule =~ s{\A [-] }{!}ixmg; # "-" -> "!" e.g. difference
+ $raw_rule =~ s{ [-] }{&& !}ixmg; # "-" -> "&& !" e.g. difference
+ $raw_rule =~ s{ [*] }{&&}ixmg; # "*" -> "&&" e.g. intersection
+ $raw_rule =~ s{ [+] }{||}ixmg; # "+" -> "||" 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 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<Perl::Critic::Policy> 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<Perl::Critic/"CONFIGURATION"> for more information about customizing the
+themes for each Policy.
+
+
+=head1 SUBROUTINES
+
+=over
+
+=item C<cook_rule( $rule )>
+
+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 Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2006-2008 Jeffrey Thalhammer
+
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself. The full text of this license
+can be found in the LICENSE file included with this module.
+
+=cut
+
+##############################################################################
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/ThemeListing.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::ThemeListing;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw<-no_match_vars>;
+
+use Perl::Critic::Utils qw< hashify >;
+
+use overload ( q<""> => 'to_string' );
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 CONSTRUCTOR
+
+=over
+
+=item C<< new( -policies => \@POLICY_OBJECTS ) >>
+
+Returns a reference to a new C<Perl::Critic::ThemeListing> object.
+
+
+=back
+
+
+=head1 METHODS
+
+=over
+
+
+=item to_string()
+
+Returns a string representation of this C<ThemeListing>. See
+L<"OVERLOADS"> for more information.
+
+
+=back
+
+
+=head1 OVERLOADS
+
+
+When a L<Perl::Critic::ThemeListing> is evaluated in string context,
+it produces a one-line summary of the default severity, policy name,
+and default themes for each L<Perl::Critic::Policy> object that was
+given to the constructor of this C<ThemeListing>.
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/UserProfile.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::UserProfile;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw(-no_match_vars);
+use Readonly;
+
+use Config::Tiny qw();
+use File::Spec qw();
+
+use Perl::Critic::OptionsProcessor qw();
+use Perl::Critic::Utils qw{ :characters 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.088';
+
+#-----------------------------------------------------------------------------
+
+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 - //mxo; #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 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<Perl::Critic::Config> does that.
+
+
+=back
+
+
+=head1 METHODS
+
+=over
+
+=item C< options_processor() >
+
+Returns the L<Perl::Critic::OptionsProcessor> object for this UserProfile.
+
+
+=item C< policy_is_disabled( $policy ) >
+
+Given a reference to a L<Perl::Critic::Policy> 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<Perl::Critic::Policy> 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<Perl::Critic::Policy> object or the name of
+one, returns a L<Perl::Critic::PolicyConfig> for the user's
+configuration parameters for that policy.
+
+
+=item C< raw_policy_params( $policy ) >
+
+Given a reference to a L<Perl::Critic::Policy> 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<Perl::Critic::Config>, L<Perl::Critic::OptionsProcessor>
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Utils.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+# 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 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 base 'Exporter';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+# 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
+ $FATCOMMA
+ $PERIOD
+ $PIPE
+ $QUOTE
+ $BACKTICK
+ $SCOLON
+ $SPACE
+ $SLASH
+ $BSLASH
+ $LEFT_PAREN
+ $RIGHT_PAREN
+
+ all_perl_files
+ find_keywords
+ first_arg
+ hashify
+ interpolate
+ 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.
+Readonly::Array our @EXPORT => @EXPORT_OK; ## no critic (ProhibitAutomaticExport)
+
+
+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
+ $FATCOMMA
+ $PERIOD
+ $PIPE
+ $QUOTE
+ $BACKTICK
+ $SCOLON
+ $SPACE
+ $SLASH
+ $BSLASH
+ $LEFT_PAREN
+ $RIGHT_PAREN
+ }
+ ],
+ classification => [
+ qw{
+ 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 $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, '<' => 10, '//' => 15, '.=' => 19,
+ '++' => 2, '>' => 10, '||' => 15, '^=' => 19,
+ '--' => 2, '<=' => 10, '..' => 16, '<<=' => 19,
+ '**' => 3, '>=' => 10, '...' => 17, '>>=' => 19,
+ '!' => 4, 'lt' => 10, '?' => 18, ',' => 20,
+ '~' => 4, 'gt' => 10, ':' => 18, '=>' => 20,
+ '\\' => 4, 'le' => 10, '=' => 19, 'not' => 22,
+ '=~' => 5, 'ge' => 10, '+=' => 19, 'and' => 23,
+ '!~' => 5, '==' => 11, '-=' => 19, 'or' => 24,
+ '*' => 6, '!=' => 11, '*=' => 19, 'xor' => 24,
+ '/' => 6, '<=>' => 11, '/=' => 19,
+ '%' => 6, 'eq' => 11, '%=' => 19,
+ 'x' => 6, 'ne' => 11, '||=' => 19,
+ '+' => 7, 'cmp' => 11, '&&=' => 19,
+ '-' => 7, '&' => 12, '|=' => 19,
+ '.' => 7, '|' => 13, '&=' => 19,
+ '<<' => 8, '^' => 13, '**=' => 19,
+ '>>' => 8, '&&' => 14, 'x=' => 19,
+);
+
+## use critic
+#-----------------------------------------------------------------------------
+
+sub hashify { ##no critic(ArgUnpacking)
+ return map { $_ => 1 } @_;
+}
+
+#-----------------------------------------------------------------------------
+
+sub interpolate {
+ my ( $literal ) = @_;
+ return eval "\"$literal\""; ## 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 {
+ my @globals = map { substr $_, 1 } @B::Keywords::Arrays,
+ @B::Keywords::Hashes,
+ @B::Keywords::Scalars;
+
+ # 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 [\$@%*] }{}mx; #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 }mx;
+}
+
+#-----------------------------------------------------------------------------
+
+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)/mxo;
+}
+
+#-----------------------------------------------------------------------------
+
+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;
+ return if !$elem;
+
+ return if is_hash_key($elem);
+ return if is_method_call($elem);
+ return if is_class_name($elem);
+ return if is_subroutine_name($elem);
+ return if is_included_module_name($elem);
+ return if is_package_declaration($elem);
+ return if is_perl_bareword($elem);
+ return if is_perl_filehandle($elem);
+ return if is_label_pointer($elem);
+
+ return 1;
+}
+
+#-----------------------------------------------------------------------------
+
+sub is_script {
+ my $doc = shift;
+
+ return shebang_line($doc) ? 1 : 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::ForLoop');
+ return if $parent->isa('PPI::Structure::Condition');
+ return if $parent->isa('PPI::Structure::Constructor');
+
+ 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 }mx ) {
+ $policy_name = $POLICY_NAMESPACE . q{::} . $policy_name;
+ }
+ return $policy_name;
+}
+
+#-----------------------------------------------------------------------------
+
+sub policy_short_name {
+ my ( $policy_name ) = @_;
+ $policy_name =~ s{\A $POLICY_NAMESPACE ::}{}mx;
+ 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;
+ 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 _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 { !$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}mx;
+ return 1 if $file =~ m{ [.] bak \z}mx;
+ return 1 if $file =~ m{ ~ \z}mx;
+ return 1 if $file =~ m{ \A [#] .+ [#] \z}mx;
+ 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}mx;
+ return 1 if $file =~ m{ [.] p[lm] \z}mx;
+ return 1 if $file =~ m{ [.] t \z}mx;
+
+ #Check for shebang
+ open my $fh, '<', $file or return;
+ my $first = <$fh>;
+ close $fh or throw_generic "unable to close $file: $!";
+
+ return 1 if defined $first && ( $first =~ m{ \A [#]!.*perl }mx );
+ 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 [#]! }mx;
+ return $shebang;
+}
+
+#-----------------------------------------------------------------------------
+
+sub words_from_string {
+ my $str = shift;
+
+ return split q{ }, $str; # This must be a literal space, not $SPACE
+}
+
+#-----------------------------------------------------------------------------
+
+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) = @_;
+ 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;
+}
+
+sub _is_fatal {
+ my ($elem) = @_;
+
+ my $top = $elem->top;
+ return if !$top->isa('PPI::Document');
+ my $includes = $top->find('PPI::Statement::Include');
+ return if !$includes;
+ for my $include (@{$includes}) {
+ next if 'use' ne $include->type;
+ if ('Fatal' eq $include->module) {
+ my @args = parse_arg_list($include->schild(1));
+ for my $arg (@args) {
+ return 1 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
+ for my $arg (@args) {
+ return 1 if $arg->[0]->isa('PPI::Token::Quote') && $elem eq $arg->[0]->string;
+ }
+ }
+ }
+ 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<Perl::Critic::Policy> subclasses. Unless you are writing Policy
+modules, you probably don't care about this package.
+
+=head1 IMPORTABLE SUBS
+
+=over 8
+
+=item C<find_keywords( $doc, $keyword )>
+
+B<DEPRECATED:> 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<do> 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<PPI::Document> as C<$doc>, returns a reference to an array
+containing all the L<PPI::Token::Word> 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<is_perl_global( $element )>
+
+Given a L<PPI::Token::Symbol> or a string, returns true if that token
+represents one of the global variables provided by the L<English> 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<is_perl_builtin( $element )>
+
+Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
+if that token represents a call to any of the builtin functions defined in
+Perl 5.8.8.
+
+=item C<is_perl_bareword( $element )>
+
+Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
+if that token represents a bareword (e.g. "if", "else", "sub", "package")
+defined in Perl 5.8.8.
+
+=item C<is_perl_filehandle( $element )>
+
+Given a L<PPI::Token::Word>, or string, returns true if that token represents
+one of the global filehandles (e.g. C<STDIN>, C<STDERR>, C<STDOUT>, C<ARGV>)
+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<is_perl_builtin_with_list_context( $element )>
+
+Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, 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<is_perl_builtin_with_multiple_arguments( $element )>
+
+Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
+if that token represents a call to any of the builtin functions defined in
+Perl 5.8.8 that B<can> take multiple arguments.
+
+=item C<is_perl_builtin_with_no_arguments( $element )>
+
+Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, or string, returns true
+if that token represents a call to any of the builtin functions defined in
+Perl 5.8.8 that B<cannot> take any arguments.
+
+=item C<is_perl_builtin_with_one_argument( $element )>
+
+Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, 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<one and only one> argument.
+
+=item C<is_perl_builtin_with_optional_argument( $element )>
+
+Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, 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<no more than one> argument.
+
+The sets of values for which C<is_perl_builtin_with_multiple_arguments()>,
+C<is_perl_builtin_with_no_arguments()>,
+C<is_perl_builtin_with_one_argument()>, and
+C<is_perl_builtin_with_optional_argument()> return true are disjoint and
+their union is precisely the set of values that C<is_perl_builtin()> will
+return true for.
+
+=item C<is_perl_builtin_with_zero_and_or_one_arguments( $element )>
+
+Given a L<PPI::Token::Word>, L<PPI::Statement::Sub>, 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<is_perl_builtin_with_no_arguments()>,
+C<is_perl_builtin_with_one_argument()>, and
+C<is_perl_builtin_with_optional_argument()> returns true.
+
+=item C<is_qualified_name( $name )>
+
+Given a string, L<PPI::Token::Word>, or L<PPI::Token::Symbol>, answers
+whether it has a module component, i.e. contains "::".
+
+=item C<precedence_of( $element )>
+
+Given a L<PPI::Token::Operator> 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<is_hash_key( $element )>
+
+Given a L<PPI::Element>, 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<PPI::Token::Word>
+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<not> considered a hash key:
+
+ $hash1{ foo() } = 1;
+ &hash2 = (foo() => 1);
+
+=item C<is_included_module_name( $element )>
+
+Given a L<PPI::Token::Word>, returns true if the element is the name of a
+module that is being included via C<use>, C<require>, or C<no>.
+
+=item C<is_integer( $value )>
+
+Answers whether the parameter, as a string, looks like an integral value.
+
+=item C<is_class_name( $element )>
+
+Given a L<PPI::Token::Word>, returns true if the element that immediately
+follows this element is the dereference operator "->". When a bareword has a
+"->" on the B<right> side, it usually means that it is the name of the class
+(from which a method is being called).
+
+=item C<is_label_pointer( $element )>
+
+Given a L<PPI::Token::Word>, returns true if the element is the label
+in a C<next>, C<last>, C<redo>, or C<goto> statement. Note this is not the
+same thing as the label declaration.
+
+=item C<is_method_call( $element )>
+
+Given a L<PPI::Token::Word>, returns true if the element that immediately
+precedes this element is the dereference operator "->". When a bareword has a
+"->" on the B<left> side, it usually means that it is the name of a method
+(that is being called from a class).
+
+=item C<is_package_declaration( $element )>
+
+Given a L<PPI::Token::Word>, returns true if the element is the name of a
+package that is being declared.
+
+=item C<is_subroutine_name( $element )>
+
+Given a L<PPI::Token::Word>, 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<is_function_call( $element )>
+
+Given a L<PPI::Token::Word> returns true if the element appears to be call to
+a static function. Specifically, this function returns true if
+C<is_hash_key>, C<is_method_call>, C<is_subroutine_name>,
+C<is_included_module_anme>, C<is_package_declaration>, C<is_perl_bareword>,
+C<is_perl_filehandle>, C<is_label_pointer> and C<is_subroutine_name> all
+return false for the given element.
+
+=item C<first_arg( $element )>
+
+Given a L<PPI::Element> that is presumed to be a function call (which is
+usually a L<PPI::Token::Word>), return the first argument. This is similar of
+C<parse_arg_list()> 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<parse_arg_list()>. Another caveat is:
+
+ int(($x + $y) + 0.5)
+
+which returns C<($x + $y)> as a L<PPI::Structure::List> instance.
+
+=item C<parse_arg_list( $element )>
+
+Given a L<PPI::Element> that is presumed to be a function call (which is
+usually a L<PPI::Token::Word>), 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<split_nodes_on_comma( @nodes )>
+
+This has the same return type as C<parse_arg_list()> but expects to be passed
+the nodes that represent the interior of a list, like:
+
+ 'foo', 1, 2, 'bar'
+
+=item C<is_script( $document )>
+
+Given a L<PPI::Document>, test if it starts with C</#!.*/>. If so, it is
+judged to be a script instead of a module. See C<shebang_line()>.
+
+=item C<is_in_void_context( $token )>
+
+Given a L<PPI::Token>, answer whether it appears to be in a void context.
+
+=item C<policy_long_name( $policy_name )>
+
+Given a policy class name in long or short form, return the long form.
+
+=item C<policy_short_name( $policy_name )>
+
+Given a policy class name in long or short form, return the short form.
+
+=item C<all_perl_files( @directories )>
+
+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 4
+
+=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<severity_to_number( $severity )>
+
+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<is_valid_numeric_verbosity( $severity )>
+
+Answers whether the argument has a translation to a Violation format.
+
+=item C<verbosity_to_format( $verbosity_level )>
+
+Given a verbosity level between 1 and 10, returns the corresponding predefined
+format string. These formats are suitable for passing to the C<set_format>
+method in L<Perl::Critic::Violation>. See the L<perlcritic> documentation for
+a listing of the predefined formats.
+
+=item C<hashify( @list )>
+
+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<interpolate( $literal )>
+
+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<shebang_line( $document )>
+
+Given a L<PPI::Document>, test if it starts with C<#!>. If so, return that
+line. Otherwise return undef.
+
+=item C<words_from_string( $str )>
+
+Given config string I<$str>, return all the words from the string. This is
+safer than splitting on whitespace.
+
+=item C<is_unchecked_call( $element )>
+
+Given a L<PPI::Element>, test to see if it contains a function call whose
+return value is not checked.
+
+=back
+
+=head1 IMPORTABLE VARIABLES
+
+=over 8
+
+=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<$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<Perl::Critic::Policy>. The C<get_severity> and C<default_severity> 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<use Perl::Critic::Util> 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<is_function_call>,
+C<is_hash_key>,
+C<is_included_module_name>,
+C<is_integer>,
+C<is_method_call>,
+C<is_package_declaration>,
+C<is_perl_builtin>,
+C<is_perl_global>,
+C<is_perl_builtin_with_list_context>
+C<is_perl_builtin_with_multiple_arguments>
+C<is_perl_builtin_with_no_arguments>
+C<is_perl_builtin_with_one_argument>
+C<is_perl_builtin_with_optional_argument>
+C<is_perl_builtin_with_zero_and_or_one_arguments>
+C<is_script>,
+C<is_subroutine_name>,
+C<is_unchecked_call>
+C<is_valid_numeric_verbosity>
+
+See also L<Perl::Critic::Utils::PPI>.
+
+=item C<:data_conversion>
+
+Generic manipulation, not having anything specific to do with Perl::Critic.
+
+Includes:
+C<hashify>,
+C<words_from_string>,
+C<interpolate>
+
+=item C<:ppi>
+
+Things for dealing with L<PPI>, other than classification.
+
+Includes:
+C<first_arg>,
+C<parse_arg_list>
+
+See also L<Perl::Critic::Utils::PPI>.
+
+=item C<:internal_lookup>
+
+Translations between internal representations.
+
+Includes:
+C<severity_to_number>,
+C<verbosity_to_format>
+
+=item C<:language>
+
+Information about Perl not programmatically available elsewhere.
+
+Includes:
+C<precedence_of>
+
+=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<find_keywords>
+
+=back
+
+=head1 SEE ALSO
+
+L<Perl::Critic::Utils::Constants>,
+L<Perl::Critic::Utils::McCabe>,
+L<Perl::Critic::Utils::PPI>,
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Utils/Constants.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Utils::Constants;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ hashify };
+
+use base 'Exporter';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+our @EXPORT_OK = qw{
+ $PROFILE_STRICTNESS_WARN
+ $PROFILE_STRICTNESS_FATAL
+ $PROFILE_STRICTNESS_QUIET
+ $PROFILE_STRICTNESS_DEFAULT
+ %PROFILE_STRICTNESSES
+};
+
+our %EXPORT_TAGS = (
+ all => \@EXPORT_OK,
+ profile_strictness => [
+ qw{
+ $PROFILE_STRICTNESS_WARN
+ $PROFILE_STRICTNESS_FATAL
+ $PROFILE_STRICTNESS_QUIET
+ $PROFILE_STRICTNESS_DEFAULT
+ %PROFILE_STRICTNESSES
+ }
+ ],
+);
+
+#-----------------------------------------------------------------------------
+
+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,
+ );
+
+#-----------------------------------------------------------------------------
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=for stopwords
+
+=head1 NAME
+
+Perl::Critic::Utils::Constants - Global constants.
+
+=head1 DESCRIPTION
+
+Defines commonly used constants for L<Perl::Critic>.
+
+
+=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<perlcritic/"-profile-strictness"> 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.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Utils/DataConversion.pm $
+# $Date: 2007-09-02 21:31:09 -0500 (Sun, 02 Sep 2007) $
+# $Author: clonezone $
+# $Revision: 1859 $
+##############################################################################
+
+package Perl::Critic::Utils::DataConversion;
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Perl::Critic::Utils qw{ :characters :booleans };
+
+use base 'Exporter';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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)
+ return defined $_[0] ? $_[0] : $_[1];
+}
+
+#-----------------------------------------------------------------------------
+
+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 IMPORTABLE SUBS
+
+=over
+
+=item C<boolean_to_number( $value )>
+
+Return 0 or 1 based upon the value of parameter in a boolean context.
+
+
+=item C<dor( $value, $default )>
+
+Return either the value or the default based upon whether the value is
+defined or not.
+
+
+=item C<defined_or_empty( $value )>
+
+Return either the parameter or an empty string based upon whether the
+parameter is defined or not.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Utils/McCabe.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Utils::McCabe;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Readonly;
+
+use Perl::Critic::Utils qw{ :data_conversion :classification };
+
+use base 'Exporter';
+
+#-----------------------------------------------------------------------------
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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 Subroutines::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<http://www.sei.cmu.edu/str/descriptions/cyclomatic_body.html> for
+some discussion about the McCabe number and other complexity metrics.
+
+
+=head1 IMPORTABLE SUBS
+
+=over
+
+=item C<calculate_mccabe_of_sub( $sub )>
+
+Calculates an approximation of the McCabe number of the code in a
+L<PPI::Statement::Sub>.
+
+=item C<calculate_mccabe_of_main( $doc )>
+
+Calculates an approximation of the McCabe number of all the code in a
+L<PPI::Statement::Document> that is B<not> contained in a subroutine.
+
+=back
+
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Utils/POD.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Utils::POD;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw< -no_match_vars >;
+
+use IO::String ();
+use Pod::PlainText ();
+use Pod::Select ();
+
+# TODO: non-fatal generic?
+use Perl::Critic::Exception::Fatal::Generic qw< throw_generic >;
+use Perl::Critic::Exception::IO qw< throw_io >;
+use Perl::Critic::Utils qw< :characters >;
+
+use base 'Exporter';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+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<Could not find POD for "$module_name".>;
+
+ 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<Could not find POD for "$module_name".>;
+
+ return get_pod_section_from_file($file_name, $section_name);
+}
+
+#-----------------------------------------------------------------------------
+
+sub _get_pod_section_from_file {
+ my ($file_name, $section_name, $parser) = @_;
+
+ # Grr... the handle is open for a whopping 1 statement. Too painful to
+ # fix the policy right now.
+ ## no critic (RequireBriefOpen)
+ open my $file_handle, '<', $file_name
+ or throw_io
+ message => qq<Could not open "$file_name": $ERRNO>,
+ 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<Could not close "$file_name": $ERRNO>,
+ file_name => $file_name,
+ errno => $ERRNO;
+ ## use critic
+
+ 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<Could not find POD for "$module_name".>;
+
+ 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<Could not find POD for "$module_name".>;
+
+ return get_module_abstract_from_file($file_name);
+}
+
+#-----------------------------------------------------------------------------
+
+sub _get_module_abstract_from_file {
+ my ($file_name, $parser, $trimmer) = @_;
+
+ # Grr... the handle is open for a whopping 1 statement. Too painful to
+ # fix the policy right now.
+ ## no critic (RequireBriefOpen)
+ open my $file_handle, '<', $file_name
+ or throw_io
+ message => qq<Could not open "$file_name": $ERRNO>,
+ 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<Could not close "$file_name": $ERRNO>,
+ file_name => $file_name,
+ errno => $ERRNO;
+ ## use critic
+
+ 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<Malformed NAME section in "$name_section". >
+ . q<It must be on a single line>;
+ }
+ }
+ 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<Malformed NAME section in "$name_section".>;
+}
+
+#-----------------------------------------------------------------------------
+
+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 IMPORTABLE SUBROUTINES
+
+=over
+
+=item C<get_pod_file_for_module( $module_name )>
+
+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<get_raw_pod_section_from_file( $file_name, $section_name )>
+
+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<Perl::Critic::Exception::IO> if there's a problem with the
+file.
+
+
+=item C<get_raw_pod_section_from_filehandle( $file_handle, $section_name )>
+
+Does the same as C<get_raw_pod_section_from_file()>, but with a file
+handle.
+
+
+=item C<get_raw_pod_section_from_string( $source, $section_name )>
+
+Does the same as C<get_raw_pod_section_from_file()>, but with a string
+that contains the raw POD.
+
+
+=item C<get_raw_pod_section_for_module( $module_name, $section_name )>
+
+Does the same as C<get_raw_pod_section_from_file()>, but with a module
+name.
+
+Throws a L<Perl::Critic::Exception::Generic> if a file containing POD
+for the module can't be found.
+
+
+=item C<get_pod_section_from_file( $file_name, $section_name )>
+
+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<Perl::Critic::Exception::IO> if there's a problem with the
+file.
+
+
+=item C<get_pod_section_from_filehandle( $file_handle, $section_name )>
+
+Does the same as C<get_pod_section_from_file()>, but with a file
+handle.
+
+
+=item C<get_pod_section_from_string( $source, $section_name )>
+
+Does the same as C<get_pod_section_from_file()>, but with a string
+that contains the raw POD.
+
+
+=item C<get_pod_section_for_module( $module_name, $section_name )>
+
+Does the same as C<get_pod_section_from_file()>, but with a module
+name.
+
+Throws a L<Perl::Critic::Exception::Generic> if a file containing POD
+for the module can't be found.
+
+
+=item C<trim_raw_pod_section( $pod_section )>
+
+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<get_raw_pod_section_from_*> functions
+to get the "NAME" section of this module and then calling
+C<trim_raw_pod_section()> on the result would give you
+"Perl::Critic::Utils::POD - Utility functions for dealing with POD.".
+
+
+=item C<trim_pod_section( $pod_section )>
+
+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<trim_raw_pod_section()>.
+
+
+=item C<get_raw_module_abstract_from_file( $file_name )>
+
+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<Perl::Critic::Exception::Fatal::Generic>.
+
+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<get_raw_module_abstract_from_filehandle( $file_handle )>
+
+Does the same as C<get_raw_module_abstract_from_file()>, but with a
+file handle.
+
+
+=item C<get_raw_module_abstract_from_string( $source )>
+
+Does the same as C<get_raw_module_abstract_from_file()>, but with a
+string that contains the raw POD.
+
+
+=item C<get_raw_module_abstract_for_module( $module_name )>
+
+Does the same as C<get_raw_module_abstract_from_file()>, but for a
+module name.
+
+
+=item C<get_module_abstract_from_file( $file_name )>
+
+Does the same as C<get_raw_module_abstract_from_file()>, but with
+escapes interpreted.
+
+
+=item C<get_module_abstract_from_filehandle( $file_handle )>
+
+Does the same as C<get_module_abstract_from_file()>, but with a file
+handle.
+
+
+=item C<get_module_abstract_from_string( $source )>
+
+Does the same as C<get_module_abstract_from_file()>, but with a string
+that contains the raw POD.
+
+
+=item C<get_module_abstract_for_module( $module_name )>
+
+Does the same as C<get_module_abstract_from_file()>, but for a module
+name.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Utils/PPI.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Utils::PPI;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use base 'Exporter';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+our @EXPORT_OK = qw(
+ is_ppi_expression_or_generic_statement
+ is_ppi_generic_statement
+ is_ppi_statement_subclass
+);
+
+our %EXPORT_TAGS = (
+ all => \@EXPORT_OK,
+);
+
+#-----------------------------------------------------------------------------
+
+sub is_ppi_expression_or_generic_statement {
+ my $element = shift;
+
+ my $element_class = ref $element;
+
+ return 0 if not $element_class;
+ return 0 if not $element->isa('PPI::Statement');
+
+ return 1 if $element->isa('PPI::Statement::Expression');
+
+ return $element_class eq 'PPI::Statement';
+}
+
+#-----------------------------------------------------------------------------
+
+sub is_ppi_generic_statement {
+ my $element = shift;
+
+ my $element_class = ref $element;
+
+ return 0 if not $element_class;
+ return 0 if not $element->isa('PPI::Statement');
+
+ return $element_class eq 'PPI::Statement';
+}
+
+#-----------------------------------------------------------------------------
+
+sub is_ppi_statement_subclass {
+ my $element = shift;
+
+ my $element_class = ref $element;
+
+ return 0 if not $element_class;
+ return 0 if not $element->isa('PPI::Statement');
+
+ return $element_class ne 'PPI::Statement';
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=for stopwords
+
+=head1 NAME
+
+Perl::Critic::Utils::PPI - Utility functions for dealing with PPI objects.
+
+
+=head1 DESCRIPTION
+
+Provides classification of L<PPI::Elements>.
+
+
+=head1 IMPORTABLE SUBS
+
+=over
+
+=item C<is_ppi_expression_or_generic_statement( $element )>
+
+Answers whether the parameter is an expression or an undifferentiated
+statement. I.e. the parameter either is a
+L<PPI::Statement::Expression> or the class of the parameter is
+L<PPI::Statement> and not one of its subclasses other than
+C<Expression>.
+
+
+=item C<is_ppi_generic_statement( $element )>
+
+Answers whether the parameter is an undifferentiated statement, i.e.
+the parameter is a L<PPI::Statement> but not one of its subclasses.
+
+
+=item C<is_ppi_statement_subclass( $element )>
+
+Answers whether the parameter is a specialized statement, i.e. the
+parameter is a L<PPI::Statement> but the class of the parameter is not
+L<PPI::Statement>.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@galumph.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Utils/PPIRegexp.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::Utils::PPIRegexp;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw(-no_match_vars);
+use Readonly;
+use Carp qw(croak);
+
+use PPI::Node;
+
+use base 'Exporter';
+
+our $VERSION = '1.088';
+
+#-----------------------------------------------------------------------------
+
+our @EXPORT_OK = qw(
+ parse_regexp
+ get_match_string
+ get_substitute_string
+ get_modifiers
+ get_delimiters
+ ppiify
+);
+
+our %EXPORT_TAGS = (
+ all => \@EXPORT_OK,
+);
+
+#-----------------------------------------------------------------------------
+
+sub parse_regexp {
+ my ($elem) = @_;
+
+ eval { require Regexp::Parser; } or return;
+
+ my $re = get_match_string($elem);
+ return if !defined $re;
+
+ # Are there any external regexp modifiers? If so, embed the ones
+ # that matter before parsing.
+ my %modifiers = get_modifiers($elem);
+ my $mods = join q{}, map {$modifiers{$_} ? $_ : q{}} qw(i m x s);
+ if ($mods) {
+ $re = "(?$mods:$re)";
+ }
+
+ my $parser = Regexp::Parser->new;
+ # If we can't parse the regexp, don't return a parse tree
+ {
+ local $SIG{__WARN__} = sub {}; # blissful silence...
+ return if ! $parser->regex($re);
+ }
+
+ return $parser;
+}
+
+#-----------------------------------------------------------------------------
+
+sub get_match_string {
+ my ($elem) = @_;
+ return if !$elem->{sections};
+ my $section = $elem->{sections}->[0];
+ return if !$section;
+ return substr $elem->content, $section->{position}, $section->{size};
+}
+
+#-----------------------------------------------------------------------------
+
+sub get_substitute_string {
+ my ($elem) = @_;
+ return if !$elem->{sections};
+ my $section = $elem->{sections}->[1];
+ return if !$section;
+ return substr $elem->content, $section->{position}, $section->{size};
+}
+
+#-----------------------------------------------------------------------------
+
+sub get_modifiers {
+ my ($elem) = @_;
+ return if !$elem->{modifiers};
+ return %{ $elem->{modifiers} };
+}
+
+#-----------------------------------------------------------------------------
+
+sub get_delimiters {
+ my ($elem) = @_;
+ return if !$elem->{sections};
+ my @delimiters;
+ if (!$elem->{sections}->[0]->{type}) {
+ # PPI v1.118 workaround: the delimiters were not recorded in some cases
+ # hack: pull them out ourselves
+ # limitation: this regexp fails on s{foo}<bar>
+ my $operator = defined $elem->{operator} ? $elem->{operator} : q{};
+ @delimiters = join q{}, $elem =~ m/\A $operator (.).*?(.) (?:[xmsocgie]*) \z/mx;
+ } else {
+ @delimiters = ($elem->{sections}->[0]->{type});
+ if ($elem->{sections}->[1]) {
+ push @delimiters, $elem->{sections}->[1]->{type} || $delimiters[0];
+ }
+ }
+ return @delimiters;
+}
+
+#-----------------------------------------------------------------------------
+
+{
+ ## This nastiness is to auto-vivify PPI packages from Regexp::Parser classes
+
+ # Track which ones are already created
+ my %seen = ('Regexp::Parser::__object__' => 1);
+
+ sub _get_ppi_package {
+ my ($src_class, $re_node) = @_;
+ (my $dest_class = $src_class) =~ s/\A Regexp::Parser::/Perl::Critic::PPIRegexp::/mx;
+ if (!$seen{$src_class}) {
+ $seen{$src_class} = 1;
+ croak 'Regexp node which is not in the Regexp::Parser namespace'
+ if $dest_class eq $src_class;
+ my $src_isa_name = $src_class . '::ISA';
+ my $dest_isa_name = $dest_class . '::ISA';
+ my @isa;
+ for my $isa (eval "\@$src_isa_name") { ##no critic(Eval)
+ my $dest_isa = _get_ppi_package($isa, $re_node);
+ push @isa, $dest_isa;
+ }
+ eval "\@$dest_isa_name = qw(@isa)"; ##no critic(Eval)
+ croak $EVAL_ERROR if $EVAL_ERROR;
+ }
+ return $dest_class;
+ }
+}
+
+Readonly::Scalar my $NO_DEPTH_USED => -1;
+
+sub ppiify {
+ my ($re) = @_;
+ return if !$re;
+
+ # walk the Regexp::Parser tree, converting to PPI nodes as we go
+
+ my $ppire = PPI::Node->new;
+ my @stack = ($ppire);
+ my $iter = $re->walker;
+ my $last_depth = $NO_DEPTH_USED;
+ while (my ($node, $depth) = $iter->()) {
+ if ($last_depth > $depth) { # -> parent
+ # walker() creates pseudo-closing nodes for reasons I don't understand
+ while ($last_depth-- > $depth) {
+ pop @stack;
+ }
+ } else {
+ my $src_class = ref $node;
+ my $ppipkg = _get_ppi_package($src_class, $node);
+ my $ppinode = $ppipkg->new($node);
+ if ($last_depth == $depth) { # -> sibling
+ $stack[-1] = $ppinode;
+ } else { # -> child
+ push @stack, $ppinode;
+ }
+ $stack[-2]->add_element($ppinode); ## no critic qw(MagicNumbers)
+ }
+ $last_depth = $depth;
+ }
+ return $ppire;
+}
+
+{
+ package ## no critic (ProhibitMultiplePackages) # hide from PAUSE
+ Perl::Critic::PPIRegexp::__object__;
+ use base 'PPI::Node';
+
+ # Base wrapper class for PPI versions of Regexp::Parser classes
+
+ # This is a hack because we call everything PPI::Node instances instead of
+ # PPI::Token instances. One downside is that PPI::Dumper doesn't work on
+ # regexps.
+
+ sub new {
+ my ($class, $re_node) = @_;
+ my $self = $class->SUPER::new();
+ $self->{_re} = $re_node;
+ return $self;
+ }
+ sub content {
+ my ($self) = @_;
+ return $self->{_re}->visual;
+ }
+ sub re {
+ my ($self) = @_;
+ return $self->{_re};
+ }
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=for stopwords
+
+=head1 NAME
+
+Perl::Critic::Utils::PPIRegexp - Utility functions for dealing with PPI regexp tokens.
+
+=head1 SYNOPSIS
+
+ use Perl::Critic::Utils::PPIRegexp qw(:all);
+ use PPI::Document;
+ my $doc = PPI::Document->new(\'m/foo/');
+ my $elem = $doc->find('PPI::Token::Regexp::Match')->[0];
+ print get_match_string($elem); # yields 'foo'
+
+=head1 DESCRIPTION
+
+As of PPI v1.1xx, the PPI regexp token classes
+(L<PPI::Token::Regexp::Match>, L<PPI::Token::Regexp::Substitute> and
+L<PPI::Token::QuoteLike::Regexp>) has a very weak interface, so it is
+necessary to dig into internals to learn anything useful. This
+package contains subroutines to encapsulate that excess intimacy. If
+future versions of PPI gain better accessors, this package will start
+using those.
+
+=head1 IMPORTABLE SUBS
+
+=over
+
+=item C<parse_regexp( $token )>
+
+Parse the regexp token with L<Regexp::Parser>. If that module is not
+available or if there is a parse error, returns undef. If a parse success,
+returns a Regexp::Parser instance that can be used to walk the regexp object
+model.
+
+CAVEAT: This method pays special attention to the C<x> modifier to the regexp.
+If present, we wrap the regexp string in C<(?x:...)> to ensure a proper parse.
+This does change the object model though.
+
+Someday if PPI gets native Regexp support, this method may become deprecated.
+
+=item C<ppiify( $regexp )>
+
+Given a L<Regexp::Parser> instance (perhaps as returned from C<parse_regexp>)
+convert it to a tree of L<PPI::Node> instances. This is useful because PPI
+has a more familiar and powerful programming model than the Regexp::Parser
+object tree.
+
+Someday if PPI gets native Regexp support, this method may become a no-op.
+
+=item C<get_match_string( $token )>
+
+Returns the match portion of the regexp or undef if the specified
+token is not a regexp. Examples:
+
+ m/foo/; # yields 'foo'
+ s/foo/bar/; # yields 'foo'
+ / \A a \z /xms; # yields ' \\A a \\z '
+ qr{baz}; # yields 'baz'
+
+=item C<get_substitute_string( $token )>
+
+Returns the substitution portion of a search-and-replace regexp or
+undef if the specified token is not a valid regexp. Examples:
+
+ m/foo/; # yields undef
+ s/foo/bar/; # yields 'bar'
+
+=item C<get_modifiers( $token )>
+
+Returns a hash containing booleans for the modifiers of the regexp, or
+undef if the token is not a regexp.
+
+ /foo/xms; # yields (m => 1, s => 1, x => 1)
+ s/foo//; # yields ()
+ qr/foo/i; # yields (i => 1)
+
+=item C<get_delimiters( $token )>
+
+Returns one (or two for a substitution regexp) two-character strings
+indicating the delimiters of the regexp, or an empty list if the token is not
+a regular expression token. For example:
+
+ m/foo/; # yields ('//')
+ m#foo#; # yields ('##')
+ m<foo>; # yields ('<>')
+ s/foo/bar/; # yields ('//', '//')
+ s{foo}{bar}; # yields ('{}', '{}')
+ s{foo}/bar/; # yields ('{}', '//') valid, but yuck!
+ qr/foo/; # yields ('//')
+
+=back
+
+=head1 AUTHOR
+
+Chris Dolan <cdolan@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/lib/Perl/Critic/Violation.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package 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 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.088';
+
+#Class variables...
+our $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( 'PPI::Element' ) } ) {
+
+ if ( eval { $elem->isa( 'Perl::Critic::Document' ) } ) {
+ # break the facade, return the real PPI::Document
+ $elem = $elem->{_doc};
+ }
+ else {
+ throw_internal
+ '3rd arg to Violation->new() must be a PPI::Element';
+ }
+ }
+
+ #Create object
+ my $self = bless {}, $class;
+ $self->{_description} = $desc;
+ $self->{_explanation} = $expl;
+ $self->{_severity} = $sev;
+ $self->{_policy} = caller;
+ $self->{_elem} = $elem;
+
+ # Do these now before the weakened $doc gets garbage collected
+ my $top = $elem->top();
+ $self->{_filename} = $top->can('filename') ? $top->filename() : undef;
+ $self->{_source} = _first_line_of_source( $elem );
+
+ 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
+
+ ## no critic qw(RequireSimpleSort);
+ ## 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
+
+ ## no critic qw(RequireSimpleSort);
+ ## 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} ||= $self->{_elem}->location() || [0,0,0];
+}
+
+#-----------------------------------------------------------------------------
+
+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 source {
+ my $self = shift;
+ return $self->{_source};
+}
+
+#-----------------------------------------------------------------------------
+
+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->filename() },
+ 'F' => sub { basename( $self->filename()) },
+ 'l' => sub { $self->location->[0] },
+ 'c' => sub { $self->location->[1] },
+ '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<cmp> 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 _first_line_of_source {
+ my $elem = shift;
+
+ my $stmnt = $elem->statement() || $elem;
+ my $code_string = $stmnt->content() || $EMPTY;
+
+ #Chop everything but the first line (without newline);
+ $code_string =~ s{ \n.* }{}smx;
+ return $code_string;
+}
+
+
+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<Perl::Critic> don't have to know anything
+about L<PPI>. The C<violations> method of all L<Perl::Critic::Policy>
+subclasses must return a list of these Perl::Critic::Violation
+objects.
+
+=head1 CONSTRUCTOR
+
+=over 8
+
+=item C<new( $description, $explanation, $element, $severity )>
+
+Returns a reference to a new C<Perl::Critic::Violation> 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<PPI> element that caused
+the violation, and the severity of the violation (as an integer).
+
+=back
+
+=head1 METHODS
+
+=over 8
+
+=item C<description()>
+
+Returns a brief description of the specific violation. In other
+words, this value may change on a per violation basis.
+
+=item C<explanation()>
+
+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<location()>
+
+Returns a three-element array reference containing the line and real
+& virtual column numbers where this Violation occurred, as in
+L<PPI::Element>.
+
+=item C<filename()>
+
+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<severity()>
+
+Returns the severity of this Violation as an integer ranging from 1 to
+5, where 5 is the "most" severe.
+
+=item C<sort_by_severity( @violation_objects )>
+
+If you need to sort Violations by severity, use this handy routine:
+
+ @sorted = Perl::Critic::Violation::sort_by_severity(@violations);
+
+=item C<sort_by_location( @violation_objects )>
+
+If you need to sort Violations by location, use this handy routine:
+
+ @sorted = Perl::Critic::Violation::sort_by_location(@violations);
+
+=item C<diagnostics()>
+
+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<DESCRIPTION> section of the Policy module's POD.
+
+=item C<policy()>
+
+Returns the name of the L<Perl::Critic::Policy> that created this
+Violation.
+
+=item C<source()>
+
+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 first line will be returned.
+
+=item C<set_format( $FORMAT )>
+
+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<get_format()>
+
+Class method. Returns the current format for all Violation objects
+when they are evaluated in string context.
+
+=item C<to_string()>
+
+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 FIELDS
+
+=over 8
+
+=item C<$Perl::Critic::Violation::FORMAT>
+
+B<DEPRECATED:> Use the C<set_format> and C<get_format> methods instead.
+
+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. If you want to change C<$FORMAT>, you
+should probably localize it first.
+
+=back
+
+=head1 OVERLOADS
+
+Perl::Critic::Violation overloads the C<""> operator to produce neat
+little messages when evaluated in string context. The format depends
+on the current value of the C<$FORMAT> package variable.
+
+Formats are a combination of literal and escape characters similar to
+the way C<sprintf> works. If you want to know the specific formatting
+capabilities, look at L<String::Format>. 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
+
+Here are some examples:
+
+ $Perl::Critic::Violation::FORMAT = "%m at line %l, column %c.\n";
+ #looks like "Mixed case variable name at line 6, column 23."
+
+ $Perl::Critic::Violation::FORMAT = "%m near '%r'\n";
+ #looks like "Mixed case variable name near 'my $theGreatAnswer = 42;'"
+
+ $Perl::Critic::Violation::FORMAT = "%l:%c:%p\n";
+ #looks like "6:23:NamingConventions::ProhibitMixedCaseVars"
+
+ $Perl::Critic::Violation::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 <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/00_modules.t $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+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.088';
+
+#-----------------------------------------------------------------------------
+
+Perl::Critic::TestUtils::block_perlcriticrc();
+
+my @bundled_policy_names = bundled_policy_names();
+
+my @concrete_exceptions = qw{
+ AggregateConfiguration
+ Configuration::Generic
+ 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 =>
+ 108
+ + ( 9 * scalar @concrete_exceptions )
+ + ( 14 * 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't continue.>);
+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't continue.>);
+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', 'criticism_fatal');
+can_ok('Perl::Critic::Config', 'site_policy_names');
+
+#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't continue.>);
+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', 'criticism_fatal');
+
+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't continue.>);
+can_ok('Perl::Critic::Policy', 'add_themes');
+can_ok('Perl::Critic::Policy', 'applies_to');
+can_ok('Perl::Critic::Policy', 'default_severity');
+can_ok('Perl::Critic::Policy', 'default_themes');
+can_ok('Perl::Critic::Policy', 'get_severity');
+can_ok('Perl::Critic::Policy', 'get_themes');
+can_ok('Perl::Critic::Policy', 'new');
+can_ok('Perl::Critic::Policy', 'set_severity');
+can_ok('Perl::Critic::Policy', 'set_themes');
+can_ok('Perl::Critic::Policy', 'violates');
+can_ok('Perl::Critic::Policy', 'violation');
+
+
+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't continue.>);
+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't continue.>);
+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't continue.>);
+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't continue.>);
+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't continue.>);
+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't continue.>);
+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 module interface for exceptions
+
+{
+ foreach my $class (
+ map { "Perl::Critic::Exception::$_" } @concrete_exceptions
+ ) {
+ use_ok($class) or BAIL_OUT(q<Can't continue.>);
+ 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't continue.>);
+ 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, 'new');
+ can_ok($mod, 'set_severity');
+ can_ok($mod, 'set_themes');
+ can_ok($mod, 'set_themes');
+ can_ok($mod, 'violates');
+ can_ok($mod, 'violation');
+
+ my $policy = $mod->new();
+ isa_ok($policy, 'Perl::Critic::Policy');
+ is($policy->VERSION(), $version_string, "Version of $mod");
+ }
+}
+
+#-----------------------------------------------------------------------------
+# 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 run 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 :
--- /dev/null
+# 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
+
+# Test non-existent parameter
+[BuiltinFunctions::RequireBlockGrep]
+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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/01_config.t $
+# $Date: 2008-06-21 19:57:54 -0700 (Sat, 21 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2464 $
+##############################################################################
+
+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< :severities >;
+
+use Test::More tests => 66;
+
+
+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;
+
+#-----------------------------------------------------------------------------
+# 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;
+ }
+}
+
+#-----------------------------------------------------------------------------
+# 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 : '<undef>';
+# 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<There are no enabled policies>,
+# "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 $last_policy_count = 0;
+ my $severity = $SEVERITY_HIGHEST;
+ for my $index ( 0 .. $#names_of_policies_willing_to_work ) {
+ $severity-- if $index && $index % 10 == 0;
+ $severity = $SEVERITY_LOWEST if $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' );
+}
+
+#-----------------------------------------------------------------------------
+#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::ProhibitMixedCaseVars' => {},
+ '-NamingConventions::ProhibitMixedCaseSubs' => {},
+ '-Miscellanea::RequireRcsKeywords' => {},
+ );
+
+ my @include = qw(mixedcase RCS);
+ 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 !~ /$_/imx} @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/imx} @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/imx} @pol_names]},
+ 'include/exclude pattern match had "builtinfunc" policies',
+ );
+}
+
+#-----------------------------------------------------------------------------
+# Test the switch behavior
+
+{
+ my @switches = qw(
+ -top
+ -verbose
+ -theme
+ -severity
+ -only
+ -force
+ -color
+ -criticism-fatal
+ );
+
+ 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(), 1, 'Undefined -color');
+ is( $c->verbose(), 4, 'Undefined -verbose');
+ is( $c->criticism_fatal(), 0, 'Undefined -criticism-fatal');
+
+ my %zero_args = map { $_ => 0 } @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(), 0, 'zero -color');
+ 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(), 0, 'empty -color');
+ is( $c->verbose(), 4, 'empty -verbose');
+ is( $c->criticism_fatal(), 0, 'empty -criticism-fatal');
+}
+
+#-----------------------------------------------------------------------------
+# Test the -only switch
+
+{
+ my %profile = (
+ '-NamingConventions::ProhibitMixedCaseVars' => {},
+ 'NamingConventions::ProhibitMixedCaseSubs' => {},
+ 'Miscellanea::RequireRcsKeywords' => {},
+ );
+
+ 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<There are no enabled policies>,
+# "got correct exception message with -only switch, empty profile.",
+# );
+}
+
+#-----------------------------------------------------------------------------
+# Test the -single-policy switch
+
+{
+ my %pc_config = ('-single-policy' => 'ProhibitEvilModules');
+ 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 );
+ my %profile = ( '__defaults__' => \%true_defaults );
+
+ my %pc_config = (-force => 0, -only => 0, -top => 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');
+}
+
+#-----------------------------------------------------------------------------
+# 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/, 'add_policy w/ bad args' );
+
+ # Try adding w/o policy
+ eval { $config->add_policy() };
+ like( $EVAL_ERROR, qr/The -policy argument is required/, '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/,
+ 'invalid severity'
+ );
+
+ # Try using vague -single-policy option
+ eval{ Perl::Critic::Config->new( '-single-policy' => '.*' ) };
+ like( $EVAL_ERROR, qr/matched multiple policies/, '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/, 'invalid -single-policy' );
+}
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/01_config_bad_perlcriticrc.t $
+# $Date: 2008-06-21 19:57:54 -0700 (Sat, 21 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2464 $
+##############################################################################
+
+
+# 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;
+
+plan tests => 13;
+
+Readonly::Scalar my $PROFILE => 't/01_bad_perlcriticrc';
+Readonly::Scalar my $NO_ENABLED_POLICIES_MESSAGE =>
+ q<There are no enabled policies.>;
+Readonly::Scalar my $INVALID_PARAMETER_MESSAGE =>
+ q<The BuiltinFunctions::RequireBlockGrep policy doesn't take a "no_such_parameter" option.>;
+Readonly::Scalar my $REQUIRE_POD_SECTIONS_SOURCE_MESSAGE_PREFIX =>
+ q<The value for the Documentation::RequirePodSections "source" option ("Zen_and_the_Art_of_Motorcycle_Maintenance") is not one of the allowed values: >;
+
+eval {
+ my $critic = 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',
+ );
+
+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
+>;
+
+my %expected_regexes =
+ map
+ { $_ => generate_global_message_regex( $_, $PROFILE ) }
+ @parameters;
+
+my $expected_exceptions = 2 + scalar @parameters;
+is(
+ scalar @exceptions,
+ $expected_exceptions,
+ 'should have received the correct number of exceptions'
+);
+if (@exceptions != $expected_exceptions) {
+ diag "Exception: $_" foreach @exceptions;
+}
+
+while (my ($parameter, $regex) = each %expected_regexes) {
+ is(
+ ( scalar grep { m/$regex/ } @exceptions ),
+ 1,
+ "should have received one and only one exception for $parameter",
+ );
+}
+
+is(
+ ( scalar grep { $INVALID_PARAMETER_MESSAGE eq $_ } @exceptions ),
+ 1,
+ "should 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 run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/01_policy_config.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Carp qw< confess >;
+
+use Test::More tests => 29;
+
+#-----------------------------------------------------------------------------
+
+BEGIN {
+ use_ok('Perl::Critic::PolicyConfig') or confess 'No point in continuing.';
+}
+
+
+{
+ 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 run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/02_policy.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw<-no_match_vars>;
+
+use Test::More tests => 26;
+
+
+#-----------------------------------------------------------------------------
+# 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.
+
+package PolicyTest;
+use base 'Perl::Critic::Policy';
+
+package PolicyTestOverriddenDefaultMaximumViolations;
+use base 'Perl::Critic::Policy';
+
+sub default_maximum_violations_per_document { return 31; }
+
+#-----------------------------------------------------------------------------
+
+package main;
+
+my $p = PolicyTest->new();
+isa_ok($p, 'PolicyTest');
+
+
+eval { $p->violates(); };
+ok($EVAL_ERROR, 'abstract violates() throws exception');
+
+
+# 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<default_maximum_violations_per_document() hasn't changed>,
+);
+is(
+ $p->get_maximum_violations_per_document(),
+ 3,
+ q<get_maximum_violations_per_document() returns new value>,
+);
+
+
+my $overridden_default = PolicyTestOverriddenDefaultMaximumViolations->new();
+isa_ok($overridden_default, 'PolicyTestOverriddenDefaultMaximumViolations');
+
+# 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<default_maximum_violations_per_document() overridden hasn't changed>,
+);
+is(
+ $overridden_default->get_maximum_violations_per_document(),
+ undef,
+ q<get_maximum_violations_per_document() overridden returns new undefined value>,
+);
+
+
+# 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 ); #Still the same
+is( $p->get_severity(), 3 ); #Should have new value
+
+
+# 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()], [] ); #Still the same
+is_deeply( [$p->get_themes()], [qw(a b c)] ); #Should have new value, sorted
+
+# Append theme
+$p->add_themes( qw(f e d) ); #unsorted
+
+# Test theme again...
+is_deeply( [$p->default_themes()], [] ); #Still the same
+is_deeply( [$p->get_themes()], [ qw(a b c d e f) ] ); #Should have new value, sorted
+
+
+# Test format getter/setters
+is( Perl::Critic::Policy::get_format, "%p\n", '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 run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/03_pragmas.t $
+# $Date: 2008-06-29 11:47:22 -0700 (Sun, 29 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2483 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Test::More (tests => 28);
+use Perl::Critic::PolicyFactory (-test => 1);
+
+# common P::C testing tools
+use Perl::Critic::TestUtils qw(critique);
+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::RequireRcsKeywords' => {},
+ '-ValuesAndExpressions::ProhibitMagicNumbers' => {},
+};
+
+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'
+);
+
+#-----------------------------------------------------------------------------
+
+$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,
+ 'inline no-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
+
+## 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)
+
+# no 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;
+
+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',
+);
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/04_optionsprocessor.t $
+# $Date: 2008-06-08 20:41:30 -0500 (Sun, 08 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2430 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw(-no_match_vars);
+
+use Perl::Critic::OptionsProcessor;
+
+use Test::More tests => 24;
+
+#-----------------------------------------------------------------------------
+
+{
+ 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(), 1, 'native default color');
+ 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');
+}
+
+#-----------------------------------------------------------------------------
+
+{
+ my %user_defaults = (
+ force => 1,
+ only => 1,
+ severity => 4,
+ theme => 'pbp',
+ top => 50,
+ color => 0,
+ verbose => 7,
+ 'criticism-fatal' => 1,
+ include => 'foo bar',
+ exclude => 'baz nuts',
+ );
+
+ 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(), 0, 'user default color');
+ 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');
+}
+
+#-----------------------------------------------------------------------------
+
+{
+ my $processor = Perl::Critic::OptionsProcessor->new( 'colour' => 1 );
+ is($processor->color(), 1, 'user default colour true');
+
+ $processor = Perl::Critic::OptionsProcessor->new( 'colour' => 0 );
+ is($processor->color(), 0, 'user default colour false');
+}
+
+#-----------------------------------------------------------------------------
+# 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/m, 'First invalid default' );
+ like( $EVAL_ERROR, qr/"bar" is not a supported option/m, 'Second invalid default' );
+
+}
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/05_utils.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use PPI::Document;
+
+use Test::More tests => 115;
+
+#-----------------------------------------------------------------------------
+
+BEGIN
+{
+ # Needs to be in BEGIN for global vars
+ use_ok('Perl::Critic::Utils', qw{ :all } );
+}
+
+#-----------------------------------------------------------------------------
+# export tests
+
+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, ' ', 'character constants');
+is($SEVERITY_LOWEST, 1, 'severity constants');
+is($POLICY_NAMESPACE, 'Perl::Critic::Policy', 'Policy namespace');
+
+#-----------------------------------------------------------------------------
+# find_keywords tests
+
+sub count_matches { my $val = shift; return defined $val ? scalar @$val : 0; }
+sub make_doc { my $code = shift; return PPI::Document->new( ref $code ? $code : \$code); }
+
+{
+ 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');
+}
+
+#-----------------------------------------------------------------------------
+# is_hash_key tests
+
+{
+ 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');
+ }
+}
+
+#-----------------------------------------------------------------------------
+# is_script tests
+
+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",
+);
+
+for my $code (@good) {
+ my $doc = PPI::Document->new(\$code) || die;
+ $doc->index_locations();
+ ok(is_script($doc), 'is_script, true');
+}
+
+for my $code (@bad) {
+ my $doc = PPI::Document->new(\$code) || die;
+ $doc->index_locations();
+ ok(!is_script($doc), 'is_script, false');
+}
+
+#-----------------------------------------------------------------------------
+# is_perl_builtin tests
+
+{
+ is( is_perl_builtin('print'), 1, 'Is perl builtin function' );
+ isnt( is_perl_builtin('foobar'), 1, 'Is not perl builtin function' );
+
+ my $code = 'sub print {}';
+ my $doc = make_doc( $code );
+ my $sub = $doc->find_first('Statement::Sub');
+ is( is_perl_builtin($sub), 1, 'Is perl builtin function (PPI)' );
+
+ $code = 'sub foobar {}';
+ $doc = make_doc( $code );
+ $sub = $doc->find_first('Statement::Sub');
+ isnt( is_perl_builtin($sub), 1, 'Is not perl builtin function (PPI)' );
+
+}
+
+#-----------------------------------------------------------------------------
+# is_perl_global tests
+
+{
+ is( is_perl_global('$OSNAME'), 1, '$OSNAME is a perl global var' );
+ is( is_perl_global('*STDOUT'), 1, '*STDOUT is a perl global var' );
+ isnt( is_perl_global('%FOOBAR'), 1, '%FOOBAR is a not perl global var' );
+
+ my $code = '$OSNAME';
+ my $doc = make_doc($code);
+ my $var = $doc->find_first('Token::Symbol');
+ is( is_perl_global($var), 1, '$OSNAME is perl a global var (PPI)' );
+
+ $code = '*STDOUT';
+ $doc = make_doc($code);
+ $var = $doc->find_first('Token::Symbol');
+ is( is_perl_global($var), 1, '*STDOUT is perl a global var (PPI)' );
+
+ $code = '%FOOBAR';
+ $doc = make_doc($code);
+ $var = $doc->find_first('Token::Symbol');
+ isnt( is_perl_global($var), 1, '%FOOBAR is not a perl global var (PPI)' );
+
+}
+
+#-----------------------------------------------------------------------------
+# precedence_of tests
+
+{
+
+ cmp_ok( precedence_of('*'), '<', precedence_of('+'), '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)' );
+
+}
+
+#-----------------------------------------------------------------------------
+# is_subroutine_name tests
+
+{
+
+ my $code = 'sub foo {}';
+ my $doc = make_doc( $code );
+ my $word = $doc->find_first( sub { $_[1] eq 'foo' } );
+ is( is_subroutine_name( $word ), 1, 'Is a subroutine name');
+
+ $code = '$bar = foo()';
+ $doc = make_doc( $code );
+ $word = $doc->find_first( sub { $_[1] eq 'foo' } );
+ isnt( is_subroutine_name( $word ), 1, 'Is not a subroutine name');
+
+}
+
+#-----------------------------------------------------------------------------
+# policy_long_name and policy_short_name tests
+
+{
+ 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' );
+}
+
+#-----------------------------------------------------------------------------
+# interpolate() tests
+
+is( interpolate( '\r%l\t%c\n' ), "\r%l\t%c\n", 'Interpolation' );
+is( interpolate( 'literal' ), "literal", 'Interpolation' );
+
+
+#-----------------------------------------------------------------------------
+# Test _is_perl() and shebang_line() subroutines.
+
+{
+ 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: '$_'} );
+ }
+
+ use File::Temp qw<tempfile>;
+
+ 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 ($fh, $filename) = tempfile() or die 'Could not open tempfile';
+ print {$fh} "$shebang\n"; close $fh; # Must close to flush buffer
+ 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<shebang_line($shebang)>,
+ );
+ }
+
+ my @not_perl_shebangs = (
+ 'shazbot',
+ '#!/usr/bin/ruby',
+ '#!/bin/env python',
+ );
+
+ for my $shebang (@not_perl_shebangs) {
+ my ($fh, $filename) = tempfile or die 'Could not open tempfile';
+ print {$fh} "$shebang\n"; close $fh; # Must close to flush buffer
+ 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<shebang_line($shebang)>,
+ );
+ }
+}
+
+#-----------------------------------------------------------------------------
+# _is_backup() tests
+
+{
+ 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: '$_'} );
+ }
+}
+
+#-----------------------------------------------------------------------------
+# first_arg tests
+
+{
+ 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) {
+ 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);
+ }
+}
+
+#-----------------------------------------------------------------------------
+# parse_arg_list tests
+
+{
+ 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" );
+ }
+}
+
+#-----------------------------------------------------------------------------
+
+{
+ 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');
+}
+
+#-----------------------------------------------------------------------------
+
+
+use Perl::Critic::PolicyFactory;
+use Perl::Critic::TestUtils qw(bundled_policy_names);
+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');
+
+#-----------------------------------------------------------------------------
+# is_unchecked_call tests
+{
+ 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 die '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 },
+ );
+
+ foreach my $trial ( @trials ) {
+ my $doc = make_doc( $trial->{'code'} );
+ my $statement = $doc->find_first( sub { $_[1] eq 'open' } );
+ if ( $trial->{'pass'} ) {
+ ok( is_unchecked_call( $statement ), 'is_unchecked_call returns true' );
+ } else {
+ ok( ! is_unchecked_call( $statement ), 'is_unchecked_call returns false' );
+ }
+ }
+}
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/05_utils_pod.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw< -no_match_vars >;
+use Readonly;
+use Carp qw< confess >;
+
+use Test::More tests => 62;
+
+#-----------------------------------------------------------------------------
+
+Readonly::Scalar my $EXCEPTION_MESSAGE_REGEX =>
+ qr<malformed [ ] name [ ] section>xmsi;
+
+#-----------------------------------------------------------------------------
+
+BEGIN {
+ use_ok('Perl::Critic::Utils::POD', qw< :all >)
+ or confess 'No point in continuing.';
+}
+
+
+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<my $x = 3;>;
+
+ my $pod = get_raw_pod_section_from_string( $code, 'SYNOPSIS' );
+
+ is(
+ $pod,
+ undef,
+ qq<get_raw_pod_section_from_string($code, 'SYNOPSIS')>,
+ );
+
+ $pod = get_pod_section_from_string( $code, 'SYNOPSIS' );
+
+ is(
+ $pod,
+ undef,
+ qq<get_pod_section_from_string($code, 'SYNOPSIS')>,
+ );
+}
+
+
+{
+ my $code = <<'END_CODE';
+=pod
+END_CODE
+
+ my $pod = get_raw_pod_section_from_string( $code, 'SYNOPSIS' );
+
+ is(
+ $pod,
+ undef,
+ q<get_raw_pod_section_from_string('=pod', 'SYNOPSIS')>,
+ );
+
+ $pod = get_pod_section_from_string( $code, 'SYNOPSIS' );
+
+ is(
+ $pod,
+ undef,
+ q<get_pod_section_from_string('=pod', 'SYNOPSIS')>,
+ );
+}
+
+
+{
+ 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<get_raw_pod_section_from_string('=head1 FOO Some plain text.', 'FOO')>,
+ );
+
+ $pod = get_pod_section_from_string( $code, 'FOO' );
+
+ $expected = <<'END_EXPECTED';
+FOO
+ Some plain text.
+
+END_EXPECTED
+ is(
+ $pod,
+ $expected,
+ q<get_pod_section_from_string('=head1 FOO Some plain text.', 'FOO')>,
+ );
+}
+
+
+{
+ my $code = <<'END_CODE';
+=pod
+
+=head1 FOO
+
+Some C<escaped> text.
+
+=cut
+END_CODE
+
+ my $pod = get_raw_pod_section_from_string( $code, 'FOO' );
+
+ my $expected = <<'END_EXPECTED';
+=head1 FOO
+
+Some C<escaped> text.
+
+END_EXPECTED
+ is(
+ $pod,
+ $expected,
+ q/get_raw_pod_section_from_string('=head1 FOO Some C<escaped> 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<escaped> 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<get_raw_pod_section_from_string('=head1 FOO ... =head1 BAR', 'FOO')>,
+ );
+
+ $pod = get_pod_section_from_string( $code, 'FOO' );
+
+ $expected = <<'END_EXPECTED';
+FOO
+ Some plain text.
+
+END_EXPECTED
+ is(
+ $pod,
+ $expected,
+ q<get_pod_section_from_string('=head1 FOO ... =head1 BAR', 'FOO')>,
+ );
+}
+
+
+{
+ 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<get_raw_pod_section_from_string('=head1 FOO ... =head2 BAR', 'FOO')>,
+ );
+
+ $pod = get_pod_section_from_string( $code, 'FOO' );
+
+ $expected = <<'END_EXPECTED';
+FOO
+ Some plain text.
+
+ BAR
+
+END_EXPECTED
+ is(
+ $pod,
+ $expected,
+ q<get_pod_section_from_string('=head1 FOO ... =head2 BAR', 'FOO')>,
+ );
+}
+
+{
+ 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<get_raw_pod_section_from_string('=head2 FOO Some plain text.', 'FOO')>,
+ );
+
+ $pod = get_pod_section_from_string( $code, 'FOO' );
+
+ is(
+ $pod,
+ undef,
+ q<get_pod_section_from_string('=head2 FOO Some plain text.', 'FOO')>,
+ );
+}
+
+#-----------------------------------------------------------------------------
+
+{
+ 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<We like talking dirty. We smoke and we drink. >
+ . qq<We're KMFDM and all other bands\n>
+ . q<stink.>;
+
+ 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<You see, I believe in the noble, aristocratic art of doin' >
+ . qq<absolutely nothin'.\n>
+ . q<And I hope someday to be in a position where I can do even >
+ . q<less.>;
+
+ 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<Some indented text.>;
+
+ 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<An abstract.>;
+
+ my $result = get_raw_module_abstract_from_string( $source );
+
+ is(
+ $result,
+ $expected,
+ q<get_raw_module_abstract_from_string() with proper abstract>,
+ );
+
+ $result = get_module_abstract_from_string( $source );
+
+ is(
+ $result,
+ $expected,
+ q<get_module_abstract_from_string() with proper abstract>,
+ );
+}
+
+
+{
+ my $source = <<'END_MODULE';
+
+=head1 NAME
+
+A::Stupendous::Code::Module - An abstract involving C<$code>.
+
+END_MODULE
+
+ my $expected = q<An abstract involving C<$code>.>;
+
+ my $result = get_raw_module_abstract_from_string( $source );
+
+ is(
+ $result,
+ $expected,
+ q<get_raw_module_abstract_from_string() with proper abstract>,
+ );
+
+ $expected = q<An abstract involving `$code'.>;
+
+ $result = get_module_abstract_from_string( $source );
+
+ is(
+ $result,
+ $expected,
+ q<get_module_abstract_from_string() with proper abstract>,
+ );
+}
+
+
+{
+ 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<get_raw_module_abstract_from_string() with no name section>,
+ );
+
+ $result = get_module_abstract_from_string( $source );
+
+ is(
+ $result,
+ undef,
+ q<get_module_abstract_from_string() with no name section>,
+ );
+}
+
+
+{
+ my $source = <<'END_MODULE';
+
+=head1 NAME
+
+=head1 DESCRIPTION
+
+END_MODULE
+
+ my $result = get_raw_module_abstract_from_string( $source );
+
+ is(
+ $result,
+ undef,
+ q<get_raw_module_abstract_from_string() without NAME section content>,
+ );
+
+ $result = get_module_abstract_from_string( $source );
+
+ is(
+ $result,
+ undef,
+ q<get_module_abstract_from_string() without NAME section content>,
+ );
+}
+
+
+{
+ 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<get_raw_module_abstract_from_string() with no abstract>,
+ );
+
+ $result = get_module_abstract_from_string( $source );
+
+ is(
+ $result,
+ undef,
+ q<get_module_abstract_from_string() with no abstract>,
+ );
+}
+
+
+{
+ 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<get_raw_module_abstract_from_string() with hyphen but no abstract>,
+ );
+
+ $result = get_module_abstract_from_string( $source );
+
+ is(
+ $result,
+ undef,
+ q<get_module_abstract_from_string() with hyphen but no abstract>,
+ );
+}
+
+
+{
+ 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<with abstract but no hyphen>,
+ );
+
+ test_exception_from_get_module_abstract_from_string(
+ $source, q<with abstract but no hyphen>,
+ );
+}
+
+
+{
+ 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<with double hyphen>,
+ );
+
+ test_exception_from_get_module_abstract_from_string(
+ $source, q<with double hyphen>,
+ );
+}
+
+
+{
+ 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<with multiple lines>,
+ );
+
+# Cannot do this test: Pod::PlainText merges the lines.
+# test_exception_from_get_module_abstract_from_string(
+# $source, q<with multiple lines>,
+# );
+}
+
+#-----------------------------------------------------------------------------
+
+sub test_exception_from_get_raw_module_abstract_from_string {
+ my ($source, $name) = @_;
+
+ my $result;
+ my $message_like_name =
+ qq<Got expected message for get_raw_module_abstract_from_string() $name>;
+
+ 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<Got expected message for get_module_abstract_from_string() $name>;
+
+ 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<Got the right kind of exception for get_module_abstract_from_string() $name>,
+ )
+ ) {
+ like( $exception->message(), $EXCEPTION_MESSAGE_REGEX, $message_like_name );
+ }
+ else {
+ diag( 'Result: ', (defined $result ? ">$result<" : '<undef>') );
+ if ($eval_error) {
+ diag(
+ qq<However, did get an exception: $eval_error>,
+ );
+ like( $eval_error, $EXCEPTION_MESSAGE_REGEX, $message_like_name );
+ }
+ else {
+ fail($message_like_name);
+ }
+ }
+
+ return;
+}
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/05_utils_ppi.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+use Readonly;
+
+use Test::More tests => 67;
+
+#-----------------------------------------------------------------------------
+
+my @PPI_STATEMENT_CLASSES;
+
+BEGIN {
+ @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
+ };
+
+ use_ok('PPI::Token::Word');
+ foreach my $class (@PPI_STATEMENT_CLASSES) {
+ use_ok($class);
+ }
+
+ use_ok('Perl::Critic::Utils::PPI', qw{ :all } );
+}
+
+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');
+
+#-----------------------------------------------------------------------------
+# 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 )',
+ );
+}
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/06_violation.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+use PPI::Document;
+use English qw(-no_match_vars);
+use Test::More tests => 41;
+
+#-----------------------------------------------------------------------------
+
+BEGIN
+{
+ # Needs to be in BEGIN for global vars
+ use_ok('Perl::Critic::Violation');
+}
+
+use lib qw(t/tlib);
+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');
+
+#-----------------------------------------------------------------------------
+# 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');
+
+#-----------------------------------------------------------------------------
+# Accessor tests
+
+my $pkg = __PACKAGE__;
+my $code = 'Hello World;';
+my $doc = PPI::Document->new(\$code);
+my $no_diagnostics_msg = qr/ \s* No [ ] diagnostics [ ] available \s* /xms;
+my $viol = Perl::Critic::Violation->new( 'Foo', 'Bar', $doc, 99, );
+
+my $expected_location = [1,1,1];
+
+is( $viol->description(), 'Foo', 'description');
+is( $viol->explanation(), 'Bar', 'explanation');
+is_deeply( $viol->location(), $expected_location, 'location');
+is( $viol->severity(), 99, 'severity');
+is( $viol->source(), $code, 'source');
+is( $viol->policy(), $pkg, 'policy');
+like( $viol->diagnostics(), qr/ \A $no_diagnostics_msg \z /xms, 'diagnostics');
+
+{
+ local $Perl::Critic::Violation::FORMAT = '%l,%c,%m,%e,%p,%d,%r';
+ my $expect = qr/\A $expected_location->[0],$expected_location->[1],Foo,Bar,$pkg,$no_diagnostics_msg,\Q$code\E \z/xms;
+
+ like($viol->to_string(), $expect, 'to_string');
+ like("$viol", $expect, 'stringify');
+}
+
+$viol = Perl::Critic::Violation->new('Foo', [28], $doc, 99);
+is($viol->explanation(), 'See page 28 of PBP', 'explanation');
+
+$viol = Perl::Critic::Violation->new('Foo', [28,30], $doc, 99);
+is($viol->explanation(), 'See pages 28,30 of PBP', 'explanation');
+
+
+#-----------------------------------------------------------------------------
+# Import tests
+like(ViolationTest->get_violation()->diagnostics(),
+ qr/ \A \s* This [ ] is [ ] a [ ] test [ ] diagnostic\. \s*\z /xms, 'import diagnostics');
+
+#-----------------------------------------------------------------------------
+# Violation sorting
+
+SKIP: {
+
+ #For reasons I don't yet understand these tests fail
+ #on my perl at work. So for now, I just skip them.
+ skip( 'Broken on perls <= 5.6.1', 2 ) if $] <= 5.006001;
+
+$code = <<'END_PERL';
+my $foo = 1; my $bar = 2;
+my $baz = 3;
+END_PERL
+
+ $doc = PPI::Document->new(\$code);
+ my @children = $doc->schildren();
+ my @violations = map {Perl::Critic::Violation->new('', '', $_, 0)} $doc, @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('', '', $doc, $_)} @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');
+ $code = "print;\n";
+ $doc = PPI::Document->new(\$code);
+ $doc->index_locations();
+ my $p = Perl::Critic::Policy::Test->new();
+ my @t = $doc->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';
+ 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');
+
+}
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/07_perlcritic.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+use File::Spec;
+use English qw(-no_match_vars);
+use Test::More tests => 36;
+
+#-----------------------------------------------------------------------------
+# Load perlcritic like a library so we can test its subroutines. If it is not
+# found in blib, then use the one in bin (for example, when using 'prove')
+
+my $perlcritic = File::Spec->catfile( qw(blib script perlcritic) );
+$perlcritic = File::Spec->catfile( qw(bin perlcritic) ) if ! -e $perlcritic;
+require $perlcritic; ## no critic
+
+# Because bin/perlcritic does not declare a package, it has functions
+# in main, just like this test file, so we can use its functions
+# without a prefix.
+
+#-----------------------------------------------------------------------------
+
+local @ARGV = ();
+my %options = ();
+
+#-----------------------------------------------------------------------------
+
+@ARGV = qw(-1 -2 -3 -4 -5);
+%options = get_options();
+is( $options{-severity}, 1);
+
+@ARGV = qw(-5 -3 -4 -1 -2);
+%options = get_options();
+is( $options{-severity}, 1);
+
+@ARGV = qw();
+%options = get_options();
+is( $options{-severity}, undef);
+
+@ARGV = qw(-2 -3 -severity 4);
+%options = get_options();
+is( $options{-severity}, 4);
+
+@ARGV = qw(-severity 2 -3 -4);
+%options = get_options();
+is( $options{-severity}, 2);
+
+@ARGV = qw(--severity=2 -3 -4);
+%options = get_options();
+is( $options{-severity}, 2);
+
+@ARGV = qw(-cruel);
+%options = get_options();
+is( $options{-severity}, 'cruel');
+
+@ARGV = qw(-cruel --severity=1);
+%options = get_options();
+is( $options{-severity}, 1);
+
+@ARGV = qw(-stern --severity=1 -2);
+%options = get_options();
+is( $options{-severity}, 1);
+
+@ARGV = qw(-stern -severity 1 -2);
+%options = get_options();
+is( $options{-severity}, 1);
+
+#-----------------------------------------------------------------------------
+
+@ARGV = qw(-top);
+%options = get_options();
+is( $options{-severity}, 1);
+is( $options{-top}, 20);
+
+@ARGV = qw(-top 10);
+%options = get_options();
+is( $options{-severity}, 1);
+is( $options{-top}, 10);
+
+@ARGV = qw(-severity 4 -top);
+%options = get_options();
+is( $options{-severity}, 4);
+is( $options{-top}, 20);
+
+@ARGV = qw(-severity 4 -top 10);
+%options = get_options();
+is( $options{-severity}, 4);
+is( $options{-top}, 10);
+
+@ARGV = qw(-severity 5 -2 -top 5);
+%options = get_options();
+is( $options{-severity}, 5);
+is( $options{-top}, 5);
+
+#-----------------------------------------------------------------------------
+
+@ARGV = qw(-noprofile);
+%options = get_options();
+is( $options{-profile}, q{});
+
+@ARGV = qw(-profile foo);
+%options = get_options();
+is( $options{-profile}, 'foo');
+
+#-----------------------------------------------------------------------------
+
+@ARGV = qw(-single-policy nowarnings);
+%options = get_options();
+is( $options{'-single-policy'}, 'nowarnings');
+
+#-----------------------------------------------------------------------------
+
+@ARGV = qw(-verbose 2);
+%options = get_options();
+is( $options{-verbose}, 2);
+
+@ARGV = qw(-verbose %l:%c:%m);
+%options = get_options();
+is( $options{-verbose}, '%l:%c:%m');
+
+#-----------------------------------------------------------------------------
+
+@ARGV = qw(-statistics);
+%options = get_options();
+is( $options{-statistics}, 1);
+
+#-----------------------------------------------------------------------------
+
+@ARGV = qw(-statistics-only);
+%options = get_options();
+is( $options{'-statistics-only'}, 1);
+
+#-----------------------------------------------------------------------------
+
+@ARGV = qw(-quiet);
+%options = get_options();
+is( $options{-quiet}, 1);
+
+#-----------------------------------------------------------------------------
+# Intercept pod2usage so we can test invalid options and special switches
+
+{
+ no warnings qw(redefine once);
+ local *main::pod2usage = sub { my %args = @_; die $args{-message} || q{} };
+
+ eval { @ARGV = qw( -help ); get_options() };
+ ok( $EVAL_ERROR, '-help option' );
+
+ eval { @ARGV = qw( -options ); get_options() };
+ ok( $EVAL_ERROR, '-options option' );
+
+ eval { @ARGV = qw( -man ); get_options() };
+ ok( $EVAL_ERROR, '-man option' );
+
+ eval { @ARGV = qw( -noprofile -profile foo ); get_options() };
+ like( $EVAL_ERROR, qr/-noprofile with -profile/, '-noprofile with -profile');
+
+ eval { @ARGV = qw( -verbose bogus ); get_options() };
+ like( $EVAL_ERROR, qr/looks odd/, 'Invalid -verbose option' );
+
+ eval { @ARGV = qw( -top -9 ); get_options() };
+ like( $EVAL_ERROR, qr/is negative/, 'Negative -verbose option' );
+
+ eval { @ARGV = qw( -severity 0 ); get_options() };
+ like( $EVAL_ERROR, qr/out of range/, '-severity too small' );
+
+ eval { @ARGV = qw( -severity 6 ); get_options() };
+ like( $EVAL_ERROR, qr/out of range/, '-severity too large' );
+}
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/08_document.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use version;
+
+use Perl::Critic::Utils::DataConversion qw< dor >;
+
+use Test::More tests => 25;
+
+#-----------------------------------------------------------------------------
+
+use_ok('Perl::Critic::Document');
+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', 'highest_explicit_perl_version');
+can_ok('Perl::Critic::Document', 'ppi_document');
+
+{
+ my $code = q{'print 'Hello World';}; #Has 6 PPI::Element
+ my $ppi_doc = PPI::Document->new( \$code );
+ my $pc_doc = Perl::Critic::Document->new( $ppi_doc );
+ isa_ok($pc_doc, 'Perl::Critic::Document');
+
+
+ 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/ || warn @_
+ };
+ $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');
+
+ }
+}
+
+#-----------------------------------------------------------------------------
+
+{
+ 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'),
+ );
+}
+
+sub test_version {
+ my ($code, $expected_version) = @_;
+
+ my $description_version = dor( $expected_version, '<undef>' );
+
+ my $document =
+ Perl::Critic::Document->new(
+ PPI::Document->new( \$code )
+ );
+
+ is(
+ $document->highest_explicit_perl_version(),
+ $expected_version,
+ qq<Get "$description_version" for "$code".>,
+ );
+}
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/09_theme.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+use English qw(-no_match_vars);
+
+use List::MoreUtils qw(any all none);
+use Test::More (tests => 66);
+
+use Perl::Critic::TestUtils;
+use Perl::Critic::PolicyFactory;
+use Perl::Critic::UserProfile;
+use Perl::Critic::Theme;
+
+#-----------------------------------------------------------------------------
+
+ILLEGAL_RULES:{
+
+ my @invalid_rules = (
+ '$cosmetic',
+ '"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/, 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 );
+
+ #--------------
+
+ $rule = 'cosmetic - pbp';
+ $theme = Perl::Critic::Theme->new( -rule => $rule );
+ @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols;
+ ok( all { has_theme( $_, 'cosmetic' ) } @members );
+ ok( none { has_theme( $_, 'pbp') } @members );
+
+ $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 );
+ ok( none { has_theme( $_, 'pbp') } @members );
+
+ $rule = 'cosmetic && ! pbp';
+ $theme = Perl::Critic::Theme->new( -rule => $rule );
+ @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols;
+ ok( all { has_theme( $_, 'cosmetic' ) } @members );
+ ok( none { has_theme( $_, 'pbp') } @members );
+
+ #--------------
+
+ $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 );
+
+ $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 );
+
+ $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 );
+
+ #--------------
+
+ $rule = 'bugs * pbp';
+ $theme = Perl::Critic::Theme->new( -rule => $rule );
+ @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols;
+ ok( all { has_theme($_, 'bugs') } @members );
+ ok( all { has_theme($_, 'pbp') } @members );
+
+ $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 );
+ ok( all { has_theme($_, 'pbp') } @members );
+
+ $rule = 'bugs && pbp';
+ $theme = Perl::Critic::Theme->new( -rule => $rule );
+ @members = grep { $theme->policy_is_thematic( -policy => $_) } @pols;
+ ok( all { has_theme($_, 'bugs') } @members );
+ ok( all { has_theme($_, 'pbp') } @members );
+
+ #-------------
+
+ $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 );
+ ok( none { has_theme($_, 'danger') &&
+ has_theme($_, 'security') } @members );
+
+ $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 );
+ ok( none { has_theme($_, 'danger') &&
+ has_theme($_, 'security') } @members );
+
+ $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 );
+ ok( none { has_theme($_, 'danger') &&
+ has_theme($_, 'security') } @members );
+
+ #--------------
+
+ $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/, 'invalid theme expression' );
+
+}
+
+#-----------------------------------------------------------------------------
+
+sub has_theme {
+ my ($policy, $theme) = @_;
+ return any { $_ eq $theme } $policy->get_themes();
+}
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/10_userprofile.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+use Test::More tests => 41;
+use English qw(-no_match_vars);
+use Perl::Critic::UserProfile;
+
+#-----------------------------------------------------------------------------
+# Create profile from hash
+
+{
+ my %policy_params = (keywords => 'Revision');
+ my %profile_hash = ( '-NamingConventions::ProhibitMixedCaseVars' => {},
+ 'Miscellanea::RequireRcsKeywords' => \%policy_params );
+
+ my $up = Perl::Critic::UserProfile->new( -profile => \%profile_hash );
+
+ #Using short policy names
+ is($up->policy_is_enabled('Miscellanea::RequireRcsKeywords'), 1 );
+ is($up->policy_is_disabled('NamingConventions::ProhibitMixedCaseVars'), 1 );
+ is_deeply($up->raw_policy_params('Miscellanea::RequireRcsKeywords'), \%policy_params);
+
+ #Now using long policy names
+ is($up->policy_is_enabled('Perl::Critic::Policy::Miscellanea::RequireRcsKeywords'), 1 );
+ is($up->policy_is_disabled('Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseVars'), 1 );
+ is_deeply($up->raw_policy_params('Perl::Critic::Policy::Miscellanea::RequireRcsKeywords'), \%policy_params);
+
+ #Using bogus policy names
+ is($up->policy_is_enabled('Perl::Critic::Policy::Bogus'), q{} );
+ is($up->policy_is_disabled('Perl::Critic::Policy::Bogus'), q{} );
+ is_deeply($up->raw_policy_params('Perl::Critic::Policy::Bogus'), {} );
+}
+
+#-----------------------------------------------------------------------------
+# Create profile from array
+
+{
+ my %policy_params = (keywords => 'Revision');
+ my @profile_array = ( q{ [-NamingConventions::ProhibitMixedCaseVars] },
+ q{ [Miscellanea::RequireRcsKeywords] },
+ q{ keywords = Revision },
+ );
+
+
+ my $up = Perl::Critic::UserProfile->new( -profile => \@profile_array );
+
+ #Now using long policy names
+ is($up->policy_is_enabled('Miscellanea::RequireRcsKeywords'), 1 );
+ is($up->policy_is_disabled('NamingConventions::ProhibitMixedCaseVars'), 1 );
+ is_deeply($up->raw_policy_params('Miscellanea::RequireRcsKeywords'), \%policy_params);
+
+ #Now using long policy names
+ is($up->policy_is_enabled('Perl::Critic::Policy::Miscellanea::RequireRcsKeywords'), 1 );
+ is($up->policy_is_disabled('Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseVars'), 1 );
+ is_deeply($up->raw_policy_params('Perl::Critic::Policy::Miscellanea::RequireRcsKeywords'), \%policy_params);
+
+ #Using bogus policy names
+ is($up->policy_is_enabled('Perl::Critic::Policy::Bogus'), q{} );
+ is($up->policy_is_disabled('Perl::Critic::Policy::Bogus'), q{} );
+ is_deeply($up->raw_policy_params('Perl::Critic::Policy::Bogus'), {} );
+}
+
+#-----------------------------------------------------------------------------
+# Create profile from string
+
+{
+ my %policy_params = (keywords => 'Revision');
+ my $profile_string = <<'END_PROFILE';
+[-NamingConventions::ProhibitMixedCaseVars]
+[Miscellanea::RequireRcsKeywords]
+keywords = Revision
+END_PROFILE
+
+ my $up = Perl::Critic::UserProfile->new( -profile => \$profile_string );
+
+ #Now using long policy names
+ is($up->policy_is_enabled('Miscellanea::RequireRcsKeywords'), 1 );
+ is($up->policy_is_disabled('NamingConventions::ProhibitMixedCaseVars'), 1 );
+ is_deeply($up->raw_policy_params('Miscellanea::RequireRcsKeywords'), \%policy_params);
+
+ #Now using long policy names
+ is($up->policy_is_enabled('Perl::Critic::Policy::Miscellanea::RequireRcsKeywords'), 1 );
+ is($up->policy_is_disabled('Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseVars'), 1 );
+ is_deeply($up->raw_policy_params('Perl::Critic::Policy::Miscellanea::RequireRcsKeywords'), \%policy_params);
+
+ #Using bogus policy names
+ is($up->policy_is_enabled('Perl::Critic::Policy::Bogus'), q{} );
+ is($up->policy_is_disabled('Perl::Critic::Policy::Bogus'), q{} );
+ is_deeply($up->raw_policy_params('Perl::Critic::Policy::Bogus'), {} );
+}
+
+#-----------------------------------------------------------------------------
+# Test long policy names
+
+{
+ my %policy_params = (keywords => 'Revision');
+ my $long_profile_string = <<'END_PROFILE';
+[-Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseVars]
+[Perl::Critic::Policy::Miscellanea::RequireRcsKeywords]
+keywords = Revision
+END_PROFILE
+
+ my $up = Perl::Critic::UserProfile->new( -profile => \$long_profile_string );
+
+ #Now using long policy names
+ is($up->policy_is_enabled('Miscellanea::RequireRcsKeywords'), 1 );
+ is($up->policy_is_disabled('NamingConventions::ProhibitMixedCaseVars'), 1 );
+ is_deeply($up->raw_policy_params('Miscellanea::RequireRcsKeywords'), \%policy_params);
+
+ #Now using long policy names
+ is($up->policy_is_enabled('Perl::Critic::Policy::Miscellanea::RequireRcsKeywords'), 1 );
+ is($up->policy_is_disabled('Perl::Critic::Policy::NamingConventions::ProhibitMixedCaseVars'), 1 );
+ is_deeply($up->raw_policy_params('Perl::Critic::Policy::Miscellanea::RequireRcsKeywords'), \%policy_params);
+
+ #Using bogus policy names
+ is($up->policy_is_enabled('Perl::Critic::Policy::Bogus'), q{} );
+ is($up->policy_is_disabled('Perl::Critic::Policy::Bogus'), q{} );
+ is_deeply($up->raw_policy_params('Perl::Critic::Policy::Bogus'), {} );
+ }
+
+#-----------------------------------------------------------------------------
+# Test exception handling
+
+{
+ my $code_ref = sub { return };
+ eval { Perl::Critic::UserProfile->new( -profile => $code_ref ) };
+ like( $EVAL_ERROR, qr/Can't load UserProfile/, 'Invalid profile type');
+
+ eval { Perl::Critic::UserProfile->new( -profile => 'bogus' ) };
+ like( $EVAL_ERROR, qr/File 'bogus' does not exist/, '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/, 'Invalid profile syntax');
+
+ $invalid_syntax = 'severity 2'; #Missing "="
+ eval { Perl::Critic::UserProfile->new( -profile => \$invalid_syntax ) };
+ like( $EVAL_ERROR, qr/Syntax error at line/, 'Invalid profile syntax');
+
+}
+
+#-----------------------------------------------------------------------------
+# Test profile finding
+
+{
+ my $expected = $ENV{PERLCRITIC} = 'foo';
+ my $got = Perl::Critic::UserProfile::_find_profile_path();
+ is( $got, $expected, 'PERLCRITIC environment variable');
+}
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/11_policyfactory.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+use English qw(-no_match_vars);
+use Test::More (tests => 10);
+use Perl::Critic::UserProfile;
+use Perl::Critic::PolicyFactory (-test => 1);
+
+# common P::C testing tools
+use Perl::Critic::TestUtils qw();
+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/m, '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/m, '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"/m, '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/m );
+ $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/m );
+ $last_warning = q{};
+}
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/12_policylisting.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw<-no_match_vars>;
+
+use Test::More;
+
+use Perl::Critic::UserProfile;
+use Perl::Critic::PolicyFactory (-test => 1);
+use Perl::Critic::PolicyListing;
+
+#-----------------------------------------------------------------------------
+
+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 /\n/, $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};
+for my $line ( @listing_lines ) {
+ like($line, $listing_pattern, 'Listing format matches expected pattern');
+}
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/12_themelisting.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+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;
+
+#-----------------------------------------------------------------------------
+
+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
+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 run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/13_bundled_policies.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Test::More (tests => 1);
+
+use Perl::Critic::UserProfile;
+use Perl::Critic::PolicyFactory (-test => 1);
+
+# common P::C testing tools
+use Perl::Critic::TestUtils qw(bundled_policy_names);
+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 run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/14_policy_parameter_behavior_boolean.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Test::More tests => 9;
+use English qw(-no_match_vars);
+
+use Perl::Critic::Utils qw{ :booleans };
+use Perl::Critic::Policy;
+use Perl::Critic::PolicyParameter;
+
+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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/14_policy_parameter_behavior_enumeration.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Test::More tests => 24;
+use English qw(-no_match_vars);
+
+use Perl::Critic::Policy;
+use Perl::Critic::PolicyParameter;
+
+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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/14_policy_parameter_behavior_integer.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Test::More tests => 22;
+use English qw(-no_match_vars);
+
+use Perl::Critic::Policy;
+use Perl::Critic::PolicyParameter;
+use Perl::Critic::Utils qw{ :booleans };
+
+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}, '==', 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}, '==', 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}, '==', -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}, '==', 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}, '==', 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}, '==', -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}, '==', 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}, '==', 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}, '==', 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}, '==', 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}, '==', 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}, '==', -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}, '==', 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}, '==', 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}, '==', 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}, '==', 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/14_policy_parameter_behavior_list_string.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Test::More tests => 28;
+use English qw(-no_match_vars);
+
+use Perl::Critic::Policy;
+use Perl::Critic::PolicyParameter;
+
+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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/14_policy_parameter_behavior_string.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Test::More tests => 4;
+use English qw(-no_match_vars);
+
+use Perl::Critic::Policy;
+use Perl::Critic::PolicyParameter;
+
+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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/14_policy_parameters.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw(-no_match_vars);
+
+use Perl::Critic::UserProfile qw();
+use Perl::Critic::PolicyFactory (-test => 1);
+use Perl::Critic::PolicyParameter qw{ $NO_DESCRIPTION_AVAILABLE };
+use Perl::Critic::Utils qw( policy_short_name );
+use Perl::Critic::TestUtils qw(bundled_policy_names);
+
+use Test::More; #plan set below!
+
+Perl::Critic::TestUtils::block_perlcriticrc();
+
+#-----------------------------------------------------------------------------
+# This script 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 script 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 );
+
+ 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/,
+ $label
+ );
+}
+
+#-----------------------------------------------------------------------------
+
+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 run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/15_statistics.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Test::More (tests => 25);
+use English qw(-no_match_vars);
+use Perl::Critic::PolicyFactory (-test => 1);
+use Perl::Critic::TestUtils;
+
+Perl::Critic::TestUtils::block_perlcriticrc();
+
+#-----------------------------------------------------------------------------
+
+my $pkg = 'Perl::Critic::Statistics';
+use_ok( $pkg );
+
+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( $pkg, $method );
+}
+
+#-----------------------------------------------------------------------------
+
+my $code = <<'END_PERL';
+package Foo;
+
+use My::Module;
+$this = $that if $condition;
+sub foo { return @list unless $condition };
+END_PERL
+
+#-----------------------------------------------------------------------------
+
+# User may not have Perl::Tidy installed...
+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 => 10,
+ violations_per_file => 10,
+ violations_per_line_of_code => 2,
+ violations_per_statement => 2,
+);
+
+my $stats = $critic->statistics();
+isa_ok($stats, $pkg);
+
+while ( my($method, $expected) = each %expected_stats) {
+ is( $stats->$method, $expected, "Statistics: $method");
+}
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL$
+# $Date$
+# $Author$
+# $Revision$
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw(-no_match_vars);
+
+use Test::More;
+
+use Perl::Critic::PolicyFactory (-test => 1);
+use Perl::Critic::Config;
+use Perl::Critic::ProfilePrototype;
+use Perl::Critic::Utils qw{ :characters :severities };
+
+#-----------------------------------------------------------------------------
+
+eval 'use Test::Deep'; ## no critic (
+plan( skip_all => 'Test::Deep requried to test round-trip of default values')
+ if $EVAL_ERROR;
+
+#-----------------------------------------------------------------------------
+
+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 = 12 + $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(),
+ '==',
+ $default_configuration->severity(),
+ 'severity',
+);
+
+#-----------------------------------------------------------------------------
+
+cmp_ok(
+ $derived_configuration->top(),
+ '==',
+ $default_configuration->top(),
+ 'top',
+);
+
+#-----------------------------------------------------------------------------
+
+cmp_ok(
+ $derived_configuration->verbose(),
+ '==',
+ $default_configuration->verbose(),
+ 'verbose',
+);
+
+#-----------------------------------------------------------------------------
+
+cmp_deeply(
+ $derived_configuration->theme(),
+ $default_configuration->theme(),
+ 'theme',
+);
+
+#-----------------------------------------------------------------------------
+
+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++) {
+ 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 :
--- /dev/null
+#!perl
+
+use 5.006001;
+use strict;
+use warnings;
+use Test::More;
+use English qw(-no_match_vars);
+
+# common P::C testing tools
+use Perl::Critic::Utils qw( :characters );
+use Perl::Critic::TestUtils qw(
+ pcritique_with_violations
+ fcritique_with_violations
+ subtests_in_tree
+);
+Perl::Critic::TestUtils::block_perlcriticrc();
+
+my $subtests = subtests_in_tree( 't' );
+
+# Check for cmdline limit on policies. Example:
+# perl -Ilib t/20_policies.t BuiltinFunctions::ProhibitLvalueSubstr
+# or
+# perl -Ilib t/20_policies.t t/BuiltinFunctions/ProhibitLvalueSubstr.run
+if (@ARGV) {
+ my @policies = keys %{$subtests}; # get a list of all tests
+ # This is inefficient, but who cares...
+ for (@ARGV) {
+ next if m/::/xms;
+ if (!s{\A t[\\/](\w+)[\\/](\w+)\.run \z}{$1\::$2}xms) {
+ die 'Unknown argument ' . $_;
+ }
+ }
+ for my $p (@policies) {
+ if (0 == grep {$_ eq $p} @ARGV) {
+ delete $subtests->{$p};
+ }
+ }
+}
+
+# count how many tests there will be
+my $nsubtests = 0;
+for my $s (values %$subtests) {
+ $nsubtests += @$s; # one [pf]critique() test per subtest
+}
+my $npolicies = scalar keys %$subtests; # one can() test per policy
+
+plan tests => $nsubtests + $npolicies;
+
+for my $policy ( sort keys %$subtests ) {
+ can_ok( "Perl::Critic::Policy::$policy", 'violates' );
+ for my $subtest ( @{$subtests->{$policy}} ) {
+ local $TODO = $subtest->{TODO}; # Is NOT a TODO if it's not set
+
+ my $desc =
+ join ' - ', $policy, "line $subtest->{lineno}", $subtest->{name};
+
+ my @violations = $subtest->{filename}
+ ? eval {
+ fcritique_with_violations(
+ $policy,
+ \$subtest->{code},
+ $subtest->{filename},
+ $subtest->{parms},
+ )
+ }
+ : eval {
+ pcritique_with_violations(
+ $policy,
+ \$subtest->{code},
+ $subtest->{parms},
+ )
+ };
+ my $err = $EVAL_ERROR;
+
+ my $test_passed;
+ if ($subtest->{error}) {
+ if ( 'Regexp' eq ref $subtest->{error} ) {
+ $test_passed = like($err, $subtest->{error}, $desc);
+ }
+ else {
+ $test_passed = ok($err, $desc);
+ }
+ }
+ elsif ($err) {
+ if ($err =~ m/\A Unable [ ] to [ ] create [ ] policy [ ] [']/xms) {
+ # We most likely hit a configuration that a parameter didn't like.
+ fail($desc);
+ diag($err);
+ $test_passed = 0;
+ }
+ else {
+ die $err;
+ }
+ }
+ else {
+ my $expected_failures = $subtest->{failures};
+
+ # If any optional modules are NOT installed, then there should be no failures.
+ if ($subtest->{optional_modules}) {
+ MODULE:
+ for my $module (split m/,\s*/xms, $subtest->{optional_modules}) {
+ eval "require $module";
+ if ($EVAL_ERROR) {
+ $expected_failures = 0;
+ last MODULE;
+ }
+ }
+ }
+
+ $test_passed = is(scalar @violations, $expected_failures, $desc);
+ }
+
+ if (not $test_passed) {
+ diag("Violation found: $_") foreach @violations;
+ }
+ }
+}
+
+#-----------------------------------------------------------------------------
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/20_policy_podspelling.t $
+# $Date: 2008-06-21 19:57:54 -0700 (Sat, 21 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2464 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+use Test::More tests => 4;
+
+# common P::C testing tools
+use Perl::Critic::TestUtils qw(pcritique);
+Perl::Critic::TestUtils::block_perlcriticrc();
+
+my $code;
+my $policy = 'Documentation::PodSpelling';
+my %config;
+my $can_podspell =
+ eval {require Pod::Spell}
+ && can_determine_spell_command()
+ && can_run_spell_command();
+
+sub can_determine_spell_command {
+ my $policy = Perl::Critic::Policy::Documentation::PodSpelling->new();
+ $policy->initialize_if_enabled();
+
+ return $policy->_get_spell_command_line();
+}
+
+sub can_run_spell_command {
+ my $policy = Perl::Critic::Policy::Documentation::PodSpelling->new();
+ $policy->initialize_if_enabled();
+
+ return $policy->_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
+
+if ( eval { pcritique($policy, \$code, \%config) } ) {
+ skip 'Test environment is not English', 4
+}
+
+#-----------------------------------------------------------------------------
+
+$code = <<'END_PERL';
+=head1 arglbargl
+
+=cut
+END_PERL
+
+is(
+ eval { pcritique($policy, \$code, \%config) },
+ can_podspell() ? 1 : undef,
+ 'Mispelled header',
+);
+
+#-----------------------------------------------------------------------------
+
+$code = <<'END_PERL';
+=head1 Test
+
+arglbargl
+
+=cut
+END_PERL
+
+is(
+ eval { pcritique($policy, \$code, \%config) },
+ can_podspell() ? 1 : undef,
+ 'Mispelled body',
+);
+
+#-----------------------------------------------------------------------------
+
+
+$code = <<'END_PERL';
+=for stopwords arglbargl
+
+=head1 Test
+
+arglbargl
+
+=cut
+END_PERL
+
+is(
+ eval { pcritique($policy, \$code, \%config) },
+ can_podspell() ? 0 : undef,
+ 'local stopwords',
+);
+
+#-----------------------------------------------------------------------------
+
+$code = <<'END_PERL';
+=head1 Test
+
+arglbargl
+
+=cut
+END_PERL
+
+{
+ local $config{stop_words} = 'foo arglbargl bar';
+ is(
+ eval { pcritique($policy, \$code, \%config) },
+ can_podspell() ? 0 : undef ,
+ 'global stopwords',
+ );
+}
+
+} # end skip
+
+#-----------------------------------------------------------------------------
+
+# ensure we run true if this test is loaded by
+# t/20_policy_podspelling.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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/20_policy_prohibithardtabs.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+use Test::More tests => 5;
+
+# common P::C testing tools
+use Perl::Critic::TestUtils qw(pcritique fcritique);
+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!
+
+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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/20_policy_prohibittrailingwhitespace.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+use Test::More tests => 2;
+
+use Perl::Critic::Utils qw( :characters );
+
+use Perl::Critic::TestUtils qw( pcritique );
+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';
+my %config;
+my @violations;
+my $violation_line_number;
+my $violation_column_number;
+
+#-----------------------------------------------------------------------------
+
+$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, $policy );
+
+#-----------------------------------------------------------------------------
+
+$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, $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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/20_policy_requireconsistentnewlines.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+use Test::More tests => 29;
+
+# common P::C testing tools
+use Perl::Critic::TestUtils qw(pcritique fcritique);
+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/mx, $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/mx;
+ my $nfail = $is_first_line ? @lines-1 : 1;
+ for my $nl ("\012", "\015", "\015\012") {
+ next if $nl eq "\n";
+ ($code = $base_code) =~ s/(\Q$keyword\E)\n/$1$nl/;
+ is( fcritique($policy, \$code), $nfail, $policy.' - '.$keyword );
+ }
+}
+
+for my $nl ("\012", "\015", "\015\012") {
+ next if $nl eq "\n";
+ ($code = $base_code) =~ s/\n/$nl/;
+ is( pcritique($policy, \$code), 0, $policy.' - no filename' );
+}
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/20_policy_requiretidycode.t $
+# $Date: 2008-06-21 19:57:54 -0700 (Sat, 21 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2464 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Test::More tests => 6;
+
+# common P::C testing tools
+use Perl::Critic::TestUtils qw(pcritique);
+Perl::Critic::TestUtils::block_perlcriticrc();
+
+my $code;
+my $policy = 'CodeLayout::RequireTidyCode';
+my %config;
+
+#-----------------------------------------------------------------------------
+
+$code = <<'END_PERL';
+$foo= 42;
+$bar =56;
+$baz = 67;
+END_PERL
+
+my $has_perltidy = eval {require Perl::Tidy};
+%config = (perltidyrc => q{});
+is(
+ eval { pcritique($policy, \$code, \%config) },
+ $has_perltidy ? 1 : undef,
+ 'Untidy code',
+);
+
+#-----------------------------------------------------------------------------
+
+$code = <<'END_PERL';
+#Only one trailing newline
+$foo = 42;
+$bar = 56;
+END_PERL
+
+%config = (perltidyrc => q{});
+is(
+ eval { pcritique($policy, \$code, \%config) },
+ $has_perltidy ? 0 : undef,
+ 'Tidy with one trailing newline',
+);
+
+#-----------------------------------------------------------------------------
+
+$code = <<'END_PERL';
+#Two trailing newlines
+$foo = 42;
+$bar = 56;
+
+END_PERL
+
+%config = (perltidyrc => q{});
+is(
+ eval { pcritique($policy, \$code, \%config) },
+ $has_perltidy ? 0 : undef,
+ 'Tidy with two trailing newlines',
+);
+
+#-----------------------------------------------------------------------------
+
+$code = <<'END_PERL';
+#Several trailing newlines
+$foo = 42;
+$bar = 56;
+
+
+
+
+
+
+END_PERL
+
+
+
+%config = (perltidyrc => q{});
+is(
+ eval { pcritique($policy, \$code, \%config) },
+ $has_perltidy ? 0 : undef,
+ 'Tidy with several trailing newlines',
+);
+
+#-----------------------------------------------------------------------------
+
+$code = <<'END_PERL';
+sub foo {
+ my $code = <<'TEST';
+ foo bar baz
+TEST
+ $code;
+}
+END_PERL
+
+%config = (perltidyrc => q{});
+is(
+ eval { pcritique($policy, \$code, \%config) },
+ $has_perltidy ? 0 : undef,
+ '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(
+ eval { pcritique($policy, \$code, \%config) },
+ $has_perltidy ? 0 : undef,
+ 'Tidy with shell escape',
+);
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/92_memory_leaks.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Test::More; #plan set below
+
+use Perl::Critic::PolicyFactory (-test => 1);
+use Perl::Critic::Document;
+use Perl::Critic;
+
+use PPI::Document;
+
+use Perl::Critic::TestUtils qw();
+Perl::Critic::TestUtils::block_perlcriticrc();
+
+eval 'use Test::Memory::Cycle'; ## no critic
+plan( skip_all => 'Test::Memory::Cycle requried to test memory leaks') if $@;
+
+#-----------------------------------------------------------------------------
+{
+
+ # 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{print foo(); split /this/, $that;};
+ my $ppi_doc = PPI::Document->new( \$code );
+ my $pc_doc = Perl::Critic::Document->new( $ppi_doc );
+ my $critic = Perl::Critic->new( -severity => 1 );
+ my @violations = $critic->critique( $pc_doc );
+ die "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 );
+ memory_cycle_ok($_) for @violations;
+}
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/98_pod_syntax.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+use Test::More;
+use Perl::Critic::TestUtils qw{ starting_points_including_examples };
+
+eval 'use Test::Pod 1.00'; ## no critic
+plan skip_all => 'Test::Pod 1.00 required for testing POD' if $@;
+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 :
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/99_pod_coverage.t $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+use Test::More;
+
+eval 'use Test::Pod::Coverage 1.04'; ## no critic
+plan skip_all => 'Test::Pod::Coverage 1.00 requried to test POD' if $@;
+
+{
+ # 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<uses> 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 script 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;
+ 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 }x;
+all_pod_coverage_ok( {trustme => [$trusted_rx]} );
+
+#-----------------------------------------------------------------------------
+
+sub get_trusted_methods {
+ return qw(
+ new
+ initialize_if_enabled
+ violates
+ applies_to
+ 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 :
--- /dev/null
+## 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};
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/BuiltinFunctions/ProhibitBooleanGrep.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/BuiltinFunctions/ProhibitComplexMappings.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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};
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/BuiltinFunctions/ProhibitLvalueSubstr.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 );
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/BuiltinFunctions/ProhibitReverseSortBlock.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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};
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/BuiltinFunctions/ProhibitSleepViaSelect.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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);
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/BuiltinFunctions/ProhibitStringyEval.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 );
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/BuiltinFunctions/ProhibitStringySplit.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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);
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/BuiltinFunctions/ProhibitUniversalCan.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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);
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/BuiltinFunctions/ProhibitUniversalIsa.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/BuiltinFunctions/ProhibitVoidGrep.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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');
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/BuiltinFunctions/ProhibitVoidMap.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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);
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/BuiltinFunctions/RequireBlockGrep.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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);
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/BuiltinFunctions/RequireBlockMap.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 $_;
+}
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/BuiltinFunctions/RequireGlobFunction.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/BuiltinFunctions/RequireSimpleSortBlock.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+}
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ClassHierarchies/ProhibitAutoloading.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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');
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ClassHierarchies/ProhibitExplicitISA.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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( [] );
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ClassHierarchies/ProhibitOneArgBless.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 Parentheses with unary operators
+## 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;
+
+#-----------------------------------------------------------------------------
+
+## 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 = <STDIN> );
+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 Handling sort having subroutine name as an argument
+## failures 0
+## cut
+
+sort(foo(@x));
+[ sort ( modules_used_in_string( $code ) ) ]
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/CodeLayout/ProhibitParensWithBuiltins.run $
+# $Date: 2008-06-17 01:11:23 -0500 (Tue, 17 Jun 2008) $
+# $Author: chrisdolan $
+# $Revision: 2446 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## name Basic failure
+## failures 2
+## cut
+
+@list = ('foo', 'bar', 'baz');
+
+@list = ('foo',
+ 'bar',
+ 'baz');
+
+#-----------------------------------------------------------------------------
+
+## 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'); # XXX is this a typo? What is this trying to test?
+@list = ($foo, 'bar', 'baz');
+@list = (foo => 'bar');
+%hash = ('foo' => 'bar', 'fo' => 'fum');
+my_function('foo', 'bar', 'fudge');
+$a_function->('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');
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/CodeLayout/ProhibitQuotedWordLists.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 --
+ );
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/CodeLayout/RequireTrailingCommas.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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();
+}
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ControlStructures/ProhibitCStyleForLoops.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+}
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ControlStructures/ProhibitCascadingIfElse.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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) {
+ }
+ }
+ }
+}
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ControlStructures/ProhibitDeepNests.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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; }
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ControlStructures/ProhibitLabelsWithSpecialBlockNames.run $
+# $Date: 2008-05-13 22:08:28 -0500 (Tue, 13 May 2008) $
+# $Author: clonezone $
+# $Revision: 2337 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## name Assignment and op-assignment
+## failures 3
+## cut
+
+@bar = map {$_ = 1} @foo;
+@bar = map {$_ *= 2} @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;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ControlStructures/ProhibitMutatingListFunctions.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+#!/usr/bin/env perl
+
+use 5.006001;
+use strict;
+use warnings;
+
+use English qw{-no_match_vars};
+
+use Carp qw{ confess };
+use Fatal qw{ open close };
+
+our $VERSION = '1.088';
+
+
+
+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
+ or die "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);
+}
+
+
+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
+}
+
+#-----------------------------------------------------------------------------
+
+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
+}
+
+#-----------------------------------------------------------------------------
+
+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
+}
+
+#-----------------------------------------------------------------------------
+
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ControlStructures/ProhibitNegativeExpressionsInUnlessAndUntilConditions.run.PL $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## name Basic failure
+## failures 6
+## 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;
+
+#-----------------------------------------------------------------------------
+
+## name Configured to allow all
+## failures 0
+## parms {allow => 'if while until unless for foreach'}
+## 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;
+
+#-----------------------------------------------------------------------------
+
+## name Configured to allow all, all regular control structures
+## failures 0
+## parms {allow => 'if unless until while'}
+## cut
+
+if($condition){ do_something() }
+while($condition){ do_something() }
+until($condition){ do_something() }
+unless($condition){ 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 Legal postfix 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 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;
+
+#-----------------------------------------------------------------------------
+
+## name "Keyword"-list hash assignment
+## failures 0
+## cut
+
+my %hash = (
+ if => 1,
+ unless => 1,
+ until => 1,
+ while => 1,
+ for => 1,
+ foreach => 1,
+);
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ControlStructures/ProhibitPostfixControls.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## name Basic passing
+## failures 0
+## cut
+
+if(! $condition){
+ do_something();
+}
+
+do_something() unless $condition
+
+#-----------------------------------------------------------------------------
+
+## name Basic failure
+## failures 1
+## cut
+
+unless($condition){
+ do_something();
+}
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ControlStructures/ProhibitUnlessBlocks.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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';
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ControlStructures/ProhibitUnreachableCode.run $
+# $Date: 2008-05-21 14:50:31 -0500 (Wed, 21 May 2008) $
+# $Author: clonezone $
+# $Revision: 2397 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## name Basic passing
+## failures 0
+## cut
+
+while(! $condition){
+ do_something();
+}
+
+do_something() until $condition
+
+#-----------------------------------------------------------------------------
+
+## name Basic failure
+## failures 1
+## cut
+
+until($condition){
+ do_something();
+}
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ControlStructures/ProhibitUntilBlocks.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## name No POD
+## failures 0
+## cut
+print 'Hello World';
+
+#-----------------------------------------------------------------------------
+
+## name Script
+## 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<Foo> - A module that does stuff
+
+=head1 DESCRIPTION
+
+Blah...
+
+=cut
+
+#-----------------------------------------------------------------------------
+
+## name A good match with L<>
+## failures 0
+## cut
+package Foo;
+
+=pod
+
+=head1 NAME
+
+L<Foo> - 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 bad
+## failures 1
+## 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
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Documentation/RequirePackageMatchesPodName.run $
+# $Date: 2008-06-05 22:24:36 -0500 (Thu, 05 Jun 2008) $
+# $Author: chrisdolan $
+# $Revision: 2414 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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__
+
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Documentation/RequirePodAtEnd.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Documentation/RequirePodSections.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 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" ;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ErrorHandling/RequireCarping.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 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;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ErrorHandling/RequireCheckingReturnValueOfEval.run $
+# $Date: 2008-06-30 00:37:19 -0500 (Mon, 30 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2484 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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/ }
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/InputOutput/ProhibitBacktickOperators.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/InputOutput/ProhibitExplicitStdin.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+## name basic passes
+## failures 0
+## cut
+
+$foo = 'STDIN';
+my $STDIN = 1;
+close STDIN;
+while (<>) {
+ print;
+}
+while (<FOO>) {
+ print;
+}
+while (<$fh>) {
+ print;
+}
+
+#-----------------------------------------------------------------------------
+
+## name basic failures
+## failures 3
+## cut
+
+$answer = <STDIN>;
+while (<STDIN>) {
+ print;
+}
+if (<STDIN> =~ /y/) {
+ remove 'tmp.txt';
+}
+
+#-----------------------------------------------------------------------------
+
+## name ppi failures
+## failures 4
+## cut
+
+$content = join '', <STDIN>;
+$content = join('', <STDIN>);
+$content = join $var, <STDIN>;
+$content = join($var, <STDIN>);
+
+#-----------------------------------------------------------------------------
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## name basic failures
+## failures 2
+## cut
+
+-t;
+if (-t) { }
+
+#-----------------------------------------------------------------------------
+
+## name basic passes
+## failures 0
+## cut
+-toomany;
+-f _;
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/InputOutput/ProhibitJoinedReadline.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+## name basic passes
+## failures 0
+## cut
+
+$content = do {local $/ = undef; <>};
+@content = <>;
+$content = do {local $/ = undef; <$fh>};
+@content = <$fh>;
+$content = do {local $/ = undef; <STDIN>};
+@content = <STDIN>;
+
+#-----------------------------------------------------------------------------
+
+## 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 '', <STDIN>;
+$content = join('', <$fh>);
+$content = join('', <STDIN>);
+$content = join $var, <$fh>;
+$content = join $var, <STDIN>;
+$content = join($var, <$fh>);
+$content = join($var, <STDIN>);
+
+#-----------------------------------------------------------------------------
+
+## 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 :
--- /dev/null
+## 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 { }
--- /dev/null
+## name basic failures
+## failures 6
+## cut
+for my $foo (<FH>) {}
+for $foo (<$fh>) {}
+for (<>) {}
+
+foreach my $foo (<FH>) {}
+foreach $foo (<$fh>) {}
+foreach (<>) {}
+
+#-----------------------------------------------------------------------------
+
+## name basic passes
+## failures 0
+## cut
+for my $foo (@lines) {}
+while( my $foo = <> ){}
+while( $foo = <> ){}
+while( <> ){}
--- /dev/null
+## 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
+
+# There is no three-arg equivalent for these
+open( \*STDOUT, '>&STDERR' );
+open( *STDOUT, '>&STDERR' );
+open( STDOUT, '>&STDERR' );
+
+# 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;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/InputOutput/ProhibitTwoArgOpen.run $
+# $Date: 2008-06-19 15:03:01 -0500 (Thu, 19 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2461 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## name basic failures
+## 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 more arcane passes
+## 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 bracing arcana
+## failures 0
+## cut
+
+print {$fh};
+print {$fh} @list;
+print {$fh} $foo, $bar;
+print( {$fh} @list );
+print( {$fh} $foo, $bar );
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/InputOutput/RequireBriefOpen.run $
+# $Date: 2008-05-11 17:44:01 -0500 (Sun, 11 May 2008) $
+# $Author: clonezone $
+# $Revision: 2335 $
+##############################################################################
+
+## 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
+## failures 1
+## 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
+
+#-----------------------------------------------------------------------------
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+
+#-----------------------------------------------------------------------------
+
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/InputOutput/RequireCheckedClose.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+
+#-----------------------------------------------------------------------------
+
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/InputOutput/RequireCheckedOpen.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 config
+## failures 0
+## cut
+
+accept NEWSOCK, SOCKET;
+
+#-----------------------------------------------------------------------------
+
+## name config
+## parms {functions => 'accept'}
+## failures 1
+## cut
+
+accept NEWSOCK, SOCKET;
+
+#-----------------------------------------------------------------------------
+
+## name config
+## parms {functions => ':builtins'}
+## failures 1
+## cut
+
+accept NEWSOCK, SOCKET;
+
+#-----------------------------------------------------------------------------
+
+## name insane config
+## parms {functions => ':all'}
+## failures 2
+## cut
+
+sub foo {
+ return 1;
+}
+foo();
+
+#-----------------------------------------------------------------------------
+
+
+## name insane config
+## parms {functions => ':all'}
+## failures 0
+## cut
+
+sub foo {
+ return 1 or die;
+}
+foo() or die;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/InputOutput/RequireCheckedSyscalls.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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();
--- /dev/null
+## 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();
--- /dev/null
+## name RCS keywords in POD
+## failures 0
+## cut
+=pod
+
+ $Revision: 1006 $
+ $Source$
+ $Date: 2006-12-03 00:23:19 -0600 (Sun, 03 Dec 2006) $
+
+=cut
+
+#-----------------------------------------------------------------------------
+
+## name No RCS keywords at all
+## failures 3
+## cut
+
+#just a comment
+$foo = "bar";
+$baz = qq{nuts};
+
+#-----------------------------------------------------------------------------
+
+## name Keywords in comments
+## failures 0
+## cut
+# $Revision: 1006 $
+# $Source$
+# $Date: 2006-12-03 00:23:19 -0600 (Sun, 03 Dec 2006) $
+
+#-----------------------------------------------------------------------------
+
+## name Id in comments
+## failures 0
+## cut
+# $Id$
+END_PERL
+
+#-----------------------------------------------------------------------------
+
+## name Keywords in literals
+## failures 0
+## cut
+'$Revision: 1006 $'
+'$Source: foo/bar $'
+'$Date: 2006-12-03 00:23:19 -0600 (Sun, 03 Dec 2006) $'
+
+#-----------------------------------------------------------------------------
+
+## name Keywords in literals, q{}-style
+## failures 0
+## cut
+q{$Revision: 1006 $}
+q{$Source: foo/bar $}
+q{$Date: 2006-12-03 00:23:19 -0600 (Sun, 03 Dec 2006) $}
+
+#-----------------------------------------------------------------------------
+
+## name Keywords in literals, q{}-style, with parms
+## failures 0
+## parms {keywords => 'Revision Author Id'}
+## cut
+q{$Revision: 1006 $}
+q{$Author: petdance $}
+q{$Id: whatever $}
+
+#-----------------------------------------------------------------------------
+
+## name Empty code
+## failures 1
+## parms {keywords => 'Author Id'}
+## cut
+#nothing here!
+$policy = 'Miscellanea::RequireRcsKeywords';
+is( pcritique($policy, \$code, \%config), 1, $policy);
+
--- /dev/null
+## 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
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Modules/ProhibitAutomaticExportation.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+#-----------------------------------------------------------------------------
+## 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';
+
+##############################################################################
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Modules/ProhibitExcessMainComplexity.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+#-----------------------------------------------------------------------------
+
+## 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 :
+
--- /dev/null
+## 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 :
--- /dev/null
+## 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;
--- /dev/null
+## 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 DESTROY sub hides the 1;
+## TODO This is a PPI bug. See http://rt.cpan.org/Ticket/Display.html?id=27364
+## failures 0
+## cut
+
+DESTROY { warn 'DEAD'; }
+
+1;
+
--- /dev/null
+## 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
+
+({})
+
--- /dev/null
+#------------------------------------------------------------------------------
+## 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;
+
+##############################################################################
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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);
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Modules/RequireNoMatchVarsWithUseEnglish.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Modules/RequireVersionVar.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+
+## 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
+## TODO "no critic" doesn't work at the document level
+## 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
+
+##############################################################################
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 :
--- /dev/null
+## name Basic failures.
+## failures 4
+## cut
+
+sub fooBAR {}
+sub FooBar {}
+sub Foo_Bar {}
+sub FOObar {}
+
+#-----------------------------------------------------------------------------
+
+## name Basic passes.
+## failures 0
+## cut
+
+sub foo_BAR {}
+sub foo_bar {}
+sub FOO_bar {}
+sub Foo::Bar::grok {}
+sub Class::Encapsulate::_hidden::_hash_overload {}
+
+#-----------------------------------------------------------------------------
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## name Basic failures, one variable
+## failures 4
+## cut
+
+my $fooBAR;
+my ($fooBAR) = 'nuts';
+local $FooBar;
+our ($FooBAR);
+
+#-----------------------------------------------------------------------------
+
+## name Failing vars, mixed with some passing ones
+## failures 6
+## cut
+
+my ($foobar, $fooBAR);
+my (%foobar, @fooBAR, $foo);
+local ($foobar, $fooBAR);
+local (%foobar, @fooBAR, $foo);
+our ($foobar, $fooBAR);
+our (%foobar, @fooBAR, $foo);
+
+#-----------------------------------------------------------------------------
+
+## name Basic passes
+## failures 0
+## cut
+
+my $foo_BAR;
+my $FOO_BAR;
+my $foo_bar;
+my ($foo_BAR, $BAR_FOO);
+my ($foo_BAR, $BAR_FOO) = q(this, that);
+our (%FOO_BAR, @BAR_FOO);
+local ($FOO_BAR, %BAR_foo) = @_;
+my ($foo_bar, $foo);
+
+
+#-----------------------------------------------------------------------------
+
+## name Variables from other packages should pass
+## failures 0
+## cut
+
+local $Other::Package::foo_BAR;
+$Other::Package::foo_BAR;
+local $Other::Package::fooBAR;
+$Some::Package::fooBAR;
+
+#-----------------------------------------------------------------------------
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/References/ProhibitDoubleSigils.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/RegularExpressions/ProhibitComplexRegexes.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+## 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
+## optional_modules Regexp::Parser
+## 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;
+
+#-----------------------------------------------------------------------------
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/RegularExpressions/ProhibitEnumeratedClasses.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+## 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
+## optional_modules Regexp::Parser
+## cut
+
+m/[A-Z]/; # \p{Uppercase}
+m/[a-z]/; # \p{Lowercase}
+m/[0-9]/; # \d
+m/[A-Za-z_]/; # \w
+m/[a-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
+## optional_modules Regexp::Parser
+## cut
+
+m/[\ \t\012\015]/; # \s
+m/[\ \t\x0a\x0d]/; # \s
+m/[\ \t\x{0a}\x{0d}]/; # \s
+
+#-----------------------------------------------------------------------------
+
+## name negative failures
+## failures 8
+## optional_modules Regexp::Parser
+## cut
+
+m/[^\w]/; # \W
+m/[^\s]/; # \S
+m/[^0-9]/; # \D
+m/[^A-Za-z_]/; # \W
+m/[^a-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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/RegularExpressions/ProhibitEscapedMetacharacters.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+## name basic passes
+## failures 0
+## cut
+
+m/ [{] . [.] \d{2} [}] /xms;
+$name =~ m{ harry [ ] s [ ] truman
+ | harry [ ] j [ ] potter
+ }ixms;
+
+## name basic failures
+## failures 2
+## optional_modules Regexp::Parser
+## 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;
+
+#-----------------------------------------------------------------------------
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/RegularExpressions/ProhibitFixedStringMatches.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+## 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/RegularExpressions/ProhibitSingleCharAlternation.run $
+# $Date: 2008-06-06 19:57:46 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2417 $
+##############################################################################
+
+## 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 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;
+
+## name basic failures
+## failures 2
+## optional_modules Regexp::Parser
+## 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/RegularExpressions/ProhibitUnusedCapture.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+## 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 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/;
+
+#-----------------------------------------------------------------------------
+
+## name basic failures
+## failures 5
+## optional_modules Regexp::Parser
+## 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
+## optional_modules Regexp::Parser
+## cut
+
+my ($foo) = $str !~ m/(foo)/;
+
+#-----------------------------------------------------------------------------
+
+## name statement failures
+## failures 1
+## optional_modules Regexp::Parser
+## cut
+
+m/(foo)/ && m/(bar)/ && print $1;
+
+#-----------------------------------------------------------------------------
+
+## name sub failures
+## failures 1
+## optional_modules Regexp::Parser
+## cut
+
+sub foo {
+ m/(foo)/;
+ return;
+}
+print $1;
+
+#-----------------------------------------------------------------------------
+
+## name anon sub failures
+## failures 1
+## optional_modules Regexp::Parser
+## 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
+## optional_modules Regexp::Parser
+## TODO lvalue subs are too complex to support
+## cut
+
+(substr $str, 0, 1) = m/(\w+)(\d+)/;
+
+#-----------------------------------------------------------------------------
+
+## name code coverage
+## failures 1
+## optional_modules Regexp::Parser
+## cut
+
+m/(foo)/;
+print $0;
+print @ARGV;
+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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/RegularExpressions/ProhibitUnusualDelimiters.run $
+# $Date: 2008-04-12 14:38:38 -0500 (Sat, 12 Apr 2008) $
+# $Author: clonezone $
+# $Revision: 2218 $
+##############################################################################
+
+## name basic passes
+## failures 0
+## cut
+
+m/foo/;
+m{foo};
+s/foo//;
+s{foo}{};
+qr/foo/;
+qr{foo};
+
+## name basic failures
+## failures 25
+## cut
+
+m#foo#;
+m|foo|;
+m<foo>;
+m(foo);
+m'foo';
+m"foo";
+m;foo;;
+m,foo,;
+
+s#foo##;
+s|foo||;
+s<foo><>;
+s<foo>//;
+s(foo)();
+s'foo'';
+s"foo"";
+s;foo;;;
+s,foo,,;
+
+qr#foo#;
+qr|foo|;
+qr<foo>;
+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<foo>;
+
+s{foo}{};
+s(foo){};
+s[foo]{};
+s<foo>{};
+
+s{foo}();
+s(foo)();
+s[foo]();
+s<foo>();
+
+s{foo}[];
+s(foo)[];
+s[foo][];
+s<foo>[];
+
+s{foo}<>;
+s(foo)<>;
+s[foo]<>;
+s<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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/RegularExpressions/RequireBracesForMultiline.run $
+# $Date: 2008-04-12 14:38:38 -0500 (Sat, 12 Apr 2008) $
+# $Author: clonezone $
+# $Revision: 2218 $
+##############################################################################
+
+## 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<foo
+ bar>
+ <baz
+ fzz>;
+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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/RegularExpressions/RequireExtendedFormatting.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+## name basic passes
+## failures 0
+## cut
+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 $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;
+
+#-----------------------------------------------------------------------------
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/RegularExpressions/RequireLineBoundaryMatching.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+## 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;
+
+#-----------------------------------------------------------------------------
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 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;
--- /dev/null
+## name Basic failures
+## failures 3
+## cut
+sub open {}
+sub map {}
+sub eval {}
+
+#-----------------------------------------------------------------------------
+
+## 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(); }
--- /dev/null
+## 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 {
+}
--- /dev/null
+## 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
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Subroutines/ProhibitManyArgs.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+## 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;
+}
+
+#-----------------------------------------------------------------------------
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 } } } }
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Subroutines/ProhibitNestedSubs.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## name simple failure
+## failures 2
+## cut
+
+sub my_sub1 ($@) {}
+sub my_sub2 (@@) {}
+
+#-----------------------------------------------------------------------------
+
+## name simple success
+## failures 0
+## cut
+
+sub my_sub1 {}
+sub my_sub1 {}
+
--- /dev/null
+## 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 Difficult-to-detect pass
+# This one should be illegal, but it is too hard to distinguish from
+# the next one, which is legal
+## failures 0
+## cut
+$pkg->_foo();
+
+$self->_bar();
+$self->SUPER::_foo();
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Subroutines/RequireArgUnpacking.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+## 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 = bar {
+ 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();
+}
+
+#-----------------------------------------------------------------------------
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Subroutines/RequireFinalReturn.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+
+#-----------------------------------------------------------------------------
+
+## 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 { exit; }
+sub quux2 { throw 'nuts'; }
+
+#-----------------------------------------------------------------------------
+
+## name Final return is present, but conditional
+## failures 4
+## cut
+sub foo { die if $condition }
+sub bar { croak unless $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 }
+
+##############################################################################
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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";
--- /dev/null
+## name warnings disabled
+## failures 1
+## cut
+
+package foo;
+no warnings;
+
+#-----------------------------------------------------------------------------
+
+## name selective warnings disabled
+## failures 1
+## cut
+
+package foo;
+no warnings 'uninitialized', 'deprecated';
+END_PERL
+
+$policy = 'TestingAndDebugging::ProhibitNoWarnings';
+is( pcritique($policy, \$code), 1, $policy.' selective warnings disabled');
+
+#-----------------------------------------------------------------------------
+
+## name selective warnings disabled
+## 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);
--- /dev/null
+## 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;
+}
--- /dev/null
+## 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' );
--- /dev/null
+## 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;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/TestingAndDebugging/RequireUseStrict.run $
+# $Date: 2008-04-13 21:16:24 -0500 (Sun, 13 Apr 2008) $
+# $Author: clonezone $
+# $Revision: 2242 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/TestingAndDebugging/RequireUseWarnings.run $
+# $Date: 2008-06-18 16:19:46 -0500 (Wed, 18 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2459 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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
+## TODO PPI parses this code as a block and not a hash constructor.
+## 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,
+ ) ;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/ProhibitCommaSeparatedStatements.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/ProhibitConstantPragma.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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";
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/ProhibitEmptyQuotes.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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};
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/ProhibitEscapedCharacters.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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>;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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/;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/ProhibitInterpolationOfLiterals.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 );
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/ProhibitLeadingZeros.run $
+# $Date: 2008-06-22 16:23:43 -0700 (Sun, 22 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2475 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/ProhibitLongChainsOfMethodCalls.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 not work.
+## failures 1
+## 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 not work.
+## failures 2
+## cut
+
+use Readonly;
+
+Readonly::Hash1 %frobnication_factors => ( 57 => 290 );
+
+## 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
+## cut
+
+use Some::Module { 1 => 2, 3 => 4 };
+
+## name Any numbers allowed in hash references in require statement.
+## failures 0
+## cut
+
+require Some::Other::Module { 1 => 2, 3 => 4 };
+
+## name Any numbers allowed in hash references in readonly statement.
+## failures 0
+## cut
+
+Readonly $Vlad_the_Impaler => { 1 => 2, 3 => 4 };
+
+## name Magic numbers not allowed in hash references in regular statement.
+## failures 2
+## cut
+
+$gnome_lord = { 1 => 2, 3 => 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 not allowed in nested hash references in regular statement.
+## failures 1
+## cut
+
+@fire_elemental = ( 1, { 2 => 4 } );
+
+## name Good numbers allowed in nested hash references anywhere.
+## failures 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: 2293 $) =~ s/Revision //;
+(our $VERSION) = '$Revision: 2293 $' =~ /([\d.]+)/;
+(our $VERSION) = sprintf "%d", q$Revision: 2293 $ =~ /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: 2293 $ =~ /: (\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: 2293 $))[1];
+our $VERSION = $local_variable;
+our $VERSION = '$Date: 2008-05-04 12:18:31 -0500 (Sun, 04 May 2008) $'; $VERSION =~ s|^\$Date:\s*([0-9]{4})/([0-9]{2})/([0-9]{2})\s.*|\1.\2.\3| ;
+our $VERSION = '$Revision: 2293 $' =~ /\$Revision:\s+([^\s]+)/;
+our $VERSION = '$Revision: 2293 $';
+our $VERSION = '-123 blah';
+our $VERSION = '1.' . qw $Revision: 2293 $[1];
+our $VERSION = '1.' . sprintf "%d", (qw($Revision: 2293 $))[1];
+our $VERSION = '1.' . sprintf("%d", (qw($Revision: 2293 $))[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: 2293 $ =~ /(\d+)/; sprintf "%4.2f", $1 / 100 };
+our $VERSION = '123';
+our $VERSION = ('$Revision: 2293 $' =~ /(\d+.\d+)/)[ 0];
+our $VERSION = ('$Revision: 2293 $' =~ /(\d+\.\d+)/);
+our $VERSION = ('$Revision: 2293 $' =~ m/(\d+)/)[0];
+our $VERSION = ((require SomeOtherModule), $SomeOtherModule::VERSION)[1];
+our $VERSION = (q$Revision: 2293 $ =~ /([\d\.]+)/);
+our $VERSION = (q$Revision: 2293 $ =~ /(\d+)/g)[0];
+our $VERSION = (qq$Revision: 2293 $ =~ /(\d+)/)[0];
+our $VERSION = (qw$Revision: 2293 $)[-1];
+our $VERSION = (qw$Revision: 2293 $)[1];
+our $VERSION = (qw($Revision: 2293 $))[1];
+our $VERSION = (split(/ /, '$Revision: 2293 $'))[1];
+our $VERSION = (split(/ /, '$Revision: 2293 $'))[2];
+our $VERSION = 1.2.3;
+our $VERSION = 1.23;
+our $VERSION = 1.2_3;
+our $VERSION = 123;
+our $VERSION = SomeOtherModule::RCSVersion('$Revision: 2293 $');
+our $VERSION = SomeOtherModule::VERSION;
+our $VERSION = [ qw{ $Revision: 2293 $ } ]->[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: 2293 $ =~ /(\d+)/; sprintf "%4.2f", $1 / 100 };
+our $VERSION = do { q$Revision: 2293 $ =~ /Revision: (\d+)/; sprintf "1.%d", $1; };
+our $VERSION = do { require mod_perl2; $mod_perl2::VERSION };
+our $VERSION = do {(q$URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/ProhibitMagicNumbers.run $=~ m$.*/(?:tags|branches)/([^/ \t]+)$)[0] || "0.0"};
+our $VERSION = eval { require version; version::qv((qw$Revision: 2293 $)[1] / 1000) };
+our $VERSION = q$0.04$;
+our $VERSION = q$Revision: 2293 $;
+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: 2293 $, 4)/1000;
+our $VERSION = sprintf "%d.%d", '$Revision: 2293 $' =~ /(\d+)\.(\d+)/;
+our $VERSION = sprintf "%d.%d", '$Revision: 2293 $' =~ /(\d+)/g;
+our $VERSION = sprintf "%d.%d", '$Revision: 2293 $' =~ /(\d+)\.(\d+)/;
+our $VERSION = sprintf "%d.%d", q$Revision: 2293 $ =~ /: (\d+)\.(\d+)/;
+our $VERSION = sprintf "%d.%d", q$Revision: 2293 $ =~ /(\d+)/g;
+our $VERSION = sprintf "%d.%d", q$Revision: 2293 $ =~ /(\d+)\.(\d+)/;
+our $VERSION = sprintf "%d.%d", q$Revision: 2293 $ =~ /(\d+)\.(\d+)/g;
+our $VERSION = sprintf "%d.%d", q$Revision: 2293 $ =~ /: (\d+)\.(\d+)/;
+our $VERSION = sprintf "%d.%d", q$Revision: 2293 $ =~ m/ (\d+) \. (\d+) /xg;
+our $VERSION = sprintf "%d.%d", q$Revision: 2293 $ ~~ 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: 2293 $' =~ /(\d+)/;
+our $VERSION = sprintf "1.%d", q$Revision: 2293 $ =~ /(\d+)/g;
+our $VERSION = sprintf '%d.%d', (q$Revision: 2293 $ =~ /(\d+)\.(\d+)/);
+our $VERSION = sprintf '%d.%d', q$Revision: 2293 $ =~ /(\d+)\.(\d+)/;
+our $VERSION = sprintf '%d.%d', q$Revision: 2293 $ =~ /(\d+)\.(\d+)/;
+our $VERSION = sprintf '%s', 'q$Revision: 2293 $' =~ /\S+\s+(\S+)\s+/ ;
+our $VERSION = sprintf '%s', 'q$Revision: 2293 $' =~ /\S+\s+(\S+)\s+/ ;
+our $VERSION = sprintf '%s', q$Revision: 2293 $ =~ /Revision:\s+(\S+)\s+/ ;
+our $VERSION = sprintf '%s', q{$Revision: 2293 $} =~ /\S+\s+(\S+)/ ;
+our $VERSION = sprintf '1.%d', (q$Revision: 2293 $ =~ /\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: 2293 $ =~ /(\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: 2293 $ =~ /(\d+)\.(\d+)/);
+our $VERSION = sprintf("%d.%d", q$Revision: 2293 $ =~ /(\d+)\.(\d+)/o);
+our $VERSION = sprintf("%d.%d", q$Revision: 2293 $ =~ m/(\d+)\.(\d+)/);
+our $VERSION = sprintf("%d.%d", q$Revision: 2293 $=~/(\d+)\.(\d+)/);
+our $VERSION = sprintf("%d.%d", q'$Revision: 2293 $' =~ /(\d+)\.(\d+)/);
+our $VERSION = sprintf("%d.%d.%d", 0, q$Revision: 2293 $ =~ /(\d+)\.(\d+)/);
+our $VERSION = sprintf("1.%d", q$Revision: 2293 $ =~ / (\d+) /);
+our $VERSION = sprintf("1.%d", q$Revision: 2293 $ =~ /(\d+)/);
+our $VERSION = sprintf("1.2%d%d", q$Revision: 2293 $ =~ /(\d+)\.(\d+)/);
+our $VERSION = sprintf('%d.%d', '$Revision: 2293 $' =~ /(\d+)\.(\d+)/);
+our $VERSION = sprintf('%d.%d', q$Revision: 2293 $ =~ /(\d+)\.(\d+)/);
+our $VERSION = sprintf('%d.%d', q$Revision: 2293 $ =~ /(\d+)\.(\d+)/);
+our $VERSION = substr q$Revision: 2293 $, 10;
+our $VERSION = substr(q$Revision: 2293 $, 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: 2293 $);
+our ($PACKAGE, $VERSION) = ('') x 2;
+our ($VERSION) = "1.23";
+our ($VERSION) = $SomeOtherModule::VERSION;
+our ($VERSION) = '$Revision: 2293 $' =~ /\$Revision:\s+([^\s]+)/;
+our ($VERSION) = '$Revision: 2293 $' =~ /\$Revision:\s+([^\s]+)/;
+our ($VERSION) = '$Revision: 2293 $' =~ m{ \$Revision: \s+ (\S+) }x;
+our ($VERSION) = '$Revision: 2293 $' =~ m{ \$Revision: \s+ (\S+) }xm;
+our ($VERSION) = '$Revision: 2293 $'=~/(\d+(\.\d+))/;
+our ($VERSION) = '$Revision: 2293 $' =~ m{ \$Revision: \s+ (\S+) }x;
+our ($VERSION) = '1.23' =~ /([.,\d]+)/;
+our ($VERSION) = '1.23';
+our ($VERSION) = ($local_variable =~ /(\d+\.\d+)/);
+our ($VERSION) = ('$Revision: 2293 $' =~ /(\d+\.\d+)/) ;
+our ($VERSION) = ('$Revision: 2293 $' =~ /(\d+\.\d+)/);
+our ($VERSION) = ('$Revision: 2293 $' =~ m/([\.\d]+)/) ;
+our ($VERSION) = (q$Revision: 2293 $ =~ /([\d\.]+)/);
+our ($VERSION) = (qq$Revision: 2293 $ =~ /(\d+)/)[0];
+our ($VERSION) = 1.23;
+our ($VERSION) = q$Revision: 2293 $ =~ /Revision:\s+(\S+)/ or $VERSION = "1.23";
+our ($VERSION) = q$Revision: 2293 $ =~ /Revision:\s+(\S+)/ or $VERSION = '1.23';
+our ($VERSION) = q$Revision: 2293 $ =~ /[\d.]+/g;
+our ($VERSION) = q$Revision: 2293 $ =~ /^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: 2293 $)[1] / 1000);
+use version; our $VERSION = version->new('1.23');
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/ProhibitMagicNumbers.run $
+# $Date: 2008-05-04 12:18:31 -0500 (Sun, 04 May 2008) $
+# $Author: clonezone $
+# $Revision: 2293 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/ProhibitMismatchedOperators.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/ProhibitMixedBooleanOperators.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+
+## 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;
+ }
+};
+
+##############################################################################
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 = "]}";
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/ProhibitNoisyQuotes.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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```;
+
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/ProhibitQuotesAsQuotelikeOperatorDelimiters.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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');
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/ProhibitVersionStrings.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 4
+## 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};
+
+#-----------------------------------------------------------------------------
+
+## 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
+
+#-----------------------------------------------------------------------------
+
+## name Things that look like email addresses are exempt
+## failures 0
+## cut
+
+$simple = 'me@foo.bar';
+$complex = q{don-quixote@man-from.lamancha.org};
+
+#-----------------------------------------------------------------------------
+
+## name Email address is part of larger string
+## TODO False positive: we should allow this but I'm feeling lazy right now.
+## failures 0
+## cut
+
+$simple = 'Email: me@foo.bar';
+$complex = q{"don-quixote@man-from.lamancha.org" is my address};
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/RequireInterpolationOfMetachars.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/RequireNumberSeparators.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## name Basic failure
+## failures 1
+## cut
+
+print <<END_QUOTE;
+Four score and seven years ago...
+END_QUOTE
+
+#-----------------------------------------------------------------------------
+
+## name Single quote passing
+## failures 0
+## cut
+
+print <<'END_QUOTE';
+Four score and seven years ago...
+END_QUOTE
+
+#-----------------------------------------------------------------------------
+
+## name Double quote passing
+## failures 0
+## cut
+
+print <<"END_QUOTE";
+Four score and seven years ago...
+END_QUOTE
+
+#-----------------------------------------------------------------------------
+
+## name RT# 25085: Spaces before HEREDOC token - w/ double quotes
+## failures 0
+## cut
+
+print << "END_QUOTE";
+Four score and seven years ago...
+END_QUOTE
+
+#-----------------------------------------------------------------------------
+
+## name RT# 25085: Spaces before HEREDOC token - w/ single quotes
+## failures 0
+## cut
+
+print << 'END_QUOTE';
+The only thing we have to fear is fear itself...
+END_QUOTE
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/RequireQuotedHeredocTerminator.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## name Basic passing
+## failures 0
+## cut
+
+print <<"QUOTE_1";
+Four score and seven years ago...
+QUOTE_1
+
+#-----------------------------------------------------------------------------
+
+## name Quoted failure
+## failures 1
+## cut
+
+print <<"endquote";
+Four score and seven years ago...
+endquote
+
+#-----------------------------------------------------------------------------
+
+## name Bareword failure
+## failures 1
+## cut
+
+print <<endquote;
+Four score and seven years ago...
+endquote
+
+#-----------------------------------------------------------------------------
+
+## name RT #27073: Spaces before HEREDOC token
+## failures 0
+## cut
+
+print << 'END_QUOTE';
+The only thing we have to fear is fear itself...
+END_QUOTE
+
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/ValuesAndExpressions/RequireUpperCaseHeredocTerminator.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Variables/ProhibitConditionalDeclarations.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Variables/ProhibitLocalVars.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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);
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Variables/ProhibitMatchVars.run $
+# $Date: 2008-05-20 22:20:33 -0500 (Tue, 20 May 2008) $
+# $Author: clonezone $
+# $Revision: 2390 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+
+#-----------------------------------------------------------------------------
+
+## 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;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Variables/ProhibitPackageVars.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 = *';
+
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Variables/ProhibitPerl4PackageNames.run $
+# $Date: 2008-05-20 22:43:14 -0500 (Tue, 20 May 2008) $
+# $Author: clonezone $
+# $Revision: 2391 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## name basic
+## failures 3
+## cut
+
+$/ = undef;
+$| = 1;
+$> = 3;
+
+#-----------------------------------------------------------------------------
+
+## 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 = $_;
+
+#-----------------------------------------------------------------------------
+
+## name Configuration
+## parms { allow => '$@ $!' }
+## failures 0
+## cut
+
+print $@;
+print $!;
+
+#-----------------------------------------------------------------------------
+
+## name Strings
+## failures 4
+## TODO We don't look into strings.
+## cut
+
+print "$+";
+print qq<$+>;
+print qx<$+>;
+print qr<$+>;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Variables/ProhibitPunctuationVars.run $
+# $Date: 2008-05-17 12:25:37 -0500 (Sat, 17 May 2008) $
+# $Author: clonezone $
+# $Revision: 2345 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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();
+}
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Variables/ProhibitUnusedVariables.run $
+# $Date: 2008-06-07 21:31:50 -0500 (Sat, 07 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2421 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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;
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Variables/ProtectPrivateVars.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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};
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Variables/RequireInitializationForLocalVars.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+## 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 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 ) {}
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Variables/RequireLexicalLoopIterators.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+#!perl
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Variables/RequireLocalizedPunctuationVars.run.PL $
+# $Date: 2008-06-06 00:48:04 -0500 (Fri, 06 Jun 2008) $
+# $Author: clonezone $
+# $Revision: 2416 $
+##############################################################################
+
+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";
+
+
+
+open my $test_file, '>', $test_file_name
+ or die "Could not open $test_file_name: $ERRNO";
+
+my @globals = (
+ @B::Keywords::Arrays,
+ @B::Keywords::Hashes,
+ @B::Keywords::Scalars,
+);
+push @globals, uniq apply { s/ \A ([^*]) /*$1/xms } @B::Keywords::Filehandles;
+my %exceptions = map {$_ => 1} qw(
+ $_
+ $ARG
+ @_
+);
+
+my $carat_re = qr/\A [\$%]\^\w+ /xms;
+
+my $numvars = @globals - keys %exceptions;
+my $numcarats = grep {!$exceptions{$_} && m/ $carat_re /xms} @globals;
+
+print {$test_file} <<'EOF';
+
+## 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);
+
+#-----------------------------------------------------------------------------
+
+## name Named magic variables, special case failures
+## failures 1
+## TODO we are not handling dereferences yet...
+## cut
+
+$SIG{__DIE__} = sub { print "AAAAAAARRRRRGGGGHHHHH....\n"; };
+
+#-----------------------------------------------------------------------------
+
+## name Named magic variables, pass local
+## failures 0
+## cut
+
+EOF
+
+for my $varname (@globals) {
+ print {$test_file} "local $varname = ();\n";
+}
+
+print {$test_file} <<"EOF";
+
+#-----------------------------------------------------------------------------
+
+## name Named magic variables, pass local()
+## failures 0
+## cut
+
+EOF
+
+for my $varname (@globals) {
+ print {$test_file} "local ($varname) = ();\n";
+}
+
+print {$test_file} <<"EOF";
+
+#-----------------------------------------------------------------------------
+
+## name Named magic variables, pass (local)
+## failures 0
+## cut
+
+EOF
+
+for my $varname (@globals) {
+ print {$test_file} "(local $varname) = ();\n";
+}
+
+print {$test_file} <<"EOF";
+
+#-----------------------------------------------------------------------------
+
+## name Named magic variables, pass = (local) =
+## failures 0
+## cut
+
+EOF
+
+for my $varname (@globals) {
+ print {$test_file} "\@foo = (local $varname) = ();\n";
+}
+
+print {$test_file} <<"EOF";
+
+#-----------------------------------------------------------------------------
+
+## name Named magic variables, fail non-local, non-carats
+## failures @{[$numvars - $numcarats]}
+## cut
+
+EOF
+
+for my $varname (@globals) {
+ next if $exceptions{$varname};
+ next if $varname =~ m/ $carat_re /xms;
+ print {$test_file} "$varname = ();\n";
+}
+
+print {$test_file} <<"EOF";
+
+#-----------------------------------------------------------------------------
+
+## name Named magic variables, fail non-local, carats
+## failures $numcarats
+## cut
+
+EOF
+
+for my $varname (@globals) {
+ next if $exceptions{$varname};
+ next if $varname !~ m/ $carat_re /xms;
+ print {$test_file} "$varname = ();\n";
+}
+
+print {$test_file} <<"EOF";
+
+#-----------------------------------------------------------------------------
+
+## name Named magic variables, fail non-local, carats, no space
+## failures $numcarats
+## cut
+
+EOF
+
+for my $varname (@globals) {
+ next if $exceptions{$varname};
+ next if $varname !~ m/ $carat_re /xms;
+ print {$test_file} "$varname= ();\n";
+}
+
+print {$test_file} <<"EOF";
+
+#-----------------------------------------------------------------------------
+
+## name Named magic variables, fail = (non-local) =
+## failures $numvars
+## cut
+
+EOF
+
+for my $varname (@globals) {
+ next if $exceptions{$varname};
+ print {$test_file} "\@foo = ($varname) = ();\n";
+}
+
+print {$test_file} <<"EOF";
+
+#-----------------------------------------------------------------------------
+
+## name Named magic variables, fail (non-local)
+## failures $numvars
+## cut
+
+EOF
+
+for my $varname (@globals) {
+ next if $exceptions{$varname};
+ print {$test_file} "($varname) = ();\n";
+}
+
+
+print {$test_file} <<'EOF';
+
+#-----------------------------------------------------------------------------
+
+## 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;
+}
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $\URL$
+# $\Date$
+# $\Author$
+# $\Revision$
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
+EOF
+
+close $test_file;
+print "Done.\n\n";
--- /dev/null
+## 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];
+
+#-----------------------------------------------------------------------------
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/Variables/RequireNegativeIndices.run $
+# $Date: 2008-03-16 17:40:45 -0500 (Sun, 16 Mar 2008) $
+# $Author: clonezone $
+# $Revision: 2187 $
+##############################################################################
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+#!/usr/bin/env perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/generate_without_optional_dependencies_wrappers.PL $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+use 5.006001;
+use strict;
+use warnings;
+
+use lib 'inc';
+
+use English qw{-no_match_vars};
+use Readonly;
+use Carp qw{ confess };
+use Fatal qw{ open close };
+
+use Perl::Critic::BuildUtilities qw{ recommended_module_versions };
+
+our $VERSION = '1.088';
+
+Readonly::Scalar my $GENERATED_DIRECTORY => 'xt/author/generated/';
+
+if ( not -d $GENERATED_DIRECTORY ) {
+ print
+ "\n\nSkipping generating tests because it doesn't ",
+ "look like we're in an author environment.\n\n";
+ exit 0;
+}
+
+print "\n\nGenerating tests that hide modules and then run other tests.\n";
+
+my $this_program = __FILE__;
+
+my @modules_to_hide = sort keys %{ { recommended_module_versions } };
+my $modules_to_hide = join "\n" . q< > x 4, @modules_to_hide;
+
+foreach my $test_program_name (@ARGV) {
+ my ($wrapped_test_name) =
+ $test_program_name =~ m<
+ \A
+ $GENERATED_DIRECTORY
+ ( (?: t | xt/author ) / [\w.]+ \.t ) # test to be wrapped
+ _without_optional_dependencies\.t # suffix the new test will have
+ \z
+ >xmso;
+ if (not $wrapped_test_name) {
+ confess
+ 'Could not figure out the name of the test to wrap from "'
+ . $test_program_name
+ . q{".};
+ }
+
+ print "Generating $test_program_name.\n";
+ open my $test_program, '>', $test_program_name
+ or die "Could not open $test_program_name: $ERRNO";
+
+ print {$test_program} <<"END_TEST_PROGRAM";
+#!/usr/bin/env perl
+
+# Do not edit!!! This program generated by $this_program.
+
+use strict;
+use warnings;
+
+use English qw{-no_match_vars};
+
+use lib 't/tlib';
+
+use Perl::Critic::TestUtilitiesWithMinimalDependencies qw{
+ get_skip_all_tests_tap
+};
+
+our \$VERSION = $VERSION;
+
+#-----------------------------------------------------------------------------
+
+eval <<'END_HIDE_MODULES';
+use Test::Without::Module qw{
+ $modules_to_hide
+};
+END_HIDE_MODULES
+
+if ( \$EVAL_ERROR ) {
+ print
+ get_skip_all_tests_tap(),
+ 'Test::Without::Module required to test with the ',
+ "absence of optional modules\\n";
+ exit 0;
+}
+
+
+require '$wrapped_test_name';
+END_TEST_PROGRAM
+
+ close $test_program;
+}
+
+print "Done.\n\n";
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=for stopwords
+
+=head1 NAME
+
+generate_without_additional_dependencies_wrappers.PL - generate tests that are wrappers around other tests but which hide the existence of modules first.
+
+
+=head1 SYNOPSIS
+
+ generate_without_additional_dependencies_wrappers.PL \
+ t/00_modules.t_without_optional_dependencies.t \
+ t/01_config.t_without_optional_dependencies.t \
+ t/13_bundled_policies.t_without_optional_dependencies.t
+
+
+=head1 DESCRIPTION
+
+Release 1.07 of Perl::Critic was an embarrassment because there were no tests
+of core without the presence of optional modules. This program generates
+wrappers for other tests that hide those optional modules.
+
+
+=head1 AUTHOR
+
+Elliot Shank C<< <perl@galumph.org> >>
+
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+package Perl::Critic::Policy::Test;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use Perl::Critic::Utils qw{ :severities };
+use base 'Perl::Critic::Policy';
+
+sub default_severity { return $SEVERITY_LOWEST }
+sub applies_to { return 'PPI::Token::Word' }
+
+sub violates {
+ my ( $self, $elem, undef ) = @_;
+ return $self->violation( 'desc', 'expl', $elem );
+}
+
+1;
+__END__
+
+=head1 DESCRIPTION
+
+diagnostic
+
+=cut
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/t/tlib/Perl/Critic/TestUtilitiesWithMinimalDependencies.pm $
+# $Date: 2008-07-03 10:19:10 -0500 (Thu, 03 Jul 2008) $
+# $Author: clonezone $
+# $Revision: 2489 $
+##############################################################################
+
+package Perl::Critic::TestUtilitiesWithMinimalDependencies;
+
+use 5.006001;
+use strict;
+use warnings;
+
+# do not use Readonly-- this module is used at build-time.
+
+use base 'Exporter';
+
+our $VERSION = '1.088';
+our @EXPORT_OK = qw(
+ get_skip_all_tests_tap
+);
+
+#-----------------------------------------------------------------------------
+
+sub get_skip_all_tests_tap {
+ return '1..0 # Skip ';
+}
+
+1;
+
+__END__
+
+#-----------------------------------------------------------------------------
+
+=pod
+
+=for stopwords
+
+=head1 NAME
+
+Perl::Critic::TestUtilitiesWithMinimalDependencies - Testing functions that only depend upon L<strict>, L<warnings>, and L<Exporter>.
+
+=head1 SYNOPSIS
+
+ use Perl::Critic::TestUtilitiesWithMinimalDependencies qw{
+ get_skip_all_tests_tap
+ };
+
+ use Test::More;
+
+ if ($should_not_run) {
+ plan skip_all => 'Hey! I shouldn't be run!';
+ }
+
+=head1 DESCRIPTION
+
+This module is used by L<Perl::Critic> only for self-testing. It
+differs from L<Perl::Critic::TestUtils> in that it only depends upon
+L<strict>, L<warnings>, and L<Exporter>. This is important for tests
+that need to hide the presence of other modules before starting.
+
+=head1 IMPORTABLE SUBROUTINES
+
+=over
+
+=item C< get_skip_all_tests_tap() >
+
+Returns a string representing the TAP (Test Anything Protocol) output
+for skipping an entire file. This is useful if you don't want to load
+any Test::* modules.
+
+
+=back
+
+
+=head1 AUTHOR
+
+Elliot Shank <perl@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2007-2008 Elliot Shank. 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 :
--- /dev/null
+package ViolationTest;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use PPI::Document;
+use Perl::Critic::Violation;
+use Perl::Critic::Violation; # this is duplicated for test coverage of repeated calls to import()
+
+# This file exists solely to test Perl::Critic::Violation::import()
+
+=head1 DESCRIPTION
+
+This is a test diagnostic.
+
+=cut
+
+sub get_violation {
+
+ my $code = 'Hello World;';
+ my $doc = PPI::Document->new(\$code);
+ return Perl::Critic::Violation->new('', '', $doc, 0);
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+package ViolationTest2;
+
+use 5.006001;
+use strict;
+use warnings;
+
+use PPI::Document;
+use Perl::Critic::Violation;
+
+# This file exists solely to test Perl::Critic::Violation::import()
+
+sub get_violation {
+
+ my $code = 'Hello World;';
+ my $doc = PPI::Document->new(\$code);
+ return Perl::Critic::Violation->new('', '', [0,0], 0);
+}
+
+1;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use PPI::Document;
+use PPI::Dumper;
+
+our $VERSION = '1.088';
+
+my $whitespace = $ARGV[0] && $ARGV[0] eq '-w' ? shift : 0;
+my $code = $ARGV[0] ? (-f $ARGV[0] ? shift : \shift) : \join q{}, <STDIN>;
+my $doc = PPI::Document->new( $code )
+ or die 'Could not parse code: ', PPI::Document::errstr(), "\n";
+my $dump = PPI::Dumper->new( $doc, whitespace => $whitespace );
+$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<PPI> would parse a snippet of
+code, just feed it to C<ppidump>.
+
+By default, whitespace tokens are hidden. Use the C<-w> flag to show
+them.
+
+=head1 AUTHOR
+
+Jeffrey Ryan Thalhammer <thaljef@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2005-2008 Jeffrey Ryan Thalhammer. 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 :
--- /dev/null
+svn propset svn:keywords 'URL Author Revision Date' "$@"
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/xt/author/40_criticize-code.t $
+# $Date: 2008-05-04 17:25:51 -0500 (Sun, 04 May 2008) $
+# $Author: clonezone $
+# $Revision: 2319 $
+##############################################################################
+
+# Self-compliance tests
+
+use strict;
+use warnings;
+
+use English qw( -no_match_vars );
+
+use File::Spec qw();
+use Test::More;
+
+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 } ],
+);
+
+#-----------------------------------------------------------------------------
+
+eval { require Test::Perl::Critic; };
+plan skip_all => 'Test::Perl::Critic required to criticise code' if $EVAL_ERROR;
+
+#-----------------------------------------------------------------------------
+
+eval { require Perl::Critic::Policy::ErrorHandling::RequireUseOfExceptions; };
+plan skip_all =>
+ 'ErrorHandling::RequireUseOfExceptions policy required to criticise code.'
+ . ' This policy is part of the Perl::Critic::More distribution.'
+ if $EVAL_ERROR;
+
+#-----------------------------------------------------------------------------
+# 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
+
+eval { require Devel::EnforceEncapsulation; };
+if ( !$EVAL_ERROR ) {
+ for my $pkg ( $EMPTY, '::Config', '::Policy', '::Violation' ) {
+ Devel::EnforceEncapsulation->apply_to('Perl::Critic'.$pkg);
+ }
+}
+else {
+ diag($EMPTY);
+ diag(
+ 'You should install Devel::EnforceEncapsulation, but other tests '
+ . 'will still run.'
+ );
+}
+
+#-----------------------------------------------------------------------------
+# 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/xt/author/40_perlcriticrc-code $
+# $Date: 2008-05-04 17:25:51 -0500 (Sun, 04 May 2008) $
+# $Author: clonezone $
+# $Revision: 2319 $
+##############################################################################
+
+profile-strictness = quiet
+severity = 1
+theme = core
+verbose = %f: %m at line %l, column %c. %e. (Severity: %s, %p)\n
+
+#-----------------------------------------------------------------------------
+
+[-CodeLayout::RequireTidyCode]
+
+[Documentation::RequirePodSections]
+lib_sections = NAME|DESCRIPTION|AUTHOR|COPYRIGHT
+script_sections = NAME|DESCRIPTION|AUTHOR|COPYRIGHT
+
+[Miscellanea::RequireRcsKeywords]
+keywords = URL Date Author Revision
+
+[CodeLayout::ProhibitHardTabs]
+allow_leading_tabs = 0
+
+[Documentation::PodSpelling]
+stop_words = accessor accessors autoflushes AUTOLOAD backticks bareword barewords BBEdit bitwise boolean booleans builtin CGI config CPAN CVS dereference dereferencing Dolan Dominus elsif exponentials filehandle filehandle filehandles filename globals globbing Guzis hashref HEREDOC HEREDOCs IDE lvalue Maxia Mehner memoization metacharacters Metadata metadata multi-line mutators namespace namespaces PBP perl perlcritic perlcriticrc perldoc Perlish perls PolicyListing postfix PPI pragma pragmas prepend prepending programmatically readline Readonly refactor refactoring regex runtime Schwartzian sigil sigils SQL STDERR STDIN STDOUT stringification subdirectories superclass TerMarsch Thalhammer TODO typeglob UI unblessed undef unescaped unparsed vice-versa whitespace
+
+[InputOutput::RequireCheckedSyscalls]
+functions = open close
+
+[RegularExpressions::ProhibitUnusualDelimiters]
+allow_all_brackets = 1
+
+[RegularExpressions::RequireBracesForMultiline]
+allow_all_brackets = 1
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/xt/author/41_criticize-policies.t $
+# $Date: 2008-05-04 18:52:15 -0500 (Sun, 04 May 2008) $
+# $Author: clonezone $
+# $Revision: 2320 $
+##############################################################################
+
+# Extra self-compliance tests for Policies.
+
+use strict;
+use warnings;
+
+use English qw< -no_match_vars >;
+
+use File::Spec qw<>;
+
+use Test::More;
+
+use Perl::Critic::PolicyFactory ( '-test' => 1 );
+
+#-----------------------------------------------------------------------------
+
+eval { require Test::Perl::Critic; };
+plan skip_all => 'Test::Perl::Critic required to criticise code' if $EVAL_ERROR;
+
+#-----------------------------------------------------------------------------
+
+# 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 :
--- /dev/null
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/xt/author/41_perlcriticrc-policies $
+# $Date: 2008-05-04 19:28:41 -0500 (Sun, 04 May 2008) $
+# $Author: clonezone $
+# $Revision: 2322 $
+##############################################################################
+
+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
--- /dev/null
+#!perl
+
+##############################################################################
+# $URL: http://perlcritic.tigris.org/svn/perlcritic/trunk/Perl-Critic/xt/author/80_policysummary.t $
+# $Date: 2008-04-20 22:15:46 -0700 (Sun, 20 Apr 2008) $
+# $Author: clonezone $
+# $Revision: 2277 $
+##############################################################################
+
+use strict;
+use warnings;
+
+use English qw< -no_match_vars >;
+
+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;
+
+#-----------------------------------------------------------------------------
+
+my $summary_file =
+ File::Spec->catfile( qw< lib Perl Critic PolicySummary.pod > );
+if (open my ($fh), '<', $summary_file) {
+
+ my $content = do {local $/=undef; <$fh> };
+ close $fh;
+
+ my @policy_names = bundled_policy_names();
+ my @summaries = $content =~ m/^=head2 [ ]+ L<([\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:]+)>\n\n([^\n]+)/gxms;
+ for my $policy_name (keys %descriptions) {
+ $descriptions{$policy_name} =~ s/[ ] \[Severity [ ] (\d+)\]//xms;
+ my $severity = $1;
+ $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<Cannot open "$summary_file": $ERRNO>;
+}
+
+#-----------------------------------------------------------------------------
+
+# ensure we run 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 :
--- /dev/null
+#!perl -w
+use warnings;
+use strict;
+
+use File::Find;
+use Test::More;
+
+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');
+}
+
+sub check_version {
+ return if (! m{blib/script/}xms && ! m{\.pm \z}xms);
+
+ local $/ = undef;
+ my $fh;
+ open $fh, '<', $_ or die $!;
+ my $content = <$fh>;
+ close $fh;
+
+ # Skip POD
+ $content =~ s/^__END__.*//xms;
+
+ # only look at perl scripts, not sh scripts
+ return if (m{blib/script/}xms && $content !~ m/\A \#![^\r\n]+?perl/xms);
+
+ my @version_lines = $content =~ m/ ( [^\n]* \$VERSION [^\n]* ) /gxms;
+ # Special cases for printing/documenting version numbers
+ @version_lines = grep {! m/(?:\\|\"|\'|C<|v)\$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, $_);
+ }
+ }
+}
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+#!perl
+
+use warnings;
+use strict;
+
+use Test::More;
+
+use File::Find;
+use PPI::Document;
+
+my %implied = (
+ # Universal
+ SUPER => 1,
+
+ 'Readonly::Scalar' => 'Readonly',
+ 'Readonly::Array' => 'Readonly',
+ 'Readonly::Hash' => 'Readonly',
+);
+
+
+my @pm;
+find(
+ {
+ wanted => sub { push @pm, $_ if m/\.pm \z/xms && !m/svn/xms },
+ no_chdir => 1,
+ },
+ 'lib'
+);
+plan tests => scalar @pm;
+
+for my $file (@pm) {
+ SKIP:
+ {
+ my $doc = PPI::Document->new($file) || die 'Failed to parse '.$file;
+
+ 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::[a-z]+/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;
+ if (@failures) {
+ diag("found deps @{[sort keys %deps]}");
+ diag("Missed @failures");
+ }
+ ok(@failures == 0, $file);
+ }
+}
+
+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 run 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 :
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval {
+ require Test::Kwalitee;
+ Test::Kwalitee->import( tests => [ qw{ -no_symlinks } ] );
+};
+plan( skip_all => 'Test::Kwalitee not installed; skipping' ) if $@;
+
+# Local Variables:
+# mode: cperl
+# cperl-indent-level: 4
+# fill-column: 78
+# indent-tabs-mode: nil
+# c-indentation-style: bsd
+# End:
+# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :
--- /dev/null
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+Format: 1.0
+Source: libperl-critic-perl
+Binary: libperl-critic-perl
+Architecture: all
+Version: 1.088-1
+Maintainer: Debian Perl Group <pkg-perl-maintainers@lists.alioth.debian.org>
+Uploaders: gregor herrmann <gregor+debian@comodo.priv.at>, Damyan Ivanov <dmn@debian.org>
+Homepage: http://search.cpan.org/dist/Perl-Critic/
+Standards-Version: 3.8.0
+Vcs-Browser: http://svn.debian.org/wsvn/pkg-perl/trunk/libperl-critic-perl/
+Vcs-Svn: svn://svn.debian.org/pkg-perl/trunk/libperl-critic-perl/
+Build-Depends: debhelper (>= 7)
+Build-Depends-Indep: perl (>= 5.8), perl-modules, libb-keywords-perl, libconfig-tiny-perl, libfile-spec-perl, libio-string-perl, liblist-moreutils-perl, libmodule-pluggable-perl, libppi-perl (>= 1.203), libstring-format-perl, libfile-homedir-perl, libfile-which-perl, perltidy, libpod-spell-perl, libreadonly-xs-perl, libreadonly-perl, libexception-class-perl, libtest-pod-perl, libtest-pod-coverage-perl, perl-modules (>= 5.10) | libversion-perl, libtest-deep-perl
+Checksums-Sha1:
+ 8ae460eab707667b907763d78ce28bf2cb0ef14a 367270 libperl-critic-perl_1.088.orig.tar.gz
+ d7ed8c0bfcfde6d898860a3b255c12a3d481bf5f 2874 libperl-critic-perl_1.088-1.diff.gz
+Checksums-Sha256:
+ a4ed804dcfe8aa5bf3e59d91d0ffd7029120a6e14450ce5b1c036e867029fb82 367270 libperl-critic-perl_1.088.orig.tar.gz
+ 489b26ac484ad853c0bcb3987ee8c1fab74d391b63c78c6ddd6a06e3fb66c6ac 2874 libperl-critic-perl_1.088-1.diff.gz
+Files:
+ 54c83f49fcf0888e8e8d81516cb6f76b 367270 libperl-critic-perl_1.088.orig.tar.gz
+ 2895dcdb05473c42bc68201409b33841 2874 libperl-critic-perl_1.088-1.diff.gz
+
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.4.9 (GNU/Linux)
+
+iEYEARECAAYFAkhx89AACgkQHqjlqpcl9jvMSwCcCsb3C0u0dys1cCOaEZ/NK11Z
+qvoAn2tAfVJtPPBOxsLIlXP8zKeg1jzo
+=sBEr
+-----END PGP SIGNATURE-----
projects / dh-make-perl / commitdiff