From 59a22f410156fad3900cfe23e96845ccaf47e3d7 Mon Sep 17 00:00:00 2001
From: Scott Walters <scott@slowass.net>
Date: Thu, 5 May 2011 14:55:28 -0400
Subject: [PATCH] set recursion limit to 1 for dumped lexicals and function
 args; with unlimited depth, it was making my Mozilla shoot to 1.5gigs and
 taking the server and browser forever to get the error page up. keep the HTML
 of the original page and tack it on to the end of the stack trace. add
 WebGUI::Middleware::StackTrace to the default site.psgi in place of the
 standard StackTrace, but leave a comment for the other one in case people
 prefer it.

---
 lib/WebGUI/Middleware/StackTrace.pm | 69 +++++++++++++++++++++++++++--
 share/site.psgi                     |  4 +-
 2 files changed, 69 insertions(+), 4 deletions(-)

diff --git a/lib/WebGUI/Middleware/StackTrace.pm b/lib/WebGUI/Middleware/StackTrace.pm
index 7204df015..77e345350 100644
--- a/lib/WebGUI/Middleware/StackTrace.pm
+++ b/lib/WebGUI/Middleware/StackTrace.pm
@@ -40,12 +40,15 @@ sub call {
     if( my $trace = $env->{'webgui.session'}->log->{_stacktrace} ) {
 
         undef $env->{'webgui.session'}->log->{_stacktrace};  # the stack trace modules do create circular references; this is necessary
+                                                             # this should also keep us from doing this work twice if we get stacked twice
+
+        my @previous_html = $res && $res->[2] ? (map ref $_ ? @{ $_ } : $_, $res->[2]) : ();
 
         my $text = trace_as_string($trace);
         $env->{'psgi.errors'}->print($text) unless $self->no_print_errors;
         my $html = eval { trace_as_html($trace, $env->{'webgui.session'}) };
         if ( $html and ($env->{HTTP_ACCEPT} || '*/*') =~ /html/) {
-            $res = [500, ['Content-Type' => 'text/html; charset=utf-8'], [ utf8_safe($html) ]];
+            $res = [500, ['Content-Type' => 'text/html; charset=utf-8'], [ utf8_safe($html), @previous_html ] ];
         } else {
             $res = [500, ['Content-Type' => 'text/plain; charset=utf-8'], [ utf8_safe($text) ]];
         }
@@ -76,8 +79,8 @@ do {
     no strict 'refs'; 
     *encode_html = *Devel::StackTrace::AsHTML::encode_html{CODE};
     *_build_context = *Devel::StackTrace::AsHTML::_build_context{CODE};
-    *_build_arguments = *Devel::StackTrace::AsHTML::_build_arguments{CODE};
-    *_build_lexicals = *Devel::StackTrace::AsHTML::_build_lexicals{CODE};
+    # *_build_arguments = *Devel::StackTrace::AsHTML::_build_arguments{CODE};
+    # *_build_lexicals = *Devel::StackTrace::AsHTML::_build_lexicals{CODE};
 };
 
 sub trace_as_html {
@@ -257,6 +260,66 @@ sub _build_asset_info {
     return $message;
 }
 
+my $dumper = sub {
+    my $value = shift;
+    $value = $$value if ref $value eq 'SCALAR' or ref $value eq 'REF';
+    my $d = Data::Dumper->new([ $value ]);
+    # $d->Indent(1)->Terse(1)->Deparse(1);
+    $d->Indent(1)->Terse(1)->Maxdepth(1);
+    chomp(my $dump = $d->Dump);
+    $dump;
+};
+
+# copied this in so that we could use a differently configured Data::Dumper
+
+sub _build_arguments {
+    my($id, $args) = @_;
+    my $ref = "arg-$id";
+
+    return '' unless @$args;
+
+    my $html = qq(<p><a class="toggle" id="toggle-$ref" href="javascript:toggleArguments('$ref')">Show function arguments</a></p><table class="arguments" id="arguments-$ref">);
+
+    # Don't use while each since Dumper confuses that
+    for my $idx (0 .. @$args - 1) {
+        my $value = $args->[$idx];
+        my $dump = $dumper->($value);
+        $html .= qq{<tr>};
+        $html .= qq{<td class="variable">\$_[$idx]</td>};
+        $html .= qq{<td class="value">} . encode_html($dump) . qq{</td>};
+        $html .= qq{</tr>};
+    }
+    $html .= qq(</table>);
+
+    return $html;
+}
+
+# copied this in so that we could use a differently configured Data::Dumper
+
+sub _build_lexicals {
+    my($id, $lexicals) = @_;
+    my $ref = "lex-$id";
+
+    return '' unless keys %$lexicals;
+
+    my $html = qq(<p><a class="toggle" id="toggle-$ref" href="javascript:toggleLexicals('$ref')">Show lexical variables</a></p><table class="lexicals" id="lexicals-$ref">);
+
+    # Don't use while each since Dumper confuses that
+    for my $var (sort keys %$lexicals) {
+        my $value = $lexicals->{$var};
+        my $dump = $dumper->($value);
+        $dump =~ s/^\{(.*)\}$/($1)/s if $var =~ /^\%/;
+        $dump =~ s/^\[(.*)\]$/($1)/s if $var =~ /^\@/;
+        $html .= qq{<tr>};
+        $html .= qq{<td class="variable">} . encode_html($var)  . qq{</td>};
+        $html .= qq{<td class="value">}    . encode_html($dump) . qq{</td>};
+        $html .= qq{</tr>};
+    }
+    $html .= qq(</table>);
+
+    return $html;
+}
+
 sub utf8_safe {
     my $str = shift;
 
diff --git a/share/site.psgi b/share/site.psgi
index 6da08f9ca..da9b5b8ff 100644
--- a/share/site.psgi
+++ b/share/site.psgi
@@ -34,7 +34,9 @@ builder {
 
     enable '+WebGUI::Middleware::Maintenance';
 
-    enable_if { $_[0]->{'webgui.debug'} } 'StackTrace';
+    # enable_if { $_[0]->{'webgui.debug'} } 'StackTrace';
+    enable_if { $_[0]->{'webgui.debug'} } '+WebGUI::Middleware::StackTrace';
+
     enable_if { $_[0]->{'webgui.debug'} } 'Debug', panels => [
         'Timer',
         'Memory',