view release on metacpan or  search on metacpan

MrShell.pm  view on Meta::CPAN

    my $fh    = shift;
    my $msg   = shift;

    my $host_msg = $host ? $this->_host_route_to_nick($host) . ": " : "";
    my $time_str = strftime('%H:%M:%S', localtime);

    print $time_str,
        sprintf(' %-*s', $this->{_host_width}+2, $host_msg),
            ( $fh==2 ? ('[',BOLD,YELLOW,'stderr',RESET,'] ') : () ), $msg, RESET, "\n";

    if( $this->{_log_fh} ) {
        $time_str = strftime('%Y-%m-%d %H:%M:%S', localtime);

        # No point in printing colors, stripped anyway.  Formatting columns is
        # equally silly -- in append mode anyway.
        $host_msg = $host ? "$host: " : "";
        print {$this->{_log_fh}} "$time_str $host_msg", ($fh==2 ? "[stderr] " : ""), $msg, "\n";
    }

    return $this;
}
# }}}

# 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 {