rproxy: cache addr2line output

We'll hoist out exe resolution into its own sub and rely on
reusing stat info (via `stat(_)') to give us ctime + size info
to use as a cache key.

1 files changed, 48 insertions, 30 deletions

diff --git a/lib/Devel/Mwrap/Rproxy.pm b/lib/Devel/Mwrap/Rproxy.pm
index e98aebe..8dc78a2 100644
--- a/lib/Devel/Mwrap/Rproxy.pm
+++ b/lib/Devel/Mwrap/Rproxy.pm
@@ -59,17 +59,53 @@ sub list {
 }
 
 our %addr2line; # { exe|lib => Devel::Mwrap::Rproxy::A2L }
+my %cache; # "$exe\0$addr$st_ctime$st_size" => $line
+my $cache_exp = 0;
+my $cache_time = 1800;
+
+sub resolve_exe ($$) {
+        my ($exe, $st) = @_;
+        # n.b. this assumes PATH is identical across the rproxy and
+        # mwrap-httpd process, which may not always be the case:
+        if (index($exe, '/') < 0 && !-r $exe) {
+                for my $p (split(/:/, $ENV{PATH})) {
+                        $p .= "/$exe";
+                        if (-x $p) {
+                                $exe = $p;
+                                last;
+                        }
+                }
+        }
+        my $fh;
+        if (-T $exe && open($fh, '<', $exe)) { # is it text? use shebang
+                my $l = readline($fh);
+                $exe = ($l =~ /\A\#\![ \t]*(\S+)/) ? $1 : $^X;
+        }
+        return unless -e $exe;
+
+        # Debian `perl-debug' is special:
+        ($exe eq '/usr/bin/perl' && -x '/usr/bin/debugperl') and
+                $exe = '/usr/bin/debugperl';
+        my @st = stat(_);
+        $$st = pack('dd', $st[10], $st[7]); # ctime + size
+        $exe;
+}
 
 # addr2line bidirectional pipe wrapper
 sub a2l {
         my ($exe, $addr) = @_;
-        my $a2l = $addr2line{$exe} //=
-                Devel::Mwrap::Rproxy::A2L->new($exe) //
-                return "$exe $addr";
-        chomp(my $line = $a2l->lookup($addr));
-        $line = Plack::Util::encode_html($line);
-        $line =~ /\?\?/ ? "$line $exe $addr" :
-                ($line =~ /\S/ ? $line : "$exe $addr");
+        $exe = resolve_exe($exe, \(my $st)) // return "$exe($addr)";
+        $cache{"$addr\0$exe$st"} //= do {
+                my $a2l = $addr2line{$exe} //=
+                        Devel::Mwrap::Rproxy::A2L->new($exe);
+
+                $a2l ? do {
+                        chomp(my $line = $a2l->lookup($addr));
+                        $line = Plack::Util::encode_html($line);
+                        $line =~ /\?\?/ ? "$line $exe($addr)" :
+                                ($line =~ /\S/ ? $line : "$exe($addr)");
+                } : "$exe($addr)"
+        }
 }
 
 sub call { # PSGI entry point
@@ -97,6 +133,11 @@ sub call { # PSGI entry point
         sub {
                 my ($wcb) = @_;
                 my $http_out = $wcb->([$code, \@hdr]);
+                my $now = time;
+                if ($now > $cache_exp) {
+                        undef %cache;
+                        $cache_exp = $now + $cache_time;
+                }
                 eval {
                         local %addr2line;
                         # extract executable|library(address)
@@ -134,29 +175,6 @@ use v5.12;
 
 sub new {
         my ($cls, $exe) = @_;
-        # n.b. this assumes PATH is identical across the rproxy and
-        # mwrap-httpd process, which may not always be the case:
-        if (index($exe, '/') < 0 && !-r $exe) {
-                for my $p (split(/:/, $ENV{PATH})) {
-                        $p .= "/$exe";
-                        if (-x $p) {
-                                $exe = $p;
-                                last;
-                        }
-                }
-        }
-        my $fh;
-        if (-T $exe && open($fh, '<', $exe)) { # is it text? use shebang
-                my $l = readline($fh);
-                $exe = ($l =~ /\A\#\![ \t]*(\S+)/) ? $1 : $^X;
-        }
-        return unless -e $exe;
-
-        # Debian `perl-debug' is special:
-        if ($exe eq '/usr/bin/perl' && -x '/usr/bin/debugperl') {
-                $exe = '/usr/bin/debugperl';
-        }
-
         pipe(my ($rd, $_wr)) or die "pipe: $!";
         pipe(my ($_rd, $wr)) or die "pipe: $!";
         # -f/--functions needs -p/--pretty-print to go with it