Parent Directory
| 
Revision Log
split warning messages in a more intelligent fashion. The line breaks should now appear. You will still see some other weirdnesses because the warning message has been htmlEscaped to prevent XSS
1 ################################################################################ 2 # WeBWorK Online Homework Delivery System 3 # Copyright © 2000-2007 The WeBWorK Project, http://openwebwork.sf.net/ 4 # $CVSHeader$ 5 # 6 # This program is free software; you can redistribute it and/or modify it under 7 # the terms of either: (a) the GNU General Public License as published by the 8 # Free Software Foundation; either version 2, or (at your option) any later 9 # version, or (b) the "Artistic License" which comes with this package. 10 # 11 # This program is distributed in the hope that it will be useful, but WITHOUT 12 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS 13 # FOR A PARTICULAR PURPOSE. See either the GNU General Public License or the 14 # Artistic License for more details. 15 ################################################################################ 16 17 package Apache::WeBWorK; 18 19 =head1 NAME 20 21 Apache::WeBWorK - mod_perl handler for WeBWorK 2. 22 23 =head1 CONFIGURATION 24 25 This module should be installed as a Handler for the location selected for 26 WeBWorK on your webserver. Refer to the file F<conf/webwork.apache-config> for 27 details. 28 29 =cut 30 31 use strict; 32 use warnings; 33 use HTML::Entities; 34 use Date::Format; 35 use WeBWorK; 36 37 use mod_perl; 38 use constant MP2 => ( exists $ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} >= 2 ); 39 40 # load correct modules 41 BEGIN { 42 if (MP2) { 43 require Apache2::Log; 44 Apache2::Log->import; 45 } else { 46 require Apache::Log; 47 Apache::Log->import; 48 } 49 } 50 51 ################################################################################ 52 53 =head1 APACHE REQUEST HANDLER 54 55 =over 56 57 =item handler($r) 58 59 =cut 60 61 sub handler($) { 62 my ($r) = @_; 63 my $log = $r->log; 64 my $uri = $r->uri; 65 66 # the warning handler accumulates warnings in $r->notes("warnings") for 67 # later cumulative reporting 68 my $warning_handler; 69 if (MP2) { 70 $warning_handler = sub { 71 my ($warning) = @_; 72 chomp $warning; 73 74 my $warnings = $r->notes->get("warnings"); 75 $warnings .= "$warning\n"; 76 #my $backtrace = join("\n",backtrace()); 77 #$warnings .= "$backtrace\n\n"; 78 $r->notes->set(warnings => $warnings); 79 80 $log->warn("[$uri] $warning"); 81 }; 82 } else { 83 $warning_handler = sub { 84 my ($warning) = @_; 85 chomp $warning; 86 87 my $warnings = $r->notes("warnings"); 88 $warnings .= "$warning\n"; 89 #my $backtrace = join("\n",backtrace()); 90 #$warnings .= "$backtrace\n\n"; 91 $r->notes("warnings" => $warnings); 92 93 $log->warn("[$uri] $warning"); 94 }; 95 96 # the exception handler generates a backtrace when catching an exception 97 my @backtrace; 98 my $exception_handler = sub { 99 @backtrace = backtrace(); 100 die @_; 101 }; 102 } 103 104 # the exception handler generates a backtrace when catching an exception 105 my @backtrace; 106 my $exception_handler = sub { 107 @backtrace = backtrace(); 108 die @_; 109 }; 110 111 my $result = do { 112 local $SIG{__WARN__} = $warning_handler; 113 local $SIG{__DIE__} = $exception_handler; 114 115 eval { WeBWorK::dispatch($r) }; 116 }; 117 118 if ($@) { 119 my $exception = $@; 120 121 my $warnings = MP2 ? $r->notes->get("warnings") : $r->notes("warnings"); 122 my $htmlMessage = htmlMessage($r, $warnings, $exception, @backtrace); 123 unless ($r->bytes_sent) { 124 $r->content_type("text/html"); 125 $r->send_http_header unless MP2; # not needed for Apache2 126 $htmlMessage = "<html><body>$htmlMessage</body></html>"; 127 } 128 print $htmlMessage; 129 130 # log the error to the apache error log 131 my $textMessage = textMessage($r, $warnings, $exception, @backtrace); 132 $log->error($textMessage); 133 } 134 135 return $result; 136 } 137 138 =back 139 140 =cut 141 142 ################################################################################ 143 144 =head1 ERROR HANDLING ROUTINES 145 146 =over 147 148 =item backtrace() 149 150 Produce a stack-frame traceback for the calls up through the ones in 151 Apache::WeBWorK. 152 153 =cut 154 155 sub backtrace { 156 my $frame = 2; 157 my @trace; 158 159 while (my ($pkg, $file, $line, $subname) = caller($frame++)) { 160 last if $pkg eq "Apache::WeBWorK"; 161 push @trace, "in $subname called at line $line of $file"; 162 } 163 164 return @trace; 165 } 166 167 =back 168 169 =cut 170 171 ################################################################################ 172 173 =head1 ERROR OUTPUT FUNCTIONS 174 175 =over 176 177 =item htmlMessage($r, $warnings, $exception, @backtrace) 178 179 Format a message for HTML output reporting an exception, backtrace, and any 180 associated warnings. 181 182 =cut 183 184 sub htmlMessage($$$@) { 185 my ($r, $warnings, $exception, @backtrace) = @_; 186 187 $warnings = htmlEscape($warnings); 188 $exception = htmlEscape($exception); 189 190 my @warnings = defined $warnings ? split m|<br />|, $warnings : (); #fragile 191 $warnings = htmlWarningsList(@warnings); 192 my $backtrace = htmlBacktrace(@backtrace); 193 194 my $admin = ($ENV{SERVER_ADMIN} 195 ? " (<a href=\"mailto:$ENV{SERVER_ADMIN}\">$ENV{SERVER_ADMIN}</a>)" 196 : ""); 197 my $time = time2str("%a %b %d %H:%M:%S %Y", time); 198 my $method = htmlEscape( $r->method ); 199 my $uri = htmlEscape( $r->uri ); 200 my $headers = do { 201 my %headers = MP2 ? %{$r->headers_in} : $r->headers_in; 202 join("", map { "<tr><td><small>" . htmlEscape($_). "</small></td><td><small>" . 203 htmlEscape($headers{$_}) . " </small></td></tr>" } keys %headers); 204 }; 205 206 return <<EOF; 207 <div style="text-align:left"> 208 <h2>WeBWorK error</h2> 209 <p>An error occured while processing your request. For help, please send mail 210 to this site's webmaster$admin, including all of the following information as 211 well as what what you were doing when the error occured.</p> 212 <p>$time</p> 213 <h3>Warning messages</h3> 214 <ul>$warnings</ul> 215 <h3>Error messages</h3> 216 <blockquote style="color:red"><code>$exception</code></blockquote> 217 <h3>Call stack</h3> 218 <p>The information below can help locate the source of the problem.</p> 219 <ul>$backtrace</ul> 220 <h3>Request information</h3> 221 <table border="1"> 222 <tr><td>Method</td><td>$method</td></tr> 223 <tr><td>URI</td><td>$uri</td></tr> 224 <tr><td>HTTP Headers</td><td> 225 <table width="90%"> 226 $headers 227 </table> 228 </td></tr> 229 </table> 230 </div> 231 EOF 232 } 233 234 =item textMessage($r, $warnings, $exception, @backtrace) 235 236 Format a message for HTML output reporting an exception, backtrace, and any 237 associated warnings. 238 239 =cut 240 241 sub textMessage($$$@) { 242 my ($r, $warnings, $exception, @backtrace) = @_; 243 244 #my @warnings = defined $warnings ? split m/\n+/, $warnings : (); 245 #$warnings = textWarningsList(@warnings); 246 chomp $exception; 247 my $backtrace = textBacktrace(@backtrace); 248 my $uri = $r->uri; 249 250 return "[$uri] $exception\n$backtrace"; 251 } 252 253 =item htmlBacktrace(@frames) 254 255 Formats a list of stack frames in a backtrace as list items for HTML output. 256 257 =cut 258 259 sub htmlBacktrace(@) { 260 my (@frames) = @_; 261 foreach my $frame (@frames) { 262 $frame = htmlEscape($frame); 263 $frame = "<li><code>$frame</code></li>"; 264 } 265 return join "\n", @frames; 266 } 267 268 =item textBacktrace(@frames) 269 270 Formats a list of stack frames in a backtrace as list items for text output. 271 272 =cut 273 274 sub textBacktrace(@) { 275 my (@frames) = @_; 276 foreach my $frame (@frames) { 277 $frame = " * $frame"; 278 } 279 return join "\n", @frames; 280 } 281 282 =item htmlWarningsList(@warnings) 283 284 Formats a list of warning strings as list items for HTML output. 285 286 =cut 287 288 sub htmlWarningsList(@) { 289 my (@warnings) = @_; 290 foreach my $warning (@warnings) { 291 $warning = htmlEscape($warning); 292 $warning = "<li><code>$warning</code></li>"; 293 } 294 return join "\n", @warnings; 295 } 296 297 =item textWarningsList(@warnings) 298 299 Formats a list of warning strings as list items for text output. 300 301 =cut 302 303 sub textWarningsList(@) { 304 my (@warnings) = @_; 305 foreach my $warning (@warnings) { 306 $warning = " * $warning"; 307 } 308 return join "\n", @warnings; 309 } 310 311 =item htmlEscape($string) 312 313 Protect characters that would be interpreted as HTML entities. Then, replace 314 line breaks with HTML "<br />" tags. 315 316 =cut 317 318 sub htmlEscape($) { 319 my ($string) = @_; 320 $string = encode_entities($string); 321 $string =~ s|\n|<br />|g; 322 return $string; 323 } 324 325 =back 326 327 =cut 328 329 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |