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

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