[PATCH 4/4] add PSGI front-end

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

This will make diagnosing memory problems in PSGI applications
easier.
---
 MANIFEST                |   2 +
 Mwrap.xs                |  34 +++++++-
 examples/mwrap.psgi     |  22 ++++++
 lib/Devel/Mwrap/PSGI.pm | 169 ++++++++++++++++++++++++++++++++++++++++
 4 files changed, 223 insertions(+), 4 deletions(-)
 create mode 100644 examples/mwrap.psgi
 create mode 100644 lib/Devel/Mwrap/PSGI.pm

diff --git a/MANIFEST b/MANIFEST
index caea857..4db1455 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4,8 +4,10 @@ MANIFEST
 Makefile.PL
 Mwrap.xs
 README
+examples/mwrap.psgi
 jhash.h
 lib/Devel/Mwrap.pm
+lib/Devel/Mwrap/PSGI.pm
 ppport.h
 script/mwrap-perl
 t/mwrap.t
diff --git a/Mwrap.xs b/Mwrap.xs
index 4d3e8af..e9b8b3f 100644
--- a/Mwrap.xs
+++ b/Mwrap.xs
@@ -63,6 +63,9 @@ static int resolving_malloc;
 } while (0)
 
 static __thread size_t locating;
+#ifndef PERL_IMPLICIT_CONTEXT
+static size_t *root_locating; /* determines if PL_curcop is our thread */
+#endif
 static size_t page_size;
 static struct cds_lfht *totals;
 union padded_mutex {
@@ -92,6 +95,9 @@ lfht_new(void)
 __attribute__((constructor)) static void resolve_malloc(void)
 {
 	int err;
+#ifndef PERL_IMPLICIT_CONTEXT
+	root_locating = &locating;
+#endif
 	++locating;
 
 #ifdef __FreeBSD__
@@ -319,13 +325,17 @@ update_stats_rcu_lock(size_t *generation, size_t size, uintptr_t caller)
 	static const size_t xlen = sizeof(caller);
 	char *dst;
 	const COP *cop;
+	struct cds_lfht *t = rcu_dereference(totals);
 
-	if (caa_unlikely(!totals)) return 0;
+	if (caa_unlikely(!t)) return 0;
 	if (locating++) goto out; /* do not recurse into another *alloc */
 
 	*generation = uatomic_add_return(&total_bytes_inc, size);
-	cop = PL_curcop;
-
+#ifdef PERL_IMPLICIT_CONTEXT
+	cop = aTHX ? PL_curcop : 0;
+#else
+	cop = &locating == root_locating ? PL_curcop : 0;
+#endif
 	rcu_read_lock();
 	if (cop) {
 		const char *ptr = OutCopFILE(cop);
@@ -775,6 +785,9 @@ out:
 MODULE = Devel::Mwrap	PACKAGE = Devel::Mwrap	PREFIX = mwrap_
 
 BOOT:
+#ifndef PERL_IMPLICIT_CONTEXT
+	root_locating = &locating;
+#endif
 	totals = lfht_new();
 	if (!totals)
 		fprintf(stderr, "failed to allocate totals table\n");
@@ -979,16 +992,29 @@ src_loc_mean_lifespan(self)
 PREINIT:
 	size_t tot, frees;
 CODE:
+	++locating;
 	frees = uatomic_read(&self->frees);
 	tot = uatomic_read(&self->age_total);
 	RETVAL = frees ? ((double)tot/(double)frees) : HUGE_VAL;
 OUTPUT:
 	RETVAL
+CLEANUP:
+	--locating;
+
+double
+src_loc_max_lifespan(self)
+	Devel::Mwrap::SrcLoc self
+CODE:
+	++locating;
+	RETVAL = uatomic_read(&self->max_lifespan);
+OUTPUT:
+	RETVAL
+CLEANUP:
+	--locating;
 
 SV *
 src_loc_name(self)
 	Devel::Mwrap::SrcLoc self
-PREINIT:
 CODE:
 	++locating;
 	RETVAL = location_string(self);
diff --git a/examples/mwrap.psgi b/examples/mwrap.psgi
new file mode 100644
index 0000000..be814fe
--- /dev/null
+++ b/examples/mwrap.psgi
@@ -0,0 +1,22 @@
+# Copyright (C) all contributors <mwrap-perl@80x24.org>
+# License: GPL-2.0+ <https://www.gnu.org/licenses/gpl-2.0.txt>
+# A startup command for development:
+#	plackup -I ./blib/lib -I ./blib/arch -o 127.0.0.1 examples/mwrap.psgi
+use v5.12;
+use Devel::Mwrap::PSGI;
+use Plack::Builder;
+my $mw = Devel::Mwrap::PSGI->new;
+delete $ENV{LD_PRELOAD};
+
+builder {
+	eval {
+		enable 'Deflater',
+			content_type => [ qw(
+				text/html
+				text/plain
+				application/atom+xml
+				)]
+	}; # Plack::Middleware::Deflater may not be installed
+	enable 'Head';
+	sub { $mw->call($_[0]) };
+}
diff --git a/lib/Devel/Mwrap/PSGI.pm b/lib/Devel/Mwrap/PSGI.pm
new file mode 100644
index 0000000..b6e660c
--- /dev/null
+++ b/lib/Devel/Mwrap/PSGI.pm
@@ -0,0 +1,169 @@
+# Copyright (C) all contributors <mwrap@80x24.org>
+# License: GPL-2.0+ <https://www.gnu.org/licenses/gpl-2.0.txt>
+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 = (
+	'&' => '&amp;',
+	'>' => '&gt;',
+	'<' => '&lt;',
+	'"' => '&quot;',
+	"'" => '&#39;'
+);
+
+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 @COLS = qw(total allocations frees mean_life max_life location);
+my $HDR = '<tr><th>' . join('</th><th>', @COLS) . '</th></tr>';
+my @FIELDS = qw(total allocations frees mean_life max_life location);
+
+sub accumulate_i { # callback for Devel::Mwrap::each
+	my ($all, $src_loc) = @_;
+	push @$all, [ $src_loc->total, $src_loc->allocations, $src_loc->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, $sort) = @_;
+	open my $fh, '+>', undef or die "open: $!";
+	$sort //= 'total';
+	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++) {
+		next if $FIELDS[$i] ne $sort;
+		$sc = $i;
+		last;
+	}
+	$f[$sc] = "<b>$f[$sc]</b>";
+	@f = (join('</th><th>', map {;
+		if (/\A<b>/) {
+			$_;
+		} else {
+			qq(<a\nhref="$sn/each/$min?sort=$_">$_</a>);
+		}
+	} @f));
+	my @all;
+	Devel::Mwrap::each($min, \&accumulate_i, \@all);
+	@all = sort { $b->[$sc] <=> $a->[$sc] } @all;
+	my $age = Devel::Mwrap::current_age();
+	print $fh <<EOM;
+<html><head><title>$t</title></head><body><h1>$t</h1>
+<h2>Current age: $age</h2>
+<table><tr><th>@f</th></tr>
+EOM
+	while (my $cols = shift @all) {
+		# cols: [ total, allocations, frees, mean_lifespan,
+		#   max_lifespan, name ]
+		my $loc_name = pop @$cols;
+		$cols->[3] = sprintf('%0.3f', $cols->[3]); # 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) = @_;
+	print $fh "<tr><td>$size</td><td>$gen</td></tr>\n";
+}
+
+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();
+	print $fh <<EOM;
+<html><head><title>$t</title></head><body><h1>live allocations at $t</h1>
+<h2>Current age: $age</h2>\n<table>
+<tr><th>size</th><th>generation</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 &gt;$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 $path_info = $env->{PATH_INFO};
+	my $ret;
+	if ($path_info =~ m!\A/each/([0-9]+)\z!) {
+		my $min = $1 + 0;
+		my ($sort) = ($env->{QUERY_STRING} =~ /\bsort=([a-z+])\b/);
+		$ret = each_gt($env, $min, $sort);
+	} 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 ] ]
+	} else {
+		r404();
+	}
+	Devel::Mwrap::quiet(0);
+	$ret;
+}
+
+1;