Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex/Die.pm

   1 package CGI::Ex::Die;
   2
   3 =head1 NAME
   4
   5 CGI::Ex::Die - A CGI::Carp::FatalsToBrowser type utility.
   6
   7 =cut
   8
   9 ###----------------------------------------------------------------###
  10 #  Copyright 2007 - Paul Seamons                                     #
  11 #  Distributed under the Perl Artistic License without warranty      #
  12 ###----------------------------------------------------------------###
  13
  14 use strict;
  15 use vars qw($VERSION
  16             $no_recurse
  17             $EXTENDED_ERRORS $SHOW_TRACE $IGNORE_EVAL
  18             $ERROR_TEMPLATE
  19             $LOG_HANDLER $FINAL_HANDLER
  20             );
  21
  22 use CGI::Ex;
  23 use CGI::Ex::Dump qw(debug ctrace dex_html);
  24
  25 BEGIN {
  26   $VERSION = '2.08';
  27   $SHOW_TRACE = 0      if ! defined $SHOW_TRACE;
  28   $IGNORE_EVAL = 0     if ! defined $IGNORE_EVAL;
  29   $EXTENDED_ERRORS = 1 if ! defined $EXTENDED_ERRORS;
  30 }
  31
  32 ###----------------------------------------------------------------###
  33
  34 sub import {
  35   my $class = shift;
  36   if ($#_ != -1) {
  37     if (($#_ + 1) % 2) {
  38       require Carp;
  39       &Carp::croak("Usage: use ".__PACKAGE__." register => 1");
  40     }
  41     my %args = @_;
  42     ### may be called as
  43     #   use CGI::Ex::Die register => 1;
  44     #   OR
  45     #   use CGI::Ex::Die register => [qw(die)];
  46     if (! ref($args{register}) || grep {/die/} @{ $args{register} }) {
  47       $SIG{__DIE__} = \&die_handler;
  48     }
  49     $SHOW_TRACE      = $args{'show_trace'}      if exists $args{'show_trace'};
  50     $IGNORE_EVAL     = $args{'ignore_eval'}     if exists $args{'ignore_eval'};
  51     $EXTENDED_ERRORS = $args{'extended_errors'} if exists $args{'extended_errors'};
  52     $ERROR_TEMPLATE  = $args{'error_template'}  if exists $args{'error_template'};
  53     $LOG_HANDLER     = $args{'log_handler'}     if exists $args{'log_handler'};
  54     $FINAL_HANDLER   = $args{'final_handler'}   if exists $args{'final_handler'};
  55   }
  56   return 1;
  57 }
  58
  59 ###----------------------------------------------------------------###
  60
  61 sub die_handler {
  62   my $err   = shift;
  63
  64   die $err if $no_recurse;
  65   local $no_recurse = 1;
  66
  67   ### test for eval - if eval - propogate it up
  68   if (! $IGNORE_EVAL) {
  69     if (! $ENV{MOD_PERL}) {
  70       my $n = 0;
  71       while (my $sub = (caller(++$n))[3]) {
  72         next if $sub !~ /eval/;
  73         die $err; # die and let the eval catch it
  74       }
  75
  76       ### test for eval in a mod_perl environment
  77     } else {
  78       my $n     = 0;
  79       my $found = 0;
  80       while (my $sub = (caller(++$n))[3]) {
  81         $found = $n if ! $found && $sub =~ /eval/;
  82         last if $sub =~ /^(Apache|ModPerl)::(PerlRun|Registry)/;
  83       }
  84       if ($found && $n - 1 != $found) {
  85         die $err;
  86       }
  87     }
  88   }
  89
  90   ### decode the message
  91   if (ref $err) {
  92
  93   } elsif ($EXTENDED_ERRORS && $err) {
  94     my $copy = "$err";
  95     if ($copy =~ m|^Execution of ([/\w\.\-]+) aborted due to compilation errors|si) {
  96       eval {
  97         local $SIG{__WARN__} = sub {};
  98         require $1;
  99       };
 100       my $error = $@ || '';
 101       $error =~ s|Compilation failed in require at [/\w/\.\-]+/Die.pm line \d+\.\s*$||is;
 102       chomp $error;
 103       $err .= "\n($error)\n";
 104     } elsif ($copy =~ m|^syntax error at ([/\w.\-]+) line \d+, near|mi) {
 105     }
 106   }
 107
 108   ### prepare common args
 109   my $msg = &CGI::Ex::Dump::_html_quote("$err");
 110   $msg = "<pre style='background:red;color:white;border:2px solid black;font-size:120%;padding:3px'>Error: $msg</pre>\n";
 111   my $ctrace = ! $SHOW_TRACE ? ""
 112     : "<pre style='background:white;color:black;border:2px solid black;padding:3px'>"
 113     . dex_html(ctrace)."</pre>";
 114   my $args = {err => "$err", msg => $msg, ctrace => $ctrace};
 115
 116   &$LOG_HANDLER($args) if $LOG_HANDLER;
 117
 118   ### web based - give more options
 119   if ($ENV{REQUEST_METHOD}) {
 120     my $cgix = CGI::Ex->new;
 121     $| = 1;
 122     ### get the template and swap it in
 123     # allow for a sub that returns the template
 124     # or a string
 125     # or a filename (string starting with /)
 126     my $out;
 127     if ($ERROR_TEMPLATE) {
 128       $out = UNIVERSAL::isa($ERROR_TEMPLATE, 'CODE') ? &$ERROR_TEMPLATE($args) # coderef
 129         : (substr($ERROR_TEMPLATE,0,1) ne '/') ? $ERROR_TEMPLATE # html string
 130         : do { # filename
 131           if (open my $fh, $ERROR_TEMPLATE) {
 132             read($fh, my $str, -s $ERROR_TEMPLATE);
 133             $str; # return of the do
 134           } };
 135     }
 136     if ($out) {
 137       $cgix->swap_template(\$out, $args);
 138     } else {
 139       $out = $msg.'<p></p>'.$ctrace;
 140     }
 141
 142     ### similar to CGI::Carp
 143     if (my $r = $cgix->apache_request) {
 144       if ($r->bytes_sent) {
 145         $r->print($out);
 146       } else {
 147         $r->status(500);
 148         $r->custom_response(500, $out);
 149       }
 150     } else {
 151       $cgix->print_content_type;
 152       print $out;
 153     }
 154   } else {
 155     ### command line execution
 156   }
 157
 158   &$FINAL_HANDLER($args) if $FINAL_HANDLER;
 159
 160   die $err;
 161 }
 162
 163 1;
 164
 165 __END__
 166
 167 =head1 SYNOPSIS
 168
 169   use CGI::Ex::Die;
 170   $SIG{__DIE__} = \&CGI::Ex::Die::die_handler;
 171
 172   # OR #
 173
 174   use CGI::Ex::Die register => 1;
 175
 176 =head1 DESCRIPTION
 177
 178 This module is intended for showing more useful messages to
 179 the developer, should errors occur.  This is a stub phase module.
 180 More features (error notification, custom error page, etc) will
 181 be added later.
 182
 183 =head1 AUTHORS
 184
 185 Paul Seamons <perlspam at seamons dot com>
 186
 187 =cut