| package Apache::Debug; |
| use Cwd 'fastcwd'; |
| |
| use vars qw($VERSION); |
| $VERSION = "1.61"; |
| |
| sub import { |
| local $^W = 0; |
| shift; |
| |
| my(%args) = @_; |
| return unless exists $args{level}; |
| |
| print STDERR "Apache::Debug: [@_]\n"; |
| $Apache::Registry::Debug = $args{level}; |
| |
| $^M = 'a' x (1<<16); |
| |
| require Carp; |
| $SIG{__DIE__} = \&Carp::confess; |
| } |
| |
| #from HTTP::Status |
| |
| my %StatusCode = ( |
| 100 => 'Continue', |
| 101 => 'Switching Protocols', |
| 200 => 'OK', |
| 201 => 'Created', |
| 202 => 'Accepted', |
| 203 => 'Non-Authoritative Information', |
| 204 => 'No Content', |
| 205 => 'Reset Content', |
| 206 => 'Partial Content', |
| 300 => 'Multiple Choices', |
| 301 => 'Moved Permanently', |
| 302 => 'Moved Temporarily', |
| 303 => 'See Other', |
| 304 => 'Not Modified', |
| 305 => 'Use Proxy', |
| 400 => 'Bad Request', |
| 401 => 'Unauthorized', |
| 402 => 'Payment Required', |
| 403 => 'Forbidden', |
| 404 => 'Not Found', |
| 405 => 'Method Not Allowed', |
| 406 => 'Not Acceptable', |
| 407 => 'Proxy Authentication Required', |
| 408 => 'Request Timeout', |
| 409 => 'Conflict', |
| 410 => 'Gone', |
| 411 => 'Length Required', |
| 412 => 'Precondition Failed', |
| 413 => 'Request Entity Too Large', |
| 414 => 'Request-URI Too Large', |
| 415 => 'Unsupported Media Type', |
| 500 => 'Internal Server Error', |
| 501 => 'Not Implemented', |
| 502 => 'Bad Gateway', |
| 503 => 'Service Unavailable', |
| 504 => 'Gateway Timeout', |
| 505 => 'HTTP Version Not Supported', |
| ); |
| |
| sub dump { |
| my($r, $status) = (shift,shift); |
| my $srv = $r->server; |
| my $conn = $r->connection; |
| my %headers = $r->headers_in; |
| my $host = $r->get_remote_host; |
| my $cwd = fastcwd; |
| $r->status($status); |
| $r->content_type("text/html"); |
| $r->content_language("en"); |
| $r->no_cache(1); |
| $r->header_out("X-Debug-Version" => q$Id$); |
| $r->send_http_header; |
| |
| return 0 if $r->header_only; # should not generate a body |
| |
| my $title = "$status $StatusCode{$status}"; |
| $r->write_client(join("\n", "<html>", |
| "<head><title>$title</title></head>", |
| "<body>", "<h3>$title</h3>", @_, |
| "<pre>", ($@ ? "$@\n" : ""), "cwd=$cwd\n")); |
| |
| for ( |
| qw( |
| method uri protocol path_info filename |
| allow_options |
| ) |
| ) |
| { |
| $r->print(sprintf "<b>\$r->%-17s</b> : %s\n", $_, $r->$_() ); |
| } |
| |
| for ( |
| qw( |
| server_admin |
| server_hostname |
| port |
| ) |
| ) |
| { |
| $r->print(sprintf "<b>\$s->%-17s</b> : %s\n", $_, $srv->$_() ); |
| } |
| |
| for ( |
| qw( |
| remote_host |
| remote_ip |
| remote_logname |
| user |
| auth_type |
| ) |
| ) |
| { |
| $r->print(sprintf "<b>\$c->%-17s</b> : %s\n", $_, $conn->$_() ); |
| } |
| |
| my $args = $r->args; |
| my %args = $r->args; |
| my %in = $r->content; |
| $r->print( |
| "\n<b>scalar \$r->args :</b> $args\n", |
| |
| "\n<b>\$r->args:</b>\n", |
| (map { " $_ = $args{$_}\n" } sort keys %args), |
| |
| "\n<b>\$r->content:</b>\n", |
| (map { " $_ = $in{$_}\n" } sort keys %in), |
| |
| "\n<b>\$r->headers_in:</b>\n", |
| (map { sprintf " %-12s = %s\n", $_, $headers{$_} } sort keys %headers), |
| ); |
| $r->print("</pre>\n</body></html>\n"); |
| return 0; #need to give a return status |
| } |
| |
| 1; |
| |
| __END__ |
| |
| =head1 NAME |
| |
| Apache::Debug - Utilities for debugging embedded perl code |
| |
| =head1 SYNOPSIS |
| |
| use Apache::Debug (); |
| |
| Apache::Debug::dump($r, SERVER_ERROR, "Uh Oh!"); |
| |
| =head1 DESCRIPTION |
| |
| This module sends what may be helpful debugging info to the client |
| rather that the error log. |
| |
