Prohibit pipe opens, and shell out through qx where we mean to

logicLAB::ProhibitShellDispatch flags system, exec, qx and backticks, and not
open($fh, '-|', ...), which runs an external command the same as any of them
and reads its output besides.  That gap makes the linter an argument for
writing a shell-out in whichever spelling it does not happen to look at, which
is the opposite of the point.  I walked straight into it in 0c69346.

Troglodyne::ProhibitPipeOpen closes it.  Modelled on the core
InputOutput::ProhibitTwoArgOpen, which is where the '-|'/'|-' mode regex and
the parse_arg_list() approach come from -- that policy has the inverse job, so
it *exempts* the fork handles this one is looking for.  Catches the three-arg
forms, the bare two-arg fork, and the old "cmd |" spelling; leaves ordinary
file opens, opendir, bitwise or, and a method that happens to be named open.
A mode computed at runtime goes unnoticed, as documented.

It lives in policy/ rather than lib/ because it is a development tool and
should not ship with tCMS.  perlcritic finds policies by scanning @INC once at
load time, so it wants PERL5LIB=policy; without it perlcritic says the policy
is not installed rather than quietly skipping it.  'make -f Installer.mk
critic' sets it for you.

favicon_mongler's version probe is now a qx with the same explicit no-critic
the render call carries.  The binary path is quoted, as File::Which returns
whatever it found and that may have spaces in it.

Co-Authored-By: Claude Opus 5 (1M context) <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_01CJ2NAMQyytncwHKSmD5dFe

.perlcriticrc

@@ -44,6 +44,8 @@ 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]
 [Performance::ProhibitRegexForSimpleSubstring]
 # Extensions to perl -c
 [CompileTime]

Installer.mk

@@ -42,6 +42,10 @@ 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

bin/favicon_mongler.pl

@@ -51,11 +51,12 @@ extension.  The real container is assembled with Imager afterwards.
 # flipped between the two by hand twice (e23b678, then back in 5f0cdca).
 sub _export_flag ($bin) {
 
-    # A list-form pipe open, rather than qx// or backticks, so the path to the
-    # binary is handed over as an argument and never sees a shell.
-    open( my $fh, '-|', $bin, '--version' ) or die "Could not run $bin --version: $!";
-    my $version = do { local $/; <$fh> };
-    close $fh;
+    # Shelling out, on purpose and on the record.  system() cannot hand back
+    # what the child printed, and reaching for a pipe open instead would only
+    # be picking the spelling ProhibitShellDispatch happens not to look at --
+    # which is what Troglodyne::ProhibitPipeOpen now exists to stop.  $bin is
+    # quoted because File::Which returns whatever path it found, spaces and all.
+    my $version = qx{"$bin" --version};    ## no critic (logicLAB::ProhibitShellDispatch)
 
     my ($major) = ( $version // '' ) =~ m/Inkscape\s+(\d+)/;
     die "Could not read a version out of `$bin --version`, got: " . ( $version // '(nothing)' ) unless defined $major;

policy/Perl/Critic/Policy/Troglodyne/ProhibitPipeOpen.pm

@@ -0,0 +1,117 @@
+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

t/Perl-Critic-Policy-Troglodyne-ProhibitPipeOpen.t

@@ -0,0 +1,74 @@
+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();