# -------------------------------------------------------------------- #
#   KCatch.pm - Catch warn and die to avoid "Internal Server Error"
#   Copyright (C) 1999-2000 Kawasaki Yuusuke <u-suke@kawa.net>
# -------------------------------------------------------------------- #

=head1 NAME

KCatch.pm - Catch warn and die to avoid "Internal Server Error"

=head1 SYNOPSIS

    use KCatch;
    print "Content-Type: text/html\n\n";
    warn;
    die;

=head1 DESCRIPTION

    1ST STEP) Upload KCatch.pm to your script's directory or to @INC.
    2ND STEP) Insert just a line "use KCatch;" at top of your script.
    3RD STEP) This module could not work without the bug you made! :-)

=head1 OPTIONS

    use KCatch qw( [OPTIONS] );

KCatch.pm would automatically detect whether running under CGI or not, 
when no options given. Available options are following:

    use KCatch qw( plain );

Force to make output as plain text for command-line use.

    use KCatch qw( html );

Force to make output as HTML for CGI.

    use KCatch qw( source );

Display also warned or died Perl source code for debugging.
(Notes: The options could make influence on some security 
problems to display your code for the users.)

    use KCatch qw( stderr );

Output additional information of CGI to STDERR.

=head1 VERSIONS

    1999/11/05 v1.02 First Release
    1999/11/23 v1.03 Recognize between use and require
    2000/04/25 v1.04 Bug fix: undefined $ENV{GATEWAY_INTERFACE}
    2000/05/03 v1.05 Add options "use KCatch qw( source );", etc.
    2000/05/05 v1.06 Bug fix: undefined $ENV{REQUEST_URI}
    2000/08/04 v1.07 Output additional information to STDERR

=head1 SITES

    http://www.kawa.net/works/perl/catch/
    http://www.harukaze.net/~mishima/perl/cgi-debug-env/deb-tech.html

=head1 AUTHOR

Copyright 1999-2000 Kawasaki Yusuke <u-suke@kawa.net>

=cut
# -------------------------------------------------------------------- #
    package KCatch;
    use strict;
# -------------------------------------------------------------------- #
    my $argv = {};                      # Option arguments when "use"
    my $messbuf = [];                   # Error messages buffer (null)
    $main::SIG{__WARN__} = \&warn;      # Catch the signal from warn()
    $main::SIG{__DIE__}  = \&die;       # Catch the signal from die()
# -------------------------------------------------------------------- #
sub import {
    my $package = shift;
    $argv = { map { $_ => ! undef } @_ };
}
# -------------------------------------------------------------------- #
sub warn {
    my $mess = shift;
    my $caller = &get_caller();
    push( @$messbuf, [ "warn", $mess, @$caller ] ) if $caller;
    CORE::warn( $mess );
}
# -------------------------------------------------------------------- #
sub die {
    my $mess = shift;
    my $caller = &get_caller();
    push( @$messbuf, [ "die", $mess, @$caller ] ) if $caller;
    CORE::die( $mess );
}
# -------------------------------------------------------------------- #
END {
    return if ( $#$messbuf < 0 );       # Exit if no errors
	if ( $argv->{stderr} ) {
		&disp_stderr();					# Additional information
	}
    my $routine = \&disp_plain;         # Plain text as default
    if ( $argv->{html} ) {
        $routine = \&disp_html;         # Force HTML
    } elsif ( $argv->{plain} ) {
        $routine = \&disp_plain;        # Force plain text
    } elsif ( defined $ENV{GATEWAY_INTERFACE} and
              $ENV{GATEWAY_INTERFACE} =~ /cgi/i ){
        $routine = \&disp_html;         # HTML under CGI
    }else{
        $routine = \&disp_plain;        # Plain text under non-CGI
    }
    &{$routine}();                      # Display buffer
}
# -------------------------------------------------------------------- #
#   Output additional information to STDERR
# -------------------------------------------------------------------- #
sub disp_stderr {
    my $info = &conv_disp();

    my $name = &get_int_name();
    my( $sec, $min, $hour, $day, $mon, $year ) = localtime();
	my $qlength = ( $ENV{REQUEST_METHOD} eq "POST" )
				  ? $ENV{CONTENT_LENGTH}
				  : length( $ENV{QUERY_STRING} );
	my $url = $ENV{REQUEST_URI};
	$url =~ s/\?.*$//;
    printf STDERR "(Catch) %04d/%02d/%02d %02d:%02d:%02d %s [%05d] %s %s (%s) \"%s\"\n",
		   $year+1900, $mon+1, $day, $hour, $min, $sec,
		   $name, $$, $ENV{REMOTE_ADDR},
		   $url, $qlength, $ENV{HTTP_USER_AGENT};
}
# -------------------------------------------------------------------- #
#	Get the name of this script
# -------------------------------------------------------------------- #
sub get_int_name {
	my $name;
    if ( defined $ENV{SCRIPT_NAME} ){
        $name = (split( /[\?\#]/, $ENV{SCRIPT_NAME} ))[0];
        $name = ( $name =~ m#([^/]+)$# )[0];
    }
	if ( $name =~ /^$/ ) {
	    $name = ( $0 =~ m#([^/]+)$# )[0]
	}
	$name;
}
# -------------------------------------------------------------------- #
#   Display infomation as plain text
# -------------------------------------------------------------------- #
sub disp_plain {
    print "\n";
    print "-" x 79, "\n";               # <HR>
    my $info = &conv_disp();
    my( $name ) = ( $0 =~ m#([^/]+)$# );
    print join( "", @$info );
    print "-" x 79, "\n";               # <HR>
    print $name;                        # Script name
    print " (Version $main::VERSION)" if defined $main::VERSION;
    print " with Perl $] for $^O\n";    # Perl versoin
}
# -------------------------------------------------------------------- #
#   Display infomation as HTML
# -------------------------------------------------------------------- #
sub disp_html {
    my $time = scalar localtime;

    my $info = &conv_disp();
    foreach ( @$info ) {
        s#^>#\255#g;
        s#&#&amp;#g;
        s#<#&lt;#g;
        s#>#&gt;#g;
        s:^\255(.*)$:</b><font color="#008080">&gt;\t$1</font><b>:g;
        s#\n#<br>\n#g;
    };
    my $name;
    if ( defined $ENV{REQUEST_URI} ){
        ( $name ) = split( /[\?\#]/, $ENV{REQUEST_URI} );
        ( $name ) = ( $name =~ m#([^/]+)$# );
    }
    ( $name ) = ( $0 =~ m#([^/]+)$# ) if ( $name =~ /^$/ );

    print "Catch: $time<hr><!--\n";             # HTML comment trick
    print "Content-Type: text/html\n\n";        # HTTP header
    print "<html><head>\n";                     # HTML header
    print "<title>Catch: $time</title>\n";      # Page title
    print "</head><body text='#000000' bgcolor='#FFFFFF'>\n";
    print "Catch: $time<hr><! -->\n";           # Title again
    print "<tt><b><font color='#E00000'>\n";
    print @$info;
    print "</font></b></tt><hr>\n";
    print "<tt><a href='$name'>$name</a></tt>"; # Script name
    print " (Version $main::VERSION)" if defined $main::VERSION;
    print " with Perl $] for $^O\n";            # Perl versoin
    print "\n</body></html>\n";                 # HTML footer
}
# -------------------------------------------------------------------- #
#   Format warn/die message into text for output
# -------------------------------------------------------------------- #
sub conv_disp {
    my $out = [];
    foreach my $array ( @$messbuf ){
        my( $type, $mess, $pack, $file, $line, $sub ) = @$array;
        $file =~ s#^.*[/\\]##;                  # Enshort filename
        chomp $mess;
        my $temp = sprintf( "[%s:%d:%s] %s\n", $file, $line, $type, $mess );
        push( @$out, $temp );
        if ( $argv->{source} and $line > 0 ) {
            open ( TEMP, $file ) and do {
                my $c = 1;
                while ( <TEMP> ){
                    if ( $line == $c++ ) {
                        chomp;
                        push( @$out, "> $_\n" );
                        last;
                    }
                }
            };
        }
    }
    $out;
}
# -------------------------------------------------------------------- #
#   false when in eval, or return caller (except for Carp.pm)
# -------------------------------------------------------------------- #
sub get_caller {
    my $c = 1;
    my $result;
    while( 1 ){
        my( $pack, $file, $line, $sub, $hasargs,
            $wantarray, $evaltext, $is_require ) = caller( $c ++ ) or last;
        last if $is_require;                    # between require or use
        return undef if ( $sub eq "(eval)" );   # cancel when in eval
        if( $pack eq "Carp" ){
            $c ++;
        }else{
            $result ||= [ $pack, $file, $line, $sub ];
        }
    }
    $result;
}
# -------------------------------------------------------------------- #
1;
# -------------------------------------------------------------------- #