run sub-process of a urxvt perl extension in calling urxvt window

Question

I am trying to write a rxvt-unicode perl extension to do what mrxvt PrintScreen does. I.e., the extension should pipe urxvt's contents to user-defined commands. The main purpose would be viewing urxvt's contents unwrapped in less -S.

Here are my first attempts. (The command is still hardcoded cat -n, and including color escape codes and joining of wrapped lines is still missing.)

#! perl -w
use strict;

sub on_user_command {
    my ($self, $cmd) = @_;
    open PIPE, "|cat -n" or die "urxvt-pipe: error opening pipe: $^E\n";
    for (my $i = $self->top_row; $i < $self->nrow; $i++) {
        print PIPE $self->ROW_t($i), "\n";
    }
    close PIPE or warn "urxvt-pipe: error closing pipe: $^E\n";
    ()
}

Replacing the pipe with exec_async does not help:

#! perl -w
use strict;

sub on_user_command {
    my ($self, $cmd) = @_;
    open FH, ">/tmp/urxvt.txt" or die "urxvt-pipe: error opening file: $^E\n";

    for (my $i = $self->top_row; $i < $self->nrow; $i++) {
        print FH $self->ROW_t($i), "\n";
    }

    close FH or warn "urxvt-pipe: error closing file: $^E\n";
    $self->exec_async("cat", "-n", "/tmp/urxvt.txt");
    ()
}

The problem with both is that the cat runs inside urxvt's parent (e.g. another urxvt or an emacs buffer if I call urxvt as the "compile" command during extension development). I would like it to run in the instance whose contents I'm piping, or a new tab thereof. Is that possible?

Obviously as a workaround, the exec_async could be modified to open a new window: $self->exec_async("urxvt", "-title", "less urxvt scrollback", "-e", "less", "-S", "/tmp/urxvt.txt"); But I'd prefer the same window, and also rather avoid creating a temporary file.

Answer 1

This does not answer the real question, but unfortunately it was rejected as too long for a comment.

I made the workaround less ugly, moving the new window part out of the extension:

• The extension uses IPC::Run3::run3 to capture the subprocess's stdout and stderr, and writes that to the "right" urxvt using $term->special_encode and $term->cmd_parse. (Not that less had any usefull output, but just to make it a general purpose extension.)
• The configured command (in a URxvt.keysym... line in ~/.Xdefaults) is: zsh -c 'stdin2fifo | read -r p && urxvt -e less -SNRfI -- "$p"'
• Script stdin2fifo reads stdin and writes it to a temp named pipe. less -f displays the pipe. So there's hopefully no disk I/O for the real data, only for a file system entry.

Script stdin2fifo:

#!/bin/zsh
if [ $# -ne 0 ]; then
    cat <<EOF
Usage: $(basename "$0")
Reads stdin, writes it to a new named pipe (in the background), and prints the
pipe's pathname.
Can be used (in zsh, at least) to "send stdin to another terminal". For example:
... | $(basename "$0") | read -r p && urxvt -e less -f -- "\$p"
EOF
    exit 4
fi
set -e
dir=$(mktemp -d "/tmp/$(basename "$0")_XXXXXX")
pipe=$dir/pipe
mkfifo "$pipe"
(cat > "$pipe")&
echo "$pipe"

---

EDIT 2022-12-10 in response to @geb's question how far I got. Caveat: I stopped using urxvt years ago and don't know whether this works in current versions and even how much of it worked back in the day. It seems it was last edited in May 2016. So WITHOUT WARRANTY, use at your own risk.

Script stdin2fifo: see above, unchanged.

Script urxvt-pipe:

#! perl -w
use strict;
use Env;
use IPC::Run3;
use feature qw(current_sub);
use constant EXT_NAME => 'urxvt-pipe';
use constant INFO => 8;
use constant DEBUG => 13;
use constant TRACE => 16;
sub msgLevelEnabled { my ($level) = @; $ENV{URXVT_PERL_VERBOSITY} >= $level; }
sub msg { my $level = shift @; printf STDERR @_ if msgLevelEnabled($level); }
sub errorMsg { die(sprintf("%s: %s\n", EXT_NAME, join(", ", @))); }
sub warnMsg { warn(sprintf("%s: %s\n", EXT_NAME, join(", ", @))); }
sub on_start {
    my ($t) = @_;
    # corresponding .Xdefaults line: URxvt.pipe.stdout-format:  \033[34m%s\033[0m\015\n
    $t->{stdoutFormat} = $t->conf("stdout-format", "\e[34m%s\e[0m\r\n");
    msg(DEBUG, "{stdoutFormat} == '%s'\n", $t->{stdoutFormat});
    $t->{stderrFormat} = $t->conf("stderr-format", "\e[31m%s\e[0m\r\n");
    msg(DEBUG, "{stderrFormat} == '%s'\n", $t->{stderrFormat});
    $t->{statusFormat} = $t->conf("status-format", "\e[41;37;1m Status: %s \e[0m\r\n");
    msg(DEBUG, "{statusFormat} == '%s'\n", $t->{statusFormat});
    $t->{echoFormat} = $t->conf("echo-format", "\r\n\e[34m" . EXT_NAME . "> %s\e[0m\r\n");
    msg(DEBUG, "{echoFormat} == '%s'\n", $t->{echoFormat});
    $t->{promptPattern} = $t->conf("prompt-pattern", '.?[>$#]\s+(.+)');
    msg(DEBUG, "{promptPattern} == '%s'\n", $t->{promptPattern});
    $t->{sendBeforeCommand} = $t->conf("send-before-cmd", '');
    msg(DEBUG, "{sendBeforeCommand} == '%s'\n", $t->{sendBeforeCommand});
    $t->{sendAfterCommand} = $t->conf("send-after-cmd", '');
    msg(DEBUG, "{sendAfterCommand} == '%s'\n", $t->{sendAfterCommand});
msg(TRACE, "DEFAULT_RSTYLE == %032b (%s)\n", urxvt::DEFAULT_RSTYLE, describeRendition(urxvt::DEFAULT_RSTYLE));
msg(TRACE, "RS_Bold        == %032b\n", urxvt::RS_Bold);
msg(TRACE, "RS_Italic      == %032b\n", urxvt::RS_Italic);
msg(TRACE, "RS_Blink       == %032b\n", urxvt::RS_Blink);
msg(TRACE, "RS_RVid        == %032b\n", urxvt::RS_RVid);
msg(TRACE, "RS_Uline       == %032b\n", urxvt::RS_Uline);

}
sub conf {
    my ($term, $name, $defaultValue) = @_;
    defined $term->x_resource("%.$name") ? $term->x_resource("%.$name") : $defaultValue;
}
sub on_user_command {
    my ($term, $arg) = @_;
# === parse $arg ===
msg(DEBUG, "on_user_command(.., '%s')\n", $arg);
my (undef, $options, $cmd) = $arg =~ m{.*?:(.)(.*?)\1(.*)} or errorMsg("expected arg format ...:[<options>]:<command>");
msg(DEBUG, "\$options == '%s', \$cmd == '%s'\n", $options, $cmd);
my %options = ();
for (split /,/, $options) { m{(.*?)=(.*)} or errorMsg("options: expected comma-separated key=value pairs"); $options{$1} = $2; };
msg(DEBUG, "%%options == (%s)\n", join("; ", map { "$_ = $options{$_}" } keys(%options))) if msgLevelEnabled(DEBUG);

# === prepare $cmd's input ===
my ($rowNum, $maxRowNum) = selectRows($term, $options{start}, $options{end});
my $nextLine = sub {
    return undef if $rowNum > $maxRowNum;
    my $l = $term->line($rowNum);
    msg(TRACE, "\nline(%d)->t == \"%s\"\n", $rowNum, $l->t);
    msg(TRACE, "line(%d)->beg == %d, ->end == %d\n", $rowNum, $l->beg, $l->end);
    $rowNum += $l->end - $l->beg + 1;
    return line2string($term, $l, \%options) . "\n";
};
$nextLine = logFunction($nextLine, 'nextLine') if msgLevelEnabled(DEBUG);

# wrap $nextLine() to discard trailing empty results
my $bufferedEmptyResultsCount = 0;  #buffered empty lines returned by nextLine()
my $bufferedResult; #buffered non-empty line after $bufferedEmptyResultsCount
my $nextLineTruncated = sub {
    # prefer buffered results to new $nextLine() invocation
    if ($bufferedEmptyResultsCount > 0) {
        msg(TRACE, "returning buffered empty line\n");
        $bufferedEmptyResultsCount--;
        return "\n";
    }
    if (defined($bufferedResult)) {
        msg(TRACE, "returning buffered non-empty line\n");
        my $result = $bufferedResult;
        $bufferedResult = undef;
        return $result;
    }

    my $origResult = &$nextLine(@_);
    if ($origResult ne "\n") {
        msg(TRACE, "returning original line\n");
        return $origResult;
    }

    msg(TRACE, "buffering empty line; looking for next non-empty line\n");
    $bufferedEmptyResultsCount++;
    # after empty result, search for next non-empty result (or stop at undef)
    while (1) {
        $origResult = &$nextLine(@_);
        if (!defined($origResult)) {
            msg(DEBUG, "discarding %d trailing empty lines\n", $bufferedEmptyResultsCount);
            $bufferedEmptyResultsCount = 0;
            $bufferedResult = undef;
            return undef;
        }
        if ($origResult eq "\n") {
            msg(TRACE, "buffering empty line\n");
            $bufferedEmptyResultsCount++;
        } else {    #found non-empty
            msg(TRACE, "buffering non-empty line, re-invoking %s\n", __SUB__);
            $bufferedResult = $origResult;
            return __SUB__->(@_);
        }
    }
};


$nextLineTruncated = logFunction($nextLineTruncated, 'nextLineTruncated') if msgLevelEnabled(DEBUG);

# === read $cmd from terminal if empty ===
if (length($cmd) == 0) {
    $cmd = readCommandFromTerminal($term);
    if (!defined($cmd)) { return (); }
}

# === sub to e.g. cut current input line (only before 1st output) ===
my $hasOutput = 0;
my $beforeOutput = sub {
    if (!$hasOutput) {
        $hasOutput = 1;
        $term->tt_write($term->{sendBeforeCommand}) if length($term->{sendBeforeCommand}) > 0;
    }
};

# === print $cmd ===
if ($options{'echo'}) {
    &$beforeOutput;
    $term->cmd_parse(sprintf($term->{echoFormat}, $term->special_encode($cmd)));
}

# === execute $cmd ===
my($cmdIn, $cmdOut, $cmdErr, %run3options);
$run3options{binmode_stdin} = $run3options{binmode_stdout} = $run3options{binmode_stderr} = ':utf8';
my $run = run3($cmd, $nextLineTruncated, \$cmdOut, \$cmdErr, \%run3options)
    or errorMsg("failed to start ${cmd}: $^E");
my $status = $? >> 8;
msg(DEBUG, "\$? == %d, \$status == %d\n", $?, $status);

# === print $cmd's output and status ===
unless ($options{'quiet'}) {
    if (length($term->{stdoutFormat}) > 0 && length($cmdOut) > 0) {
        msg(DEBUG, "printing stdout\n");
        for (split /\r?\n/, $cmdOut) {
            &$beforeOutput;
            $term->cmd_parse(sprintf($term->{stdoutFormat}, $term->special_encode($_)));
        }
    }
    if (length($term->{stderrFormat}) > 0 && length($cmdErr) > 0) {
        msg(DEBUG, "printing stderr\n");
        for (split /\r?\n/, $cmdErr) {
            &$beforeOutput;
            $term->cmd_parse(sprintf($term->{stderrFormat}, $term->special_encode($_)));
        }
    }
    if ($status != 0 && length($term->{statusFormat}) > 0) {
        msg(DEBUG, "printing status\n");
        &$beforeOutput;
        $term->cmd_parse(sprintf($term->{statusFormat}, $status));
    }
}

# === try to correct prompt (e.g. paste current input) ===
if ($hasOutput && length($term->{sendAfterCommand}) > 0) {
    msg(DEBUG, "printing {sendAfterCommand}\n");
    $term->tt_write($term->{sendAfterCommand});
}

msg(DEBUG, "on_user_command returns\n");
()

}
sub selectRows {
    my ($term, $startPage, $endPage) = @_;
msg(DEBUG, "nrow=%d, saveL.=%d, total_rows=%d, view_start=%d [%s], top_row=%d [%s]\n",
    $term->nrow, $term->saveLines, $term->total_rows,
    $term->view_start, substr($term->ROW_t($term->view_start), 0, 30),
    $term->top_row, substr($term->ROW_t($term->top_row), 0, 30))
    if msgLevelEnabled(DEBUG);

if (!defined $startPage && !defined $endPage) { #neither start nor end set => only current page
    $startPage = 0;
    $endPage = 0;
}
# only one of start or end set
$startPage = '^' unless defined $startPage;
$endPage = '$' unless defined $endPage;

my $startRow = selectRow($term, $startPage, 0);
my $endRow = selectRow($term, $endPage, 1);
msg(DEBUG, "selectRows(.., %s, %s) == (%s, %s)\n", $startPage, $endPage, $startRow, $endRow);
return ($startRow, $endRow);

}
sub selectRow {
    my ($term, $page, $bottom) = @_;
my $min = $term->top_row;
my $max = $term->total_rows - $term->nrow + 1;
my $row;
if ($page eq '^') {
    $row = $min;
} elsif ($page eq '$') {
    $row = $max;
} else {
    $row = $term->view_start + $page * $term->nrow;
    if ($row < $min) { $row = $min; }
    if ($row > $max) { $row = $max; }
}

if ($bottom) {
    $row += $term->nrow - 1;
} else {
    # TODO Set environment variable according to (logical) line, not (wrapped) row
    my $envLineNo = $term->view_start - $row;
    msg(DEBUG, "URXVT_PIPE_LINENO = %s\n", $envLineNo);
    $ENV{URXVT_PIPE_LINENO} = $envLineNo if $envLineNo >= 0;
}

return $row;

}
sub readLastTerminalLine {
    my ($term) = @_;
my $lastLineText = '';
for (my $rowNum = $term->total_rows; $rowNum >= $term->top_row; $rowNum--) {
    my $line = $term->line($rowNum);
    msg(TRACE, "readLastTerminalLine: [%d] \$line->t = '%s'\n", $rowNum, $line->t);
    $lastLineText = $term->special_decode($line->t) . $lastLineText;
    last if $line->l > 0;
    $rowNum -= $line->end - $line->beg;
}
$lastLineText =~ s{\n+$}{}g;
msg(DEBUG, "readLastTerminalLine() == '%s'\n", $lastLineText);
return $lastLineText;

}
sub readCommandFromTerminal {
    my ($term) = @_;
my $lastLineText = readLastTerminalLine($term);
if ($lastLineText =~ m{$term->{promptPattern}}s && length($1) > 0) {
    msg(INFO, "found command '%s'\n", $1);
    return $1;
}
warnMsg('No command found using prompt pattern ' . $term->{promptPattern}
        . ' (did you forget a capturing group?)');
return undef;

}
converts a urxvt->line object into the string to write to the pipe
sub line2string {
    my ($term, $line, $optionsRef) = @_;
my %options = %$optionsRef;
my $text = $line->t;
if (!$options{'color'}) {
    return $term->special_decode($text);
}

my @rendsArray = @{$line->r};
my $textEsc = '';   # $text with escapes
my $len = length($text);
my $prevRend;
my $resetSuffix = '';

for (my $i = 0; $i < $len; $i++) {
    my $char = substr($text, $i, 1);
    my $rend = $rendsArray[$i];
    msg(TRACE, "[%d]\t'%s': \$rend == %032b (%s)\n", $i, $char, $rend,
        $rend == $prevRend ? '...' : describeRendition($rend)) if msgLevelEnabled(TRACE);
    if ($i == 0 || $rend != $prevRend) {
        $textEsc .= "\e[m" if $i > 0;   #TODO make escapes configurable
        my $escape = rendition2Escape($rend);
        $resetSuffix = "\e[m" if '' ne $escape; #TODO make escapes configurable
        $textEsc .= $escape;
    }

    $textEsc .= $char;
    $prevRend = $rend;
}

return $term->special_decode($textEsc . $resetSuffix);

}
#TODO make escapes configurable
sub rendition2Escape {
    my ($rend) = @_;
    if ($rend == 0) {
        msg(TRACE, "rendition2Escape(0) == ''\n");
        return '';
    }
my @escapes = ();

# WTF? GET_BASEFG == 0 / GET_BASEBG == 1 seem to mean default color; otherwise they are color index + 2.
# TODO: But GET_BASEBG == 1 can also be color 1 (red). How to distinguish?
# Example (showing output of /usr/share/screen/256colors.pl):
# "S" in "System colors:" header, default colors:
# -> $rend == 00000000000010000000000000000001 (fg: 0, bg: 1, bold: 0, it: 0, ul: 0, rv: 0, bl: 0, custom: 0)
# 3rd " " in line 2, red background:
# -> $rend == 00000000000010000000000000000011 (fg: 0, bg: 3, bold: 0, it: 0, ul: 0, rv: 0, bl: 0, custom: 0)
my $bg = urxvt::GET_BASEBG $rend;
my $fg = urxvt::GET_BASEFG $rend;
push @escapes, ('38;5;' . ($fg - 2)) if $fg != 0;
push @escapes, ('48;5;' . ($bg - 2)) if $bg != 1;

push @escapes, '1' if $rend & urxvt::RS_Bold;
push @escapes, '3' if $rend & urxvt::RS_Italic;
push @escapes, '5' if $rend & urxvt::RS_Blink;
push @escapes, '7' if $rend & urxvt::RS_RVid;
push @escapes, '4' if $rend & urxvt::RS_Uline;


my $escapeSeq = "\e[" . join(';', @escapes) . 'm';
my $escapeSeq = join('', map { "\e[" . $_ . 'm' } @escapes);
msg(TRACE, "rendition2Escape(%s): %sxyz\e[0m\n", $rend, $escapeSeq) if @escapes > 0 && msgLevelEnabled(TRACE);
return $escapeSeq;

}
sub describeRendition {
    my ($rend) = @_;
    sprintf("fg: %d, bg: %d, bold: %d, it: %d, ul: %d, rv: %d, bl: %d, custom: %d",
            urxvt::GET_BASEFG $rend,
            urxvt::GET_BASEBG $rend,
            $rend & urxvt::RS_Bold,
            $rend & urxvt::RS_Italic,
            $rend & urxvt::RS_Uline,
            $rend & urxvt::RS_RVid,
            $rend & urxvt::RS_Blink,
            urxvt::GET_CUSTOM $rend);
}
sub logFunction {
    my ($funcRef, $funcName) = @;
    my $logF = sub {
        my $res = &$funcRef(@);
        msg(DEBUG, "%s(..) == '%s'\n", $funcName, defined($res) ? $res : '<undef>');
        return $res;
    };
    msg(TRACE, "logFunction(%s) == %s\n", $funcRef, $logF);
    return $logF;
}
TODO: documentation

~/.Xdefaults entries (grepping for "pipe", the one called "URxvt.print-pipe" is probably unrelated):

URxvt.print-pipe:   cat > /tmp/urxvt.pp
URxvt.perl-ext-common: default,keyboard-select,pipe
URxvt.pipe.stdout-format:   \033[90m[%s]\033[0m\015\n
URxvt.pipe.stderr-format:   \033[31m[%s]\033[0m\015\n
URxvt.pipe.status-format:   \040\033[101;37;1m\!%d\!\033[0m\040\015\n
urxvt.perl-ext-common:  default,pipe
urxvt.keysym.F5:    perl:pipe::start=-2,end=0,color=1:  zsh -c 'stdin2fifo | read -r f && env URXVT_PERL_VERBOSITY= mintty -t "less urxvt" -s 270x73 -p 0,0 -o BackgroundColour=255,249,216 -i /c/windows/system32/shell32.dll,56 -e less -SRf +${URXVT_PIPE_LINENO:-0}g "$f"&'
urxvt.keysym.S-F5:  perl:pipe::start=-4,end=0,color=1:  zsh -c 'stdin2fifo | read -r f && env URXVT_PERL_VERBOSITY= mintty -t "less urxvt" -s 270x73 -p 0,0 -o BackgroundColour=255,249,216 -i /c/windows/system32/shell32.dll,56 -e less -SRf +${URXVT_PIPE_LINENO:-0}g "$f"&'
urxvt.keysym.F6:    perl:pipe::start=-20,end=$,color=1: zsh -c 'stdin2fifo | read -r f && env URXVT_PERL_VERBOSITY= mintty -t "less urxvt" -s 270x73 -p 0,0 -o BackgroundColour=255,249,216 -i /c/windows/system32/shell32.dll,56 -e less -SRf +G "$f"&'
urxvt.keysym.S-F6:  perl:pipe::start=^,end=$,color=1:   zsh -c 'stdin2fifo | read -r f && env URXVT_PERL_VERBOSITY= mintty -t "less urxvt" -s 270x73 -p 0,0 -o BackgroundColour=255,249,216 -i /c/windows/system32/shell32.dll,56 -e less -SRf +G "$f"&'