Login
Apply the unmodified patch from Schwern (modulo dealing with
authorElliot Shank <perl@galumph.com>
Thu, 14 Aug 2008 03:58:27 +0000 (03:58 +0000)
committerElliot Shank <perl@galumph.com>
Thu, 14 Aug 2008 03:58:27 +0000 (03:58 +0000)
RJBS' change to support PAR).  I have no idea whether tests
or anything works at this point.  I just considered it
worthwhile to capture the change as it is before modifying
it further.

bin/perlcritic
lib/Perl/Critic.pm
lib/Perl/Critic/Config.pm
lib/Perl/Critic/OptionsProcessor.pm
lib/Perl/Critic/ProfilePrototype.pm
t/01_config.t
t/04_optionsprocessor.t
t/07_perlcritic.t

index 2ab0dc7..75a4fb4 100755 (executable)
@@ -44,6 +44,7 @@ Readonly::Scalar my $EXIT_HAD_FILE_PROBLEMS => 3;
 
 my @FILES = ();
 my $CRITIC = undef;
+my $Output = \*STDOUT;
 
 # This %ENV check is to allow perlcritic to function when bundled under PAR,
 # which invokes this program not as the top stack frame. -- rjbs, 2008-08-11
@@ -52,6 +53,11 @@ exit run() if not caller() or $ENV{PAR_0};
 #-----------------------------------------------------------------------------
 # Begin subroutines
 
+sub out {
+    print $Output @_;
+}
+
+
 sub run {
     my %options    = get_options();
     @FILES         = get_input(@ARGV);
@@ -107,7 +113,7 @@ sub get_options {
 #-----------------------------------------------------------------------------
 
 sub _parse_command_line {
-    my %opts      = ( -color => 1 );
+    my %opts;
     my @opt_specs = _get_option_specification();
     Getopt::Long::Configure('no_ignore_case');
     GetOptions( \%opts, @opt_specs ) || pod2usage();           #Exits
@@ -121,7 +127,7 @@ sub _dispatch_special_requests {
     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{version}         ) { out "$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
@@ -225,6 +231,8 @@ sub critique {
     $CRITIC = Perl::Critic->new( %{$opts_ref} );
     $CRITIC->policies() || die "No policies selected.\n";
 
+    set_up_pager();
+
     my $number_of_violations = undef;
     my $had_error_in_file = 0;
 
@@ -274,15 +282,15 @@ sub render_report {
     # 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";
+        ref $file || out "$file: ";
+        out "$number_of_violations\n";
         return $number_of_violations;
     }
 
     # Hail all-clear unless we should shut up.
     if( !@violations && !$opts_ref->{-quiet} ) {
-        ref $file || print "$file ";
-        print "source OK\n";
+        ref $file || out "$file ";
+        out "source OK\n";
         return 0;
     }
 
@@ -298,11 +306,21 @@ sub render_report {
     Perl::Critic::Violation::set_format( $fmt );
 
     my $color = $CRITIC->config->color();
-    print $color ? _colorize_by_severity(@violations) : @violations;
+    out $color ? _colorize_by_severity(@violations) : @violations;
 
     return $number_of_violations;
 }
 
+
+sub set_up_pager {
+    return unless _at_tty();
+
+    my $command = $CRITIC->config->pager;
+    open( my $pager, '|-', $command ) or die qq{Unable to pipe to pager "$command": $!};
+    $Output = $pager;
+}
+
+
 #-----------------------------------------------------------------------------
 
 sub report_statistics {
@@ -315,59 +333,59 @@ sub report_statistics {
             or  not $opts_ref->{-quiet} and $statistics->modules()
         )
     ) {
-        print "\n"; # There's prior output that we want to separate from.
+        out "\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";
+    out _commaify($statistics->modules()), " files.\n";
+    out _commaify($statistics->subs()), " subroutines/methods.\n";
+    out _commaify($statistics->statements_other_than_subs()), " statements.\n";
+    out _commaify($statistics->lines()), " lines.\n";
 
     my $average_sub_mccabe = $statistics->average_sub_mccabe();
     if (defined $average_sub_mccabe) {
-        printf
+        out sprintf
             "\nAverage McCabe score of subroutines was %.2f.\n",
             $average_sub_mccabe;
     }
 
-    print "\n";
+    out "\n";
 
-    print _commaify($statistics->total_violations()), " violations.\n";
+    out _commaify($statistics->total_violations()), " violations.\n";
 
     my $violations_per_file = $statistics->violations_per_file();
     if (defined $violations_per_file) {
-        printf
+        out sprintf
             "Violations per file was %.3f.\n",
             $violations_per_file;
     }
     my $violations_per_statement = $statistics->violations_per_statement();
     if (defined $violations_per_statement) {
-        printf
+        out sprintf
             "Violations per statement was %.3f.\n",
             $violations_per_statement;
     }
     my $violations_per_line = $statistics->violations_per_line_of_code();
     if (defined $violations_per_line) {
-        printf
+        out sprintf
             "Violations per line of code was %.3f.\n",
             $violations_per_line;
     }
 
     if ( $statistics->total_violations() ) {
-        print "\n";
+        out "\n";
 
         my %severity_violations = %{ $statistics->violations_by_severity() };
         foreach my $severity ( reverse sort keys %severity_violations ) {
-            print
+            out
                 _commaify($severity_violations{$severity}),
                 " severity $severity violations.\n";
         }
 
-        print "\n";
+        out "\n";
 
         my %policy_violations = %{ $statistics->violations_by_policy() };
         foreach my $policy ( sort keys %policy_violations ) {
-            print
+            out
                 _commaify($policy_violations{$policy}),
                 ' violations of ',
                 policy_short_name($policy),
@@ -416,6 +434,7 @@ sub _get_option_specification {
         noprofile
         only!
         options
+        pager=s
         profile=s
         profile-proto
         quiet
@@ -435,7 +454,6 @@ sub _get_option_specification {
 
 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 };
 
@@ -478,7 +496,7 @@ sub render_policy_listing {
     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;
+    out $listing;
     exit 0;
 }
 
@@ -491,7 +509,7 @@ sub render_theme_listing {
     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;
+    out $listing;
     exit 0;
 }
 
@@ -505,7 +523,7 @@ sub render_profile_prototype {
     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;
+    out $prototype;
     exit 0;
 }
 
@@ -553,7 +571,8 @@ C<perlcritic> - Command-line interface to critique Perl source.
              [--only | --noonly] [--profile-strictness {warn|fatal|quiet}]
              [--force | --noforce] [--statistics] [--statistics-only]
              [--count | -C] [--verbose {number | format}]
-             [--color | --nocolor] [--quiet] {FILE | DIRECTORY | STDIN}
+             [--color | --nocolor] [--pager pager]
+             [--quiet] {FILE | DIRECTORY | STDIN}
 
   perlcritic --profile-proto
 
@@ -899,15 +918,21 @@ 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|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.
+This option is on when outputting to a tty.  When set, Severity 5 and 4 are
+colored red and yellow, respectively.  Colorization only happens if
+L<Term::ANSIColor|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<--pager PAGER>
+
+If set, perlcritic will pipe it's output to the given PAGER.
+
+Setting a pager turns off color by default.  You will have to turn color on
+manually.
+
 =item C<--doc PATTERN>
 
 Displays the perldoc for all
index c59e277..1ce90f7 100644 (file)
@@ -463,7 +463,7 @@ URL and interface to the service are subject to change.
 
 =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( [ -profile => $FILE, -severity => $N, -theme => $string, -include => \@PATTERNS, -exclude => \@PATTERNS, -top => $N, -only => $B, -profile-strictness => $PROFILE_STRICTNESS_{WARN|FATAL|QUIET}, -force => $B, -verbose => $N ], -color => $B, -pager => $string, -criticism-fatal => $B) >>
 
 =item C<< new() >>
 
@@ -591,7 +591,7 @@ L<Perl::Critic::Violation|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
+B<-color> and B<-pager> are not used by Perl::Critic but is provided for the benefit
 of L<perlcritic|perlcritic>.
 
 B<-criticism-fatal> is not used by Perl::Critic but is provided for
@@ -711,6 +711,7 @@ corresponding constructor argument.
     exclude   = Variables  Modules::RequirePackage    #Space-delimited list
     criticism-fatal = 1                               #Zero or One
     color     = 1                                     #Zero or One
+    pager     = less                                  #pager to pipe output to
 
 The remainder of the configuration file is a series of blocks like
 this:
index e973f6e..d4da893 100644 (file)
@@ -102,6 +102,7 @@ sub _init {
     }
 
     $self->_validate_and_save_theme($args{-theme}, $errors);
+    $self->_validate_and_save_pager($args{-pager}, $errors);
 
     # Construct a Factory with the Profile
     my $factory =
@@ -164,7 +165,7 @@ sub _add_policy_if_enabled {
 
     my $config = $policy_object->__get_config()
         or throw_internal
-            q{Policy was not set up properly because it doesn't have }
+            q{Policy was not set up properly because it does not have }
                 . q{a value for its config attribute.};
 
     if ( $policy_object->initialize_if_enabled( $config ) ) {
@@ -630,6 +631,31 @@ sub _validate_and_save_theme {
 }
 
 #-----------------------------------------------------------------------------
+
+sub _validate_and_save_pager {
+    my ($self, $args_value, $errors) = @_;
+
+    my $pager;
+    if( $args_value ) {
+        $pager = defined $args_value ? $args_value : '';
+    }
+    elsif( $ENV{PERLCRITIC_PAGER} ) {
+        $pager = $ENV{PERLCRITIC_PAGER};
+    }
+    else {
+        my $profile = $self->_profile();
+        $pager = $profile->options_processor()->pager();
+    }
+
+    $pager = $ENV{PAGER} if $pager eq '$PAGER';
+    $pager ||= '';
+
+    $self->{_pager} = $pager;
+
+    return;
+}
+
+#-----------------------------------------------------------------------------
 # Begin ACCESSSOR methods
 
 sub _profile {
@@ -723,6 +749,13 @@ sub color {
 
 #-----------------------------------------------------------------------------
 
+sub pager  {
+    my $self = shift;
+    return $self->{_pager};
+}
+
+#-----------------------------------------------------------------------------
+
 sub criticism_fatal {
     my $self = shift;
     return $self->{_criticism_fatal};
@@ -848,8 +881,8 @@ format specification.  See
 L<Perl::Critic::Violations|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|perlcritic>.
+B<-color> and B<-pager> are not used by Perl::Critic but is provided
+for the benefit of L<perlcritic|perlcritic>.
 
 B<-criticism-fatal> is not used by Perl::Critic but is provided for
 the benefit of L<criticism|criticism>.
@@ -930,6 +963,10 @@ Returns the value of the C<-verbose> attribute for this Config.
 
 Returns the value of the C<-color> attribute for this Config.
 
+=item C< pager() >
+
+Returns the value of the C<-pager> attribute for this Config.
+
 =item C< criticism_fatal() >
 
 Returns the value of the C<-criticsm-fatal> attribute for this Config.
index 5d7a681..47dc9f4 100644 (file)
@@ -54,8 +54,11 @@ sub _init {
     $self->{_top}            = dor(delete $args{top},                $FALSE);
     $self->{_verbose}        = dor(delete $args{verbose},            $DEFAULT_VERBOSITY);
     $self->{_criticism_fatal} = dor(delete $args{'criticism-fatal'}, $FALSE);
+    $self->{_pager}          = dor(delete $args{pager},              $EMPTY);
 
-    $self->{_color} = dor(delete $args{color}, dor(delete $args{colour}, $TRUE));
+    # If we're using a pager or not outputing to a tty don't use colors.
+    my $default_color = ($self->pager or !-t *STDOUT) ? 0 : 1;
+    $self->{_color} = dor(delete $args{color}, dor(delete $args{colour}, $default_color));
 
     # If there's anything left, complain.
     _check_for_extra_options(%args);
@@ -151,6 +154,13 @@ sub color {
 
 #-----------------------------------------------------------------------------
 
+sub pager {
+    my ($self) = @_;
+    return $self->{_pager};
+}
+
+#-----------------------------------------------------------------------------
+
 sub criticism_fatal {
     my ($self) = @_;
     return $self->{_criticism_fatal};
@@ -273,6 +283,12 @@ string).
 Returns the default C<color> setting. (Either 1 or 0).
 
 
+=item C< pager() >
+
+Returns the default C<pager> setting. (Either empty string or the pager
+command string).
+
+
 =item C< criticism_fatal() >
 
 Returns the default C<criticism-fatal> setting (Either 1 or 0).
index e7649f8..f65cde3 100644 (file)
@@ -109,6 +109,11 @@ sub to_string {
     $prototype .= "\n";
 
     $prototype .= $prefix;
+    $prototype .= q{pager = };
+    $prototype .= $configuration->pager();
+    $prototype .= "\n";
+
+    $prototype .= $prefix;
     $prototype .= q{top = };
     $prototype .= $configuration->top();
     $prototype .= "\n";
index a6f1681..9c6103c 100644 (file)
@@ -25,7 +25,7 @@ use Perl::Critic::TestUtils qw<
 >;
 use Perl::Critic::Utils qw< :severities >;
 
-use Test::More tests => 66;
+use Test::More tests => 69;
 
 #-----------------------------------------------------------------------------
 
@@ -268,9 +268,12 @@ my $total_policies   = scalar @names_of_policies_willing_to_work;
         -only
         -force
         -color
+        -pager
         -criticism-fatal
     );
 
+    my $color = -t *STDOUT ? 1 : 0;
+
     my %undef_args = map { $_ => undef } @switches;
     my $c = Perl::Critic::Config->new( %undef_args );
     $c = Perl::Critic::Config->new( %undef_args );
@@ -279,7 +282,8 @@ my $total_policies   = scalar @names_of_policies_willing_to_work;
     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->color(),     $color, 'Undefined -color');
+    is( $c->pager(),     q{},   'Undefined -pager');
     is( $c->verbose(),   4,     'Undefined -verbose');
     is( $c->criticism_fatal(), 0, 'Undefined -criticism-fatal');
 
@@ -291,6 +295,7 @@ my $total_policies   = scalar @names_of_policies_willing_to_work;
     is( $c->theme()->rule(),     q{},     'zero -theme');
     is( $c->top(),       0,       'zero -top');
     is( $c->color(),     0,       'zero -color');
+    is( $c->pager(),     '',      'zero -pager');
     is( $c->verbose(),   4,       'zero -verbose');
     is( $c->criticism_fatal(), 0, 'zero -criticism-fatal');
 
@@ -302,6 +307,7 @@ my $total_policies   = scalar @names_of_policies_willing_to_work;
     is( $c->theme->rule(),     q{},     'empty -theme');
     is( $c->top(),       0,       'empty -top');
     is( $c->color(),     0,       'empty -color');
+    is( $c->pager(),     q{},     'empty -pager');
     is( $c->verbose(),   4,       'empty -verbose');
     is( $c->criticism_fatal(), 0, 'empty -criticism-fatal');
 }
index 3e61cf9..5a6d9e9 100644 (file)
@@ -15,7 +15,7 @@ use English qw(-no_match_vars);
 
 use Perl::Critic::OptionsProcessor;
 
-use Test::More tests => 24;
+use Test::More tests => 27;
 
 #-----------------------------------------------------------------------------
 
@@ -24,13 +24,16 @@ our $VERSION = '1.090';
 #-----------------------------------------------------------------------------
 
 {
+    my $color = -t *STDOUT ? 1 : 0;
+
     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->color(),    $color,      'native default color');
+    is($processor->pager(),    q{},         'native default pager');
     is($processor->verbose(),  4,           'native default verbose');
     is($processor->criticism_fatal,   0,    'native default criticism-fatal');
     is_deeply($processor->include(), [],    'native default include');
@@ -47,6 +50,7 @@ our $VERSION = '1.090';
          theme     => 'pbp',
          top       => 50,
          color     => 0,
+         pager     => 'less',
          verbose   => 7,
          'criticism-fatal'   => 1,
          include   => 'foo bar',
@@ -60,6 +64,7 @@ our $VERSION = '1.090';
     is($processor->theme(),    'pbp',       'user default theme');
     is($processor->top(),      50,          'user default top');
     is($processor->color(),    0,           'user default color');
+    is($processor->pager(),    'less',      'user default pager');
     is($processor->verbose(),  7,           'user default verbose');
     is($processor->criticism_fatal(),  1,   'user default criticism_fatal');
     is_deeply($processor->include(), [ qw(foo bar) ], 'user default include');
@@ -77,6 +82,15 @@ our $VERSION = '1.090';
 }
 
 #-----------------------------------------------------------------------------
+
+{
+    my $processor = Perl::Critic::OptionsProcessor->new(
+        pager => "foo"
+    );
+    is($processor->color(), 0, 'pager set turns off color');
+}
+
+#-----------------------------------------------------------------------------
 # Test exception handling
 
 {
index c43d7dd..18bedef 100644 (file)
@@ -18,7 +18,7 @@ use File::Spec;
 
 use Perl::Critic::Utils qw< :characters >;
 
-use Test::More tests => 36;
+use Test::More tests => 37;
 
 #-----------------------------------------------------------------------------
 
@@ -179,6 +179,14 @@ $message = "@ARGV";
 %options = get_options();
 is( $options{-quiet}, 1, $message);
 
+
+#-----------------------------------------------------------------------------
+
+local @ARGV = qw(-pager foo);
+%options = eval { get_options() };
+is( $options{-pager}, "foo",  "@ARGV" );
+
+
 #-----------------------------------------------------------------------------
 # Intercept pod2usage so we can test invalid options and special switches