diff options
Diffstat (limited to 'lib/Devel/Mwrap/PSGI.pm')
| -rw-r--r-- | lib/Devel/Mwrap/PSGI.pm | 190 |
1 files changed, 0 insertions, 190 deletions
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; |