use lib "/home/exelana0/public_html/lib";
use CGI::Carp qw(fatalsToBrowser set_die_handler noHeader);
use Devel::StackTrace;
package TDL::Error;
# Automated error reporting
# Export the error subroutine
use Exporter;
@ISA = "Exporter";
@EXPORT = qw(error);
use strict;
our ($cgi, $count, @email, $emailFrom, @errors, $fullReport, $html, $logFile, $logOffset, $logOpen,
$needHeader, $outputSafe, $q, $VERSION, %SRC);
BEGIN
{
@errors = ();
@email = ();
$emailFrom = $ENV{SERVER_ADMIN} | "";
$VERSION = "2.0";
$cgi = 0;
$count = 0;
$fullReport = 0;
$html = 1;
$logFile = "/usr/local/apache/logs/error_log";
$logOffset = -s $logFile;
$logOpen = 0;
$needHeader = 1;
$outputSafe = 0;
$q = undef;
%SRC = ();
}
END
{
our @notify = ();
if (scalar(@email) > 0 && $emailFrom ne "")
{
eval("use TDL::Admin");
eval("\@notify = TDL::Admin::adminNotify()");
if (scalar(@notify) > 0)
{
my $subject = shift @email;
my $last = pop @email;
push @email, $last if $last ne "
";
if (open(MAIL, "|/usr/sbin/sendmail -t -i"))
{
map { print MAIL "To: $_\n"; } @notify;
print MAIL "From: $emailFrom\n";
print MAIL "Subject: $subject\n";
print MAIL "Content-Type: text/html\n\n";
print MAIL "$subject";
map { print MAIL "$_\n" } @email;
print MAIL "\n";
close MAIL;
}
}
}
}
our $first = 1;
sub TDL_Error_trace
{
return; # disable tracing
return unless $outputSafe;
print "
" if $first;
$first = 0;
print "",join(" ",@_),"
\n";
}
sub init_log
{
my ($log) = @_;
$logOpen = 1;
my $prevFH = select TDL_ERROR; # Disable buffering
$| = 1;
select $prevFH;
print TDL_ERROR '='x80,"\n$ENV{REQUEST_URI}\n";
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time());
my $now = sprintf("%04d-%02d-%02d %02d:%02d:%02d", $year+1900, $mon+1, $mday, $hour, $min, $sec);
print TDL_ERROR "$now\n";
map { my $v = $ENV{$_}; $v =~ s/\n/\\n/; printf TDL_ERROR "%s: %s\n", $_, $ENV{$_} } sort keys %ENV;
print TDL_ERROR "admin_user: $TDL::Admin::isAdminUser\n";
print TDL_ERROR "admin_ip: $TDL::Admin::isAdminIP\n";
print TDL_ERROR "fullReport: $fullReport\n";
print TDL_ERROR "verbose: $Carp::Verbose\n" if defined($Carp::Verbose);
push @email, "Error details recorded in $log at $now
";
}
# output error messages
sub error
{
my($error_message) = @_;
# If the Admin module is installed and it reports that the current user
# is an administrator then allow full reports.
eval("use TDL::Admin");
eval("\$fullReport = TDL::Admin::isAdmin()");
$count++;
if ($needHeader)
{
TDL_Error_trace("need header");
# ----- Determine if the cgilib has already printed a header -----
if (defined($main::cgilib)
&& defined($main::cgilib{header})
&& defined($main::cgilib{header}->{done}))
{
$cgi = 1;
$needHeader = !$main::cgilib{header}->{done};
$html = ($main::cgilib{header}->{type} eq "text/html" ? 1 : 0);
}
# ----- Determine if the CGI library has already printed a header -----
if ($needHeader && %CGI::)
{
eval
{
eval("use Devel::Symdump");
my $main = Devel::Symdump->new("main");
map {
unless (m/::(?:_\<|\$|\@|\"|\\|[\x00-\x1f])/)
{
unless (defined($q))
{
eval("\$q = \$$_") if ref(eval("\$$_")) eq "CGI";
}
}
} $main->scalars;
};
$needHeader = 0 if defined($q) && !defined($q->{'.header_printed'});
}
}
# ----- Emit a header (using an appropriate library) -----
my $printedHeader = 0;
if ($needHeader)
{
TDL_Error_trace("emit header");
if ($cgi)
{
main::headTitle("CGI Error");
main::headEmit();
} elsif (defined($q)) {
print $q->start_html("CGI Error"), "\n";
} else {
print STDOUT "Content-type: text/html\n\nCGI Error\n";
}
$printedHeader = 1;
$outputSafe = 1;
$needHeader = 0;
}
# ----- Print the preface -----
if ($count < 2)
{
TDL_Error_trace("emit preface");
if (defined($ENV{REQUEST_URI}))
{
push @email, "CGI Error in $ENV{REQUEST_URI}";
push @email, "CGI Error in $ENV{REQUEST_URI}
";
} else {
push @email, "Error in $0";
}
if ($html)
{
print STDOUT "
" unless $printedHeader;
print STDOUT "CGI Error in $ENV{REQUEST_URI}
\n",
"Sorry, the following error has occurred:
\n";
} else {
print STDOUT '-'x60,"\n" unless $printedHeader;
print STDOUT "CGI Error in $ENV{REQUEST_URI}\n",
"Sorry, the following error has occurred:\n";
}
}
# ----- Record script failures for the system administrator to examine -----
unless ($logOpen)
{
my ($log) = $ENV{DOCUMENT_ROOT} =~ m/^(.*)\/[^\/]+$/;
$log .= "/dump/error_log";
TDL_Error_trace("open log $log");
init_log($log) if open(TDL_ERROR, ">>$log");
}
TDL_Error_trace("no message") unless defined($error_message);
return unless defined($error_message);
# ----- Emit the short form of the error message -----
my @src = ();
my @messages = split(/\n/, $error_message);
my $i = 0;
while ($i < scalar(@errors) && $i < scalar(@messages) && $messages[$i] eq $errors[$i])
{
$i++;
}
print TDL_ERROR '-'x10,"\n" if $i < scalar(@messages);
while ($i < scalar(@messages))
{
push @email, filterHTML($messages[$i])."
";
push @errors, $messages[$i];
TDL_Error_trace("message: $messages[$i]") if $logOpen;
print TDL_ERROR "$messages[$i]\n" if $logOpen;
push @src, $1, $2 if $messages[$i] =~ /\sat\s+(.*)\s+line\s+(\d+)/;
$messages[$i] =~ s/\s+at\s+\S+\s+line\s+\d+//g unless $fullReport;
if ($html)
{
print STDOUT "".filterHTML($messages[$i])."
\n";
} else {
print STDOUT "$messages[$i]\n";
}
$i++;
}
# ----- Record stack trace -----
if ($logOpen)
{
TDL_Error_trace("stack trace");
my $trace = Devel::StackTrace->new;
my $string = $trace->as_string;
$string =~ s/\n+$//;
print TDL_ERROR $string,"\n",'-'x10,"\n";
}
# ----- Output new entries from the system error log -----
if (defined($logOffset) && $logOffset < -s $logFile)
{
TDL_Error_trace("system log");
if (!open (F, $logFile))
{
print STDOUT "Unable to open error log: $!
\n";
} else {
tagOutput("h2","Web Server Error Log") if $fullReport;
seek F, $logOffset, 0;
while (my $line = )
{
chomp $line;
print STDOUT $html ? filterHTML($line)."
\n" : "$line\n" if $fullReport;
print TDL_ERROR "$line\n" if $logOpen;
push @src, $1, $2 if $line =~ m/\sat\s+(.*)\s+line\s+(\d+)/;
}
close F;
# Reset the log location so that subsequent calls start from the new
# location.
$logOffset = -s $logFile;
}
}
# Output the source lines for any error messages
for (my $index = 0; $index < scalar(@src); $index += 2)
{
print "\n" unless $fullReport;
showSource($src[$index], $src[$index + 1]);
}
}
sub tagOutput
{
my ($tag,$message) = @_;
print STDOUT "<$tag>" if $html;
print STDOUT $message;
print STDOUT $html ? "\n" : "\n";
}
# Show a statement from a source file (starting at a specific line)
sub showSource
{
local *S;
my ($filePath, $lineNum) = @_;
my $marker = "$filePath\t$lineNum";
return if defined($SRC{$marker});
TDL_Error_trace("source: $filePath at $lineNum");
if (open (S, $filePath))
{
my ($shortName) = $filePath =~ /([^\/]+)$/;
tagOutput("h3","Source code ($shortName at $lineNum)") if $fullReport;
print TDL_ERROR "Source code ($shortName at $lineNum)\n";
push @email, "Source code ($shortName at $lineNum)
";
while (my $line = )
{
chomp $line;
if ($lineNum-- <= 1)
{
print $html ? filterHTML($line)."
\n" : "$line\n" if $fullReport;
print TDL_ERROR "$line\n" if $logOpen;
push @email, filterHTML($line)."
";
if ($line =~ /(?:;|})\s*(?:\#|$)/)
{
print STDOUT "
\n" if $fullReport && $html;
push @email, "
";
last;
}
}
}
close S;
$SRC{$marker} = 1;
}
}
sub filterHTML
{
my ($str) = @_;
$str =~ s/\&/&/g;
$str =~ s/\/>/g;
return $str;
}
##############################################################################
# Handle error messages
BEGIN
{
sub die_handler
{
TDL::Error::error(@_);
}
CGI::Carp::set_message(\&die_handler);
CGI::Carp::set_die_handler(\&die_handler);
}
# End of TDL::Error
1;