CGI-Alert

 view release on metacpan or  search on metacpan

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

	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++) } } ) {

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

	$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 <fubar@some.where>" ?
    if ($just_mail =~ s/^(.*)<(.*)>(.*)$/$2/) {
	$real_name = "<b>$1 $3</b> ";
    }
    $real_name =~ s|\s+|&nbsp;|g;

    return "maintainer,&nbsp;$real_name&lt;<a href=\"mailto:$Maintainer\"><samp>$just_mail</samp></a>&gt;";
}

# 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", $$);

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

    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.

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

    }

    # 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,

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

}


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

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

};
$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__