mwrap (Perl version) user+dev discussion/patches/pulls/bugs/help
 help / color / mirror / code / Atom feed
* [PATCH 0/4] PSGI support
@ 2021-10-03  7:41 Eric Wong
  2021-10-03  7:41 ` [PATCH 1/4] support quiet accessor Eric Wong
                   ` (3 more replies)
  0 siblings, 4 replies; 5+ messages in thread
From: Eric Wong @ 2021-10-03  7:41 UTC (permalink / raw)
  To: mwrap-perl

Patches 1/4 and 2/4 have been sitting around for ages, the
PSGI frontend is finally running.

I'm thinking we should just import dlmalloc instead of playing
dlsym games...

Eric Wong (4):
  support quiet accessor
  each: support passing user args to callback
  treewide: require Perl 5.12, doc+copyright updates
  add PSGI front-end

 .gitignore              |   1 +
 MANIFEST                |   2 +
 Makefile.PL             |  15 +++-
 Mwrap.xs                |  51 ++++++++++--
 README                  |  22 +++---
 examples/mwrap.psgi     |  22 ++++++
 lib/Devel/Mwrap.pm      |   4 +-
 lib/Devel/Mwrap/PSGI.pm | 169 ++++++++++++++++++++++++++++++++++++++++
 script/mwrap-perl       |   4 +-
 t/mwrap.t               |  39 +++++++---
 10 files changed, 294 insertions(+), 35 deletions(-)
 create mode 100644 examples/mwrap.psgi
 create mode 100644 lib/Devel/Mwrap/PSGI.pm


^ permalink raw reply	[flat|nested] 5+ messages in thread
* [PATCH 1/4] support quiet accessor
  2021-10-03  7:41 [PATCH 0/4] PSGI support Eric Wong
@ 2021-10-03  7:41 ` Eric Wong
  2021-10-03  7:41 ` [PATCH 2/4] each: support passing user args to callback Eric Wong
                   ` (2 subsequent siblings)
  3 siblings, 0 replies; 5+ messages in thread
From: Eric Wong @ 2021-10-03  7:41 UTC (permalink / raw)
  To: mwrap-perl

This lets developers elide overhead and tracking for
certain parts of their code.
---
 Mwrap.xs  | 7 +++++++
 t/mwrap.t | 3 +++
 2 files changed, 10 insertions(+)

diff --git a/Mwrap.xs b/Mwrap.xs
index ca408b9..c93223e 100644
--- a/Mwrap.xs
+++ b/Mwrap.xs
@@ -781,6 +781,13 @@ BOOT:
 
 PROTOTYPES: ENABLE
 
+size_t
+mwrap_quiet(int on_off)
+CODE:
+	RETVAL = on_off ? locating++ : locating--;
+OUTPUT:
+	RETVAL
+
 size_t
 mwrap_current_age()
 CODE:
diff --git a/t/mwrap.t b/t/mwrap.t
index aba9709..fdae523 100644
--- a/t/mwrap.t
+++ b/t/mwrap.t
@@ -124,6 +124,9 @@ $age_after >= $age_before or die "age did not increment";
 EOF
 diag slurp($out);
 
+is(Devel::Mwrap::quiet(1), 0, 'was not quiet, before');
+is(Devel::Mwrap::quiet(0), 1, 'was quiet, before');
+
 done_testing();
 
 sub slurp {

^ permalink raw reply related	[flat|nested] 5+ messages in thread
* [PATCH 2/4] each: support passing user args to callback
  2021-10-03  7:41 [PATCH 0/4] PSGI support Eric Wong
  2021-10-03  7:41 ` [PATCH 1/4] support quiet accessor Eric Wong
@ 2021-10-03  7:41 ` Eric Wong
  2021-10-03  7:41 ` [PATCH 3/4] treewide: require Perl 5.12, doc+copyright updates Eric Wong
  2021-10-03  7:41 ` [PATCH 4/4] add PSGI front-end Eric Wong
  3 siblings, 0 replies; 5+ messages in thread
From: Eric Wong @ 2021-10-03  7:41 UTC (permalink / raw)
  To: mwrap-perl

This allows users to avoid creating expensive and cycle-prone
anonymous subs.  This API promote safer usage and reduces the
likelyhood of users introducing leaks.
---
 Mwrap.xs  |  8 ++++++--
 t/mwrap.t | 30 ++++++++++++++++++++++--------
 2 files changed, 28 insertions(+), 10 deletions(-)

diff --git a/Mwrap.xs b/Mwrap.xs
index c93223e..54daf45 100644
--- a/Mwrap.xs
+++ b/Mwrap.xs
@@ -810,9 +810,10 @@ OUTPUT:
 	RETVAL
 
 void
-mwrap_each(min, cb)
+mwrap_each(min, cb, arg = &PL_sv_undef)
 	size_t min;
 	SV *cb;
+	SV *arg;
 PREINIT:
 	struct cds_lfht *t;
 	struct cds_lfht_iter iter;
@@ -836,6 +837,7 @@ CODE:
 				PUSHMARK(SP);
 				loc = sv_newmortal();
 				sv_setref_pv(loc, "Devel::Mwrap::SrcLoc", l);
+				XPUSHs(arg);
 				XPUSHs(loc);
 				PUTBACK;
 
@@ -996,10 +998,11 @@ CLEANUP:
 	--locating;
 
 void
-src_loc_each(self, min, cb)
+src_loc_each(self, min, cb, arg = &PL_sv_undef)
 	Devel::Mwrap::SrcLoc self;
 	size_t min;
 	SV *cb;
+	SV *arg;
 PREINIT:
 	struct alloc_hdr *h;
 	bool err = false;
@@ -1021,6 +1024,7 @@ CODE:
 			 * note: we MUST NOT expose alloc_hdr to Perl code
 			 * since that opens us up to use-after-free
 			 */
+			XPUSHs(arg);
 			XPUSHs(sv_2mortal(newSVuv(size)));
 			XPUSHs(sv_2mortal(newSVuv(gen)));
 			PUTBACK;
diff --git a/t/mwrap.t b/t/mwrap.t
index fdae523..91bae8a 100644
--- a/t/mwrap.t
+++ b/t/mwrap.t
@@ -61,26 +61,40 @@ mwrap_run('Devel::Mwrap::each', {}, '-e', <<'EOF');
 open my $zero, '<', '/dev/zero' or die "open /dev/zero: $!";
 my $nbytes = 1024 * 512;
 sysread($zero, my $before, $nbytes);
-my @keep;
-eval { Devel::Mwrap::each(0, sub { die "died in each"; push @keep, @_; }) };
-"$@" =~ /died in each at -e line 5/ or die "did not propagate die in each";
+my (@keep, @uargs);
+my $uarg = 'user-arg';
+eval {
+	Devel::Mwrap::each(0, sub {
+		my $ua = shift;
+		push @uargs, $ua;
+		die "died in each";
+		push @keep, @_;
+	}, $uarg) };
+"$@" =~ /died in each at -e line \d+/ or die "did not propagate die in each";
 scalar(@keep) == 0 or die "nothing if died in sub";
+$uarg eq join('-', @uargs) or die "uarg passed to sub";
 my %h;
 my $iter;
+my $arg = "FOO";
 Devel::Mwrap::each(1, sub {
-	my ($src_loc, @more) = @_;
+	my ($argh, $src_loc, @more) = @_;
 	my $name = $src_loc->name;
 	$h{$name} = $src_loc;
 	sysread($zero, my $iter, $nbytes);
 	die 'extra args from ::each' if @more;
-});
+	die "arg mismatch $arg / $argh" if $argh ne $arg;
+}, $arg);
 my $src_loc = $h{"-e:3"} or die "missing src_loc for -e:3";
 $src_loc->total >= $nbytes or die "allocated <= $nbytes";
 $src_loc = Devel::Mwrap::get("-e:8");
 if ($src_loc && $src_loc->total >= $nbytes) {
 	die "large allocation inside :each should not be tracked";
 }
-Devel::Mwrap::each($nbytes, sub { push @keep, @_ });
+my $nr = 0;
+Devel::Mwrap::each($nbytes, sub {
+	$foo += shift;
+	push @keep, @_;
+}, 1);
 scalar(@keep) == 1 or die "got multiple matches for > $nbytes";
 $keep[0]->name eq '-e:3' or die "unexpected location for > $nbytes";
 @keep = ();
@@ -106,7 +120,7 @@ $loc && $loc->total >= ($nbytes * $nr) or die "wrong line or bad stats";
 my $ml = $loc->mean_lifespan;
 $ml >= 0.0 or die "mean_lifespan broken";
 my @sl_each;
-$loc->each($nbytes, sub { push @sl_each, \@_ });
+$loc->each($nbytes, sub { shift; push @sl_each, \@_ });
 my $n = scalar(@sl_each);
 $n == 1 or die "SrcLoc::each returned unexpected: $n";
 $sl_each[0]->[0] >= $nbytes or die "$sl_each[0]->[0] < $nbytes";
@@ -115,7 +129,7 @@ my $age_before = $sl_each[0]->[1];
 $nbytes = 1024 * 1024 * 8;
 do_read() until Devel::Mwrap::current_age() > ($age_before + $nbytes);
 @sl_each = ();
-$loc->each($nbytes, sub { push @sl_each, \@_ });
+$loc->each($nbytes, sub { shift; push @sl_each, \@_ });
 $n = scalar(@sl_each);
 $n == 1 or die "SrcLoc::each returned unexpected: $n";
 $sl_each[0]->[0] >= $nbytes or die "$sl_each[0]->[0] < $nbytes";

^ permalink raw reply related	[flat|nested] 5+ messages in thread
* [PATCH 3/4] treewide: require Perl 5.12, doc+copyright updates
  2021-10-03  7:41 [PATCH 0/4] PSGI support Eric Wong
  2021-10-03  7:41 ` [PATCH 1/4] support quiet accessor Eric Wong
  2021-10-03  7:41 ` [PATCH 2/4] each: support passing user args to callback Eric Wong
@ 2021-10-03  7:41 ` Eric Wong
  2021-10-03  7:41 ` [PATCH 4/4] add PSGI front-end Eric Wong
  3 siblings, 0 replies; 5+ messages in thread
From: Eric Wong @ 2021-10-03  7:41 UTC (permalink / raw)
  To: mwrap-perl

We shouldn't need to worry about copyright years and such
since there's git history.
---
 .gitignore         |  1 +
 Makefile.PL        | 15 +++++++++++----
 Mwrap.xs           |  2 +-
 README             | 22 +++++++++++++---------
 lib/Devel/Mwrap.pm |  4 ++--
 script/mwrap-perl  |  4 ++--
 t/mwrap.t          |  6 +++---
 7 files changed, 33 insertions(+), 21 deletions(-)

diff --git a/.gitignore b/.gitignore
index 81948b8..10623de 100644
--- a/.gitignore
+++ b/.gitignore
@@ -8,3 +8,4 @@
 /Mwrap.c
 /blib
 /pm_to_blib
+/config.mak
diff --git a/Makefile.PL b/Makefile.PL
index 274cf60..1666f09 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -1,4 +1,6 @@
-use strict;
+# Copyright (C) all contributors <mwrap-perl@80x24.org>
+# License: GPL-2.0+ <https://www.gnu.org/licenses/gpl-2.0.txt>
+use v5.12;
 use ExtUtils::MakeMaker;
 use Config;
 my $pkg_config = $ENV{PKG_CONFIG} // 'pkg-config';
@@ -21,7 +23,7 @@ END
 if ($Config{usemymalloc} eq 'y') {
 	print STDERR <<END;
 Devel::Mwrap requires `usemymalloc=n'.  malloc and related functions
-must be dynamically-linked.
+must be dynamically-linked for Devel::Mwrap to work.
 END
 	exit 0;
 }
@@ -41,12 +43,17 @@ push @writemakefile_args, (
 	AUTHOR => 'mwrap hackers <mwrap-perl@80x24.org>',
 	LIBS => $LIBS, # e.g. -lurcu-cds
 	LICENSE => 'gpl_2', # GPL-2.0+, CPAN::Meta::Spec limitation
-	MIN_PERL_VERSION => '5.8.0',
+	MIN_PERL_VERSION => '5.12.0',
 	BUILD_REQUIRES => {},
 	INC => $INC,
 	depend => {
 		Makefile => 'lib/Devel/Mwrap.pm',
-	}
+	},
+	resources => {
+		repository => 'https://80x24.org/mwrap-perl.git',
+		homepage => 'https://80x24.org/mwrap-perl.git/about',
+		bugtracker => 'https://80x24.org/mwrap-public/',
+	},
 );
 
 WriteMakefile(@writemakefile_args);
diff --git a/Mwrap.xs b/Mwrap.xs
index 54daf45..4d3e8af 100644
--- a/Mwrap.xs
+++ b/Mwrap.xs
@@ -1,5 +1,5 @@
 /*
- * Copyright (C) 2018-2019 mwrap hackers <mwrap-perl@80x24.org>
+ * Copyright (C) mwrap hackers <mwrap-perl@80x24.org>
  * License: GPL-2.0+ <https://www.gnu.org/licenses/gpl-2.0.txt>
  * Disclaimer: I don't really know my way around XS or Perl internals well
  */
diff --git a/README b/README
index 97ff4ea..e7375b0 100644
--- a/README
+++ b/README
@@ -1,4 +1,4 @@
-Devel::Mwrap - LD_PRELOAD malloc wrapper + line stats for Perl
+Devel::Mwrap - LD_PRELOAD malloc wrapper + malloc line stats for Perl
 
 Devel::Mwrap is designed to answer the question:
 
@@ -17,9 +17,9 @@ It relies on dynamic linking to a malloc(3) implementation.  If
 you got Perl from your OS distribution, this typically does not
 require rebuilding Perl.
 
-Tested on the perl package distributed with:
+Tested on the `perl' package distributed with:
 
-* Debian GNU/Linux 9, 10
+* Debian GNU/Linux 10
 
 It may work on FreeBSD, NetBSD, OpenBSD and DragonFly BSD.
 
@@ -61,13 +61,16 @@ malloc locations.
 
 * 32-bit machines are prone to overflow (WONTFIX)
 
-== Mail archives and newsgroup:
+== Public mail archives (HTTP, Atom feeds, IMAP mailbox, NNTP group):
 
 	https://80x24.org/mwrap-perl/
-	nntp://80x24.org/inbox.comp.lang.perl.mwrap
+	imaps://80x24.org/inbox.comp.lang.perl.mwrap.0
+	nntps://80x24.org/inbox.comp.lang.perl.mwrap
 
-No subscription will ever be required to post, but HTML mail
-will be rejected:
+No subscription nor real identities will ever be required to
+obtain support.  Memory usage reductions start with you; only send
+plain-text mail to us and do not top-post.  HTML mail and top-posting
+costs everybody memory and bandwidth.
 
 		mwrap-perl@80x24.org
 
@@ -75,8 +78,9 @@ will be rejected:
 
 	git clone https://80x24.org/mwrap-perl.git
 
-Send all patches and pull requests (use "git request-pull" to format)
-via email to mwrap-perl@80x24.org.  We do not and will not use
+Send all patches ("git format-patch" + "git send-email") and
+pull requests (use "git request-pull" to format) via email
+to mwrap-perl@80x24.org.  We do not and will not use
 proprietary messaging systems.
 
 == License
diff --git a/lib/Devel/Mwrap.pm b/lib/Devel/Mwrap.pm
index d8dee58..43543d0 100644
--- a/lib/Devel/Mwrap.pm
+++ b/lib/Devel/Mwrap.pm
@@ -1,7 +1,7 @@
-# Copyright (C) 2019 all contributors <mwrap-perl@80x24.org>
+# Copyright (C) all contributors <mwrap-perl@80x24.org>
 # License: GPL-2.0+ <https://www.gnu.org/licenses/gpl-2.0.txt>
 package Devel::Mwrap;
-use strict;
+use v5.12;
 our $VERSION = '0.0.0';
 use XSLoader;
 XSLoader::load(__PACKAGE__, $VERSION);
diff --git a/script/mwrap-perl b/script/mwrap-perl
index 8d372eb..4350fcc 100644
--- a/script/mwrap-perl
+++ b/script/mwrap-perl
@@ -1,7 +1,7 @@
 #!/usr/bin/perl -w
-# Copyright (C) 2019 mwrap hackers <mwrap-perl@80x24.org>
+# Copyright (C) mwrap hackers <mwrap-perl@80x24.org>
 # License: GPL-2.0+ <https://www.gnu.org/licenses/gpl-2.0.txt>
-use strict;
+use v5.12;
 use Devel::Mwrap;
 my ($so) = grep(m!/Mwrap\.so\z!, @DynaLoader::dl_shared_objects);
 defined($so) or die 'Mwrap.so not loaded';
diff --git a/t/mwrap.t b/t/mwrap.t
index 91bae8a..c6e589c 100644
--- a/t/mwrap.t
+++ b/t/mwrap.t
@@ -1,12 +1,12 @@
 #!perl -w
-# Copyright (C) 2019 mwrap hackers <mwrap-perl@80x24.org>
+# Copyright (C) mwrap hackers <mwrap-perl@80x24.org>
 # License: GPL-2.0+ <https://www.gnu.org/licenses/gpl-2.0.txt>
-use strict;
+use v5.12;
 use Test::More;
 use File::Temp qw(tempdir);
 use_ok 'Devel::Mwrap';
 
-my $tmpdir = tempdir('mwrap-perl-XXXXXX', TMPDIR => 1, CLEANUP => 1);
+my $tmpdir = tempdir('mwrap-perl-XXXX', TMPDIR => 1, CLEANUP => 1);
 my $dump = "$tmpdir/dump";
 my $out = "$tmpdir/out";
 my $err = "$tmpdir/err";

^ permalink raw reply related	[flat|nested] 5+ messages in thread
* [PATCH 4/4] add PSGI front-end
  2021-10-03  7:41 [PATCH 0/4] PSGI support Eric Wong
                   ` (2 preceding siblings ...)
  2021-10-03  7:41 ` [PATCH 3/4] treewide: require Perl 5.12, doc+copyright updates Eric Wong
@ 2021-10-03  7:41 ` Eric Wong
  3 siblings, 0 replies; 5+ messages in thread
From: Eric Wong @ 2021-10-03  7:41 UTC (permalink / raw)
  To: mwrap-perl

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;

^ permalink raw reply related	[flat|nested] 5+ messages in thread
end of thread, other threads:[~2021-10-03  7:41 UTC | newest]

Thread overview: 5+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-10-03  7:41 [PATCH 0/4] PSGI support Eric Wong
2021-10-03  7:41 ` [PATCH 1/4] support quiet accessor Eric Wong
2021-10-03  7:41 ` [PATCH 2/4] each: support passing user args to callback Eric Wong
2021-10-03  7:41 ` [PATCH 3/4] treewide: require Perl 5.12, doc+copyright updates Eric Wong
2021-10-03  7:41 ` [PATCH 4/4] add PSGI front-end Eric Wong

Code repositories for project(s) associated with this public inbox

	https://80x24.org/mwrap-perl.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).