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