package Debug;
##############################################################
# デバッグ用ツール     umino@uic.jp
#
# my $DEBUG = { mode_name => 'debug', cookie_name => 'debug', password => 'dpass' };
# my %DCKI = $cgi->cookie($DEBUG->{cookie_name});
# $DBG->{_flag} = 1 if $DCKI{password} eq $DEBUG->{password};
# if($ENV{MOD_PERL}) { *CORE::GLOBAL::exit = sub { print debug($DBG); &Apache::exit } }
# else               { *exit               = sub { print debug($DBG);    CORE::exit } }
# print debug_set($DEBUG, { exec => $FRM{exec}, expires => $FRM{expires}, password => $FRM{password} }) and exit if exists $FRM{$DEBUG->{mode_name}};
##############################################################

use strict;
use CGI;

use Exporter;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
@ISA         = qw(Exporter);
@EXPORT      = qw(show_debug debug_set);

;################################
;# init_debug
;################################
sub init_debug
{
    my $dbg = shift;
    my $flg = shift;
    my $bnc = shift;

    if($ENV{MOD_PERL})    { *CORE::GLOBAL::exit = sub { print show_debug({variable => $dbg, flag => $flg, bench => $bnc}); \&Apache::exit } }
    else                  { *::exit             = sub { print show_debug({variable => $dbg, flag => $flg, bench => $bnc});    CORE::exit } }

    return;
}

;################################
;# debug
;################################
sub show_debug
{
    my $argv = shift;
    my $DBG = $argv->{variable};
    my $BNC = $argv->{bench};

    my ($DEF, @date, $print_date, $out_put);

    return if !$argv->{flag};

    my $con = -t STDOUT ? 1 : 0;

    ### ヘッダー
    if ($con) {
        $out_put .= '-' x 50 . "\n";
        $out_put .= "Debug mode\n";
        $out_put .= '-' x 50 . "\n";
        $out_put .= "File info\n";
    } else {
        $out_put .= "<!-- DEBUG -->\n<br>\n";
        $out_put .= qq|<table bgcolor="#F0F3FE" width="100%"><tr><td>\n|;
        $out_put .= "<pre>\n";
        $out_put .= qq|<hr size="3" color="#ff0000">Debug mode\n|;
        $out_put .= qq|<hr size="3" color="#ff0000">\n|;
        $out_put .= "<b>File info</b>\n";
    }

    ### スクリプト情報
    ($DEF->{'zpath'}, $DEF->{'script'}) = $0 =~ /^(.*\/)?(.*)$/;
    $out_put .= "script    : $DEF->{'script'}\n";
    $out_put .= "path      : $DEF->{'zpath'}\n";

    my $size = (stat $DEF->{'script'})[7];
    $size =~ s/(\d{1,3})(?=(?:\d\d\d)+(?!\d))/$1,/g;
    $out_put .= "size      : $size bytes\n";

    @date       = localtime(time);
    $print_date = sprintf("%04d/%02d/%02d %02d:%02d:%02d", $date[5]+1900, $date[4]+1, $date[3], $date[2], $date[1], $date[0]);
    $out_put .= "now time  : $print_date\n";

#	@date       = localtime((stat $DEF->{'script'})[8]);
#	$print_date = sprintf("%04d/%02d/%02d %02d:%02d:%02d", $date[5]+1900, $date[4]+1, $date[3], $date[2], $date[1], $date[0]);
#	$out_put .= "最終アクセス時刻：$print_date\n";

    @date       = localtime((stat $DEF->{'script'})[9]);
    $print_date = sprintf("%04d/%02d/%02d %02d:%02d:%02d", $date[5]+1900, $date[4]+1, $date[3], $date[2], $date[1], $date[0]);
    $out_put .= "mod time  : $print_date\n";

#	@date       = localtime((stat $DEF->{'script'})[10]);
#	$print_date = sprintf("%04d/%02d/%02d %02d:%02d:%02d", $date[5]+1900, $date[4]+1, $date[3], $date[2], $date[1], $date[0]);
#	$out_put .= "最終iノード変更時刻：$print_date\n";

    my $uname  = getpwuid $>;
    my $uname2 = getpwuid $<;
    my $gname  = getgrgid $);
    my $gname2 = getgrgid $(;
    if ($con) {
        $out_put .= qq|author    : \$> = $>($uname) \$< = $<($uname2) \$) = $)($gname) \$( = $(($gname2)\n|;
    } else {
        $out_put .= qq|author    : \$> = $>($uname) <font color="#666666">\$< = $<($uname2)</font> \$) = $)($gname) <font color="#666666">\$( = $(($gname2)</font>\n|;
    }
    $out_put .= qq|process   : $$\n|;
    $out_put .= "\n";

    ### ベンチマーク
    $out_put .= $con ? "CPU time\n" : "<b>CPU time</b>\n";
    my ($total_time, $first_time);
    foreach my $key (@{ $BNC }){
        $first_time = $key->{time} if !defined $first_time;
        $total_time = $key->{time};
    }

    my ($space, $i);
    foreach my $key (@{ $BNC }){
        $key->{time} -= $first_time;
        my $per = $key->{time} / ($total_time - $first_time) * 100 if $key->{time} != 0;
        $space =~ s/  $// if($key->{flag} eq 'end');
        my $head_kigo = '';
#		my $head_kigo = $start_end eq 'start' ? '&gt;' : '&lt;';
        if ($con) {
            $out_put .= sprintf "%.5f %-30s %10.5f\n", $key->{time}, "$space$head_kigo $key->{name}", $per;
        } else {
            $out_put .= qq|<font color="#666666">| if ++$i % 2;
            $out_put .= sprintf "%.5f %-30s %10.5f\n", $key->{time}, "$space$head_kigo $key->{name}", $per;
            $out_put .= qq|</font>| if $i % 2;
        }
        $space .= '  ' if $key->{flag} eq 'start';
    }
    $out_put .= "\n";

    if ($con) {
        $out_put .= "debug info\n";
    } else {
        $out_put .= "<b>debug info</b>\n";
        $out_put .= "<xmp>\n";
    }
    $out_put .= "-SCALAR\n";
    foreach(keys %{ $DBG }){
        next unless ref($DBG->{$_}) eq '';
        &_change_code(\$DBG->{$_}, 'sjis');
        $DBG->{$_} =~ s/\0/\\0/g;
        $DBG->{$_} =~ s/\n/\n                    /g;
        $out_put .= sprintf "[%-15s] = %s\n", $_, $DBG->{$_};
    }
    $out_put .= "\n";

    $out_put .= "-REF SCALAR\n";
    foreach(keys %{ $DBG }){
        next unless ref($DBG->{$_}) eq 'SCALAR';
        &_change_code($DBG->{$_}, 'sjis');
        ${ $DBG->{$_} } =~ s/\0/\\0/g;
        ${ $DBG->{$_} } =~ s/\n/\n                    /g;
        $out_put .= sprintf "[%-15s] = %s\n", $_, ${ $DBG->{$_} };
    }
    $out_put .= "\n";

    $out_put .= "-REF ARRAY\n";
    foreach(keys %{ $DBG }){
        next unless ref($DBG->{$_}) eq 'ARRAY';
        $out_put .= "---\@$_ [$DBG->{$_}]---\n";
        my $i = 0;
        foreach(@{ $DBG->{$_} }){
            &_change_code(\$_, 'sjis');
            s/\0/\\0/g;
            s/\n/\n                    /g;
            $out_put .= sprintf "[%8d] = %s\n", $i++, $_;
        }
        $out_put .= "\n";
    }
    $out_put .= "\n";

    $out_put .= "-REF HASH\n";
    foreach my $key(keys %{ $DBG }){
        next unless ref($DBG->{$key}) eq 'HASH';
        $out_put .= "---\%$key [$DBG->{$key}]---\n";
        foreach(sort keys %{ $DBG->{$key} }){
            &_change_code(\$DBG->{$key}->{$_}, 'sjis');
            $DBG->{$key}->{$_} =~ s/\0/\\0/g;
            $DBG->{$key}->{$_} =~ s/\n/\n                    /g;
            $out_put .= sprintf "[%-15s] = %-s", $_, "$DBG->{$key}->{$_}\n";
        }
        $out_put .= "\n";
    }
    $out_put .= "\n";

#	$out_put .= `/bin/tail -30 /var/log/httpd/error_log`;

    if (!$con) {
        $out_put .= "</xmp>\n";
        ### フッター
        $out_put .= qq|<hr size="3" color="#ff0000"></pre>\n|;
        $out_put .= qq|</td></tr></table>\n|;
    }

    return $out_put;
}


;################################
;# デバッグセット
;################################
sub set_debug
{
    my $masta = shift;
    my $frm   = shift;

    my ($cookie_header, $message, $out_put);
    if($frm->{exec} ne ''){
        if($frm->{password} eq $masta->{password}){
            my $cookie = new CGI;
            my $expires = $frm->{expires};
            $cookie_header = $cookie->cookie(-name => $masta->{cookie_name}, -expires => $expires, -value => { password => $frm->{password} });
            $message  = "デバッグクッキーをセットしました<br>\n";
            $message .= "Set-Cookie: $cookie_header\n";
        }else{
            $message = "パスワードが一致しません\n";
        }
    }


    $out_put  = "Content-type:text/html\n";
    $out_put .= "Set-Cookie: $cookie_header\n" if $cookie_header;
    $out_put .= "\n";

    $out_put .= qq|<html><head>\n|;
    $out_put .= qq|<meta http-equiv="Content-Type" content="text/html;charset=shift_jis">\n|;
    $out_put .= qq|</head><body>\n|;
    $out_put .= qq|$message\n|;
    $out_put .= qq|<table border="1">\n|;
    $out_put .= qq|<form method="POST">\n|;
    $out_put .= qq|<input type="hidden" name="$masta->{mode_name}" value="1">\n|;
    $out_put .= qq|<input type="hidden" name="exec" value="1">\n|;
    $out_put .= qq|<tr><td align="right">パスワード:</td><td><input type="password" name="password" value=""></td></tr>\n|;
    $out_put .= qq|<tr><td align="right">期間:</td><td><input type="text" name="expires" value=""></td></tr>\n|;
    $out_put .= qq|<tr><td align="center" colspan="2"><input type="submit" value="SET"></td></tr>\n|;
    $out_put .= qq|</form>\n|;
    $out_put .= qq|</table>\n|;
    $out_put .= qq|※期間「0」もしくは無入力でセッション内、「-1」で削除<br>\n|;
    $out_put .= qq|</body></html>\n|;

    return $out_put;
}

;################################
;# change code
;################################
sub _change_code
{
    my $char = shift;
    my $target_code = shift;

    my ($match, $kcode) = Jcode::getcode($char) if $INC{'Jcode.pm'};
#	Jcode::convert($char, $target_code) if $target_code ne $kcode;
}

1;