view release on metacpan or  search on metacpan

lib/Apache2/ErrorReport.pm  view on Meta::CPAN

package Apache2::ErrorReport;

# $Id: ErrorReport.pm,v 1.10 2004/01/12 12:51:04 borisz Exp $

use integer;
use strict;

use Mail::Mailer;
use HTML::Entities ();

use Carp;

use Apache2::RequestRec ();
use Apache2::RequestUtil ();
use Apache2::Connection ();
use Apache2::ServerRec ();
use Apache2::ServerUtil ();
use Apache2::Response ();

# trap warn
$main::SIG{__WARN__} = \&Apache2::ErrorReport::warn;

sub error_message {
  my ($E, $type) = @_;

  return if defined($Apache2::ErrorReport::disable)
    && $Apache2::ErrorReport::disable eq 'yes';

  # PerlOptions +GlobalRequest
  my $r = Apache2::RequestUtil->request;

  my $s = Apache2::ServerUtil->server;

  return unless $r;

  my $stacktrace;
  if(ref($E) && $E->isa('Error')){
    # Special handing for derived Error.pm classes
    $stacktrace = $E->stacktrace;
  } else {
#    $stacktrace = "$E\n";
#    my $i = 0;
#    while (my ($package, $filename, $line, $subr) = caller($i)){
#      $stacktrace .= "stack $i: $package $subr line $line\n";
#      $i++;
#    }
    $stacktrace = Carp::longmess($E);
  }

  if($r->dir_config('ErrorReportHandler') eq 'email'){

    my $uri = (split(' ',$r->the_request))[1];

    # include request parameters in POST requests
    $uri .= '?' . $r->notes('query_string') if $uri !~ /\?/;

    my $userID = $r->user;

    my $headers_in = $r->headers_in;
    my $host = $headers_in->{'Host'};
    my $remote_host = $headers_in->{'X-Forwarded-For'} || $r->get_remote_host;
    my $referer = $headers_in->{'Referer'};

    my $current_callback = $r->current_callback;

    my $message = <<END;
$uri
userID: $userID  host: $host  remote_host: $remote_host  referer: $referer
handler: $current_callback

$stacktrace
END

    my $mailer = new Mail::Mailer;
    $mailer->open({To => $s->server_admin,
		   Subject => "Website $_[1]"
		  });
    print $mailer $message;
    $mailer->close;
  } elsif ($r->dir_config('ErrorReportHandler') eq 'display') {
    my $color = $_[1] eq 'WARN' ? 'blue' : 'red';

    HTML::Entities::encode_entities( $stacktrace, '<>&"' );

    my $bytes_sent = $r->bytes_sent;
    my $repeat = ( 512 < $bytes_sent ) ? 0 : 512 - $bytes_sent ;

    # send a large comment in front of the page so MSIE displays it too.
    my $html_msg =
        '<!-- ' . ( ' ' ) x $repeat . " -->\n"
	. qq{<pre><font color="$color">$_[1]: $stacktrace</font></pre><br>};

    if ( $bytes_sent ) {
      print $html_msg;
    }
    else {
      $r->custom_response( 500, $html_msg );
    }
  }
}

sub warn {
  &error_message($_[0],"WARN");
}

sub fatal {
  &error_message($_[0],"FATAL");
}

1;

__END__

=head1 NAME

Apache2::ErrorReport - Error Reporting under mod_perl

=head1 SYNOPSIS

In your Apache configuration file: