diff options
Diffstat (limited to 'lib/Devel')
| -rw-r--r-- | lib/Devel/Mwrap.pm | 21 | ||||
| -rw-r--r-- | lib/Devel/Mwrap/PSGI.pm | 190 | ||||
| -rw-r--r-- | lib/Devel/Mwrap/Rproxy.pm | 220 |
3 files changed, 0 insertions, 431 deletions
diff --git a/lib/Devel/Mwrap.pm b/lib/Devel/Mwrap.pm deleted file mode 100644 index 2691802..0000000 --- a/lib/Devel/Mwrap.pm +++ /dev/null @@ -1,21 +0,0 @@ -# Copyright (C) all contributors <mwrap-perl@80x24.org> -# License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> -package Devel::Mwrap; -use v5.12; -our $VERSION = '0.0.0'; -use XSLoader; -XSLoader::load(__PACKAGE__, $VERSION); - -# allow using via the "-d:Mwrap" switch on the command-line: -package # hide the package from the PAUSE indexer - DB; - -sub DB {} # noop, just keeps "-d:Mwrap" happy - -1; -__END__ -=pod - -=head1 NAME - -Devel::Mwrap - LD_PRELOAD malloc wrapper + line stats for Perl diff --git a/lib/Devel/Mwrap/PSGI.pm b/lib/Devel/Mwrap/PSGI.pm deleted file mode 100644 index 3a3a29b..0000000 --- a/lib/Devel/Mwrap/PSGI.pm +++ /dev/null @@ -1,190 +0,0 @@ -# Copyright (C) all contributors <mwrap@80x24.org> -# License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> -# -# Note: this is deprecated, use httpd.h instead -package Devel::Mwrap::PSGI; -use v5.12; # strict -use warnings; -use Devel::Mwrap; -use Fcntl qw(SEEK_SET); - -sub new { - my ($class) = @_; - bless {}, $class; -} - -my %HTML_ESC = ( - '&' => '&', - '>' => '>', - '<' => '<', - '"' => '"', - "'" => ''' -); - -sub encode_html { - my ($str) = @_; - $str =~ s/[&><"']/$HTML_ESC{$1}/sge; - $str; -} - -my %URI_ESC; -for (0..255) { $URI_ESC{chr($_)} = sprintf('%%%02X', $_) } -sub uri_escape { - my ($str) = @_; - $str =~ s/([^A-Za-z0-9\-\._~])/$URI_ESC{$1}/sge; - $str; -} - -sub uri_unescape { - my ($str) = @_; - $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/sge; - $str; -} - -my @FIELDS = qw(bytes allocations frees live - mean_life max_life location); -my $HDR = '<tr><th>' . join('</th><th>', @FIELDS) . '</th></tr>'; - -sub accumulate_i { # callback for Devel::Mwrap::each - my ($all, $src_loc) = @_; - my $alloc = $src_loc->allocations; - my $frees = $src_loc->frees; - push @$all, [ $src_loc->total - $src_loc->freed_bytes, - $alloc, $frees, $alloc - $frees, - $src_loc->mean_lifespan, $src_loc->max_lifespan, - $src_loc->name ]; -} - -sub fh_response { - my ($fh) = @_; - $fh->flush or die "flush: $!"; - seek($fh, 0, SEEK_SET) or die "seek: $!"; - [ 200, [ - 'Expires' => 'Fri, 01 Jan 1980 00:00:00 GMT', - 'Pragma' => 'no-cache', - 'Cache-Control' => 'no-cache, max-age=0, must-revalidate', - 'Content-Type' => 'text/html; charset=UTF-8', - 'Content-Length' => -s $fh - ], $fh]; -} - -sub each_gt { - my ($env, $min) = @_; - my ($sort) = ($env->{QUERY_STRING} =~ /\bsort=(\w+)\b/a); - open my $fh, '+>', undef or die "open: $!"; - $sort //= 'bytes'; - my $sn = $env->{SCRIPT_NAME}; - my $t = "Devel::Mwrap::each($min)"; - my $all = []; - my @f = @FIELDS; - my $sc = 0; - for (my $i = 0; $i <= $#FIELDS; $i++) { - if ($FIELDS[$i] eq $sort) { - $sc = $i; - last; - } - } - $f[$sc] = "<b>$f[$sc]</b>"; - @f = (join('</th><th>', map {; - if (substr($_, 0, 1) eq '<') { - $_; - } else { - qq(<a\nhref="$sn/each/$min?sort=$_">$_</a>); - } - } @f)); - my @all; - Devel::Mwrap::each($min, \&accumulate_i, \@all); - if ($sc eq $#FIELDS) { # locations are sorted alphabetically - @all = sort { $a->[$sc] cmp $b->[$sc] } @all; - } else { # everything else is numeric - @all = sort { $b->[$sc] <=> $a->[$sc] } @all; - } - my $age = Devel::Mwrap::current_age(); - my $live = $age - Devel::Mwrap::total_bytes_freed(); - print $fh <<EOM; -<html><head><title>$t</title></head><body><p>$t -<p>Current age: $age (live: $live) -<table><tr><th>@f</th></tr> -EOM - while (my $cols = shift @all) { - # cols: [ bytes , allocations, frees, mean_lifespan, - # max_lifespan, name ] - my $loc_name = pop @$cols; - $cols->[4] = sprintf('%0.3f', $cols->[4]); # mean_life - my $href = "$sn/at/".uri_escape($loc_name); - print $fh '<tr><td>', join('</td><td>', @$cols), - qq(<td><a\nhref="), - encode_html($href), - qq(">), encode_html($loc_name), - "</a></td></tr>\n"; - } - print $fh "</table></body></html>\n"; - fh_response($fh); -} - -sub each_at_i { - my ($fh, $size, $gen, $addr) = @_; - print $fh "<tr><td>$size</td><td>$gen</td><td>"; - printf $fh "0x%lx</td></tr>\n", $addr; -} - -sub each_at { - my ($env, $src_loc) = @_; - my $t = encode_html($src_loc->name); - open my $fh, '+>', undef or die "open: $!"; - my $age = Devel::Mwrap::current_age(); - my $live = $age - Devel::Mwrap::total_bytes_freed(); - print $fh <<EOM; -<html><head><title>$t</title></head><body><p>live allocations at $t -<p>Current age: $age (live: $live)\n<table> -<tr><th>size</th><th>generation</th><th>address</th></tr> -EOM - $src_loc->each(0, \&each_at_i, $fh); - print $fh "</table></body></html>\n"; - fh_response($fh); -} - -sub r404 { - my $t404 = "Not Found\n"; - [ 404, [ qw(Content-Type text/plain - Content-Length), length($t404) ], [ $t404 ] ]; -} - -my $default_min = 2000; -my $url = 'https://80x24.org/mwrap-perl.git/about'; -chomp(my $root = <<EOM); -<html><head><title>Mwrap demo</title></head><body><p><a -href="each/$default_min">allocations >$default_min bytes</a><p><a -href="$url">$url</a></body></html> -EOM - -sub call { # PSGI entry point - Devel::Mwrap::quiet(1); - my (undef, $env) = @_; - my $ret; - my $path_info = $env->{PATH_INFO}; - if ($env->{REQUEST_METHOD} eq 'GET') { - if ($path_info =~ m!\A/each/([0-9]+)\z!) { - $ret = each_gt($env, $1 + 0); - } elsif ($path_info =~ m!\A/at/(.*)\z!) { - my $src_loc = Devel::Mwrap::get(uri_unescape($1)); - $ret = $src_loc ? each_at($env, $src_loc) : r404(); - } elsif ($path_info eq '/') { - $ret = [ 200, [ qw(Content-Type text/html - Content-Length), length($root) ], - [ $root ] ] - } - } elsif ($env->{REQUEST_METHOD} eq 'POST') { - if ($path_info eq '/reset') { - Devel::Mwrap::reset(); - $ret = [ 200, [ qw(Content-Type text/html - Content-Length 5) ], - [ "done\n" ] ]; - } - } - $ret //= r404(); - Devel::Mwrap::quiet(0); - $ret; -} - -1; diff --git a/lib/Devel/Mwrap/Rproxy.pm b/lib/Devel/Mwrap/Rproxy.pm deleted file mode 100644 index d5a9d9d..0000000 --- a/lib/Devel/Mwrap/Rproxy.pm +++ /dev/null @@ -1,220 +0,0 @@ -# Copyright (C) mwrap hackers <mwrap-perl@80x24.org> -# License: GPL-3.0+ <https://www.gnu.org/licenses/gpl-3.0.txt> - -# minimal reverse proxy to expose the embedded httpd.h UNIX sockets -# via PSGI (and thus TCP HTTP/1.x). This does not have a hard dependency -# on Mwrap.so. -# -# Warning: this has a synchronous wait dependency, so isn't suited for -# non-blocking async HTTP servers. -package Devel::Mwrap::Rproxy; -use v5.12; # strict -use Fcntl qw(SEEK_SET); -use IO::Socket::UNIX; -use Plack::Util; - -sub new { bless { socket_dir => $_[1]}, $_[0] } - -sub r { - [ $_[0], [ - 'Expires' => 'Fri, 01 Jan 1980 00:00:00 GMT', - 'Pragma' => 'no-cache', - 'Cache-Control' => 'no-cache, max-age=0, must-revalidate', - 'Content-Type' => 'text/html; charset=UTF-8', - 'Content-Length' => length($_[1]), - ], [ $_[1] ] ]; -} - -my $valid_pid = $^O eq 'linux' ? sub { - my ($pid) = @_; - if (open(my $fh, '<', "/proc/$pid/cmdline")) { - local $/; - my $str = <$fh> // return; - $str =~ tr/\0/ /; - Plack::Util::encode_html($str); - } -} : sub { kill(0, $_[0]) ? "PID: $_[0]" : undef }; - -sub list { - my ($self, $env) = @_; - state $t = 'mwrap reverse proxy endpoints'; - open(my $fh, '+>', \(my $str)) or die "open: $!"; - print $fh '<html><head><title>', $t, '</title></head><body><pre>', $t, - "\n\n"; - my $dir = $self->{socket_dir}; - opendir(my $dh, $dir) or return r(500, "socket_dir: $!"); - my @socks = grep(/\A[0-9]+\.sock\z/, readdir($dh)); - my %o = (Type => SOCK_STREAM, Peer => undef); - for (@socks) { - $o{Peer} = "$dir/$_"; - substr($_, -5, 5, ''); # chop off .sock - my $cmd = $valid_pid->($_) // next; - my $c = IO::Socket::UNIX->new(%o) // next; - print $fh qq(<a\nhref="./$_/">$_</a>/); - $_ .= '/each/2000'; - say $fh qq(<a\nhref="./), $_, qq(">each/2000</a>\t), $cmd; - } - print $fh '</pre></body></html>'; - r(200, $str); -} - -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; - my @st = stat(_); - - # Debian `perl-debug' is special: - if ($exe eq '/usr/bin/perl' && -x '/usr/bin/debugperl') { - @st = stat(_); - $exe = '/usr/bin/debugperl'; - } - $$st = pack('dd', $st[10], $st[7]); # ctime + size - $exe; -} - -# addr2line bidirectional pipe wrapper -sub a2l { - my ($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 =~ s/\Q?? at ??:0\E//; # FreeBSD - $line = Plack::Util::encode_html($line); - $line =~ /\?\?/ ? "$line $exe($addr)" : - ($line =~ /\S/ ? $line : "$exe($addr)"); - } : "$exe($addr)" - } -} - -sub call { # PSGI entry point - my ($self, $env) = @_; - my $uri = $env->{REQUEST_URI}; - $uri =~ s!\A\Q$env->{SCRIPT_NAME}\E!!; - my $method = $env->{REQUEST_METHOD}; - return list(@_) if $uri eq '/' && $method eq 'GET'; - - # must have /$PID/ prefix to map socket - $uri =~ m!\A/([0-9]+)/! or return r(404, 'not found'); - my $s = "$self->{socket_dir}/$1.sock"; - my %o = (Peer => $s, Type => SOCK_STREAM); - my $c = IO::Socket::UNIX->new(%o) or return r(500, "connect: $!"); - my $h = "$method $uri HTTP/1.0\n\n"; - $s = send($c, $h, MSG_NOSIGNAL) // return r(500, "send: $!"); - $s == length($h) or return r(500, "send $s <".length($h)); - # 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; - sub { - my ($wcb) = @_; - my $http_out = $wcb->([$code, \@hdr]); - my $now = time; - if ($now > $cache_exp) { - undef %cache; - $cache_exp = $now + $cache_time; - } - - # GNU addr2line is slow with high bt:, and FreeBSD addr2line - # seems less capable. And we can't see addr2line in this - # anyways since we kill them at the end of this scope. - # So just disable MWRAP, here: - delete local $ENV{MWRAP}; - delete local $ENV{LD_PRELOAD}; - 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: $!"; - # -f/--functions needs -p/--pretty-print to go with it - my $addr2line = $ENV{ADDR2LINE} // 'addr2line -i -p -f'; - my @addr2line = split(/\s+/, $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) = @_; - $addr =~ s/\A\+//; - say { $self->{wr} } $addr; - readline($self->{rd}); -} - -sub DESTROY { - my ($self) = @_; - close($_) for (delete @$self{qw(wr rd)}); - waitpid(delete $self->{pid}, 0); -} - -1; |