On 14.02.24 17:52, Peter Eisentraut wrote:
A gentler way might be to start using some perlcritic policies like
InputOutput::RequireCheckedOpen or the more general
InputOutput::RequireCheckedSyscalls and add explicit error checking at
the sites it points out.
Here is a start for that. I added the required stanza to perlcriticrc
and started with an explicit list of functions to check:
functions = chmod flock open read rename seek symlink system
and fixed all the issues it pointed out.
I picked those functions because most existing code already checked
those, so the omissions are probably unintended, or in some cases also
because I thought it would be important for test correctness (e.g., some
tests using chmod).
I didn't design any beautiful error messages, mostly just used "or die
$!", which mostly matches existing code, and also this is
developer-level code, so having the system error plus source code
reference should be ok.
In the second patch, I changed the perlcriticrc stanza to use an
exclusion list instead of an explicit inclusion list. That way, you can
see what we are currently *not* checking. I'm undecided which way
around is better, and exactly what functions we should be checking. (Of
course, in principle, all of them, but since this is test and build
support code, not production code, there are probably some reasonable
compromises to be made.)
From c32941ce95281ab21691c4181962d20a820b1f20 Mon Sep 17 00:00:00 2001
From: Peter Eisentraut <pe...@eisentraut.org>
Date: Tue, 20 Feb 2024 10:12:12 +0100
Subject: [PATCH v1 1/2] perlcritic InputOutput::RequireCheckedSyscalls
---
.../t/010_pg_archivecleanup.pl | 2 +-
src/bin/pg_basebackup/t/010_pg_basebackup.pl | 8 ++++----
src/bin/pg_ctl/t/001_start_stop.pl | 2 +-
src/bin/pg_resetwal/t/002_corrupted.pl | 2 +-
src/bin/pg_rewind/t/009_growing_files.pl | 2 +-
src/bin/pg_rewind/t/RewindTest.pm | 4 ++--
src/pl/plperl/text2macro.pl | 4 ++--
src/test/kerberos/t/001_auth.pl | 2 +-
.../ssl_passphrase_callback/t/001_testfunc.pl | 2 +-
src/test/perl/PostgreSQL/Test/Cluster.pm | 12 ++++++------
src/test/perl/PostgreSQL/Test/Utils.pm | 16 ++++++++--------
src/test/ssl/t/SSL/Server.pm | 10 +++++-----
src/tools/msvc_gendef.pl | 4 ++--
src/tools/perlcheck/perlcriticrc | 4 ++++
src/tools/pgindent/pgindent | 17 +++++++++--------
15 files changed, 48 insertions(+), 43 deletions(-)
diff --git a/src/bin/pg_archivecleanup/t/010_pg_archivecleanup.pl
b/src/bin/pg_archivecleanup/t/010_pg_archivecleanup.pl
index 792f5677c87..91a98c71e99 100644
--- a/src/bin/pg_archivecleanup/t/010_pg_archivecleanup.pl
+++ b/src/bin/pg_archivecleanup/t/010_pg_archivecleanup.pl
@@ -36,7 +36,7 @@ sub create_files
{
foreach my $fn (map { $_->{name} } @_)
{
- open my $file, '>', "$tempdir/$fn";
+ open my $file, '>', "$tempdir/$fn" or die $!;
print $file 'CONTENT';
close $file;
diff --git a/src/bin/pg_basebackup/t/010_pg_basebackup.pl
b/src/bin/pg_basebackup/t/010_pg_basebackup.pl
index 86cc01a640b..159da3029af 100644
--- a/src/bin/pg_basebackup/t/010_pg_basebackup.pl
+++ b/src/bin/pg_basebackup/t/010_pg_basebackup.pl
@@ -77,7 +77,7 @@
ok(-d "$tempdir/backup", 'backup directory was created and left behind');
rmtree("$tempdir/backup");
-open my $conf, '>>', "$pgdata/postgresql.conf";
+open my $conf, '>>', "$pgdata/postgresql.conf" or die $!;
print $conf "max_replication_slots = 10\n";
print $conf "max_wal_senders = 10\n";
print $conf "wal_level = replica\n";
@@ -175,7 +175,7 @@
qw(backup_label tablespace_map postgresql.auto.conf.tmp
current_logfiles.tmp global/pg_internal.init.123))
{
- open my $file, '>>', "$pgdata/$filename";
+ open my $file, '>>', "$pgdata/$filename" or die $!;
print $file "DONOTCOPY";
close $file;
}
@@ -185,7 +185,7 @@
# unintended side effects.
if ($Config{osname} ne 'darwin')
{
- open my $file, '>>', "$pgdata/.DS_Store";
+ open my $file, '>>', "$pgdata/.DS_Store" or die $!;
print $file "DONOTCOPY";
close $file;
}
@@ -424,7 +424,7 @@
my $tblspcoid = $1;
my $escapedRepTsDir = $realRepTsDir;
$escapedRepTsDir =~ s/\\/\\\\/g;
- open my $mapfile, '>', $node2->data_dir . '/tablespace_map';
+ open my $mapfile, '>', $node2->data_dir . '/tablespace_map' or die $!;
print $mapfile "$tblspcoid $escapedRepTsDir\n";
close $mapfile;
diff --git a/src/bin/pg_ctl/t/001_start_stop.pl
b/src/bin/pg_ctl/t/001_start_stop.pl
index fd56bf7706a..cbdaee57fb1 100644
--- a/src/bin/pg_ctl/t/001_start_stop.pl
+++ b/src/bin/pg_ctl/t/001_start_stop.pl
@@ -23,7 +23,7 @@
command_ok([ $ENV{PG_REGRESS}, '--config-auth', "$tempdir/data" ],
'configure authentication');
my $node_port = PostgreSQL::Test::Cluster::get_free_port();
-open my $conf, '>>', "$tempdir/data/postgresql.conf";
+open my $conf, '>>', "$tempdir/data/postgresql.conf" or die $!;
print $conf "fsync = off\n";
print $conf "port = $node_port\n";
print $conf PostgreSQL::Test::Utils::slurp_file($ENV{TEMP_CONFIG})
diff --git a/src/bin/pg_resetwal/t/002_corrupted.pl
b/src/bin/pg_resetwal/t/002_corrupted.pl
index 897b03162e0..c5e09bbb688 100644
--- a/src/bin/pg_resetwal/t/002_corrupted.pl
+++ b/src/bin/pg_resetwal/t/002_corrupted.pl
@@ -21,7 +21,7 @@
my $data;
open my $fh, '<', $pg_control or BAIL_OUT($!);
binmode $fh;
-read $fh, $data, 16;
+read $fh, $data, 16 or die $!;
close $fh;
# Fill pg_control with zeros
diff --git a/src/bin/pg_rewind/t/009_growing_files.pl
b/src/bin/pg_rewind/t/009_growing_files.pl
index 3541d735685..8e59ad69961 100644
--- a/src/bin/pg_rewind/t/009_growing_files.pl
+++ b/src/bin/pg_rewind/t/009_growing_files.pl
@@ -69,7 +69,7 @@
# Extract the last line from the verbose output as that should have the error
# message for the unexpected file size
my $last;
-open my $f, '<', "$standby_pgdata/tst_both_dir/file1";
+open my $f, '<', "$standby_pgdata/tst_both_dir/file1" or die $!;
$last = $_ while (<$f>);
close $f;
like($last, qr/error: size of source file/, "Check error message");
diff --git a/src/bin/pg_rewind/t/RewindTest.pm
b/src/bin/pg_rewind/t/RewindTest.pm
index 72deab8e886..0bf59db9973 100644
--- a/src/bin/pg_rewind/t/RewindTest.pm
+++ b/src/bin/pg_rewind/t/RewindTest.pm
@@ -311,8 +311,8 @@ sub run_pg_rewind
# Make sure that directories have the right umask as this is
# required by a follow-up check on permissions, and better
# safe than sorry.
- chmod(0700, $node_primary->archive_dir);
- chmod(0700, $node_primary->data_dir . "/pg_wal");
+ chmod(0700, $node_primary->archive_dir) or die $!;
+ chmod(0700, $node_primary->data_dir . "/pg_wal") or die $!;
# Add appropriate restore_command to the target cluster
$node_primary->enable_restoring($node_primary, 0);
diff --git a/src/pl/plperl/text2macro.pl b/src/pl/plperl/text2macro.pl
index 577417ac7ac..c6240af69c7 100644
--- a/src/pl/plperl/text2macro.pl
+++ b/src/pl/plperl/text2macro.pl
@@ -88,11 +88,11 @@ sub selftest
close $fh;
system("perl $0 --name=X $tmp.pl > $tmp.c") == 0 or die;
- open $fh, '>>', "$tmp.c";
+ open $fh, '>>', "$tmp.c" or die;
print $fh "#include <stdio.h>\n";
print $fh "int main() { puts(X); return 0; }\n";
close $fh;
- system("cat -n $tmp.c");
+ system("cat -n $tmp.c") == 0 or die;
system("make $tmp") == 0 or die;
open $fh, '<', "./$tmp |" or die;
diff --git a/src/test/kerberos/t/001_auth.pl b/src/test/kerberos/t/001_auth.pl
index 2a81ce8834b..e51e87d0a2e 100644
--- a/src/test/kerberos/t/001_auth.pl
+++ b/src/test/kerberos/t/001_auth.pl
@@ -111,7 +111,7 @@
# Construct a pgpass file to make sure we don't use it
append_to_file($pgpass, '*:*:*:*:abc123');
-chmod 0600, $pgpass;
+chmod 0600, $pgpass or die $!;
# Build the krb5.conf to use.
#
diff --git a/src/test/modules/ssl_passphrase_callback/t/001_testfunc.pl
b/src/test/modules/ssl_passphrase_callback/t/001_testfunc.pl
index 9aa4bdc3704..a2bfb645760 100644
--- a/src/test/modules/ssl_passphrase_callback/t/001_testfunc.pl
+++ b/src/test/modules/ssl_passphrase_callback/t/001_testfunc.pl
@@ -33,7 +33,7 @@
# install certificate and protected key
copy("server.crt", $ddir);
copy("server.key", $ddir);
-chmod 0600, "$ddir/server.key";
+chmod 0600, "$ddir/server.key" or die $!;
$node->start;
diff --git a/src/test/perl/PostgreSQL/Test/Cluster.pm
b/src/test/perl/PostgreSQL/Test/Cluster.pm
index 44c1bb5afd0..73f46c846d2 100644
--- a/src/test/perl/PostgreSQL/Test/Cluster.pm
+++ b/src/test/perl/PostgreSQL/Test/Cluster.pm
@@ -470,7 +470,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" or die $!;
print $hba
"\n# Allow replication (set up by PostgreSQL::Test::Cluster.pm)\n";
if ($PostgreSQL::Test::Utils::windows_os
@@ -583,7 +583,7 @@ sub init
PostgreSQL::Test::Utils::system_or_bail($ENV{PG_REGRESS},
'--config-auth', $pgdata, @{ $params{auth_extra} });
- open my $conf, '>>', "$pgdata/postgresql.conf";
+ open my $conf, '>>', "$pgdata/postgresql.conf" or die $!;
print $conf "\n# Added by PostgreSQL::Test::Cluster.pm\n";
print $conf "fsync = off\n";
print $conf "restart_after_crash = off\n";
@@ -865,7 +865,7 @@ sub init_from_backup
rmdir($data_path);
PostgreSQL::Test::RecursiveCopy::copypath($backup_path,
$data_path);
}
- chmod(0700, $data_path);
+ chmod(0700, $data_path) or die $!;
# Base configuration for this node
$self->append_conf(
@@ -1691,16 +1691,16 @@ sub _reserve_port
if (kill 0, $pid)
{
# process exists and is owned by us, so we can't
reserve this port
- flock($portfile, LOCK_UN);
+ flock($portfile, LOCK_UN) || die $!;
close($portfile);
return 0;
}
}
# All good, go ahead and reserve the port
- seek($portfile, 0, SEEK_SET);
+ seek($portfile, 0, SEEK_SET) || die $!;
# print the pid with a fixed width so we don't leave any trailing junk
print $portfile sprintf("%10d\n", $$);
- flock($portfile, LOCK_UN);
+ flock($portfile, LOCK_UN) || die $!;
close($portfile);
push(@port_reservation_files, $filename);
return 1;
diff --git a/src/test/perl/PostgreSQL/Test/Utils.pm
b/src/test/perl/PostgreSQL/Test/Utils.pm
index 2185a079def..42d5a50dc88 100644
--- a/src/test/perl/PostgreSQL/Test/Utils.pm
+++ b/src/test/perl/PostgreSQL/Test/Utils.pm
@@ -211,10 +211,10 @@ INIT
or die "could not open STDOUT to logfile \"$test_logfile\": $!";
# Hijack STDOUT and STDERR to the log file
- open(my $orig_stdout, '>&', \*STDOUT);
- open(my $orig_stderr, '>&', \*STDERR);
- open(STDOUT, '>&', $testlog);
- open(STDERR, '>&', $testlog);
+ open(my $orig_stdout, '>&', \*STDOUT) or die $!;
+ open(my $orig_stderr, '>&', \*STDERR) or die $!;
+ open(STDOUT, '>&', $testlog) or die $!;
+ open(STDERR, '>&', $testlog) or die $!;
# The test output (ok ...) needs to be printed to the original STDOUT so
# that the 'prove' program can parse it, and display it to the user in
@@ -564,7 +564,7 @@ Find and replace string of a given file.
sub string_replace_file
{
my ($filename, $find, $replace) = @_;
- open(my $in, '<', $filename);
+ open(my $in, '<', $filename) or croak $!;
my $content = '';
while (<$in>)
{
@@ -572,7 +572,7 @@ sub string_replace_file
$content = $content . $_;
}
close $in;
- open(my $out, '>', $filename);
+ open(my $out, '>', $filename) or croak $!;
print $out $content;
close($out);
@@ -789,11 +789,11 @@ sub dir_symlink
# need some indirection on msys
$cmd = qq{echo '$cmd' | \$COMSPEC /Q};
}
- system($cmd);
+ system($cmd) == 0 or die;
}
else
{
- symlink $oldname, $newname;
+ symlink $oldname, $newname or die $!;
}
die "No $newname" unless -e $newname;
}
diff --git a/src/test/ssl/t/SSL/Server.pm b/src/test/ssl/t/SSL/Server.pm
index 149a9385119..ca4c7b567b3 100644
--- a/src/test/ssl/t/SSL/Server.pm
+++ b/src/test/ssl/t/SSL/Server.pm
@@ -191,7 +191,7 @@ sub configure_test_server_for_ssl
}
# enable logging etc.
- open my $conf, '>>', "$pgdata/postgresql.conf";
+ open my $conf, '>>', "$pgdata/postgresql.conf" or die $!;
print $conf "fsync=off\n";
print $conf "log_connections=on\n";
print $conf "log_hostname=on\n";
@@ -204,7 +204,7 @@ sub configure_test_server_for_ssl
close $conf;
# SSL configuration will be placed here
- open my $sslconf, '>', "$pgdata/sslconfig.conf";
+ open my $sslconf, '>', "$pgdata/sslconfig.conf" or die $!;
close $sslconf;
# Perform backend specific configuration
@@ -290,7 +290,7 @@ sub switch_server_cert
my %params = @_;
my $pgdata = $node->data_dir;
- open my $sslconf, '>', "$pgdata/sslconfig.conf";
+ open my $sslconf, '>', "$pgdata/sslconfig.conf" or die $!;
print $sslconf "ssl=on\n";
print $sslconf $backend->set_server_cert(\%params);
print $sslconf "ssl_passphrase_command='"
@@ -315,7 +315,7 @@ sub _configure_hba_for_ssl
# but seems best to keep it as narrow as possible for security reasons.
#
# When connecting to certdb, also check the client certificate.
- open my $hba, '>', "$pgdata/pg_hba.conf";
+ open my $hba, '>', "$pgdata/pg_hba.conf" or die $!;
print $hba
"# TYPE DATABASE USER ADDRESS
METHOD OPTIONS\n";
print $hba
@@ -337,7 +337,7 @@ sub _configure_hba_for_ssl
close $hba;
# Also set the ident maps. Note: fields with commas must be quoted
- open my $map, ">", "$pgdata/pg_ident.conf";
+ open my $map, ">", "$pgdata/pg_ident.conf" or die $!;
print $map
"# MAPNAME SYSTEM-USERNAME
PG-USERNAME\n",
"dn
\"CN=ssltestuser-dn,OU=Testing,OU=Engineering,O=PGDG\" ssltestuser\n",
diff --git a/src/tools/msvc_gendef.pl b/src/tools/msvc_gendef.pl
index 12c49ed2654..4ca08c1a475 100644
--- a/src/tools/msvc_gendef.pl
+++ b/src/tools/msvc_gendef.pl
@@ -195,8 +195,8 @@ sub usage
my $cmd = "dumpbin /nologo /symbols /out:$tmpfile " . join(' ', @files);
-system($cmd) && die "Could not call dumpbin";
-rename($tmpfile, $symfile);
+system($cmd) == 0 || die "Could not call dumpbin";
+rename($tmpfile, $symfile) || die $!;
extract_syms($symfile, \%def);
print "\n";
diff --git a/src/tools/perlcheck/perlcriticrc b/src/tools/perlcheck/perlcriticrc
index 49ac9ee52b5..57c1fd45708 100644
--- a/src/tools/perlcheck/perlcriticrc
+++ b/src/tools/perlcheck/perlcriticrc
@@ -29,3 +29,7 @@ severity = 5
[BuiltinFunctions::ProhibitVoidMap]
severity = 5
+
+[InputOutput::RequireCheckedSyscalls]
+severity = 5
+functions = chmod flock open read rename seek symlink system
diff --git a/src/tools/pgindent/pgindent b/src/tools/pgindent/pgindent
index 9093d4ff739..48d83bc434f 100755
--- a/src/tools/pgindent/pgindent
+++ b/src/tools/pgindent/pgindent
@@ -80,12 +80,14 @@ my $filtered_typedefs_fh;
sub check_indent
{
- system("$indent -? < $devnull > $devnull 2>&1");
- if ($? >> 8 != 1)
+ if (system("$indent -? < $devnull > $devnull 2>&1") != 0)
{
- print STDERR
- "You do not appear to have $indent installed on your
system.\n";
- exit 1;
+ if ($? >> 8 != 1)
+ {
+ print STDERR
+ "You do not appear to have $indent installed on your
system.\n";
+ exit 1;
+ }
}
if (`$indent --version` !~ m/ $INDENT_VERSION /)
@@ -95,8 +97,7 @@ sub check_indent
exit 1;
}
- system("$indent -gnu < $devnull > $devnull 2>&1");
- if ($? == 0)
+ if (system("$indent -gnu < $devnull > $devnull 2>&1") == 0)
{
print STDERR
"You appear to have GNU indent rather than BSD indent.\n";
@@ -283,7 +284,7 @@ sub run_indent
unlink "$filename.BAK";
- open(my $src_out, '<', $filename);
+ open(my $src_out, '<', $filename) || die $!;
local ($/) = undef;
$source = <$src_out>;
close($src_out);
base-commit: ff9e1e764fcce9a34467d614611a34d4d2a91b50
--
2.43.2
From 9068eac31c9df75b1f5302debed1a44f8c4c6c1e Mon Sep 17 00:00:00 2001
From: Peter Eisentraut <pe...@eisentraut.org>
Date: Tue, 20 Feb 2024 10:18:19 +0100
Subject: [PATCH v1 2/2] Write perlcritic InputOutput::RequireCheckedSyscalls
as an exclude list instead
---
src/tools/perlcheck/perlcriticrc | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/src/tools/perlcheck/perlcriticrc b/src/tools/perlcheck/perlcriticrc
index 57c1fd45708..bcef884df37 100644
--- a/src/tools/perlcheck/perlcriticrc
+++ b/src/tools/perlcheck/perlcriticrc
@@ -32,4 +32,5 @@ severity = 5
[InputOutput::RequireCheckedSyscalls]
severity = 5
-functions = chmod flock open read rename seek symlink system
+functions = :builtins
+exclude_functions = binmode chdir close closedir kill mkdir print rmdir
setsockopt sleep truncate umask unlink waitpid
--
2.43.2
