Record a reprovision as failed when its credentials never arrived

spawn() writes the credentials down the provisioner's stdin, closes it,
and then reads the outcome from $? alone.  tPSGI runs under Starman,
and Net::Server sets SIGPIPE to IGNORE, which the forked child
inherits.  So when the provisioner exits without reading its stdin, the
write fails with EPIPE rather than killing the child.  If the
provisioner exited 0, $? is 0, and the run was recorded as ok although
nothing received the credentials.

The print and the close are both checked now.  PerlIO drops what it
could not write, so after a print that fails, the close has nothing
left to flush and returns true.  A close that fails with $! set is the
other half: the same write, when the print only buffered it.  Either is
a failed run, with exit 1, and the log says that the provisioner could
not be written to.

The new test runs spawn() for real, which the existing test file mocks
throughout and says so.  Against the old code, the provisioner that
exits without reading is recorded as ok, and that subtest fails.  Its
credentials are more than a pipe holds, so the write cannot finish into
the buffer before the provisioner has gone, whichever one runs first.
No test reaches the close that fails after a print that succeeded,
because which write fails there depends on timing.

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

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

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