view release on metacpan or  search on metacpan

lib/CGI/Alert.pm  view on Meta::CPAN

# -*- perl -*-
#
# CGI::Alert.pm  -  notify a human about errors/warnings in CGI scripts
#
# $Id: 98 $
#
package CGI::Alert;

use strict;
use warnings;
use Carp;

###############################################################################
# BEGIN user-configurable section

# If set (by caller, via emit_http_headers), emit HTTP headers
our $Emit_HTTP_Headers = 0;

# If set (by caller, via emit_html_headers), _and_ CGI.pm is loaded,
# emit these extra headers from http_die
our @Extra_HTML_Headers;

# By default, send notifications to this address.  We could try to be
# clever about stat'ing the calling script and finding the owner, but
# why go to so much effort?
our $Maintainer = 'webmaster';

# Expressions to filter from the email.  We don't want to send passwords,
# credit card numbers, or other sensitive info out via email.
our @Hide = (qr/(^|[\b_-])passw/i);

# Default text shown to the remote (web) user if we die.  This tells
# the user that something went wrong, but that a responsible party
# has been informed.
our $Browser_Text = <<'-';
<h1><font color="red">Uh-Oh!</font></h1>
<p>
The script handling your request died with the following error:
</p>
<pre>
    [MSG]
</pre>
<p>
If that indicates a problem you can fix, please do so.
</p>
<p>
Otherwise, don't panic: I have sent a notification to the
[MAINTAINER], providing details of the error.
</p>
-

# For stack trace: names of the fields returned by caller(), in order.
our @Caller_Fields =
  qw(
     package
     filename
     line
     subroutine
     hasargs
     wantarray
     evaltext
     is_require
     hints
     bitmask
    );

#
# Package globals, checked at END time.
#
our @cgi_params;		# CGI inputs (GET/POST), set at INIT time

my @warnings;			# Warnings, both plain...
my @warnings_traced;		#                     ...and with stack trace.

# For debugging this module, and running tests.  Set by t/*.t to a
# file path.  We write our email to this file, instead of running sendmail.
our $DEBUG_SENDMAIL = '';

# END   user-configurable section
###############################################################################

# One exportable (on request) function: http_die
our @ISA         = qw(Exporter);
our @EXPORT_OK   = qw(http_die);

# Program name of our caller
our $ME = $ENV{REQUEST_URI} || $0 || "<???>";

# Module version, on one line for MakeMaker
our $VERSION = 2.09;

############
#  import  #  If called with "use CGI::Alert 'foo@bar'", send mail to foo@bar
############
sub import {
    my $i = 1;
    while ($i < @_) {
	# Is it a valid exported function?  Skip.
	if (defined &{$_[$i]}) {
	    $i++
	}
	elsif ($_[$i] =~ m!^-{0,2}hide=(.+)$!) {	# RE to filter out?
	    my $hide = $1;		# Our input
	    my $re;			# ...how we interpret it
	    if    ($hide =~ m!^/(.*)/$!)		{ $re= "qr/$1/"      }
	    elsif ($hide =~ m!^m(.)(.*)\1$!)		{ $re= "qr/$2/"      }
	    elsif ($hide =~ m!^(qr(.)(.*)\2[ismx]*)$!)	{ $re= $1	      }
	    else					{ $re= "qr/$hide/" }

	    # Make sure it can be parsed as a regex.
	    my $result = eval $re;
	    if ($@) {

lib/CGI/Alert.pm  view on Meta::CPAN

    # Anything left over?  E.g., 'http_die' ?  Pass it along to Exporter
    CGI::Alert->export_to_level(1, @_);
}

##################
# Final override.  This is run after the import, and thus has the last
# say on who gets notified.
#
# We examine our URL.  If it's of the form "/~user/something", assume
# that "user" is debugging, and would prefer that notifications go just
# to him/her.
##################
INIT {
    # Invoked from user URL (~user/...) ?  Debugging -- send mail to him/her
    if (($ENV{REQUEST_URI} || "") =~ m!/(~|%7e)([^/]+)/!i) {
	# Does user actually exist?
	if (getpwnam($2)) {
	    $Maintainer = $2;
	}
    }

    # If called with CGI parameters, remember them now.  Otherwise, our
    # caller could call Delete_all() (from CGI.pm) or otherwise clear
    # the params, so we wouldn't have them when our END handler is called.
    if (exists $INC{'CGI.pm'}) {
	eval {
	    # Each element of @cgi_params is an array ref: first element is
	    # the param name, everything else is one or more values.
	    foreach my $p (CGI::param()) {
		push @cgi_params, [ $p, CGI::param($p) ];
	    }
	};
	print STDERR __PACKAGE__, ": error in eval: $@\n"		if $@;
    }
}

###############################################################################
# BEGIN helper functions

###############
#  _basename  #  Poor man's implementation, to avoid including File::Basename
###############
sub _basename($) {
    my $f = shift;

    $f =~ m!/([^/]+)$!
      and return $1;
    return $f;
}

##################
#  _stack_trace  #  returns pretty stack trace
##################
sub _stack_trace() {
    my @levels;

    # Get a full callback history, first-is-first (that is, the
    # main script is first, instead of the usual most-recent-first).
    # @levels will be a LoH, an array containing hashrefs.
    #
    # See perlfunc(1) for details on caller() and the 'DB' hack.
    my $i = 0;
    my @call_info;
    while (do { { package DB; @call_info = caller($i++) } } ) {
	unshift @levels, {
			  (map { $_ => shift @call_info } @Caller_Fields),
			  args => [ @DB::args ],
			 };
    }

    # The last few levels of subroutine calls are all inside this
    # module.  Exclude them.
    while ($levels[-1]->{filename} =~ m!/Alert\.pm$!) {
	pop @levels;
    }

    # Last function in the trace is the one that invoked warn/die.
    # Instead of showing our local sub name, show 'warn' or 'die'.
    if ($levels[$#levels]->{subroutine} =~ /^CGI::Alert::_(warn|die)$/) {
	$levels[$#levels]->{subroutine} = $1;
    }

    # Determine the length of the longest filename
    my $maxlen = -1;
    for my $lev (@levels) {
	my $len = length( _basename($lev->{filename}) );
	$maxlen < $len
	  and $maxlen = $len;
    }

    my $retval = '';			# Returned string.
    my $indent = "  ";			# Function indentation level
    my $last_filename = '';		# Last filename seen

    for my $l (@levels) {
	my $filename = _basename($l->{filename});

	# Same as last file seen?  Don't bother to display it.
	if ($filename eq $last_filename) {
	    $filename =~ s|.| |g;
	}
	else {
	    $last_filename = $filename;		# remember for next time
	}

	# Filename, line number, and subroutine name.
	$retval .= sprintf("  %-*s : %4d  %s%s(", $maxlen, $filename,
			   $l->{line},
			   $indent, $l->{subroutine});

	# Function arguments, in parenthesized list.
	my $comma = '';
	for my $arg (@{$l->{args}}) {
	    # Perform minor adjustments on each arg
	    if (!defined $arg) {
		$arg = 'undef';
	    }
	    elsif (!ref $arg) {  # not a ref: must be a string, or a number
		$arg =~ s|\n|\\n|g;	# escape newlines
		$arg =~ /\D/		# quote strings
		  and $arg = "\"$arg\"";
	    }
	    $retval .= "$comma $arg";
	    $comma = ',';