# -------------------------------------------------------------------- #
#   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 );             # Original style
    use KCatch qw( mode=plain );        # New style

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

    use KCatch qw( html );              # Original style
    use KCatch qw( mode=html );         # New style

Force to make output as HTML for CGI.

    use KCatch qw( source );

Display also warned or died Perl source code for debugging.
(Note: 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.
Usually, it would be saved to "/usr/local/apache/logs/error_log".

    use KCatch qw( execdata );__DATA__

Execute code after token "__DATA__" in the file which calls KCatch.
You should put the token "__DATA__" just next to call KCatch.
This option is VERY STRONG to force to catch almost the all errors,
and becomes the Savior in case your-annoying-bugs never disappears!

    use KCatch qw( jcode=sjis );
    use KCatch qw( jcode=euc );
    use KCatch qw( jcode=jis );

Convert the charactor-code-set of the error infomations for Japanese.
This option make work when "jcode.pl" is already required.

=head1 VERSIONS

    1999/11/05 v1.02 First Release
    1999/11/23 v1.03 Recognize between under "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
    2000/10/27 v1.08 No use of uninitialized values
    2000/12/09 v1.10 the Savior option qw( execdata ) avaliable!
                     output templete separated, jcode=* supported

=head1 SITES

    http://www.kawa.net/works/perl/catch/
    http://www.harukaze.net/~mishima/perl/cgi-debug-env/deb-tech.html
    http://www.layer-8.com/sce/smp_detail.php3?argCatId=7&argSmpId=3

=head1 AUTHOR

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

=cut
# -------------------------------------------------------------------- #
    package KCatch;
    use strict;
# -------------------------------------------------------------------- #
    my $argv = {};                      # Option arguments when "use"
    my $caller;                         # 
    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;
    foreach my $elem ( @_ ) {
        my( $key, $value ) = split( /=/, $elem, 2 );
        $value = ! undef unless defined $value;
        $argv->{$key} = $value;
    }
    $caller = [ caller() ];
}
# -------------------------------------------------------------------- #
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 {
    if ( $argv->{execdata} ) {          # Execute __DATA__ area under eval
        &savior_exec_data();
    }
    return if ( $#$messbuf < 0 );       # Exit if no errors
    if ( $argv->{stderr} ) {
        &disp_stderr();                 # Additional information
    }
    &make_output();                     # Display buffer
}
# -------------------------------------------------------------------- #
sub env {
    $ENV{$_[0]} if exists $ENV{$_[0]};
}
# -------------------------------------------------------------------- #
#   execute source after __DATA__ token
# -------------------------------------------------------------------- #
sub savior_exec_data {
    my $handle = $caller->[0]."::DATA";
    my $source = [ <$handle> ];
    my $string = join( "", @$source );
    eval $string;
    if ( $@ ) {
        my $estr = "$@";
        $estr =~ s/,? at \(eval \d+\) line (\d+),?/,/g;
        my $line = $1;
        push( @$messbuf, [ "die", $estr, $caller->[0], $caller->[1],
                           '"__DATA__"+'.($line), "__DATA__", 
                           ($line>0) ? $source->[$line-1] : undef ] );
    }
}
# -------------------------------------------------------------------- #
#   Output additional information to STDERR
# -------------------------------------------------------------------- #
sub disp_stderr {
    my $name = ( $0 =~ m#([^/]+)$# )[0];
    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");
}
# -------------------------------------------------------------------- #
#   make output
# -------------------------------------------------------------------- #
sub make_output {
    my $mode = &select_output_mode();
    my $errorinfo = &conv_disp();
    if ( $mode eq "html" ) {
        $errorinfo =~ s#^>#\255#mg;
        $errorinfo =~ s#&#&amp;#g;
        $errorinfo =~ s#<#&lt;#g;
        $errorinfo =~ s#>#&gt;#g;
        $errorinfo =~ s:^\255(.*)$
                       :</b><font color="#008080">&gt;\t$1</font><b>:mgx;
        $errorinfo =~ s#$#<br>#mg;
    }
    my $var = { %ENV };
    $var->{localtime} = localtime();
    $var->{errorinfo} = $errorinfo;
    $var->{filename} = ( $0 =~ m#([^/]+)$# )[0];
    $var->{version} = " (Version $main::VERSION)" if defined $main::VERSION;
    $var->{perlver} = $];
    $var->{osname}  = $^O;
    my $output;
    if ( $mode eq "html" ) {
        $output = &templete_for_html();
    } else {
        $output = &templete_for_plain();
    }
    $output =~ s/\{(\w+)\}/$var->{$1}/g;
    print $output;
}
# -------------------------------------------------------------------- #
#   select output mode
# -------------------------------------------------------------------- #
sub select_output_mode {
    return $argv->{mode} if defined $argv->{mode};
    my $mode = "plain";                 # Plain text as default
    if ( $argv->{html} ) {
        $mode = "html";                 # Force HTML
    } elsif ( $argv->{plain} ) {
        $mode = "plain";                # Force plain text
    } elsif ( &env("GATEWAY_INTERFACE") =~ /cgi/i ){
        $mode = "html";                 # Auto detect CGI
    }
    $mode;
}
# -------------------------------------------------------------------- #
#   Format warn/die message into text for output
# -------------------------------------------------------------------- #
sub conv_disp {
    my $option = shift;
    my $oarray = [];
    foreach my $iarray ( @$messbuf ){
        my( $type, $mess, $pack, $file, $line, $sub, $src ) = @$iarray;
        $file =~ s#^.*[/\\]##;                  # Enshort filename
        chomp $mess;
        my $eline = sprintf( "[%s:%s:%s] %s\n", 
                    $file, ($line||"?"), $type, $mess );
        push( @$oarray, $eline );
        if ( $argv->{source} ) {
            if ( $src eq "" and $line > 0 ) {
                $src = &read_source_line( $file, $line );
            }
            push( @$oarray, "> $src" ) if ( $src ne "" );
        }
    }
    if( $argv->{jcode} and defined $jcode::version ) {
        1 if defined $jcode::version; # (not typo)
        foreach my $str ( @$oarray ) {
            &jcode::convert( \$str, $argv->{jcode} );   # tested
        }
    } elsif( $argv->{Jcode} and defined $Jcode::VERSION ) {
        1 if defined $Jcode::VERSION; # (not typo)
        foreach my $str ( @$oarray ) {
            &Jcode::convert( \$str, $argv->{Jcode} );   # not tested
        }
    }
    my $ostr = join( "\n", @$oarray );
    $ostr =~ s/[\n\r]+/\n/sg;
    $ostr =~ s/\n+$//sg;
    $ostr;
}
# -------------------------------------------------------------------- #
#   read source file
# -------------------------------------------------------------------- #
sub read_source_line {
    my $file = shift;
    my $lnum = shift;
    return unless ( -r $file );
    open ( TEMP, $file ) or return;
    my $c = 1;
    my $oline;
    while ( $oline = <TEMP> ){
        last if ( $lnum == $c++ );
    }
    close( TEMP );
    $oline;
}
# -------------------------------------------------------------------- #
#   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;
}
# -------------------------------------------------------------------- #
#   Output templete for plain text.
# -------------------------------------------------------------------- #
sub templete_for_plain {'
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
{errorinfo}
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
{filename}{version} with Perl {perlver} for {osname}
';}
# -------------------------------------------------------------------- #
#   Output templete for HTML (HTTP+HTML header magic)
# -------------------------------------------------------------------- #
sub templete_for_html {'Catch: {localtime}<hr><!-- >
Content-Type: text/html

<html><head>
<title>Catch: {localtime}</title>
</head><body text="#000000" bgcolor="#FFFFFF">
Catch: {localtime}<hr><! " -->
<tt><b><font color="#E00000">
{errorinfo}
</font></b></tt><hr>
<tt><a href="{REQUEST_URI}">{filename}</a></tt>{version}
with Perl {perlver} for {osname}
</body></html>
';}
# -------------------------------------------------------------------- #
;1;
# -------------------------------------------------------------------- #
