On 4/14/20 4:44 PM, Alvaro Herrera wrote:
> On 2020-Apr-14, Andrew Dunstan wrote:
>
>> One of the things that's a bit sad is that perlcritic doesn't generally
>> let you apply policies to a given set of files or files matching some
>> pattern. It would be nice, for instance, to be able to apply some
>> additional standards to strategic library files like PostgresNode.pm,
>> TestLib.pm and Catalog.pm. There are good reasons as suggested upthread
>> to apply higher standards to library files than to, say, a TAP test
>> script. The only easy way I can see to do that would be to have two
>> different perlcriticrc files and adjust pgperlcritic to make two runs.
>> If people think that's worth it I'll put a little work into it. If not,
>> I'll just leave things here.
> I think being more strict about it in strategic files (I'd say that's
> Catalog.pm plus src/test/perl/*.pm) might be a good idea. Maybe give it
> a try and see what comes up.
>
OK, in fact those files are in reasonably good shape. I also took a pass
through the library files in src/tools/msvc, which had a few more issues.
Here's a patch that does the stricter testing for those library files,
and fixes them so we get a clean pass
This brings to an end my perl gardening project.
cheers
andrew
--
Andrew Dunstan https://www.2ndQuadrant.com
PostgreSQL Development, 24x7 Support, Remote DBA, Training & Services
diff --git a/src/backend/catalog/Catalog.pm b/src/backend/catalog/Catalog.pm
index dd39a086ce..bd9eac0c80 100644
--- a/src/backend/catalog/Catalog.pm
+++ b/src/backend/catalog/Catalog.pm
@@ -67,7 +67,7 @@ sub ParseHeader
if (!$is_client_code)
{
# Strip C-style comments.
- s;/\*(.|\n)*\*/;;g;
+ s;/\*(?:.|\n)*\*/;;g;
if (m;/\*;)
{
@@ -260,7 +260,9 @@ sub ParseData
# We're treating the input line as a piece of Perl, so we
# need to use string eval here. Tell perlcritic we know what
# we're doing.
- eval '$hash_ref = ' . $_; ## no critic (ProhibitStringyEval)
+ ## no critic (ProhibitStringyEval)
+ ## no critic (RequireCheckingReturnValueOfEval)
+ eval '$hash_ref = ' . $_;
if (!ref $hash_ref)
{
die "$input_file: error parsing line $.:\n$_\n";
diff --git a/src/test/perl/PostgresNode.pm b/src/test/perl/PostgresNode.pm
index 1d5450758e..5249053ee2 100644
--- a/src/test/perl/PostgresNode.pm
+++ b/src/test/perl/PostgresNode.pm
@@ -385,7 +385,7 @@ sub set_replication_conf
$self->host eq $test_pghost
or croak "set_replication_conf only works with the default host";
- open my $hba, '>>', "$pgdata/pg_hba.conf";
+ open my $hba, '>>', "$pgdata/pg_hba.conf" || die;
print $hba "\n# Allow replication (set up by PostgresNode.pm)\n";
if ($TestLib::windows_os && !$TestLib::use_unix_sockets)
{
@@ -439,7 +439,7 @@ sub init
TestLib::system_or_bail($ENV{PG_REGRESS}, '--config-auth', $pgdata,
@{ $params{auth_extra} });
- open my $conf, '>>', "$pgdata/postgresql.conf";
+ open my $conf, '>>', "$pgdata/postgresql.conf" || die;
print $conf "\n# Added by PostgresNode.pm\n";
print $conf "fsync = off\n";
print $conf "restart_after_crash = off\n";
@@ -1254,7 +1254,7 @@ END
$node->clean_node if $exit_code == 0 && TestLib::all_tests_passing();
}
- $? = $exit_code;
+ $? = $exit_code; ## no critic (RequireLocalizedPunctuationVars)
}
=pod
@@ -1462,8 +1462,8 @@ sub psql
# https://metacpan.org/pod/release/ETHER/Try-Tiny-0.24/lib/Try/Tiny.pm
do
{
- local $@;
- eval {
+ local $@ = "";
+ eval { ## no critic (RequireCheckingReturnValueOfEval)
my @ipcrun_opts = (\@psql_params, '<', \$sql);
push @ipcrun_opts, '>', $stdout if defined $stdout;
push @ipcrun_opts, '2>', $stderr if defined $stderr;
@@ -2074,8 +2074,8 @@ sub pg_recvlogical_upto
do
{
- local $@;
- eval {
+ local $@ = "";
+ eval { ## no critic (RequireCheckingReturnValueOfEval)
IPC::Run::run(\@cmd, ">", \$stdout, "2>", \$stderr, $timeout);
$ret = $?;
};
diff --git a/src/test/perl/TestLib.pm b/src/test/perl/TestLib.pm
index 0e6c4819e4..fd3bbc1979 100644
--- a/src/test/perl/TestLib.pm
+++ b/src/test/perl/TestLib.pm
@@ -162,6 +162,8 @@ INIT
open my $testlog, '>', $test_logfile
or die "could not open STDOUT to logfile \"$test_logfile\": $!";
+ # don't need to check the result of these dup operations
+ ## no critic (RequireCheckedOpen)
# Hijack STDOUT and STDERR to the log file
open(my $orig_stdout, '>&', \*STDOUT);
open(my $orig_stderr, '>&', \*STDERR);
@@ -409,7 +411,7 @@ Return the full contents of the specified file.
sub slurp_file
{
my ($filename) = @_;
- local $/;
+ local $/ = undef;
my $contents;
if ($Config{osname} ne 'MSWin32')
{
diff --git a/src/tools/msvc/Install.pm b/src/tools/msvc/Install.pm
index e65ac6fc66..34797d97c3 100644
--- a/src/tools/msvc/Install.pm
+++ b/src/tools/msvc/Install.pm
@@ -12,9 +12,8 @@ use File::Basename;
use File::Copy;
use File::Find ();
-use Exporter;
-our (@ISA, @EXPORT_OK);
-@ISA = qw(Exporter);
+use Exporter qw(import);
+our (@EXPORT_OK);
@EXPORT_OK = qw(Install);
my $insttype;
@@ -45,7 +44,7 @@ sub lcopy
sub Install
{
- $| = 1;
+ STDOUT->autoflush(1);
my $target = shift;
$insttype = shift;
@@ -56,9 +55,8 @@ sub Install
our $config = shift;
unless ($config)
{
-
# suppress warning about harmless redeclaration of $config
- no warnings 'misc';
+ no warnings 'misc'; ## no critic (ProhibitNoWarnings)
do "./config_default.pl";
do "./config.pl" if (-f "config.pl");
}
@@ -158,7 +156,7 @@ sub Install
File::Find::find(
{
wanted => sub {
- /^(.*--.*\.sql|.*\.control)\z/s
+ /^(?:.*--.*\.sql|.*\.control)\z/s
&& push(@$pl_extension_files, $File::Find::name);
# Don't find files of in-tree temporary installations.
diff --git a/src/tools/msvc/MSBuildProject.pm b/src/tools/msvc/MSBuildProject.pm
index ebb169e201..aaa3d573ab 100644
--- a/src/tools/msvc/MSBuildProject.pm
+++ b/src/tools/msvc/MSBuildProject.pm
@@ -1,3 +1,6 @@
+
+## no critic (ProhibitMultiplePackages,ProhibitUnusedPrivateSubroutines)
+
package MSBuildProject;
#
@@ -11,7 +14,7 @@ use strict;
use warnings;
use base qw(Project);
-no warnings qw(redefine); ## no critic
+no warnings qw(redefine); ## no critic (ProhibitNoWarnings)
sub _new
{
@@ -145,8 +148,11 @@ EOF
{
confess "Bad format filename '$fileNameWithPath'\n"
unless ($fileNameWithPath =~ m!^(.*)/([^/]+)\.(c|cpp|y|l|rc)$!);
+ # perlcritic is a bit stupid here
+ ## no critic (ProhibitCaptureWithoutTest)
my $dir = $1;
my $fileName = $2;
+ ## use critic
if ($fileNameWithPath =~ /\.y$/ or $fileNameWithPath =~ /\.l$/)
{
push @grammarFiles, $fileNameWithPath;
@@ -415,7 +421,7 @@ use strict;
use warnings;
use base qw(MSBuildProject);
-no warnings qw(redefine); ## no critic
+no warnings qw(redefine); ## no critic (ProhibitNoWarnings)
sub new
{
@@ -440,7 +446,7 @@ use strict;
use warnings;
use base qw(MSBuildProject);
-no warnings qw(redefine); ## no critic
+no warnings qw(redefine); ## no critic (ProhibitNoWarnings)
sub new
{
@@ -465,7 +471,7 @@ use strict;
use warnings;
use base qw(MSBuildProject);
-no warnings qw(redefine); ## no critic
+no warnings qw(redefine); ## no critic (ProhibitNoWarnings)
sub new
{
@@ -490,7 +496,7 @@ use strict;
use warnings;
use base qw(MSBuildProject);
-no warnings qw(redefine); ## no critic
+no warnings qw(redefine); ## no critic (ProhibitNoWarnings)
sub new
{
diff --git a/src/tools/msvc/Mkvcbuild.pm b/src/tools/msvc/Mkvcbuild.pm
index 72a21dbd41..7f67c3582f 100644
--- a/src/tools/msvc/Mkvcbuild.pm
+++ b/src/tools/msvc/Mkvcbuild.pm
@@ -18,9 +18,8 @@ use Config;
use VSObjectFactory;
use List::Util qw(first);
-use Exporter;
-our (@ISA, @EXPORT_OK);
-@ISA = qw(Exporter);
+use Exporter qw(import);
+our (@EXPORT_OK);
@EXPORT_OK = qw(Mkvcbuild);
my $solution;
@@ -106,9 +105,9 @@ sub mkvcbuild
sprompt.c strerror.c tar.c thread.c
win32env.c win32error.c win32security.c win32setlocale.c);
- push(@pgportfiles, 'strtof.c') if ($vsVersion < '14.00');
+ push(@pgportfiles, 'strtof.c') if ($vsVersion < 14.00);
- if ($vsVersion >= '9.00')
+ if ($vsVersion >= 9.00)
{
push(@pgportfiles, 'pg_crc32c_sse42_choose.c');
push(@pgportfiles, 'pg_crc32c_sse42.c');
@@ -212,7 +211,7 @@ sub mkvcbuild
$snowball->RelocateFiles(
'src/backend/snowball/libstemmer',
sub {
- return shift !~ /(dict_snowball.c|win32ver.rc)$/;
+ return shift !~ /(?:dict_snowball.c|win32ver.rc)$/;
});
$snowball->AddIncludeDir('src/include/snowball');
$snowball->AddReference($postgres);
@@ -598,6 +597,7 @@ sub mkvcbuild
unlink $source_file;
open my $o, '>', $source_file
|| croak "Could not write to $source_file";
+ ## no critic (ProhibitHardTabs)
print $o '
/* compare to plperl.h */
#define __inline__ __inline
@@ -627,6 +627,7 @@ sub mkvcbuild
}
}
';
+ ## use critic
close $o;
# Build $source_file with a given #define, and return a true value
@@ -649,8 +650,7 @@ sub mkvcbuild
# Some builds exhibit runtime failure through Perl warning
# 'Can't spawn "conftest.exe"'; suppress that.
- no warnings;
-
+ no warnings; ## no critic (ProhibitNoWarnings)
no strict 'subs'; ## no critic (ProhibitNoStrict)
# Disable error dialog boxes like we do in the postmaster.
diff --git a/src/tools/msvc/Project.pm b/src/tools/msvc/Project.pm
index 20f79b382b..c2e82960aa 100644
--- a/src/tools/msvc/Project.pm
+++ b/src/tools/msvc/Project.pm
@@ -10,7 +10,7 @@ use strict;
use warnings;
use File::Basename;
-sub _new
+sub _new ## no critic (ProhibitUnusedPrivateSubroutines)
{
my ($classname, $name, $type, $solution) = @_;
my $good_types = {
@@ -278,6 +278,8 @@ sub AddDir
my @pieces = split /\s+/, $match;
foreach my $fn (@pieces)
{
+ # Deliberately ignore errors from ReplaceFile about files not found
+ ## no critic (RequireCheckingReturnValueOfEval)
if ($top eq "(top_srcdir)")
{
eval { $self->ReplaceFile($fn, $target) };
diff --git a/src/tools/msvc/Solution.pm b/src/tools/msvc/Solution.pm
index 545bdcef7b..d9550c3e9e 100644
--- a/src/tools/msvc/Solution.pm
+++ b/src/tools/msvc/Solution.pm
@@ -1,3 +1,6 @@
+
+## no critic (ProhibitMultiplePackages,ProhibitUnusedPrivateSubroutines)
+
package Solution;
#
@@ -10,7 +13,7 @@ use strict;
use warnings;
use VSObjectFactory;
-no warnings qw(redefine); ## no critic
+no warnings qw(redefine); ## no critic (ProhibitNoWarnings)
sub _new
{
@@ -157,20 +160,22 @@ sub GenerateFiles
|| confess("Could not open configure.in for reading\n");
while (<$c>)
{
- if (/^AC_INIT\(\[([^\]]+)\], \[([^\]]+)\], \[([^\]]+)\], \[([^\]]*)\], \[([^\]]+)\]/)
+ if (/^AC_INIT\(\[([^\]]+)\], \[([^\]]+)\], \[([^\]]+)\], \[(?:[^\]]*)\], \[([^\]]+)\]/)
{
$ac_init_found = 1;
$package_name = $1;
$package_version = $2;
$package_bugreport = $3;
- #$package_tarname = $4;
- $package_url = $5;
+ #$package_tarname = non-capturing-group;
+ $package_url = $4;
if ($package_version !~ /^(\d+)(?:\.(\d+))?/)
{
confess "Bad format of version: $self->{strver}\n";
}
+ # perlcritic is a bit stupid here
+ ## no critic (ProhibitCaptureWithoutTest)
$majorver = sprintf("%d", $1);
$minorver = sprintf("%d", $2 ? $2 : 0);
}
@@ -519,7 +524,7 @@ sub GenerateFiles
my ($digit1, $digit2, $digit3) = $self->GetOpenSSLVersion();
# More symbols are needed with OpenSSL 1.1.0 and above.
- if ($digit1 >= '1' && $digit2 >= '1' && $digit3 >= '0')
+ if ($digit1 >= 1 && $digit2 >= 1 && $digit3 >= 0)
{
$define{HAVE_ASN1_STRING_GET0_DATA} = 1;
$define{HAVE_BIO_GET_DATA} = 1;
@@ -931,7 +936,7 @@ sub AddProject
# changed their library names from:
# - libeay to libcrypto
# - ssleay to libssl
- if ($digit1 >= '1' && $digit2 >= '1' && $digit3 >= '0')
+ if ($digit1 >= 1 && $digit2 >= 1 && $digit3 >= 0)
{
my $dbgsuffix;
my $libsslpath;
@@ -1166,7 +1171,7 @@ use strict;
use warnings;
use base qw(Solution);
-no warnings qw(redefine); ## no critic
+no warnings qw(redefine); ## no critic (ProhibitNoWarnings)
sub new
{
@@ -1194,7 +1199,7 @@ use strict;
use warnings;
use base qw(Solution);
-no warnings qw(redefine); ## no critic
+no warnings qw(redefine); ## no critic (ProhibitNoWarnings)
sub new
{
@@ -1222,7 +1227,7 @@ use strict;
use warnings;
use base qw(Solution);
-no warnings qw(redefine); ## no critic
+no warnings qw(redefine); ## no critic (ProhibitNoWarnings)
sub new
{
@@ -1250,7 +1255,7 @@ use strict;
use warnings;
use base qw(Solution);
-no warnings qw(redefine); ## no critic
+no warnings qw(redefine); ## no critic (ProhibitNoWarnings)
sub new
{
diff --git a/src/tools/msvc/VSObjectFactory.pm b/src/tools/msvc/VSObjectFactory.pm
index e6983b241f..dd8cc4952e 100644
--- a/src/tools/msvc/VSObjectFactory.pm
+++ b/src/tools/msvc/VSObjectFactory.pm
@@ -1,3 +1,6 @@
+
+## no critic (ProhibitMultiplePackages)
+
package VSObjectFactory;
#
@@ -10,16 +13,15 @@ use Carp;
use strict;
use warnings;
-use Exporter;
+use Exporter qw(import);
use Project;
use Solution;
use MSBuildProject;
-our (@ISA, @EXPORT);
-@ISA = qw(Exporter);
+our (@EXPORT);
@EXPORT = qw(CreateSolution CreateProject DetermineVisualStudioVersion);
-no warnings qw(redefine); ## no critic
+no warnings qw(redefine); ## no critic (ProhibitNoWarnings)
sub CreateSolution
{
diff --git a/src/tools/perlcheck/perlcriticrc b/src/tools/perlcheck/perlcriticrc
index e230111b23..27b4af1892 100644
--- a/src/tools/perlcheck/perlcriticrc
+++ b/src/tools/perlcheck/perlcriticrc
@@ -22,3 +22,30 @@ verbose = %f: %m at line %l, column %c. %e. ([%p] Severity: %s)\n
# insist on use of the warnings pragma
[TestingAndDebugging::RequireUseWarnings]
severity = 5
+
+
+# sev 4
+[-Modules::ProhibitAutomaticExportation]
+[-InputOutput::RequireBriefOpen]
+[-Subroutines::RequireArgUnpacking]
+[Variables::RequireLocalizedPunctuationVars]
+allow = %ENV %SIG
+[-Objects::ProhibitIndirectSyntax]
+[TestingAndDebugging::ProhibitProlongedStrictureOverride]
+statements = 10
+[-BuiltinFunctions::RequireBlockGrep]
+[TestingAndDebugging::ProhibitNoWarnings]
+allow = once
+
+# sev 3
+[-ErrorHandling::RequireCarping]
+[-RegularExpressions::RequireExtendedFormatting]
+[-Variables::ProhibitPackageVars]
+[-ControlStructures::ProhibitCascadingIfElse]
+[-Subroutines::ProhibitExcessComplexity]
+[-ValuesAndExpressions::ProhibitImplicitNewlines]
+[-Subroutines::ProhibitManyArgs]
+[-InputOutput::ProhibitBacktickOperators]
+[-BuiltinFunctions::ProhibitLvalueSubstr]
+[-ValuesAndExpressions::RequireQuotedHeredocTerminator]
+[-RegularExpressions::ProhibitComplexRegexes]
diff --git a/src/tools/perlcheck/pgperlcritic b/src/tools/perlcheck/pgperlcritic
index 1c2f787580..08edd86427 100755
--- a/src/tools/perlcheck/pgperlcritic
+++ b/src/tools/perlcheck/pgperlcritic
@@ -14,7 +14,21 @@ PERLCRITIC=${PERLCRITIC:-perlcritic}
. src/tools/perlcheck/find_perl_files
-find_perl_files | xargs $PERLCRITIC \
+flist=`mktemp`
+find_perl_files > $flist
+
+pattern='src/test/perl/|src/backend/catalog/Catalog.pm|src/tools/msvc/[^/]*.pm'
+
+# normal sev 5 critic
+egrep -v "$pattern" < $flist | xargs $PERLCRITIC \
--quiet \
--program-extensions .pl \
--profile=src/tools/perlcheck/perlcriticrc
+
+# more strict sev 3 critic for some library files
+egrep "$pattern" < $flist | xargs $PERLCRITIC --severity 3 \
+ --quiet \
+ --program-extensions .pl \
+ --profile=src/tools/perlcheck/perlcriticrc
+
+rm -f $flist
