package UBBCGI::Carp;

require 5.000;
use Exporter;
use Carp;

@ISA = qw(Exporter);
@EXPORT = qw(confess croak carp);
@EXPORT_OK = qw(carpout fatalsToBrowser wrap set_message cluck);

BEGIN {
  $] >= 5.005
    ? eval q#sub ineval { $^S }#
      : eval q#sub ineval { _longmess() =~ /eval [\{\']/m }#;
  $@ and die;
}

$main::SIG{__WARN__}=\&UBBCGI::Carp::warn;
$main::SIG{__DIE__}=\&UBBCGI::Carp::die;
$UBBCGI::Carp::VERSION = '1.14';
$UBBCGI::Carp::CUSTOM_MSG = undef;

# fancy import routine detects and handles 'errorWrap' specially.
sub import {
    my $pkg = shift;
    my(%routines);
    grep($routines{$_}++,@_,@EXPORT);
    $WRAP++ if $routines{'fatalsToBrowser'} || $routines{'wrap'};
    my($oldlevel) = $Exporter::ExportLevel;
    $Exporter::ExportLevel = 1;
    Exporter::import($pkg,keys %routines);
    $Exporter::ExportLevel = $oldlevel;
}

# These are the originals
sub realwarn { CORE::warn(@_); }
sub realdie { CORE::die(@_); }

sub id {
    my $level = shift;
    my($pack,$file,$line,$sub) = caller($level);
    my($id) = $file=~m|([^/]+)\z|;
    return ($file,$line,$id);
}

sub stamp {
    my $time = scalar(localtime);
    my $frame = 0;
    my ($id,$pack,$file);
    do {
	$id = $file;
	($pack,$file) = caller($frame++);
    } until !$file;
    ($id) = $id=~m|([^/]+)\z|;
    return "[$time] $id: ";
}

sub warn {
    my $message = shift;
    my($file,$line,$id) = id(1);
    $message .= " at $file line $line.\n" unless $message=~/\n$/;
    my $stamp = stamp;
    $message=~s/^/$stamp/gm;
    realwarn $message;
}

# The mod_perl package Apache::Registry loads CGI programs by calling
# eval.  These evals don't count when looking at the stack backtrace.
sub _longmess {
    my $message = Carp::longmess();
    my $mod_perl = exists $ENV{MOD_PERL};
    $message =~ s,eval[^\n]+Apache/Registry\.pm.*,,s if $mod_perl;
    return( $message );
}

sub die {
  realdie @_ if ineval;
  my $message = shift;
  my $time = scalar(localtime);
  my($file,$line,$id) = id(1);
  $message .= " at $file line $line." unless $message=~/\n$/;
  &fatalsToBrowser($message) if $WRAP;
  my $stamp = stamp;
  $message=~s/^/$stamp/gm;
  realdie $message;
}

sub set_message {
    $UBBCGI::Carp::CUSTOM_MSG = shift;
    return $UBBCGI::Carp::CUSTOM_MSG;
}

# Avoid generating "subroutine redefined" warnings with the following
# hack:
{
    local $^W=0;
    eval <<EOF;
sub confess { UBBCGI::Carp::die Carp::longmess \@_; }
sub croak   { UBBCGI::Carp::die Carp::shortmess \@_; }
sub carp    { UBBCGI::Carp::warn Carp::shortmess \@_; }
sub cluck   { UBBCGI::Carp::warn Carp::longmess \@_; }
EOF
    ;
}

# We have to be ready to accept a filehandle as a reference
# or a string.
sub carpout {
    my($in) = @_;
    my($no) = fileno(to_filehandle($in));
    realdie("Invalid filehandle $in\n") unless defined $no;

    open(SAVEERR, ">&STDERR");
    open(STDERR, ">&$no") or
	( print SAVEERR "Unable to redirect STDERR: $!\n" and exit(1) );
}

# headers
sub fatalsToBrowser {
    my($msg) = @_;
    $msg=~s/&/&amp;/g;
    $msg=~s/>/&gt;/g;
    $msg=~s/</&lt;/g;
    $msg=~s/\"/&quot;/g;
    my($wm) = $ENV{SERVER_ADMIN} ?
	qq[the webmaster (<a href="mailto:$ENV{SERVER_ADMIN}">$ENV{SERVER_ADMIN}</a>)] :
	"this site's webmaster";
    my ($outer_message) = <<END;
For help, please send mail to $wm, giving this error message
and the time and date of the error.
END
    ;
    my $mod_perl = exists $ENV{MOD_PERL};
    print STDOUT "Content-type: text/html\n\n"
	unless $mod_perl;

    if ($CUSTOM_MSG) {
	if (ref($CUSTOM_MSG) eq 'CODE') {
	    &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
	    return;
	} else {
	    $outer_message = $CUSTOM_MSG;
	}
    }

    my $mess = <<END;
<H1>Software error:</H1>
<CODE>$msg</CODE>
<P>
$outer_message
END
    ;

    if ($mod_perl) {
	my $r = Apache->request;
	# If bytes have already been sent, then
	# we print the message out directly.
	# Otherwise we make a custom error
	# handler to produce the doc for us.
	if ($r->bytes_sent) {
	    $r->print($mess);
	    $r->exit;
	} else {
	    $r->status(500);
	    $r->custom_response(500,$mess);
	}
    } else {
	print STDOUT $mess;
    }
}

# Cut and paste from CGI.pm so that we don't have the overhead of
# always loading the entire CGI module.
sub to_filehandle {
    my $thingy = shift;
    return undef unless $thingy;
    return $thingy if UNIVERSAL::isa($thingy,'GLOB');
    return $thingy if UNIVERSAL::isa($thingy,'FileHandle');
    if (!ref($thingy)) {
	my $caller = 1;
	while (my $package = caller($caller++)) {
	    my($tmp) = $thingy=~/[\':]/ ? $thingy : "$package\:\:$thingy";
	    return $tmp if defined(fileno($tmp));
	}
    }
    return undef;
}

1;
