Enable RequireCheckedSyscalls, and check each close that can lose a write

The policy reported 33 calls whose result nothing read.  Two were say,
which prints as print does, so say joins print in exclude_functions,
here and in RequireCheckedIndirectResults, which uses the same list.

The rest were close.  Closing a handle written to flushes it, and a
write that fails there, such as on a full disk, is reported only by the
return value of close.

- bin/tcms-vault-key wrote the vault key and said that it had, whether
  the key reached the disk or not.  It dies now, and says which file.
  No test runs this script.  It refuses to run when the key file
  exists, so the trick that the test of the screenshot cache uses
  cannot reach this close.
- The screenshot cache in Trog::DataSource::Virt handed back the path
  of a file that it might not have written.  It returns the error now,
  as it does when the open fails.  The new test points the cache file
  at /dev/full, which takes the open and the print and fails the close.
  It fails against the old code.
- Trog::Data::DUMMY confesses, as it already does when the open fails.
- The tests that write fixtures die, as their opens already do.

Two closes have nothing to lose, and carry an exemption that says so:
the close of the lock in Trog::Data::FlatFile, and the close in
Trog::FileHandler, of a handle that it read to the end.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>

.perlcriticrc

@@ -96,7 +96,7 @@ formats = #!/usr/bin/env perl
 # A sub that returns the result of a syscall or an eval, called where nothing
 # looks at the result.  The same functions as RequireCheckedSyscalls below.
 [ErrorHandling::RequireCheckedIndirectResults]
-exclude_functions = print
+exclude_functions = print say
 [ProhibitUseLib]
 [ProhibitUsageSubs]
 # tCMS: help() is the interface of a data model and a datasource that links
@@ -209,8 +209,9 @@ stop_words_file = .pod_stopwords
 [InputOutput::RequireBracedFileHandleWithPrint]
 [InputOutput::RequireBriefOpen]
 [InputOutput::RequireCheckedOpen]
-#[InputOutput::RequireCheckedSyscalls]
-#exclude_functions = print
+[InputOutput::RequireCheckedSyscalls]
+# tCMS: say prints as print does.
+exclude_functions = print say
 [InputOutput::RequireEncodingWithUTF8Layer]
 [Miscellanea::ProhibitFormats]
 [Miscellanea::ProhibitTies]

bin/tcms-vault-key

@@ -91,7 +91,7 @@ if ( -e $Trog::Vault::key_file ) {    # Refusing to overwrite the one thing that
 
 open( my $fh, '>', $Trog::Vault::key_file ) or die "Could not write $Trog::Vault::key_file: $!\n";
 print {$fh} Crypt::Misc::encode_b64( Crypt::PRNG::random_bytes(32) ) . "\n";
-close($fh);
+close($fh)                                  or die "Could not write $Trog::Vault::key_file: $!\n";
 chmod( oct('600'), $Trog::Vault::key_file ) or die "Could not chmod $Trog::Vault::key_file: $!\n";
 
 print <<"SAID";

lib/Trog/Data/DUMMY.pm

@@ -33,7 +33,7 @@ sub read {
     # 'print on closed filehandle' followed by a die inside read_text.
     if ( sysopen( my $fh, $datastore, O_WRONLY | O_CREAT | O_EXCL ) ) {
         print {$fh} '[]';
-        close $fh;
+        close($fh) or confess "Could not write $datastore: $!";
     }
     elsif ( $! != Errno::EEXIST ) {
         confess "Could not create $datastore: $!";
@@ -63,7 +63,7 @@ sub write ( $self, $data, $overwrite = 0 ) {
     }
     open( my $fh, '>', $datastore ) or confess;
     print {$fh} JSON::MaybeXS::encode_json($orig);
-    close $fh;
+    close($fh) or confess "Could not write $datastore: $!";
     return 1;
 }
 

lib/Trog/Data/FlatFile.pm

@@ -175,7 +175,7 @@ sub write ( $self, $data ) {
         local $File::Slurper::Temp::FILE_TEMP_PERMS = oct('666') & ~umask;
         File::Slurper::Temp::write_binary( $file, $parser->encode($update) );
 
-        close $lock;
+        close($lock);    ## no critic (RequireCheckedSyscalls) -- a lock, with nothing buffered to lose
 
         Trog::SQLite::TagIndex::add_post( $post, $self );
     }

lib/Trog/DataSource/Virt.pm

@@ -364,7 +364,7 @@ sub screenshot ( $hypervisor, $guest_name ) {
     open( my $fh, '>', $path ) or return ( undef, "could not cache the screenshot: $!" );
     binmode $fh;
     print {$fh} $data;
-    close $fh;
+    close($fh) or return ( undef, "could not cache the screenshot: $!" );
 
     return ( $path, undef );
 }

lib/Trog/FileHandler.pm

@@ -108,7 +108,7 @@ sub serve ( $fullpath, $path, $start, $streaming, $ranges, $last_fetch = 0, $def
             while ( $fh->read( my $buf, $Trog::Vars::CHUNK_SIZE ) ) {
                 $writer->write($buf);
             }
-            close $fh;
+            close($fh);    ## no critic (RequireCheckedSyscalls) -- read to the end, with nothing to lose
             $writer->close;
           }
           if $streaming && $sz > $Trog::Vars::CHUNK_SIZE;

t/Trog-Auth-totp-mandatory.t

@@ -40,12 +40,12 @@ BEGIN {
 
     open( my $fh, '>', "$ROOT/config/default.cfg" ) or die $!;
     print {$fh} "[general]\n    data_model=FlatFile\n    hostname=totp.example.com\n";
-    close $fh;
+    close($fh) or die $!;
 
     # Otherwise login() reads the instance as a fresh install and registers
     # whoever knocks first as the admin, which is a different test.
     open( my $flag, '>', "$ROOT/config/has_users" ) or die $!;
-    close $flag;
+    close($flag)                                    or die $!;
 
     chdir($ROOT) or die "could not chdir to the sandbox: $!";
 }

t/Trog-Data-FlatFile-read.t

@@ -56,7 +56,7 @@ sub reads {
 
 open( my $fh, '>', 'data/files/good' ) or die $!;
 print {$fh} '[{"id":"good","title":"Good","tags":["public"],"visibility":"public"}]';
-close $fh;
+close($fh) or die $!;
 
 subtest 'a post that is there' => sub {
     my ( $posts, $noise ) = reads('good');
@@ -78,7 +78,7 @@ subtest 'a post that is not there' => sub {
 subtest 'a post that cannot be parsed' => sub {
     open( my $bad, '>', 'data/files/corrupt' ) or die $!;
     print {$bad} '[{"id":"corrupt"';
-    close $bad;
+    close($bad) or die $!;
 
     my ( $posts, $noise ) = reads('corrupt');
     is( scalar(@$posts), 0, "nothing comes back" );
@@ -91,7 +91,7 @@ subtest 'a post that cannot be read' => sub {
 
         open( my $no, '>', 'data/files/unreadable' ) or die $!;
         print {$no} 'x';
-        close $no;
+        close($no)                             or die $!;
         chmod( 0000, 'data/files/unreadable' ) or die $!;
 
         my ( $posts, $noise ) = reads('unreadable');

t/Trog-DataSource-DirIndex.t

@@ -52,7 +52,7 @@ sub touch {
     my ( $path, $content ) = @_;
     open( my $fh, '>', $path ) or die "$path: $!";
     print {$fh} ( $content // 'x' );
-    close $fh;
+    close($fh) or die $!;
     return;
 }
 

t/Trog-DataSource-ProvisionedVirt.t

@@ -46,7 +46,7 @@ BEGIN {
     my $program = "$ROOT/trog-provisioner/bin/provision";
     open( my $fh, '>', $program ) or die $!;
     print {$fh} "#!/bin/sh\nexit 0\n";
-    close $fh;
+    close($fh) or die $!;
     chmod( 0755, $program );
 
     # And a stand-in for the installation's own files, which live where the
@@ -55,7 +55,7 @@ BEGIN {
     File::Path::make_path("$ROOT/etc/recipes.d");
     open( my $recipe, '>', "$ROOT/etc/recipes.d/guest.example.com.yaml" ) or die $!;
     print {$recipe} "---\n_global:\n  registrar: secret:x/y/z\n";
-    close $recipe;
+    close($recipe) or die $!;
 
     chdir($ROOT) or die "could not chdir to the sandbox: $!";
 }
@@ -72,7 +72,7 @@ sub write_config {
     my (%section) = @_;
     open( my $fh, '>', "$ROOT/config/default.cfg" ) or die $!;
     print {$fh} "[general]\n    data_model=FlatFile\n[provisioner]\n" . join( '', map { "    $_=$section{$_}\n" } sort keys %section );
-    close $fh;
+    close($fh) or die $!;
 
     require Config::Simple;
     my $conf = Config::Simple->new("$ROOT/config/default.cfg");
@@ -407,7 +407,7 @@ subtest 'the log is read back onto the page' => sub {
     File::Path::make_path("$ROOT/logs/reprovision");
     open( my $fh, '>', "$ROOT/logs/reprovision/guest.example.com.log" ) or die $!;
     print {$fh} ( 'x' x 9000 ) . "\n=== finished ===\n";
-    close $fh;
+    close($fh) or die $!;
 
     my $tail = Trog::DataSource::ProvisionedVirt::log_tail('guest.example.com');
     ok( length($tail) <= $Trog::DataSource::ProvisionedVirt::log_tail_bytes, 'only the tail of it' );
@@ -425,7 +425,7 @@ subtest 'the state a reprovision leaves behind' => sub {
     my $write  = sub {
         open( my $fh, '>', $status ) or die $!;
         print {$fh} join( '', map { "$_\n" } @_ );
-        close $fh;
+        close($fh) or die $!;
     };
 
     # Nothing waits on the process which does the work, so this file is the
@@ -475,13 +475,13 @@ subtest 'the listing says what is going on' => sub {
     my $status = "$ROOT/logs/reprovision/guest.example.com.status";
     open( my $out, '>', "$ROOT/logs/reprovision/guest.example.com.log" ) or die $!;
     print {$out} "some output\n";
-    close $out;
+    close($out) or die $!;
 
     $virt->redefine( posts => sub { return ( { title => 'guest.example.com', domain => 'guest.example.com', is_self => 0 } ) } );
 
     open( my $fh, '>', $status ) or die $!;
     print {$fh} "state=running\npid=$$\nstarted=100\nuser=admin\n";
-    close $fh;
+    close($fh) or die $!;
 
     my ($post) = Trog::DataSource::ProvisionedVirt::posts( {}, {} );
     is( $post->{reprovision_state},    'running',                                  'the guest says it is reprovisioning' );
@@ -499,7 +499,7 @@ subtest 'the listing says what is going on' => sub {
 
     open( $fh, '>', $status ) or die $!;
     print {$fh} "state=failed\nexit=3\nstarted=100\nfinished=200\nuser=admin\n";
-    close $fh;
+    close($fh) or die $!;
 
     ($post) = Trog::DataSource::ProvisionedVirt::posts( {}, {} );
     is( $post->{reprovision_state},  'failed',             'a failed run says so' );
@@ -522,14 +522,14 @@ subtest 'reading the log' => sub {
 
     open( my $fh, '>', "$ROOT/logs/reprovision/guest.example.com.log" ) or die $!;
     print {$fh} "the whole log\n";
-    close $fh;
+    close($fh) or die $!;
     like( Trog::DataSource::ProvisionedVirt::log_for('guest.example.com'), qr/the[ ]whole[ ]log/, 'and the whole of it when there has' );
 
     # A provisioner can be chatty, and this goes out in one response.
     local $Trog::DataSource::ProvisionedVirt::log_max_bytes = 64;
     open( $fh, '>', "$ROOT/logs/reprovision/guest.example.com.log" ) or die $!;
     print {$fh} ( 'x' x 500 ) . "END\n";
-    close $fh;
+    close($fh) or die $!;
     my $capped = Trog::DataSource::ProvisionedVirt::log_for('guest.example.com');
     like( $capped, qr/truncated/, 'a huge one is truncated' );
     like( $capped, qr/END/,       'keeping the end, which is where the answer is' );

t/Trog-DataSource-Virt.t

@@ -262,6 +262,24 @@ subtest 'the guest cache is scoped per hypervisor' => sub {
     like( $paths[0], qr{/hv-1/alpha\.png$}, 'the path names the hypervisor and the guest' );
 };
 
+# /dev/full takes the open and the print, and fails the write that close()
+# flushes, as a full disk does.
+subtest 'a screenshot that could not be cached is not handed out' => sub {
+  SKIP: {
+        skip( 'there is no /dev/full here', 2 ) unless -c '/dev/full';
+
+        my $root = Path::Tiny->tempdir();
+        no warnings 'once';
+        local $Trog::DataSource::Virt::screenshot_dir = "$root";
+        $root->child('hv-1')->mkpath;
+        symlink( '/dev/full', "$root/hv-1/alpha.png" ) or die $!;
+
+        my ( $path, $why ) = Trog::DataSource::Virt::screenshot( { id => 'hv-1', conn_uri => 'test:///default' }, 'alpha' );
+        is( $path, undef, 'no path to a screenshot that is not there' );
+        like( $why, qr/could[ ]not[ ]cache/, 'and it says why' );
+    }
+};
+
 subtest 'the datasource hook only loads what it should' => sub {
     require Trog::Routes::HTML;
 

t/Trog-Log-Syslog.t

@@ -59,7 +59,7 @@ subtest 'nothing below the level goes out' => sub {
 };
 
 subtest 'a syslog that went away does not take the application with it' => sub {
-    close($sink);
+    close($sink) or die $!;
     unlink($path);
 
     # The file output still has the line, and a request that fails because

t/Trog-Routes-HTML-series-lifecycle.t

@@ -131,7 +131,7 @@ BEGIN {
     # dies outright if this file is missing.  Only category and emoji are read.
     open( my $fh, '>', "$ROOT/www/scripts/list.min.json" ) or die $!;
     print {$fh} '{"emojis":[{"category":"Smileys","emoji":"X"}]}';
-    close $fh;
+    close($fh) or die $!;
 
     # Text::Xslate computes its default cache dir from $HOME once, at load time.
     # Without this the sandbox writes compiled templates into the real ~/.xslate_cache.
@@ -782,7 +782,7 @@ subtest 'a directory index series' => sub {
     foreach my $n ( 1 .. 7 ) {
         open( my $fh, '>', "www/assets/spec_downloads/file$n.txt" ) or die $!;
         print {$fh} ( 'x' x ( $n * 10 ) );
-        close $fh;
+        close($fh) or die $!;
     }
 
     reindex();
@@ -1150,7 +1150,7 @@ subtest 'file' => sub {
     my $src = "$ROOT/upload-src/spec-upload.txt";
     open( my $fh, '>', $src ) or die $!;
     print {$fh} "spec upload contents\n";
-    close $fh;
+    close($fh) or die $!;
 
     my $child = save_post(
         'file child',

t/Trog-Vault.t

@@ -32,7 +32,7 @@ BEGIN {
 
     open( my $fh, '>', "$ROOT/config/default.cfg" ) or die $!;
     print {$fh} "[general]\n    data_model=FlatFile\n    hostname=vault.example.com\n";
-    close $fh;
+    close($fh) or die $!;
 
     # The key the way a deployment hands one over: base64, in the environment,
     # put there by tpsgi.sh out of a systemd credential.  Trog::Vault takes it
@@ -177,7 +177,7 @@ subtest 'the other two places a key can be' => sub {
     my $on_disk = Crypt::Misc::encode_b64( Crypt::PRNG::random_bytes(32) );
     open( my $fh, '>', 'config/secrets.key' ) or die $!;
     print {$fh} "$on_disk\n";
-    close $fh;
+    close($fh) or die $!;
     chmod( oct('600'), 'config/secrets.key' );
 
     {
@@ -192,7 +192,7 @@ subtest 'the other two places a key can be' => sub {
     File::Path::make_path('creds');
     open( $fh, '>', 'creds/tpsgi-vault' ) or die $!;
     print {$fh} $in_store;
-    close $fh;
+    close($fh) or die $!;
 
     {
         local $ENV{CREDENTIALS_DIRECTORY}  = 'creds';
@@ -204,7 +204,7 @@ subtest 'the other two places a key can be' => sub {
     # Something that is not a key is not quietly used as one.
     open( $fh, '>', 'config/secrets.key' ) or die $!;
     print {$fh} "hunter2\n";
-    close $fh;
+    close($fh) or die $!;
     {
         local $Trog::Vault::master         = undef;
         local $Trog::Vault::looked_further = 0;