Merge pull request #370 from Troglodyne-Internet-Widgets/arg-unpacking

Enable RequireArgUnpacking and RequireCheckedSyscalls, and record a reprovision whose credentials never arrived as failed

.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]
@@ -246,7 +247,7 @@ allow = read write delete index shutdown
 [Subroutines::ProhibitReturnSort]
 [Subroutines::ProhibitSubroutinePrototypes]
 [Subroutines::ProtectPrivateSubs]
-#[Subroutines::RequireArgUnpacking]
+[Subroutines::RequireArgUnpacking]
 [Subroutines::RequireFinalReturn]
 # tCMS: a sub that forks ends its child with POSIX::_exit, which never returns.
 terminal_funcs = POSIX::_exit

bin/tcms-useradd

@@ -115,10 +115,10 @@ my sub default_user_post {
     };
 }
 
-sub main {
+sub main (@args) {
     my %options;
     Getopt::Long::GetOptionsFromArray(
-        \@_,
+        \@args,
         'user=s'          => \$options{user},
         'display_name=s'  => \$options{display_name},
         'help|?'          => \$options{help},

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

bin/tcmslogin

@@ -83,10 +83,10 @@ my sub read_password ($prompt) {
     return $password ? "$password" : undef;
 }
 
-sub main {
+sub main (@args) {
     my %options;
     Getopt::Long::GetOptionsFromArray(
-        \@_,
+        \@args,
         'user=s'     => \$options{user},
         'password:s' => \$options{password},
         'token=s'    => \$options{token},

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/ProvisionedVirt.pm

@@ -617,12 +617,17 @@ sub spawn ( $domain, $credentials, $dir, $command, $user ) {
 
     # What the provisioner would otherwise have nobody to ask for.  Closed
     # afterwards, so the read on the far side ends rather than waiting on us.
-    print {$stdin} join( '', map { "$_: $credentials->{$_}\n" } sort keys %$credentials ) . "\n";
-    close($stdin);
-
-    if ($?) {
-        my $status = $? >> 8;
-        print {$fh} "\n--- $command->[0] exited $status\n";
+    my $unsent = ( print {$stdin} join( '', map { "$_: $credentials->{$_}\n" } sort keys %$credentials ) . "\n" ) ? undef : "$!";
+    my $closed = close($stdin);
+
+    # A write to a provisioner that has gone fails, rather than kills us,
+    # because the server ignores SIGPIPE and we inherit that.  The print or the
+    # close() that flushes it can be the write that fails.  close() also waits
+    # for the provisioner, and is false when it exited non-zero, with $! 0.
+    $unsent //= "$!" if !$closed && $!;
+    if ( $unsent || $? ) {
+        my $status = $unsent ? 1 : $? >> 8;
+        print {$fh} $unsent ? "\n--- could not write to $command->[0]: $unsent\n" : "\n--- $command->[0] exited $status\n";
         write_status(
             $domain,
             state    => 'failed',

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

@@ -1,148 +0,0 @@
-package Trog::FileHandler;
-
-use 5.040;
-use re '/aasx';
-use warnings FATAL => 'all';
-
-use POSIX qw{strftime};
-use IO::Compress::Gzip;
-use Time::HiRes qw{tv_interval};
-
-use Trog::Log qw{:all};
-use Trog::Vars;
-use Trog::Utils;
-
-my sub range ( $fullpath, $fh, $ranges, $sz, %headers ) {
-
-    # Set mode
-    my $primary_ct   = "Content-Type: $headers{'Content-type'}";
-    my $is_multipart = scalar(@$ranges) > 1;
-    if ($is_multipart) {
-        $headers{'Content-type'} = "multipart/byteranges; boundary=$Trog::Vars::CHUNK_SEP";
-    }
-    my $code = 206;
-
-    my $fc = '';
-
-    # Calculate the content-length up-front.  We have to fix unspecified lengths first, and reject bad requests.
-    foreach my $range (@$ranges) {
-        $range->[1] //= $sz - 1;
-        INFO("GET 416 31 $fullpath");
-        return [ 416, [%headers], ["Requested range not satisfiable"] ] if $range->[0] > $sz || $range->[0] < 0 || $range->[1] < 0 || $range->[0] > $range->[1];
-    }
-    $headers{'Content-Length'} = List::Util::sum( map { $_->[1] + 1 - $_->[0] } @$ranges );
-
-    #XXX Add the entity header lengths to the value - should hash-ify this to DRY
-    if ($is_multipart) {
-        foreach my $range (@$ranges) {
-            $headers{'Content-Length'} += length("$fc--$Trog::Vars::CHUNK_SEP\n$primary_ct\nContent-Range: bytes $range->[0]-$range->[1]/$sz\n\n");
-            $fc = "\n";
-        }
-        $headers{'Content-Length'} += length("\n--$Trog::Vars::CHUNK_SEP\--\n");
-        $fc = '';
-    }
-
-    #TODO log these requests with their length correctly
-    return sub {
-        my $responder = shift;
-        my $writer;
-
-        foreach my $range (@$ranges) {
-            $headers{'Content-Range'} = "bytes $range->[0]-$range->[1]/$sz" unless $is_multipart;
-            $writer //= $responder->( [ $code, [%headers] ] );
-            $writer->write("$fc--$Trog::Vars::CHUNK_SEP\n$primary_ct\nContent-Range: bytes $range->[0]-$range->[1]/$sz\n\n") if $is_multipart;
-            $fc = "\n";
-
-            my $len = List::Util::min( $sz, $range->[1] + 1 ) - $range->[0];
-
-            $fh->seek( $range->[0], 0 );
-            while ($len) {
-                $fh->read( my $buf, List::Util::min( $len, $Trog::Vars::CHUNK_SIZE ) );
-                $writer->write($buf);
-
-                # Adjust for amount written
-                $len = List::Util::max( $len - $Trog::Vars::CHUNK_SIZE, 0 );
-            }
-        }
-        $fh->close();
-        $writer->write("\n--$Trog::Vars::CHUNK_SEP\--\n") if $is_multipart;
-        $writer->close;
-    };
-}
-
-=head2 serve
-
-Serve a file, with options to stream and cache the output.
-
-=cut
-
-sub serve ( $fullpath, $path, $start, $streaming, $ranges, $last_fetch = 0, $deflate = 0 ) {
-    my $ft = Trog::Utils::mime_type($path);
-    $ft ||= $Trog::Vars::content_types{text};
-
-    my $ct      = 'Content-type';
-    my @headers = ( $ct => $ft );
-
-    #TODO use static Cache-Control for everything but JS/CSS?
-    push( @headers, 'Cache-control' => $Trog::Vars::cache_control{revalidate} );
-
-    push( @headers, 'Accept-Ranges' => 'bytes' );
-
-    my $mt         = ( stat($path) )[9];
-    my $sz         = ( stat(_) )[7];
-    my @gm         = gmtime($mt);
-    my $now_string = strftime( "%a, %d %b %Y %H:%M:%S GMT", @gm );
-    my $code       = $mt > $last_fetch ? 200 : 304;
-
-    push( @headers, "Last-Modified" => $now_string );
-    push( @headers, 'Vary'          => 'Accept-Encoding' );
-
-    if ( open( my $fh, '<', $path ) ) {    ## no critic (InputOutput::RequireBriefOpen) -- streamed to the client, which closes it
-        return range( $fullpath, $fh, $ranges, $sz, @headers ) if @$ranges && $streaming;
-
-        # Transfer-encoding: chunked
-        return sub {
-            my $responder = shift;
-            push( @headers, 'Content-Length' => $sz );
-            my $writer = $responder->( [ $code, \@headers ] );
-            while ( $fh->read( my $buf, $Trog::Vars::CHUNK_SIZE ) ) {
-                $writer->write($buf);
-            }
-            close $fh;
-            $writer->close;
-          }
-          if $streaming && $sz > $Trog::Vars::CHUNK_SIZE;
-
-        #Return data in the event the caller does not support deflate
-        if ( !$deflate ) {
-            push( @headers, "Content-Length" => $sz );
-            INFO("GET 200 $sz $fullpath");
-
-            # Append server-timing headers
-            my $tot = tv_interval($start) * 1000;
-            push( @headers, 'Server-Timing' => "file;dur=$tot" );
-
-            return [ $code, \@headers, $fh ];
-        }
-
-        #Compress everything less than 1MB
-        push( @headers, "Content-Encoding" => "gzip" );
-        my $dfh;
-        IO::Compress::Gzip::gzip( $fh => \$dfh );
-        print $IO::Compress::Gzip::GzipError if $IO::Compress::Gzip::GzipError;
-        push( @headers, "Content-Length" => length($dfh) );
-
-        INFO( "GET 200 " . length($dfh) . " $fullpath" );
-
-        # Append server-timing headers
-        my $tot = tv_interval($start) * 1000;
-        push( @headers, 'Server-Timing' => "file;dur=$tot" );
-
-        return [ $code, \@headers, [$dfh] ];
-    }
-
-    INFO("GET 403 23 $fullpath");
-    return [ 403, [ $ct => $Trog::Vars::content_types{text} ], ["STAY OUT YOU RED MENACE"] ];
-}
-
-1;

lib/Trog/Renderer/blob.pm

@@ -10,7 +10,7 @@ Render blobs, such as files stored in a DB.
 
 =cut
 
-# TODO use the streaming code from Trog::FileHandler, etc.
+# TODO stream large blobs, as TPSGI::serve streams files.
 sub render (%options) {
     my $code    = delete $options{code};
     my $headers = delete $options{headers};

lib/Trog/Vars.pm

@@ -15,15 +15,6 @@ them directly rather than paying for a function call on every request.
 
 =over 4
 
-=item $CHUNK_SEP
-
-Separator used when a file upload has to be reassembled from chunks.
-Chosen to be something no browser will ever send us by accident.
-
-=item $CHUNK_SIZE
-
-Size of said chunks, in bytes.  1MB.
-
 =item %content_types
 
 Maps the short names used in templates and route definitions (html, json, ...)
@@ -45,10 +36,6 @@ immutable once published.
 
 =cut
 
-#1MB chunks
-our $CHUNK_SEP  = 'tCMSep666YOLO42069';
-our $CHUNK_SIZE = 1024000;
-
 our %content_types = (
     text  => "text/plain",
     html  => "text/html",

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-DataModule-schema.t

@@ -78,7 +78,7 @@ sub set_components {
     return;
 }
 
-sub sidecar { return JSON::MaybeXS::encode_json( { type => 'object', @_ } ) }
+sub sidecar (@fields) { return JSON::MaybeXS::encode_json( { type => 'object', @fields } ) }
 
 subtest 'the base schema applies with no sidecar at all' => sub {
     set_sidecars();

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-spawn.t

@@ -0,0 +1,90 @@
+#!/usr/bin/env perl
+
+# spawn() for real: it forks, detaches, and runs a provisioner, which here is
+# a shell script in a sandbox.  t/Trog-DataSource-ProvisionedVirt.t mocks it,
+# so this is the one place where its child is run.
+
+use 5.040;
+use re '/aasx';
+use warnings FATAL => 'all';
+
+use FindBin::libs;
+
+use Test::More;
+use File::Temp  qw{tempdir};
+use File::Path  ();
+use Time::HiRes ();
+
+our ( $ROOT, $OLDCWD );
+
+BEGIN {
+    require Cwd;
+    $OLDCWD    = Cwd::getcwd();
+    $ROOT      = tempdir( 'tcms-spawn-XXXXXX', TMPDIR => 1, CLEANUP => 1 );
+    $ENV{HOME} = $ROOT;
+}
+
+require_ok('Trog::DataSource::ProvisionedVirt') or BAIL_OUT("Can't find SUT");
+
+END {
+    chdir($OLDCWD) if $OLDCWD;
+}
+
+{
+    no warnings qw{once};
+    $Trog::DataSource::ProvisionedVirt::log_dir = "$ROOT/logs";
+}
+File::Path::make_path("$ROOT/bin");
+
+my sub provisioner ( $name, $body ) {
+    my $program = "$ROOT/bin/$name";
+    open( my $fh, '>', $program ) or die "$program: $!";
+    print {$fh} "#!/bin/sh\n$body\n";
+    close($fh)              or die "$program: $!";
+    chmod( 0755, $program ) or die "$program: $!";
+    return $program;
+}
+
+# What the run says once it has stopped, or undef if it has not stopped within
+# ten seconds.
+my sub finished ($domain) {
+    foreach ( 1 .. 100 ) {
+        my $status = Trog::DataSource::ProvisionedVirt::status($domain);
+        return $status if $status && $status->{state} ne 'running';
+        Time::HiRes::sleep(0.1);
+    }
+    return;
+}
+
+my sub run ( $domain, $program, $credentials ) {
+    my ( $ok, $why ) = Trog::DataSource::ProvisionedVirt::spawn( $domain, $credentials, $ROOT, [ $program, $domain ], 'admin' );
+    ok( $ok, "a run for $domain starts" ) or diag($why);
+    return finished($domain);
+}
+
+# Starman, under which tPSGI runs, ignores SIGPIPE, and its children inherit
+# that.  So a write to a provisioner that has gone fails rather than kills.
+local $SIG{PIPE} = 'IGNORE';
+
+subtest 'a provisioner that reads its credentials and succeeds' => sub {
+    my $status = run( 'reads.test.test', provisioner( 'reads', 'cat >/dev/null; exit 0' ), { password => 'hunter2' } );
+    is( $status->{state}, 'ok', 'the run is ok' );
+    is( $status->{exit},  '0',  'and exited 0' );
+};
+
+subtest 'a provisioner that fails' => sub {
+    my $status = run( 'fails.test.test', provisioner( 'fails', 'cat >/dev/null; exit 3' ), { password => 'hunter2' } );
+    is( $status->{state}, 'failed', 'the run failed' );
+    is( $status->{exit},  '3',      'with what the provisioner exited' );
+};
+
+# More than a pipe holds, so the write cannot finish before the provisioner
+# has gone, whichever of the two is first.
+subtest 'a provisioner that never reads its credentials' => sub {
+    my $status = run( 'deaf.test.test', provisioner( 'deaf', 'exit 0' ), { password => 'x' x 1_048_576 } );
+    is( $status->{state}, 'failed', 'the run failed, although the provisioner exited 0' );
+    my $log = Trog::DataSource::ProvisionedVirt::log_for('deaf.test.test') // '';
+    like( $log, qr/could[ ]not[ ]write[ ]to[ ]\N*deaf/, 'and the log says that it never got them' );
+};
+
+done_testing();

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");
@@ -107,9 +107,9 @@ $virt->redefine( is_self => sub { return $_[0] eq 'thisserver.example.com' ? 1 :
 
 write_config( trog_provisioner => "$ROOT/trog-provisioner" );
 
-sub reprovision {
+sub reprovision (@args) {
     @SPAWNED = ();
-    return Trog::DataSource::ProvisionedVirt::reprovision( passphrase => 'hunter2', user => 'admin', @_ );
+    return Trog::DataSource::ProvisionedVirt::reprovision( passphrase => 'hunter2', user => 'admin', @args );
 }
 
 require Trog::Auth;
@@ -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

@@ -27,17 +27,17 @@ our @CALLS;
 {
 
     package FakeDomain;
-    sub new             { my ( $c, %a ) = @_; return bless {%a}, $c }
-    sub get_name        { return $_[0]{name} }
-    sub get_uuid_string { return $_[0]{uuid} }
-    sub is_active       { return $_[0]{active} }
-    sub get_info        { return { state => $_[0]{state}, memory => 1024, nrVirtCpu => 2 } }
+    sub new { my ( $c, %a ) = @_; return bless {%a}, $c }
+    sub get_name        ( $self, @ ) { return $self->{name} }
+    sub get_uuid_string ( $self, @ ) { return $self->{uuid} }
+    sub is_active       ( $self, @ ) { return $self->{active} }
+    sub get_info        ( $self, @ ) { return { state => $self->{state}, memory => 1024, nrVirtCpu => 2 } }
 
     # The operations we must never actually perform: record and return.
-    sub create          { push @main::CALLS, [ 'create',          $_[0]{name} ]; return 1 }
-    sub shutdown        { push @main::CALLS, [ 'shutdown',        $_[0]{name} ]; return 1 }
-    sub destroy         { push @main::CALLS, [ 'destroy',         $_[0]{name} ]; return 1 }
-    sub create_snapshot { push @main::CALLS, [ 'create_snapshot', $_[0]{name} ]; return 1 }
+    sub create          ( $self, @ ) { push @main::CALLS, [ 'create',          $self->{name} ]; return 1 }
+    sub shutdown        ( $self, @ ) { push @main::CALLS, [ 'shutdown',        $self->{name} ]; return 1 }
+    sub destroy         ( $self, @ ) { push @main::CALLS, [ 'destroy',         $self->{name} ]; return 1 }
+    sub create_snapshot ( $self, @ ) { push @main::CALLS, [ 'create_snapshot', $self->{name} ]; return 1 }
 
     # Reading a console is not a mutation, so this one really runs.
     sub screenshot { return 'image/png' }
@@ -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.
@@ -200,17 +200,17 @@ require Trog::Routes::JSON;
     sub EMERG { return 1 }
     sub FATAL { return 1 }
 
-    sub see_also           { return [ 303, [ 'Location' => $_[1], 'Content-Length' => 0 ], [''] ] }
-    sub redirect           { return [ 302, [ 'Location' => $_[1], 'Content-Length' => 0 ], [''] ] }
-    sub redirect_permanent { return [ 301, [ 'Location' => $_[1], 'Content-Length' => 0 ], [''] ] }
+    sub see_also           ( $, $to, @ ) { return [ 303, [ 'Location' => $to, 'Content-Length' => 0 ], [''] ] }
+    sub redirect           ( $, $to, @ ) { return [ 302, [ 'Location' => $to, 'Content-Length' => 0 ], [''] ] }
+    sub redirect_permanent ( $, $to, @ ) { return [ 301, [ 'Location' => $to, 'Content-Length' => 0 ], [''] ] }
 
-    sub reply      { return [ $_[1], [ 'Content-type' => 'text/html' ], [ defined $_[2] ? $_[2] : '' ] ] }
-    sub ok         { return $_[0]->reply( 200, $_[2] ) }
-    sub notfound   { return $_[0]->reply( 404, $_[2] // 'Not Found' ) }
-    sub forbidden  { return $_[0]->reply( 403, $_[2] // 'Forbidden' ) }
-    sub badrequest { return $_[0]->reply( 400, $_[2] // 'Bad Request' ) }
-    sub error      { return $_[0]->reply( 500, $_[2] // 'Error' ) }
-    sub serve      { return [ 200, [], [''] ] }
+    sub reply      ( $, $code, $body = undef, @ ) { return [ $code, [ 'Content-type' => 'text/html' ], [ $body // '' ] ] }
+    sub ok         ( $self, $, $body = undef, @ ) { return $self->reply( 200, $body ) }
+    sub notfound   ( $self, $, $body = undef, @ ) { return $self->reply( 404, $body // 'Not Found' ) }
+    sub forbidden  ( $self, $, $body = undef, @ ) { return $self->reply( 403, $body // 'Forbidden' ) }
+    sub badrequest ( $self, $, $body = undef, @ ) { return $self->reply( 400, $body // 'Bad Request' ) }
+    sub error      ( $self, $, $body = undef, @ ) { return $self->reply( 500, $body // 'Error' ) }
+    sub serve { return [ 200, [], [''] ] }
 
     # These two must be inert.
     #
@@ -229,7 +229,7 @@ require Trog::Routes::JSON;
     }
 
     # The real one is `kill 'HUP', getppid`.  Under prove, that is prove.
-    sub signal_restart_parent { $_[0]{restarts}++; return 1 }
+    sub signal_restart_parent ( $self, @ ) { $self->{restarts}++; return 1 }
 
     # Recorded rather than inert: a datasource that watches something is
     # supposed to register here, and the lifecycle test is where we find out
@@ -240,9 +240,9 @@ require Trog::Routes::JSON;
         return 1;
     }
 
-    sub invalidate_renders { push @{ $_[0]{invalidated} }, $_[1];              return 1 }
-    sub invalidate_render  { push @{ $_[0]{invalidated} }, [ @_[ 1 .. $#_ ] ]; return 1 }
-    sub save_render        { $_[0]{renders}{"$_[1]:$_[2]"} = $_[3]; return 1 }
+    sub invalidate_renders ( $self, $what, @ ) { push @{ $self->{invalidated} }, $what;   return 1 }
+    sub invalidate_render  ( $self, @what )    { push @{ $self->{invalidated} }, [@what]; return 1 }
+    sub save_render        ( $self, $route, $type, $content, @ ) { $self->{renders}{"$route:$type"} = $content; return 1 }
 }
 
 our $TPSGI = Test::TPSGI->new();
@@ -282,8 +282,8 @@ my sub query {
     return \%q;
 }
 
-my sub anon  { return query( user => undef,       user_acls => [],        @_ ) }
-my sub admin { return query( user => $ADMIN_USER, user_acls => ['admin'], @_ ) }
+my sub anon  (@args) { return query( user => undef,       user_acls => [],        @args ) }
+my sub admin (@args) { return query( user => $ADMIN_USER, user_acls => ['admin'], @args ) }
 
 # Returns ($code, $body, $error).  Never dies, so one bad post type cannot take
 # the rest of the file with it -- which matters because a failed render inside
@@ -331,8 +331,8 @@ my sub topbar_titles {
 }
 
 # post_title.tx emits exactly one of these per displayed post.
-my sub post_count {
-    my $n = () = $_[0] =~ m{<h3[ ]class='blogtitles'>}g;
+my sub post_count ($body) {
+    my $n = () = $body =~ m{<h3[ ]class='blogtitles'>}g;
     return $n;
 }
 
@@ -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;