system_pty_capture: use IO::Pty in preference to script(1)

1 files changed, 67 insertions, 22 deletions

diff --git a/perl5/Local/Interactive.pm b/perl5/Local/Interactive.pm
index f33533a2..b450982e 100644
--- a/perl5/Local/Interactive.pm
+++ b/perl5/Local/Interactive.pm
@@ -20,11 +20,12 @@ use warnings;
 
 use Cwd;
 use File::Temp qw(tempfile tempdir);
-use File::Path qw(remove_tree);
+use File::Path qw(rmtree);
 use Exporter 'import';
 use Term::ANSIColor;
 use Local::ScriptStatus;
 use Sys::Hostname;
+use POSIX ();
 
 # Quoting perldoc perlmodlib: "As a general rule, if the module is
 # trying to be object oriented then export nothing. If it's just a
@@ -128,47 +129,91 @@ sub interactive_ensure_subroutine_no_output {
 
 =head2 system_pty_capture($cmd)
 
-Run a command C<$cmd> with STDOUT & STDERR connected to the terminal,
+Run a command C<$cmd> with STDOUT & STDERR connected to a terminal,
 and also capture the (merged) output for inspection in Perl.  Programs
-will usually still output ANSI escape sequences, so the capturing
-should be transparent to the user.  sudo password prompts work, too.
+will usually still output ANSI escape sequences by default, so the
+capturing should be transparent to the user.  sudo password prompts
+work, too.
 
-We use script(1) because it's widely available.  An alternative is
-unbuffer(1) from the 'expect' package, or see perl function
-C<terminal_friendly_spawn()> in the myrepos program.
+If we don't have IO::Pty, we use script(1), because that's widely
+available.  An alternative is unbuffer(1) from the 'expect' package.
 
-Note that if C<$cmd> will cause sudo to prompt for a password, that
-will be forgotten when system_pty_capture() returns.  So sequential
-system_pty_capture("sudo ...") calls will each prompt the user for
-their password, bypassing sudo's usual timeout between requiring a
-password.
+Note that if we fell back to script(1), and C<$cmd> will cause sudo to
+prompt for a password, that password entry will be forgotten when
+system_pty_capture() returns.  So sequential system_pty_capture("sudo
+...") calls will each prompt the user for their password, bypassing
+sudo's usual timeout between requiring a password.  If we don't
+fallback to script(1) then this is not a problem.
 
 =cut
 
 sub system_pty_capture {
-    my ($cmd) = @_;
+    if (eval { require IO::Pty } and -t STDOUT) {
+        return _sysptycap_tty(@_);
+    } else {
+        return _sysptycap_script(@_);
+    }
+}
+
+sub _sysptycap_script {
+    # currently this sub only supports passing strings, not lists of
+    # arguments
+    my $cmd = shift;
 
     # the point of creating a tempdir and then putting a file inside
     # it is that then we can chmod that dir.  File::Temp apparently
     # uses secure permissions on files it creates in /tmp, but this
     # but it is not documented, so let's not rely on it
-    my $dir = tempdir("sysptycap." . hostname() . ".$$.XXXX",
-                      CLEANUP => 1, TMPDIR => 1);
+    my $dir = tempdir "sysptycap." . hostname . ".$$.XXXX",
+      CLEANUP => 1,
+      TMPDIR  => 1;
     chmod 0700, $dir;
-    my (undef, $filename) = tempfile("sysptycap.XXXX",
-                                     OPEN => 0, DIR => $dir);
+    my (undef, $filename) = tempfile "sysptycap.XXXX",
+      OPEN => 0,
+      DIR  => $dir;
+
     system qw(script --quiet --command), $cmd, $filename;
 
-    open my $fh, '<', $filename;
+    open my $fh, "<", $filename;
     chomp(my @output = <$fh>);
     close $fh;
-    remove_tree($dir);
+    rmtree $dir;
 
     $output[$#output] =~ /COMMAND_EXIT_CODE="([0-9]+)"/;
-    my $exit = $1;
-    @output = splice @output, 1, -1;
+    return { exit => $1, output => join "\n", splice @output, 1, -1 };
+}
 
-    return { exit => $exit, output => join("\n", @output) };
+# references:
+# - IO::Pty::Easy's 'new' and 'read' methods
+# - https://www.perlmonks.org/?node_id=299012
+# - https://www.perlmonks.org/?node_id=392942
+sub _sysptycap_tty {
+    my $pty = IO::Pty->new;
+    my $slave = $pty->slave;
+    $slave->clone_winsize_from(\*STDIN) if POSIX::isatty(*STDIN);
+    $slave->set_raw;                # so we can 'sysread' rather than 'read'
+    STDOUT->autoflush(1);
+    STDERR->autoflush(1);
+    my $pid = fork;
+    die "fork() failed: $!" unless defined $pid;
+    unless ($pid) {
+        $slave->close;
+        open STDOUT, ">&=", $pty->fileno or die $!;
+        open STDERR, ">&=", $pty->fileno or die $!;
+        exec @_;
+    }
+    $pty->close;
+    my $output;
+    while (1) {
+        my ($chars, $nchars);
+        $nchars = sysread $slave, $chars, 8192;
+        last if defined $nchars and $nchars == 0;
+        print $chars;
+        $output .= $chars;
+    }
+    $slave->close;
+    wait;
+    return { exit => $? >> 8, output => $output };
 }
 
 =head prompt($prompt)