[PATCH] rproxy: support GNU addr2line via pipe

[Eric Wong <e@80x24.org>]

We can filter the HTML and CSV and run it through addr2line to
decode addresses from rproxy.  We can't safely run another
process inside the embedded mwrap-httpd since that could
break `waitpid(-1, ...)' in the code we're being injected into.
---
 lib/Devel/Mwrap/Rproxy.pm | 81 ++++++++++++++++++++++++++++++++++++++-
 1 file changed, 80 insertions(+), 1 deletion(-)

diff --git a/lib/Devel/Mwrap/Rproxy.pm b/lib/Devel/Mwrap/Rproxy.pm
index 6db72e6..2b9ccc7 100644
--- a/lib/Devel/Mwrap/Rproxy.pm
+++ b/lib/Devel/Mwrap/Rproxy.pm
@@ -58,6 +58,17 @@ sub list {
 	r(200, $str);
 }
 
+our %addr2line; # { exe|lib => Devel::Mwrap::Rproxy::A2L }
+
+# addr2line bidirectional pipe wrapper
+sub a2l {
+	my ($exe, $addr) = @_;
+	my $a2l = $addr2line{$exe} //= Devel::Mwrap::Rproxy::A2L->new($exe);
+	chomp(my $line = $a2l->lookup($addr));
+	$line = Plack::Util::encode_html($line);
+	$line =~ /\A\?\?:/ ? "$line $exe $addr" : $line;
+}
+
 sub call { # PSGI entry point
 	my ($self, $env) = @_;
 	my $uri = $env->{REQUEST_URI};
@@ -76,9 +87,77 @@ sub call { # PSGI entry point
 	# this only expects httpd.h output, so no continuation lines:
 	$h = do { local $/ = "\r\n\r\n"; <$c> } // return r(500, "read: $!");
 	my ($code, @hdr) = split(/\r\n/, $h);
+	@hdr = grep(!/^Content-Length:/i, @hdr); # addr2line changes length
+	my $csv = grep(m!^Content-Type: text/csv!i, @hdr);
 	(undef, $code, undef) = split(/ /, $code);
 	@hdr = map { split(/: /, $_, 2) } @hdr;
-	[ $code, \@hdr, $c ];
+	sub {
+		my ($wcb) = @_;
+		my $http_out = $wcb->([$code, \@hdr]);
+		eval {
+			local %addr2line;
+			# extract executable|library(address)
+			if ($csv) {
+				while (<$c>) {
+					s/\\n/\0\0/g;
+					s!(["\0])
+						(/[^\("\0]+) # exe
+						\(([^\)"\0]+)\) # addr
+						(["\0])!
+						$1.a2l($2,$3).$4!gex;
+					s/\0\0/\\n/g;
+					$http_out->write($_);
+				}
+			} else {
+				while (<$c>) {
+					s!>
+						(/[^\(<]+) # exe
+						\(([^\)<]+)\) # addr
+						<!
+						'>'.a2l($1,$2).'<'!gex;
+					$http_out->write($_);
+				}
+			}
+			close $c;
+		};
+		warn "E: $@" if $@;
+		$http_out->close;
+	}
+}
+
+# requires GNU addr2line for stdin/stdout support
+package Devel::Mwrap::Rproxy::A2L;
+use v5.12;
+
+sub new {
+	my ($cls, $exe) = @_;
+	pipe(my ($rd, $_wr)) or die "pipe: $!";
+	pipe(my ($_rd, $wr)) or die "pipe: $!";
+	my $addr2line = $ENV{ADDR2LINE} // 'addr2line';
+	my $pid = fork // die "fork: $!";
+	if ($pid == 0) {
+		close $rd;
+		close $wr;
+		open STDIN, '<&', $_rd or die "STDIN: $!";
+		open STDOUT, '>&', $_wr or die "STDOUT: $!";
+		exec $addr2line, '-e', $exe;
+		die "exec $addr2line -e $exe: $!";
+	}
+	$_rd = $_wr = undef;
+	$wr->autoflush(1);
+	bless { rd => $rd, wr => $wr, pid => $pid }, __PACKAGE__;
+}
+
+sub lookup {
+	my ($self, $addr) = @_;
+	say { $self->{wr} } $addr;
+	readline($self->{rd});
+}
+
+sub DESTROY {
+	my ($self) = @_;
+	delete @$self{qw(rd wr)};
+	waitpid(delete $self->{pid}, 0);
 }
 
 1;