File Coverage

blib/lib/CGI/Alert.pm

Criterion	Covered	Total	%
statement	32	204	15.6
branch	14	106	13.2
condition	2	30	6.6
subroutine	8	18	44.4
pod	0	7	0.0
total	56	365	15.3

# -*- 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 = <<'-';
Uh-Oh!

The script handling your request died with the following error:


    [MSG]


If that indicates a problem you can fix, please do so.


Otherwise, don't panic: I have sent a notification to the
[MAINTAINER], providing details of the error.

-

# 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 ($@) {
		carp "Ignoring invalid filter expression '$re': $@";
	    }
	    else {
		push @Hide, $result;
	    }

	    # Eliminate it from our import list
	    splice @_, $i, 1;
	}
	else {
	    # Anything else: must be an email address.  Point $Maintainer
	    # at it, and remove from our arg list so Exporter doesn't see it.
	    ($Maintainer) = splice @_, $i, 1;
	    # (don't increment $i, since we've collapsed the array)
	}
    }


    # 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 = ',';
	}
	$retval .= " )\n";

	# Keep indenting each subsequent level in the stack trace.
	$indent .= "  ";
    }

    $retval;
}


################
#  maintainer  #  returns nicely formatted HREF and address of maintainer
################
sub maintainer() {
    my $real_name = "";
    my $just_mail = $Maintainer;

    # Address is of the form "Foo Bar " ?
    if ($just_mail =~ s/^(.*)<(.*)>(.*)$/$2/) {
	$real_name = "$1 $3 ";
    }
    $real_name =~ s|\s+| |g;

    return "maintainer, $real_name<$just_mail>";
}

# END   helper functions
###############################################################################
# BEGIN main notification function

############
#  notify  #  Gets called on END, to send email to maintainer
############
sub notify($@) {
    my $subject = shift;

    eval {
	my %env = %ENV;
	local %ENV;
	local $ENV{PATH} = "/usr/sbin:/usr/lib";	# Where sendmail lives

	# MIME part divider
	my $b = sprintf("==XxX%05d", $$);

	my $sendmail = ($DEBUG_SENDMAIL
			? "> $DEBUG_SENDMAIL"
			: '| sendmail -oi -t');

	open(SENDMAIL, $sendmail)
	  or do {
	      print STDERR "Could not fork sendmail: $!\n";
	      exit 1;
	  };

	my $http_host_full = 'localhost';
	my $at_http_host   = '';
	if (($env{HTTP_HOST}||'') =~ m!^(([\w\d.-]+)(:\d+)?)$!) {
	    # FIXME: for email host, remove the ':80'.
	    $http_host_full = $1;
	    $at_http_host   = '@' . $2;
	}

	my $request_uri = $env{REQUEST_URI} || "/unknown-url";

	my $package = __PACKAGE__;	# Can't string-interpolate __PACKAGE__

	# Do we know the remote user? Make it easy for maintainer to reply.
	exists $env{REMOTE_USER} && $env{REMOTE_USER}
	  and print SENDMAIL "Reply-To: $env{REMOTE_USER}\n";

	# Even though the subject distinguishes between errors and warnings,
	# it can be helpful to scan based on 'From' line as well.  Plus,
	# Ed's mail-announce speech synthesizer will then differentiate them
	my $from = "CGI " . ($subject =~ /warn/i
			     ? "Warnings"
			     : "Errors");

	# Include CGI script name and version (if known) in X-mailer
	my $cgi_script = _basename($0);
	$cgi_script .= " v$main::VERSION"	if defined $main::VERSION;

	print  SENDMAIL <<"-";
From:    $from
To:      $Maintainer
Subject: $subject in http://$http_host_full$request_uri
X-mailer: $cgi_script, via $package v$VERSION
Precedence: bulk
MIME-Version: 1.0
Content-Type: multipart/mixed;
	boundary="$b"

This is a MIME-Encapsulated message.  You can read it as plain text
if you insist.

--$b
Content-Type: text/plain; charset=us-ascii

-

	# Message body: start with whatever the user told us to say.
	print  SENDMAIL $_, "\n"			foreach @_;
	print  SENDMAIL "\n";

	# Display remote user/host info
	if (exists $env{REMOTE_USER} || exists $env{REMOTE_ADDR}) {
	    print  SENDMAIL "Remote user is ";

	    if (exists $env{REMOTE_USER}) {
		print  SENDMAIL $env{REMOTE_USER} || "";
		print  SENDMAIL  " @ "	if exists $env{REMOTE_ADDR};
	    }
	    if (exists $env{REMOTE_ADDR}) {
		# Find out remote host name.  Bracket inside an EVAL, so we
		# don't slow down normal execution by doing "use Socket".
		my @a = eval 'use Socket qw(AF_INET inet_aton);
                        gethostbyaddr(inet_aton($env{REMOTE_ADDR}), AF_INET);';
		if ($@) {
		    print  SENDMAIL $env{REMOTE_ADDR};
		} else {
		    printf SENDMAIL "%s [%s]", $a[0]||"",$env{REMOTE_ADDR};
		}
	    }
	    print  SENDMAIL "\n";
	}

	# Display our name and version
	print  SENDMAIL "\n",
	                "This message brought to you by $package v$VERSION\n";


	# If this was a "die", add a stack trace
	$subject =~ /FATAL/ and eval {
	    local $SIG{__DIE__};
	    print  SENDMAIL <<"-", _stack_trace;

--$b
Content-Type: text/plain; name="stack-trace"
Content-Description: Stack Trace

-
	};

	#
	# If CGI.pm is loaded, and we had CGI params, make a new MIME section
	# showing each param and its value(s).  This is all wrapped in an
	# eval block, since we don't want to call CGI::param() if CGI.pm
	# isn't loaded (plus, we don't really care about errors).
	#
	@cgi_params and eval {
	    local $SIG{__DIE__};

	    # MIME boundary.  Describe the new section, and show GET or POST
	    my $method = $env{REQUEST_METHOD} || "no REQUEST_METHOD";
	    print  SENDMAIL <<"-";

--$b
Content-Type: text/plain; name="CGI-Params"
Content-Description: CGI Parameters ($method)

-

	    # Find length of longest param...
	    my $maxlen = -1;
	    foreach my $set (@cgi_params) {
		$maxlen < length($set->[0])
		  and $maxlen = length($set->[0]);
	    }
	    # ...then display each, one per line
	    foreach my $set (@cgi_params) {
		my ($p, @v) = @$set;

		# For security purposes, never send out passwords, credit cards
		grep { $p =~ /$_/ } @Hide
		  and @v = ('[...]');

		printf SENDMAIL "  %-*s = %s\n", $maxlen, $p,
		  (defined($v[0]) ? $v[0] : '');
		# If this param is an array of more than one value, show all.
		for (my $i=1; $i < @v; $i++) {
		    printf SENDMAIL "  %-*s + %s\n", $maxlen, "", $v[$i];
		}
	    }
	};

	#
	# Another MIME section: stack traces (on warnings), if any
	#
	if (@warnings_traced) {
	    print  SENDMAIL <<"-";

--$b
Content-Type: text/plain; name="warnings"
Content-Description: Warnings, with Stack Traces

-

	    print  SENDMAIL "  * $_\n\n"		for @warnings_traced;
	    print  SENDMAIL "\n";
	}

	#
	# New MIME Section: environment
	#
	print  SENDMAIL <<"-";

--$b
Content-Type: text/plain; name="Environment"
Content-Description: Environment

-
	foreach my $v (sort keys %env) {  # FIXME: do in order of importance?
	    printf SENDMAIL "%-15s = %s\n", $v, $env{$v}||'[undef]';
	}

	#
	# Another MIME Section: included headers
	#
	print  SENDMAIL <<"-";

--$b
Content-Type: text/plain; name="%INC"
Content-Description: Included Headers

-
	foreach my $v (sort keys %INC) {
	    printf SENDMAIL "%-25s = %s\n", $v, $INC{$v}||'[undef]';
	}
	print  SENDMAIL "\n";

	# Final MIME separator, indicates the end
	print  SENDMAIL "--$b--\n";


	close SENDMAIL
	  or die "Error running sendmail; status = $?\n";
    };

    return $@;
}

# END   main notification function
###############################################################################
# BEGIN auxiliary function for our caller to die _before_ emitting headers

##############
#  http_die  #  Called if we see an error _before_ emitting HTTP headers.
##############
sub http_die($@) {
    my $status   = shift;		# Something like "400 Bad Request"
    # Or maybe it's '--no-mail' ?  If so, $status is the next one
    if ($status =~ /^--?no-?(mail|alert)$/) {
	$SIG{__WARN__} = sub {
	    printf STDERR "[%s - %s]: DIED: %s\n", $ME, scalar localtime, @_;
	};
	$status = shift;
    }

    # No reason for user to see the numeric code, it's just confusing.
    (my $friendly_status = $status) =~ s/^\d+\s*//;

    # This would best be done by CGI.pm, but we don't want the overhead.
    my $start = <<"-";
Status: $status
Content-Type: text/html; charset=ISO-8859-1



        PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
         "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">


 $status

-

    if ($INC{'CGI.pm'}) {
	$start = CGI::header(-status => $status)
	       . CGI::start_html(-title => $status, @Extra_HTML_Headers);
    }

    print <<"-";
$start

$friendly_status

@_


-

    # Emit a warning.  This goes to the logfile, but should also trigger
    # an email to the code maintainer.
    warn "Script error: $status\n"
       . ": " . join("\n: ", @_);

    exit 0;
}


# END   auxiliary function for our caller to die _before_ emitting headers
###############################################################################
# BEGIN compile-time execution
#
# This is evaluated the moment our caller does 'use CGI::Alert'.
#

#
# Execute this on each warning
#
sub _warn {
    my $w = shift;

    # Things can get quickly out of hand.  We don't want to send an
    # unreadably long email... so just include the first 10 (FIXME)
    # warnings.  Anything more, and just include a count.
    if (@warnings < 10) {
	push @warnings, $w;
	push @warnings_traced, $w . _stack_trace;
    }
    else {
	push @warnings, '(....0 more...)'		if @warnings == 10;
	$warnings[-1] =~ s/(\d+)/$1 + 1/e;
    }

    # Always send the warning to STDERR (usually goes to error_log).
    # Include the base URL and the time.
    printf STDERR "[%s - %s] %s\n", $ME, scalar(localtime), $w
      unless $DEBUG_SENDMAIL;
};
$SIG{__WARN__} = \&_warn;

# (helper function for END and signal handlers
sub check_warnings(;$) {
    if (@warnings) {
	my $msg = "The following warnings were detected:";

	# Called with arguments?  Must be a signal.
	if (@_)		{ $msg = "Script was aborted by SIG$_[0]!  $msg"    }
	# Bad exit status?  Indicate so.
	elsif ($?)	{ $msg = "Script terminated with status $?!  $msg"  }

	notify("Warnings",
	       $msg,
	       "",
	       map { "  * $_" } @warnings);
    }
}


END { check_warnings }
$SIG{TERM} = \&check_warnings;


################
################  FATAL ERRORS.  This gets called on any 'die'.
################
sub _die($) {
    my $msg = shift;

    # Called inside an eval?  Pass it on.  This lets caller do things safely.
    die $msg if $^S or not defined $^S;


    # Not an eval: die for real.

    # First of all: log to stderr (error_log) with script URL and time.
    printf STDERR "[%s - %s]: DIED: %s\n", $ME, scalar localtime, $msg
      unless $DEBUG_SENDMAIL;

    # Next, display an error message to remote (web) user.  Do this before
    # sending out the email: simple print()s are less likely to fail than
    # a complex notify(), and we want to make a good attempt at presenting
    # the remote user with a friendly diagnostic.
    my $browser_text_copy;
    if ($Browser_Text) {
	# If caller has asked us to emit HTTP headers, do so now.
	if ($Emit_HTTP_Headers && !$DEBUG_SENDMAIL) {
	    print  "Status: 500 Server Error\n",
	           "Content-type: text/html; charset=ISO-8859-1\n",
		   "\n";
	}

	my $what = ref($Browser_Text) || '';

	if ($what eq 'CODE') {
	    # $Browser_Text is a subroutine
	    eval { $Browser_Text->($msg, $Emit_HTTP_Headers); };
	    # FIXME FIXME FIXME - now what?
	}
	elsif (!$what) {
	    # $Browser_Text is simple text
	    ($browser_text_copy = $Browser_Text) =~ s/\[MSG\]/$msg/g;
	    $browser_text_copy =~ s/\[MAINTAINER\]/maintainer/ge;

	    print $browser_text_copy		unless $DEBUG_SENDMAIL;
	}
	else {
	    # Not a CODE ref or string
	    push @warnings, "[Yo!  What is \$Browser_Text?  It's '$what', and I only grok 'CODE' or '' (strings)]";
	}
    }
    else {
	# $Browser_Text undefined - I guess we just show nothing to user?
    }


    # Generate a message body for the email we're going to send out
    my @text = ("The script died with:",
		"",
		"  $msg");
    if (@warnings) {
	push @text, "",
	            "In addition, the following warnings were detected:\n",
		    "",
		    map { "  * $_" } @warnings;
	@warnings = ();
    }

    # Send out email.  Inform web user about our emailing efforts.
    notify("FATAL ERRORS", @text);

    printf <

Handled by %s v$VERSION


EOP

    exit 0;
};
$SIG{__DIE__} = \&_die;

# END   compile-time execution
###############################################################################
# BEGIN caller-accessible functions (not yet exported)

#######################
#  emit_http_headers  #  Caller can tell us when to emit 'Status', etc
#######################
sub emit_http_headers($) {
    $Emit_HTTP_Headers = 0 + $_[0];
}

########################
#  extra_html_headers  #  Caller can give us stylesheets, etc
########################
sub extra_html_headers(@) {
    @Extra_HTML_Headers = @_;
}


#########################
#  custom_browser_text  #  Caller can give us a custom text to display
#########################
sub custom_browser_text($) {
    $Browser_Text = shift;
}


# END   caller-accessible functions (not yet exported)
###############################################################################

1;

__END__