Sfoglia il codice sorgente

Move ProhibitPipeOpen out to its own distribution

A Perl::Critic policy is a module like any other, so vendoring it under
policy/ and teaching perlcritic to find it with a PERL5LIB dance was the wrong
shape.  It now lives in perl-critic-policy-prohibitpipeopen, laid out the same
way as perl-json-validator-schema-troglodyne, and .perlcriticrc names it the
same way it names every other policy it uses -- none of which are vendored
here either.

The Installer.mk critic target goes with it; there is nothing left for it to
set up.  The policy's tests moved into the new distribution.

Note that perlcritic will say the policy is not installed until you install
it.  It is not on CPAN yet, so that means installing the built tarball.

Co-Authored-By: Claude Opus 5 (1M context) <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_01CJ2NAMQyytncwHKSmD5dFe
George Baugh 1 mese fa
parent
commit
323226c89e

+ 1 - 2
.perlcriticrc

@@ -44,8 +44,7 @@ config = .preferred_modules.ini
 formats = #!/usr/bin/env perl
 # Performance
 [logicLAB::ProhibitShellDispatch]
-# Lives in policy/ in this repo, so perlcritic needs PERL5LIB=policy to see it.
-[Troglodyne::ProhibitPipeOpen]
+[ProhibitPipeOpen]
 [Performance::ProhibitRegexForSimpleSubstring]
 # Extensions to perl -c
 [CompileTime]

+ 0 - 4
Installer.mk

@@ -42,10 +42,6 @@ reset-remove:
 	rm config/has_users; /bin/true
 	rm config/setup; /bin/true
 
-.PHONY: critic
-critic:
-	PERL5LIB=policy perlcritic bin lib
-
 .PHONY: githook
 githook:
 	cp git-hooks/pre-commit .git/hooks

+ 0 - 117
policy/Perl/Critic/Policy/Troglodyne/ProhibitPipeOpen.pm

@@ -1,117 +0,0 @@
-package Perl::Critic::Policy::Troglodyne::ProhibitPipeOpen;
-
-use v5.36;
-use re '/aa';
-
-use Readonly;
-
-use Perl::Critic::Utils qw{ :severities :classification :ppi };
-use parent 'Perl::Critic::Policy';
-
-our $VERSION = '0.01';
-
-#-----------------------------------------------------------------------------
-
-# The mode argument of a three-or-more-arg open that makes it spawn something
-# rather than open a file.
-Readonly::Scalar my $PIPE_MODE_RX => qr/\A (?: -[|] | [|]- ) \z/xms;
-
-# The same thing said the old way, with the pipe buried in a two-arg string:
-# "cmd |" to read from it, "| cmd" to write to it.
-Readonly::Scalar my $TWO_ARG_PIPE_RX => qr/ (?: \A \s* [|] | [|] \s* \z ) /xms;
-
-Readonly::Scalar my $DESC => q{Pipe "open" used};
-Readonly::Scalar my $EXPL => q{Shelling out needs signing off on -- use system/exec/qx with a '## no critic' saying why};
-
-#-----------------------------------------------------------------------------
-
-sub supported_parameters { return () }
-sub default_severity     { return $SEVERITY_HIGHEST }
-sub default_themes       { return qw(troglodyne security) }
-sub applies_to           { return 'PPI::Token::Word' }
-
-#-----------------------------------------------------------------------------
-
-sub violates {
-    my ( $self, $elem, undef ) = @_;
-
-    return if $elem->content() ne 'open';
-    return if !is_function_call($elem);
-
-    my @args = parse_arg_list($elem);
-    return if @args < 2;
-
-    my $mode = $args[1]->[0];
-    return if !$mode->isa('PPI::Token::Quote');
-
-    # open($fh, '-|', @cmd) and friends, including the bare two-arg fork form.
-    return $self->violation( $DESC, $EXPL, $elem ) if $mode->string() =~ $PIPE_MODE_RX;
-
-    # open($fh, "cmd |").  Only ever a pipe when there is no third argument --
-    # with one, the second is a mode and a stray '|' in it is not our business.
-    return $self->violation( $DESC, $EXPL, $elem )
-      if @args == 2 && $mode->string() =~ $TWO_ARG_PIPE_RX;
-
-    return;    # ok!
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-Perl::Critic::Policy::Troglodyne::ProhibitPipeOpen - Don't let a pipe open be the quiet way to shell out.
-
-=head1 AFFILIATION
-
-This policy lives in the tCMS repository, under C<policy/>, rather than in a
-Perl::Critic distribution.  It is not installed with tCMS.
-
-=head1 DESCRIPTION
-
-C<logicLAB::ProhibitShellDispatch> flags C<system>, C<exec>, C<qx> and
-backticks, which is every obvious way to run an external command -- and not the
-pipe open, which does the same thing and reads its output besides:
-
-    open( my $fh, '-|', $bin, '--version' );   # not flagged by that policy
-    my $version = qx{$bin --version};          # flagged
-
-Having one of those be quietly acceptable makes the linter an argument for
-writing the shell-out in whichever form it happens not to notice, rather than a
-decision anybody made.  This policy closes that off, so every way of starting a
-process needs the same explicit C<## no critic> and the comment that goes with
-it.
-
-It is not that a pipe open is worse.  In the list form it is the better of the
-two -- no shell, so no quoting to get wrong.  It is that either one should be a
-decision on the record.
-
-Prohibited:
-
-    open( my $fh, '-|', 'ls', '-l' );   # three-arg, read from a command
-    open( my $fh, '|-', 'mail', $to );  # three-arg, write to a command
-    open( my $fh, '-|' );               # two-arg fork
-    open( FH, 'ls -l |' );              # two-arg, the old spelling
-    open( FH, '| mail bob' );
-
-Allowed, being ordinary file opens:
-
-    open( my $fh, '<',  $path );
-    open( my $fh, '>>', $path );
-
-=head1 CONFIGURATION
-
-This Policy is not configurable except for the standard options.
-
-=head1 CAVEATS
-
-The mode has to be a literal for this to see it.  A pipe open built at runtime,
-C<< open( $fh, $mode, $cmd ) >> with C<$mode> computed, goes unnoticed -- the
-policy reads source, not intent.
-
-=head1 AUTHOR
-
-Troglodyne Internet Widgets
-
-=cut

+ 0 - 74
t/Perl-Critic-Policy-Troglodyne-ProhibitPipeOpen.t

@@ -1,74 +0,0 @@
-use strict;
-use warnings;
-
-use Test::More;
-use FindBin;
-
-# policy/ has to be on @INC *before* Perl::Critic loads: it finds policies by
-# scanning @INC once, at load time, so adding the directory afterwards leaves
-# it unable to see ours.
-use lib "$FindBin::Bin/../policy";
-
-# The policy is a development tool, not part of tCMS proper -- it lives in
-# policy/ and is never installed.  Anyone without Perl::Critic can still run
-# the rest of the suite.
-BEGIN {
-    plan skip_all => 'Perl::Critic not installed' unless eval { require Perl::Critic; 1 };
-}
-
-my $policy = 'Troglodyne::ProhibitPipeOpen';
-require_ok("Perl::Critic::Policy::$policy") or BAIL_OUT("Can't find SUT");
-
-# -profile => '' so the repo's own .perlcriticrc, which perlcritic would
-# otherwise find by walking up from cwd, doesn't drag in every other policy and
-# fail these snippets for want of POD.
-# Note the hyphen: -single_policy is silently ignored and you get all 222
-# policies instead.  -profile => '' so the repo's own .perlcriticrc, which
-# perlcritic would otherwise find by walking up from cwd, doesn't drag in every
-# other policy and fail these snippets for want of POD.
-my $critic = Perl::Critic->new( -profile => q{}, '-single-policy' => $policy, -severity => 1 );
-
-sub violations {
-    my ($source) = @_;
-    return scalar $critic->critique( \"use strict;\nuse warnings;\n$source\n" );
-}
-
-subtest 'opens that spawn something are caught' => sub {
-    my %cases = (
-        'three-arg read'    => q{open( my $fh, '-|', 'ls', '-l' );},
-        'three-arg write'   => q{open( my $fh, '|-', 'mail', $to );},
-        'bare two-arg fork' => q{open( my $fh, '-|' );},
-        'two-arg trailing'  => q{open( FH, 'ls -l |' );},
-        'two-arg leading'   => q{open( FH, '| mail bob' );},
-        'qw-quoted mode'    => q{open( my $fh, q{-|}, 'ls' );},
-    );
-    foreach my $name ( sort keys %cases ) {
-        is( violations( $cases{$name} ), 1, "$name is a violation" );
-    }
-};
-
-subtest 'ordinary file opens are left alone' => sub {
-    my %cases = (
-        'read'              => q{open( my $fh, '<', $path );},
-        'write'             => q{open( my $fh, '>', $path );},
-        'append'            => q{open( my $fh, '>>', $path );},
-        'interpolated path' => q{open( my $fh, '>', "$dir/thing" );},
-        'in-memory'         => q{open( my $fh, '<', \$scalar );},
-        'opendir'           => q{opendir( my $dh, $dir );},
-        'bitwise or'        => q{my $x = $a | $b;},
-        'a sub named open'  => q{$obj->open( '-|', 'ls' );},
-    );
-    foreach my $name ( sort keys %cases ) {
-        is( violations( $cases{$name} ), 0, "$name is not a violation" );
-    }
-};
-
-subtest 'the annotation is what signs it off' => sub {
-    is(
-        violations(q{open( my $fh, '-|', 'ls' );  ## no critic (Troglodyne::ProhibitPipeOpen)}),
-        0,
-        'an explicit no-critic suppresses it'
-    );
-};
-
-done_testing();