Activate perlcritic InputOutput::RequireCheckedSyscalls and fix resulting warnings

This checks that certain I/O-related Perl functions properly check
their return value.  Some parts of the PostgreSQL code had been a bit
sloppy about that.  The new perlcritic warnings are fixed here.  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.

Initially, we only activate this check for a subset of what the
perlcritic check would warn about.  The effective list is

    chmod flock open read rename seek symlink system

The initial set of functions is picked because most existing code
already checked the return value of those, so any omissions are
probably unintended, or because it seems important for test
correctness.

The actual perlcritic configuration is written as an exclude list.
That seems better so that we are clear on what we are currently not
checking.  Maybe future patches want to investigate checking some of
the other functions.  (In principle, we might eventually want to check
all of them, but since this is test and build support code, not
production code, there are probably some reasonable compromises to be
made.)

Reviewed-by: Daniel Gustafsson <daniel@yesql.se>
Discussion: https://www.postgresql.org/message-id/flat/88b7d4f2-46d9-4cc7-b1f7-613c90f9a76a%40eisentraut.org

Author: petere

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;

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;
 }
@@ -423,7 +423,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;
 

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})

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

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");

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);

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;

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.
 #

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;
 

src/test/perl/PostgreSQL/Test/Cluster.pm

@@ -467,7 +467,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
@@ -580,7 +580,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";
@@ -862,7 +862,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(
@@ -1688,16 +1688,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;

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,15 +564,15 @@ 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>)
 	{
 		$_ =~ s/$find/$replace/;
 		$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;
 }

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",

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 or die "Could not call dumpbin";
+rename($tmpfile, $symfile) or die $!;
 extract_syms($symfile, \%def);
 print "\n";
 

src/tools/perlcheck/perlcriticrc

@@ -29,3 +29,11 @@ severity = 5
 
 [BuiltinFunctions::ProhibitVoidMap]
 severity = 5
+
+# Require checking return value of system calls.  The excluded ones
+# are currently consistently checked, but more checking could be
+# added.
+[InputOutput::RequireCheckedSyscalls]
+severity = 5
+functions = :builtins
+exclude_functions = binmode chdir close closedir kill mkdir print rmdir setsockopt sleep truncate umask unlink waitpid

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);