view release on metacpan or  search on metacpan

MrShell.pm  view on Meta::CPAN

# line {{{
sub line {
    my $this = shift;
    my $fh   = shift;
    my ($line, $wid) = @_[ ARG0, ARG1 ];
    my ($kid, $host, $cmdno, $lineno) = @{$this->{_wid}{$wid}};

    $$lineno ++;
    $this->std_msg($host, $cmdno, $fh, $line);

    return;
}
# }}}

# sigchld {{{
sub _sigchld_exit_error {
    my $this = shift;
    my ($pid, $exit) = @_[ ARG1, ARG2 ];
    $exit >>= 8;

    $this->std_msg("?", -1, 0, BOLD.RED."-- sigchld received for untracked pid($pid, $exit), probably a bug in Mr. Shell --");

    return;
}

sub sigchld {
    my $this = shift; # ARG0 is the signal name string
    my ($kid, $host, $cmdno, @c) = @{ $this->{_pid}{ $_[ARG1] } || return $this->_sigchld_exit_error(@_) };

    # NOTE: this usually isn't an error, sometimes the sigchild will arrive
    # before the handles are "closed" in the traditional sense.  We get error
    # eveents for errors.
    #### # $this->std_msg($host, $cmdno, 0, RED.'-- error: unexpected child exit --');

    # NOTE: though, the exit value may indicate an actual error.
    if( (my $exit = $_[ARG2]) != 0 ) {
        # XXX: I'd like to do more here but I'm waiting to see what Paul
        # Fenwick has to say about it.
        $exit >>= 8;

        my $reset = RESET;
        my $black = BOLD.BLACK;
        my $red   = RESET.RED;

        $this->std_msg($host, $cmdno, 0, "$black-- shell exited with nonzero status: $red$exit$black --");
    }

    $_[KERNEL]->yield( stall_close => $kid->ID, 0 );

    return;
}
# }}}
# _close {{{
sub _close {
    my $this = shift;
    my ($wid, $count) = @_[ ARG0, ARG1 ];

    return unless $this->{_wid}{$wid}; # sometimes we'll get a sigchild *and* a close event

    # NOTE: I was getting erratic results with some fast running commands and
    # guessed that I was sometimes getting the close event before the stdout
    # event. Waiting through the kernel loop once is probably enough, but I
    # used 3 because it does't hurt either.

    if( $count > 3 ) {
        my ($kid, $host, $cmdno, $lineno, @c) = @{ delete $this->{_wid}{$wid} };

        $this->std_msg($host, $cmdno++, 0, BOLD.BLACK.'-- eof --') if $$lineno == 0;
        if( @c ) {
            $this->start_queue_on_host($_[KERNEL] => $host, $cmdno, @c);
            $this->std_msg($host, $cmdno, 0, BOLD.BLACK."-- starting: @{$c[0]} --");
        }

        delete $this->{_pid}{ $kid->PID };

    } else {
        $_[KERNEL]->yield( stall_close => $wid, $count+1 );
    }

    return;
}
# }}}
# error_event {{{
sub error_event {
    my $this = shift;
    my ($operation, $errnum, $errstr, $wid) = @_[ARG0 .. ARG3];
    my ($kid, $host, $cmdno, @c) = @{ delete $this->{_wid}{$wid} || return };
    delete $this->{_pid}{ $kid->PID };

    $errstr = "remote end closed" if $operation eq "read" and not $errnum;
    $this->std_msg($host, $cmdno, 0, RED."-- $operation error $errnum: $errstr --");

    return;
}
# }}}

# set_subst_vars {{{
sub set_subst_vars {
    my $this = shift;

    while( my ($k,$v) = splice @_, 0, 2 ) {
        $this->{_subst}{$k} = $v unless exists $this->{_subst}{$k};
    }

    return $this;
}
# }}}
# subst_cmd_vars {{{
sub subst_cmd_vars {
    my $this = shift;
    my %h = %{ delete($this->{_subst}) || {} };
    my $host = $h{'%h'};

    my @c = @_; # copy this so it doesn't get altered upstream
                # (I'd swear I shoulnd't need to do this at all, but it's
                #  proovably true that I do.)

    if( $host =~ m/\b(?!<\\)!/ ) {
        my @hosts = split '!', $host;

        my @indexes_of_replacements;