root/lang/perl/NanoA/trunk/lib/NanoA/DebugScreen.pm @ 24343

Revision 24343, 3.0 kB (checked in by kazuho, 5 years ago)

minor adjustments

  • Property svn:keywords set to Id
Line 
1package NanoA::DebugScreen;
2
3use strict;
4use warnings;
5
6# original taken from MENTA
7
8sub build {
9    my $msg = shift;
10    my @trace;
11    for (my $i = 1; my ($package, $file, $line) = caller($i); $i++) {
12        push @trace, {
13            file => $file,
14            line => $line,
15            func => undef,
16        };
17        if (my @c = caller($i + 1)) {
18            $trace[-1]->{func} = $c[3]
19                if $c[3];
20        }
21    }
22    if ($msg =~ / at ([^ ]+) line (\d+)\./
23            && ($1 ne $trace[0]->{file} || $2 != $trace[0]->{line})) {
24        unshift @trace, {
25            file => $1,
26            line => $2,
27        };
28    }
29    @trace = map {
30        +{
31            level   => $_ + 1,
32            %{$trace[$_]},
33        }
34    } 0..$#trace;
35   
36    +{ message => $msg, trace => \@trace };
37}
38
39sub build_context {
40    my ($file, $linenum) = @_;
41    my $code;
42    if (-f $file) {
43        my $start = $linenum - 3;
44        my $end   = $linenum + 3;
45        $start = $start < 1 ? 1 : $start;
46        open my $fh, '<:utf8', $file
47            or die "cannot open $file:$!";
48        my $cur_line = 0;
49        while (my $line = <$fh>) {
50            ++$cur_line;
51            last if $cur_line > $end;
52            next if $cur_line < $start;
53            $line =~ s|\t|        |g;
54            my @tag = $cur_line == $linenum
55                ? (q{<b style="color: #000;background-color: #f99;">}, '</b>')
56                    : ('', '');
57            $code .= sprintf(
58                '%s%5d: %s%s', $tag[0], $cur_line, NanoA::escape_html($line),
59                $tag[1],
60            );
61        }
62        close $file;
63    }
64    return $code;
65}
66
67sub output {
68    my $err = shift;
69   
70    warn $err->{message};
71   
72    print "Status: 500\r\n";
73    print "Content-type: text/html; charset=utf-8\r\n";
74    print "\r\n";
75   
76    my $body = do {
77        my $msg = NanoA::escape_html($err->{message});
78        my $out = qq{<!doctype html><title>INTERNAL SERVER ERROR!!!</title><body style="background: red; color: white; font-weight: bold"><marquee behavior="alternate" scrolldelay="66" style="text-transform: uppercase"><span style="font-size: xx-large; color: black">&#x2620;</span> <span style="color: green">500</span> Internal Server Error <span style="font-size: xx-large; color: black">&#x2620;</span></marquee><p><span style="color: blue">$msg</span></p><ol>};
79        for my $stack (@{$err->{trace}}) {
80            $out .= join(
81                '',
82                '<li>',
83                'in ' . ($stack->{func} || ''),
84                ' at ',
85                $stack->{file} ? NanoA::escape_html($stack->{file}) : '',
86                ' line ',
87                $stack->{line},
88                q(<pre style="background-color: #fee;color: #333;">),
89                build_context($stack->{file}, $stack->{line}),
90                q(</pre></li>),
91            );
92        }
93        $out .= qq{</ol><p style="text-align: right; color: black"><strong>Regards,<br>NanoA</strong></p>\n};
94        $out;
95    };
96    utf8::encode($body);
97    print $body;
98}
99
100"ENDOFMODULE";
Note: See TracBrowser for help on using the browser.