cgi-bin/tools/http_error_handler.pl

   1 use strict;
   2 use warnings;
   3 use CGI ();
   4 use Try::Tiny;
   5 use List::Util qw/max/;
   6
   7 my ($error_code) = CGI->new->param('code');
   8 $error_code ||= 500;
   9
  10 if( $error_code == 404 ) {
  11
  12
  13     if(    $ENV{HTTP_REFERER}
  14         && $ENV{HTTP_REFERER} =~ m|http://[^/]*$ENV{HTTP_HOST}|
  15         && $c->get_conf('production_server')
  16        ) {
  17
  18         # this 404 is our mistake (i.e. the referrer is one of ours),
  19         # try to send the dev team an email before displaying the 404
  20         # page
  21         try {
  22             require Mail::Sendmail;
  23
  24             my $script_name = $ENV{HTTP_REFERER};
  25             $script_name =~ s|.+\/||;
  26             Mail::Sendmail::sendmail(
  27                 To      => $c->get_conf('bugs_email'),
  28                 From    => 'www@'.$ENV{HTTP_HOST},
  29                 Subject => "Broken link on $script_name: $ENV{REQUEST_URI}",
  30                 Body    => "Broken link $ENV{REQUEST_URI} on page $ENV{HTTP_REFERER}.\n\nEnvironment:\n".format_env( %ENV ),
  31                ) or die $Mail::Sendmail::error;
  32         } catch {
  33             warn "$0: could not send 404 broken link email: $_";
  34         };
  35
  36         $c->forward_to_mason_view( '/site/error/404.mas', message => 'We apologize for the inconvenience. An error report has been sent to the development team.' );
  37     } else {
  38         $c->forward_to_mason_view( '/site/error/404.mas', message => 'You may want to contact the referring site and inform them of this error.');
  39     }
  40
  41
  42 } else {
  43     $c->forward_to_mason_view( '/site/error/'.($error_code+0).'.mas' );
  44 }
  45
  46 # format the ENV hash into name => value, one per line,
  47 # with names padded to make the output columnar
  48 sub format_env {
  49     my %env = @_;
  50     my $key_width = 3 + max map length, keys %env;
  51     return join '', map {
  52         $_                            # key
  53       . ' ' x ( $key_width - length ) # padding
  54       . '=> '                         # =>
  55       . $env{$_}                      # value
  56       . "\n"                          # newline
  57     } sort keys %env;
  58 }
  59