#!/usr/bin/perl -wT
# Automated error reporting
#
package TDL::Error;

# Export the error subroutine
use Exporter;
@ISA = "Exporter";
@EXPORT = qw(error);

use strict;
use CGI;

our ($count, $fullReport, $logFile, $logOffset, $q, $VERSION);
$VERSION = "1.1";
$count = 0;
$fullReport = 0;
$logFile = "/usr/local/apache/logs/error_log";
$logOffset = -s $logFile;
$q = undef;

##############################################################################
# Force CGI::Carp::fatalsToBrowser into mod-perl mode so that it will
# not generate spurious "Content-type: text/html" output.
my $modPerl;
BEGIN
{
  $modPerl = $ENV{MOD_PERL};
  $ENV{MOD_PERL} = 1;
}
use CGI::Carp qw ( fatalsToBrowser );
BEGIN
{
  if (defined($modPerl))
  {
    $ENV{MOD_PERL} = $modPerl;
  } else {
    delete $ENV{MOD_PERL};
  }
}

##############################################################################
# define the error message routine for any errors that are encountered.
BEGIN
{
  # If the Admin module is installed and it reports that the current user
  # is an administrator then allow full reports.
  $fullReport = 0;
  eval("use TDL::Admin");
  eval("\$fullReport = TDL::Admin::isAdmin()");

	sub carp_error
	{
		my $error_message = shift;
		if (!defined($q))
		{
			$q = new CGI;
 			print $q->header("text/html") unless $q->{'.header_printed'};
		}
		error($q, $error_message);
	}
 	CGI::Carp::set_message(\&carp_error);
}

# allow main routine to supply it's own CGI query object so that error output is appended
# to the end of whatever output was generated before the error occurred.
sub Register
{
	($q) = @_;
}

# output error messages
sub error
{
	my($q, $error_message) = @_;

	$count++;

	print $q->start_html("CGI Error"), "\n";
	print $q->hr, $q->h1(sprintf "CGI Error in %s", $ENV{"REQUEST_URI"}), "\n";
	print $q->p("Sorry, the following error has occurred:", $q->br, $q->i($error_message)), "\n";

	# ----- Determine if a full report should be generated -----
	return unless $fullReport;

	if ($error_message =~ /\sat\s(\/.*)\sline\s(\d+)/)
	{
		showSource($q, $1, $2);
	}

	# ----- Output new entries in the system error log -----
	if ($logOffset < -s $logFile)
	{
		if (!open (F, $logFile))
    {
      print $q->h1("Unable to open error log: $!"), "\n";
      return
    };

		my @src = ();

		print $q->h2("Web Server Error Log"), "\n";
		seek F, $logOffset, 0;
		while (<F>)
		{
			print ($_, "<br>\n");
			push @src, $1, $2 if /\sat\s(\/.*)\sline\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 references from the log
		for (my $index = 0; $index < @src; $index += 2)
    {
      print $q->br, "\n";
      showSource($q, $src[$index], $src[$index + 1]);
    }
	}
}

# Show a statement from a source file (starting at a specific line)
sub showSource
{
  my ($q, $filePath, $lineNum) = @_;
  if (open (S, $filePath))
  {
    $filePath =~ /([\w\.]*)$/;
    print $q->b($q->i("Source code")," ($1 at $lineNum)"), $q->br,"\n";
    while (<S>)
    {
      if ($lineNum-- <= 1)
      {
        s/\&/\&amp;/;
        s/\</\&lt;/;
        s/\>/\&gt;/;
        print ($_, "<br>\n");
        if (/;|{.*}/) { last; }
      }
    }
    close (S);
  }
}

# End of TDL::Error
1;