path: root/perl5/Local/Interactive.pm

package Local::Interactive;

# Copyright (C) 2019-2020 Sean Whitton
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <https://www.gnu.org/licenses/>.

use strict;
use warnings;

use Cwd;
use File::Temp qw(tempfile tempdir);
use File::Path qw(rmtree);
use Exporter 'import';
use Term::ANSIColor;
use Local::ScriptStatus;
use Sys::Hostname;
use POSIX ":sys_wait_h";
use I18N::Langinfo qw(langinfo CODESET);
use Encode "decode";

# Quoting perldoc perlmodlib: "As a general rule, if the module is
# trying to be object oriented then export nothing. If it's just a
# collection of functions then @EXPORT_OK anything but use @EXPORT
# with caution."
our @EXPORT_OK = qw(
                       interactive_ensure_subroutine
                       interactive_ensure_subroutine_success
                       interactive_ensure_subroutine_no_output
                       system_pty_capture
                       prompt prompt_yn prompt_Yn prompt_yN
                       get_ack show_user
                  );

=head1 IMPORTABLE SUBROUTINES

=head2 interactive_ensure_subroutine($cmd_fn, $check_fn, $dir, $hint)

Call anonymous subroutine C<$cmd_fn> with no arguments, and expect it
to return a scalar.  Pass this to C<$check_fn>.  Do this repeatedly
until C<$check_fn> returns a true value.  When C<$check_fn> returns a
false value, print C<$hint> and start an interactive shell in C<$dir>.
Continue the loop when it exits.

Usual usage is to have C<$cmd_fn> return the value of an invocation of
C<system_pty_capture()>.

=cut

sub interactive_ensure_subroutine {
    my ($cmd_fn, $check_fn, $dir, $hint) = @_;

    $dir //= $ENV{HOME};
    my $cwd;
    my $cmd_result;
    while (1) {
        $cmd_result = $cmd_fn->();
        return if $check_fn->($cmd_result);
        return if prompt_yN("Give up and ignore this problem?");
        say_bold("Hint: to resolve this situation, $hint") if defined $hint;
        script_status("hit C-d to exit the shell and try again");
        $cwd = getcwd();
        chdir $dir;
        system $ENV{SHELL};
        chdir $cwd;
    }
}

=head2 interactive_ensure_subroutine_success($cmd_fn, $dir, $hint)

Like C<interactive_ensure_subroutine()>, except the C<$check_fn>
argument is supplied for you.  Checks that C<$cmd_fn> returns an
anonymous hash containing a key 'exit' with value 0.

=cut

sub interactive_ensure_subroutine_success {
    my ($cmd_fn, $dir, $hint) = @_;

    interactive_ensure_subroutine($cmd_fn, sub {
                                      my $result = shift;

                                      if (exists $result->{exit}
                                          && $result->{exit} == 0) {
                                          return 1;
                                      } else {
                                          say_bold("uh oh, command unexpectedly exited nonzero");
                                          return 0;
                                      }}, $dir, $hint);
}

=head2 interactive_ensure_subroutine_no_output($cmd_fn, $dir, $hint)

Like C<interactive_ensure_subroutine()>, except the C<$check_fn>
argument is supplied for you.  Checks that C<$cmd_fn> returns an
anonymous hash containing a key 'output' which is empty except
possibly for newlines.

=cut

sub interactive_ensure_subroutine_no_output {
    my ($cmd_fn, $dir, $hint) = @_;

    my $check_fn = sub {
        my $result = shift;

        if (exists $result->{output}) {
            chomp($result->{output});
            if ($result->{output} eq '') {
                return 1;
            } else {
                say_bold("uh oh, command unexpectedly produced output");
                return 0;
            }
        } else {
            return 1;
        }
    };
    interactive_ensure_subroutine($cmd_fn, $check_fn, $dir, $hint);
}

=head2 system_pty_capture($cmd)

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 by default, so the
capturing should be transparent to the user.  sudo password prompts
work, too.

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 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 {
    if (eval { require IO::Pty } and -t STDOUT) {
        return _sysptycap_pty(@_);
    } 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;
    chmod 0700, $dir;
    my (undef, $filename) = tempfile "sysptycap.XXXX",
      OPEN => 0,
      DIR  => $dir;

    # These are the arguments for script from Debian's bsdutils
    # package; could use some heuristics to detect whether we need to
    # use other arguments, since all this is one big fallback from
    # using IO::Pty
    system qw(script --quiet --command), $cmd, $filename;

    open my $fh, "<", $filename;
    chomp(my @output = <$fh>);
    close $fh;
    rmtree $dir;

    $output[$#output] =~ /COMMAND_EXIT_CODE="([0-9]+)"/;
    return { exit => $1, output => join "\n", splice @output, 1, -1 };
}

# 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_pty {
    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'
    local $| = 1;

    # catch SIGINT and allow the current child process to finish up
    my $interrupted;
    (my $us = $0) =~ s{^.+/}{};
    local $SIG{INT}
      = sub { print STDERR "\n$us: interrupted\n"; $interrupted = 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 $!;

        # render child processes immune to C-c unless they have their
        # own signal handlers to perform cleanup, which will override
        # this
        $SIG{INT} = $SIG{HUP} = 'IGNORE';

        exec @_;
    }
    $pty->close;
    my $return = { output => "" };
    while (1) {
        my $rin = "";
        vec($rin, fileno $slave, 1) = 1;
        my $nbytes = sysread $slave, my $bytes, 8192
          if select $rin, undef, undef, 1;
        if ($nbytes) {
            print $bytes;
            $return->{output} .= $bytes;
        } elsif (my $deceased = waitpid $pid, WNOHANG) {
            # As there was no new output, or we got EOF, check if the
            # child has died.  We can't just check for EOF alone
            # because we can't rely on the pty getting EOF, e.g. if an
            # SSH control socket is still alive (seems to happen when
            # using Debian's SSH jump host to SSH to salsa)
            $return->{exit} = $? >> 8 if $deceased > 0;
            last;
        }
    }
    $slave->close;
    exit 2 if $interrupted;

    # since sysread was raw bytes, want to decode if possible
    my $codeset = eval { langinfo CODESET };
    $return->{output} = decode $codeset, $return->{output} if $codeset;

    $return;
}

=head prompt($prompt)

Prompt with C<$prompt> for a single line of input.

=cut

sub prompt {
    my ($prompt) = @_;

    local $| = 1;
    print colored("$prompt ", 'bold');
    chomp(my $response = <STDIN>);
    return $response;
}

=head prompt_yn($prompt)

Prompt with C<$prompt> for input of either 'y' or 'n', returning a
true or false value respectively.  No default response; just hitting
RET is invalid.

=cut

sub prompt_yn {
    my ($prompt) = @_;

    my $response;
    while (1) {
        $response = prompt("$prompt (y/n)");
        return 1 if lc($response) eq 'y';
        return 0 if lc($response) eq 'n';
        print "invalid response\n";
    }
}

=head prompt_Yn($prompt)

Prompt with C<$prompt> for input of either 'y' or 'n', returning a
true or false value respectively.  Hitting RET is equivalent to
answering 'y'.

=cut

sub prompt_Yn {
    my ($prompt) = @_;

    my $response;
    while (1) {
        $response = prompt("$prompt (Y/n)");
        return 1 if lc($response) eq 'y' or $response eq '';
        return 0 if lc($response) eq 'n';
        print "invalid response\n";
    }
}

=head prompt_yN($prompt)

Prompt with C<$prompt> for input of either 'y' or 'n', returning a
true or false value respectively.  Hitting RET is equivalent to
answering 'n'.

=cut

sub prompt_yN {
    my ($prompt) = @_;

    my $response;
    while (1) {
        $response = prompt("$prompt (y/N)");
        return 1 if lc($response) eq 'y';
        return 0 if lc($response) eq 'n' or $response eq '';
        print "invalid response\n";
    }
}

=head get_ack()

Wait for user to hit RET.

=cut

sub get_ack { prompt("[acknowledge]") };

=head show_user($cmd, $comment)

Show the output of command C<$cmd> to the user, make a comment on it,
prompt for acknowledgement.

=cut

sub show_user {
    my ($cmd, $comment) = @_;

    system $cmd;
    say_spaced_bullet($comment);
    get_ack();
}

1;