Parent Directory
| 
Revision Log
separate definitions for $warning_handler for Apache 1/2
1 ################################################################################ 2 # WeBWorK Online Homework Delivery System 3 # Copyright © 2000-2006 The WeBWorK Project, http://openwebwork.sf.net/ 4 # $CVSHeader: webwork2/lib/Apache/WeBWorK.pm,v 1.75 2006/01/25 23:13:51 sh002i Exp $ 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 logging module 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; 126 $htmlMessage = "<html><body>$htmlMessage</body></html>"; 127 } 128 $r->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 my @warnings = defined $warnings ? split m/\n+/, $warnings : (); 188 $warnings = htmlWarningsList(@warnings); 189 $exception = htmlEscape($exception); 190 my $backtrace = htmlBacktrace(@backtrace); 191 192 my $admin = ($ENV{SERVER_ADMIN} 193 ? " (<a href=\"mailto:$ENV{SERVER_ADMIN}\">$ENV{SERVER_ADMIN}</a>)" 194 : ""); 195 my $time = time2str("%a %b %d %H:%M:%S %Y", time); 196 my $method = $r->method; 197 my $uri = $r->uri; 198 my $headers = do { 199 my %headers = MP2 ? %{$r->headers_in} : $r->headers_in; 200 join("", map { "<tr><td><small>$_</small></td><td><small>$headers{$_}</small></td></tr>" } keys %headers); 201 }; 202 203 return <<EOF; 204 <div style="text-align:left"> 205 <h2>WeBWorK error</h2> 206 <p>An error occured while processing your request. For help, please send mail 207 to this site's webmaster$admin, including all of the following information as 208 well as what what you were doing when the error occured.</p> 209 <p>$time</p> 210 <h3>Warning messages</h3> 211 <ul>$warnings</ul> 212 <h3>Error messages</h3> 213 <blockquote style="color:red"><code>$exception</code></blockquote> 214 <h3>Call stack</h3> 215 <p>The information below can help locate the source of the problem.</p> 216 <ul>$backtrace</ul> 217 <h3>Request information</h3> 218 <table border="1"> 219 <tr><td>Method</td><td>$method</td></tr> 220 <tr><td>URI</td><td>$uri</td></tr> 221 <tr><td>HTTP Headers</td><td> 222 <table width="90%"> 223 $headers 224 </table> 225 </td></tr> 226 </table> 227 </div> 228 EOF 229 } 230 231 =item textMessage($r, $warnings, $exception, @backtrace) 232 233 Format a message for HTML output reporting an exception, backtrace, and any 234 associated warnings. 235 236 =cut 237 238 sub textMessage($$$@) { 239 my ($r, $warnings, $exception, @backtrace) = @_; 240 241 #my @warnings = defined $warnings ? split m/\n+/, $warnings : (); 242 #$warnings = textWarningsList(@warnings); 243 chomp $exception; 244 my $backtrace = textBacktrace(@backtrace); 245 my $uri = $r->uri; 246 247 return "[$uri] $exception\n$backtrace"; 248 } 249 250 =item htmlBacktrace(@frames) 251 252 Formats a list of stack frames in a backtrace as list items for HTML output. 253 254 =cut 255 256 sub htmlBacktrace(@) { 257 my (@frames) = @_; 258 foreach my $frame (@frames) { 259 $frame = htmlEscape($frame); 260 $frame = "<li><code>$frame</code></li>"; 261 } 262 return join "\n", @frames; 263 } 264 265 =item textBacktrace(@frames) 266 267 Formats a list of stack frames in a backtrace as list items for text output. 268 269 =cut 270 271 sub textBacktrace(@) { 272 my (@frames) = @_; 273 foreach my $frame (@frames) { 274 $frame = " * $frame"; 275 } 276 return join "\n", @frames; 277 } 278 279 =item htmlWarningsList(@warnings) 280 281 Formats a list of warning strings as list items for HTML output. 282 283 =cut 284 285 sub htmlWarningsList(@) { 286 my (@warnings) = @_; 287 foreach my $warning (@warnings) { 288 $warning = htmlEscape($warning); 289 $warning = "<li><code>$warning</code></li>"; 290 } 291 return join "\n", @warnings; 292 } 293 294 =item textWarningsList(@warnings) 295 296 Formats a list of warning strings as list items for text output. 297 298 =cut 299 300 sub textWarningsList(@) { 301 my (@warnings) = @_; 302 foreach my $warning (@warnings) { 303 $warning = " * $warning"; 304 } 305 return join "\n", @warnings; 306 } 307 308 =item htmlEscape($string) 309 310 Protect characters that would be interpreted as HTML entities using the CGI.pm 311 escapeHTML() routine. Then, replace line breaks with HTML "<br />" tags. 312 313 =cut 314 315 sub htmlEscape($) { 316 my ($string) = @_; 317 $string = encode_entities($string); 318 $string =~ s|\n|<br />|g; 319 return $string; 320 } 321 322 =back 323 324 =cut 325 326 1;
| aubreyja at gmail dot com | ViewVC Help |
| Powered by ViewVC 1.0.9 |