#!/usr/local/bin/perl

#-----------------------------------------------------------------------------
#-
#- ブラクラチェッカー by kuri|minima
#- 4/18 conchから持ってきた ver. 0.01
#-
#-----------------------------------------------------------------------------


# 【重大な警告】
#
#　　　このスクリプトは決して利用しないで下さい。
#　　　常識的な HTTP 処理を行っておらず，
#　　　ネットワークに無用な負荷を与えるだけです。
#　　　我ながら "厨房さ" 炸裂のスクリプトでした。とほほー。
#



use Socket;

$cgi = './bcc.cgi';
$version = '0.03';
$copyright = '<HR><FONT size="2">Browser Crasher Checker - (C) kuri|minima. All rights reserved.(warai</FONT>';
$view = './view.cgi'; #チェック済みサイト表示
$nowTime = time;
$data_not_enough = 0;  # データが不十分だったらコレ
$lastdata = ''; # タイムアウト処理された時，直前に受け取ったデータはここ

#-----------------------------------------------------------------------------
#- GETデータ取得
#-----------------------------------------------------------------------------
$url = $ENV{'QUERY_STRING'};

#- 270というのは，ほんのわずかな優しみのつもり（わらい
if( 270 < length( $url ) ){
	$url = substr( $url, 0, 255 );
}

$url =~ s/\++$//;
$url =~ s/%([2-7][a-fA-F0-9])/pack("C",hex($1))/eg;
$url =~ s/^url=//;

$url =~ s/\x7f/%7f/ig;

$url =~ s/,/%2c/g;
$url =~ s/</%3c/g;
$url =~ s/\r/%0d/g;
$url =~ s/\n/%0a/g;

# $url = 'http://127.0.0.1/~tkuri/';
$url =~ s/http...cgi.coara.or.jp.cgi.bin.cgiwrap.tkuri//ig;

$target_url = $url;

#-----------------------------------------------------------------------------
#- URLがなければ，最初のページを表示して終わり
#-----------------------------------------------------------------------------
if( $target_url eq '' )
{
	print "Content-type: text/html\n\n";

	&title;

	&form;

	$bcc_help = 'http://www.coara.or.jp/~tkuri/BC/help.htm';

	print <<"_HTML_";

<HR><A target="_blank" href="$view">チェック済みURL一覧</A></FONT>

<HR><A target="_blank" href="http://www.kakiko.com/check/sample.html">飛び先のチェック</A> by ぴょん基地の友達 - 併せてご覧下さい

<HR>&quot;concon問題&quot;修正モジュール：<BR>
<A href="http://www.a2001.com/down/concon.html">Decon</A>
- <FONT size="2">→<A href="http://www.a2001.com/">株式会社テクノクラフト</A></FONT><BR>
<A href="http://www.microsoft.com/japan/support/kb/articles/J052/7/92.htm">サポート技術情報</A>
- <FONT size="2">→Microsoft社から修正モジュールが出ています</FONT>

<HR><!-- FONT size="2"><A target="_blank" href="$bcc_help">ヘルプ</A></FONT -->

<P align="center">
<HR>
<FONT size="2">
この情報による損害は責任とれません。<BR>
当然，リンクは自由。商用も雑誌掲載も知りません。ご自由に。<BR>
ソ\ースは<A href="http://www.coara.or.jp/~tkuri/">Smart Contents Collection</A>の方で。商売でも何でもご自由に(´ー｀)<BR>
<BR>
これ，↓流行ってます←虚偽<BR>
　 &lt;FORM action=&quot;http://cgi.coara.or.jp/cgi-bin/cgiwrap/tkuri/BCC/bcc.cgi&quot; method=&quot;GET&quot;&gt;<BR>
　 Browser Crasher Checker : &lt;INPUT type=&quot;text&quot; name=&quot;url&quot; size=&quot;60&quot; value=&quot;http://&quot;&gt;
&lt;INPUT type=&quot;submit&quot; value=&quot;Check&quot;&gt;<BR>
　 &lt;/FORM&gt;<BR>
デザインは各自で工夫してください。<BR>
<BR>
こんな使い方を不許可にした覚えはありませんヽ('-'*)<BR>
　 &lt;A href=&quot;http://cgi.coara.or.jp/cgi-bin/cgiwrap/tkuri/BCC/bcc.cgi?http://www.minima.com/~minima/&quot;&gt;<BR>
　 http://www.minima.com/~minima/ を検査する<BR>
　 &lt;/A&gt;<BR>
<BR>
4/30 ver. 0.03<BR>
　 ↓20秒内にデータを処理できなくても，&lt;/HTML&gt;まではちゃんとデータを取得できているのです。<BR>
　 あと，検査済みURL一覧をソ\ートしました。やっぱりこっちの方がみやすいです。<BR>
4/25 ver. 0.02<BR>
　 どうして<A href="http://www.goo.ne.jp" target="_blank">http://www.goo.ne.jp</A>を検査しても20秒内にデータを処理できないかなぁと思ったら・・・。<BR>
4/23 ver. 0.01 unfold...<BR>
　 っていうか，conconチェッカーのスクリプトをそのまま使いまわしてます。笑い
</FONT>
</P>
$copyright
</BODY></HTML>
_HTML_

exit;
}


#-----------------------------------------------------------------------------
#- サーバ名，ポートを取得
#-----------------------------------------------------------------------------
if( $target_url =~ m|^http://(.*?)/(.*)| ){
	($server, $port) = split(/:/, $1);
	$url = '/' . $2;
	$port = 80 unless $port;
}
else{
	&error_html("URLの記述が間違っていませんか？");
}



#-----------------------------------------------------------------------------
#- タイムアウト処理ルーチン
#-----------------------------------------------------------------------------
$timeout= 20;

sub timeout_server{
	close( SOCK );
	$data_not_enough = 1;
	if( $lastdata =~ /<\/HTML>/i ){
		$data_not_enough = 2;
	}
}



#-----------------------------------------------------------------------------
#- サーバに接続開始
#-----------------------------------------------------------------------------
#- ホスト名からIPアドレスを取得
$ipaddr = inet_aton( $server )
	or &error_html("$server : IPアドレスが取得できません");

#- ソケットのオープン
# socket( SOCK, PF_INET, SOCK_STREAM, getprotobyname( 'tcp' ) )
socket( SOCK, AF_INET, SOCK_STREAM, getprotobyname( 'tcp' ) )
	or &error_html("ソ\ケットがオープンできませんでした<BR>ごめんなさい");

#- ホスト，ポートへの接続
# if( !connect( SOCK, sockaddr_in( $port, $ipaddr ) ) ) {
if( !connect( SOCK, pack( 'S n a4 x8', AF_INET, $port, $ipaddr) ) ) {
	close( SOCK );
	&error_html("$server:$port に接続できませんでした");
}
        
#- ソケットのバッファリングを止める
select( SOCK ); $| = 1; select( STDOUT );



#-----------------------------------------------------------------------------
#- リクエストをサーバに送る
#-----------------------------------------------------------------------------
print SOCK "GET $url HTTP/1.1\r\n";
print SOCK "Referer: $target_url\r\n";
print SOCK "Host: $server\r\n";
print SOCK "Accept: */*\r\n";
print SOCK "User-Agent: BrowserCrasherChecker $version\r\n";
print SOCK "\r\n";


#-----------------------------------------------------------------------------
#- 受信
#-----------------------------------------------------------------------------
#- タイムアウトの設定
$SIG{'ALRM'} = \&timeout_server;
alarm( $timeout );

$head = '';
$text = '';

$status = '';
$content = ''; #- テキストかどうか
$len = 0;

$head_flg = 1; #- ヘッダを見分けるためのフラグ

while ( <SOCK> ){

	#- タイムアウト設定
	alarm( $timeout );

	#- とりあえず，これ
	# s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;

	#- ヘッダかどうかを見分ける
	if( $_ eq "\n" || $_ eq "\r\n" ){ $head_flg = 0; }

	#- まだヘッダなら
	if( $head_flg ){

		$head .= $_;
		chomp;
		($mes, $cont) = split(/:/, $_, 2);
		$cont =~ s/ //g;

		#----------------------------------
		#- ここで Location チェック
		#----------------------------------
		if( $mes =~ m/Location/i ){
			$head_location = $cont;
			if( &file_scheme( $cont ) ){
				$head_location_filescheme = 1;
			}
		}

		#- forbidden とか，not found とか
		if( $mes =~ m/HTTP(.*)403(.*)Forbidden/i ){
			$status = 'forbidden';
		}
		if( $mes =~ m/HTTP(.*)404(.*)Not/i ){
			$status = 'notfound';
		}

		#- コンテントデータはどうよ？
		if( $mes =~ m/Content-type/i ){
			$content = $cont;
		}
	}
	else{
		#- 連結
		$len += length( $_ );
		$text .= $lastdata = $_;
		if( 204800 < $len ){ # 200kbまで
			$data_not_enough = 3;
			last;
		}
	}
}

close( SOCK );
alarm( 0 );

#- htaccess はチェックはこれだけ
if( $target_url =~ /htaccess$/ ){

	if( $status eq 'forbidden' ){
		$htaccess_forbidden = 1;
		goto _Print;
	}

	$htaccess_filescheme = &file_scheme( $text );

	goto _Print;
}

#- cssファイルはチェックはこれだけ
if( $content =~ /text\/css/ ){
	$css_filescheme = &file_scheme( $text );
	goto _Print;
}

$text_view = $text;

$text =~ s/[\r\n]/ /g;
$text =~ s/\s*url/url/ig;
$text =~ s/["']/ /g;
$text =~ s/&quot;/ /ig;
# $text =~ s/([>\)])/ $1/g;
$text =~ s/>/ >/g;
$text =~ s/\s*([=\(])\s*/$1/g;
$text =~ s/\s*\+\s*//g;

@in_style = ( $text =~ m!<STYLE.*{(.*?)}.*</STYLE!ig );

@window_open = ( $text =~ m!<SCRIPT.*open\(([^\)\s]*).*</SCRIPT!ig );
@history_go = ( $text =~ m!<SCRIPT.*go\(([^\)]*).*</SCRIPT!ig );
@location_js = ( $text =~ m!<SCRIPT.*location=([\S]*).*</SCRIPT!ig );
@location_href = ( $text =~ m!<SCRIPT.*location.href=([\S]*).*</SCRIPT!ig );
@navigate = ( $text =~ m!<SCRIPT.*navigate\(([^\)]*).*</SCRIPT!ig );
@src_js = ( $text =~ m!<SCRIPT.*\.src=([\S]*).*</SCRIPT!ig );

$text =~ s/>.*?</></g;

@tags = split( '<', $text ); #- 今回はこれがキーです。笑い

#-----------------------------------------------------------------------------
#- タグチェック
#-----------------------------------------------------------------------------
foreach( @tags ){

	study; # 効果はあるのかな？

	if( /style=([\S]*)/i ){ push( @style_prop, $1 ); }

	push @window_open, ( m!open\(([^\)]*)!g );
	push @history_go, ( m!go\(([^\)]*)!g );
	push @location_js, ( m!location=([\S]*)!g );
	push @location_href, ( m!location.href=([\S]*)!g );
	push @navigate, ( m!navigate\(([^\)]*)!g );
	push @src_js, ( m!\.src=([\S]*)!g );
	push @src_js, ( m!\.lowsrc=([\S]*)!g );

	if( /^img/i ){ # imgタグ 量が多いから特別にココで

		if( (!$html_img_filescheme) && (!$html_img_mailto) ){
			$html_img_is = 1;
		}

		#- file:// と mailto: が両方あった -> これ以上imgを調べる余地なし
		if( $html_img_filescheme && $html_img_mailto ){ next; }
		#- imgが50を超えた -> これ以上imgを調べたくない
		if( 50 < @img ){ next; }

		($temp) = ( /src=([^\s]*)/i );
		foreach( @img ){  #重複uzeee
			if( $temp eq $_ ){ goto _Escape; }
		}
		if( &file_scheme( $temp ) ){
			$html_img_filescheme = 1;
			$html_img_is = 0;
		}
		elsif( $temp =~ m!^mailto:!i ){
			$html_img_mailto = 1;
			$html_img_is = 0;
		}
		push( @img, $temp );
		next;
	}

	if( /^a/i ){ # <A> or <AREA> 量が多いから特別にココで

		#- file:// があった -> これ以上調べる余地なし
		if( $html_ank_filescheme ){ next; }

		if( /onmouseover=([\S]*)/i ){ push @ank_onmouseover, $1; }

		($temp) = ( /href=([\S]*)/i );
		foreach( @ank ){  #重複uzeee
			if( $temp eq $_ ){ goto _Escape; }
		}
		if( &file_scheme( $temp ) ){
			$html_ank_filescheme = 1;
		}
		push( @ank, $temp );
		next;
	}

	# tableタグネストチェック
	if( /^table/i ){ # <table> カウンタ

		$nest_table++;
		if( 10 < $nest_table ){ $html_table_nest = 1; } # ネストが10を超えた
		next;
	}
	if( /^\/table/i ){ # </table> カウンタ

		if( 0 < $nest_table ){ $nest_table--; }
		next;
	}

	if( /^meta.*url=([\S]*)/i ){ $meta = $1;  next; }

	if( /^frame.*src=([\S]*)/i ){ push( @frame, $1 );  next; }

	if( /^embed.*src=([\S]*)/i ){ push( @embed, $1 );  next; }
	if( /^iframe.*src=([\S]*)/i ){ push( @iframe, $1 );  next; }
	if( /^layer.*src=([\S]*)/i ){ push( @layer, $1 );  next; }

	if( /^b.*ground=([\S]*)/i ){ push( @body, $1 );  next; }
	if( /^body.*onload=([\S]*)/i ){ push( @body_onload, $1 );  next; }
	if( /^in.*src=([\S]*)/i ){ push( @input, $1 );  next; }
	if( /^l.*rel=([\S]*)/i ){ push( @rel_of_link, $1 ); }
	if( /^l.*href=([\S]*)/i ){ push( @link, $1 );  next; }
	if( /^obj.*(?:data|classid)=([\S]*)/i ){ push( @object, $1 );  next; }
	if( /^s.*src=([\S]*)/i ){ push( @script, $1 );  next; }
	if( /^t.*ground=([\S]*)/i ){ push( @table, $1 );  next; }

	if( /^fo.*on=([\S]*)/i ){ push( @form, $1 );  next; } # <FORM action=...>

	if( /^base.*href=([\S]*)/i ){ $baseurl = $1; }

_Escape: 1;
}




#-----------------------------------------------------------------------------
# conconチェック，mailto:チェック
#-----------------------------------------------------------------------------

#-- HTML lv.A -- 自動で他のURLを読み込むタグ
$html_lvA_is = 0;
foreach( $meta, @frame ){ # $metaはスカラね

	unless( $_ ){ next; } # $meta がスカラなもんで，必ず1回はループに入ってくる
	$html_lvA_is = 1;  #- とりあえず，何かあったということで

	if( &file_scheme( $_ ) ){
		$html_lvA_filescheme = 1;
		$html_lvA_is = 0;
		last;
	}
}

#-- HTML lv.B -- 機種によって違うタグ
foreach( @embed, @iframe, @layer ){

	unless( $html_lvB_filescheme ){
		$html_lvB_is = 1;
	}
	if( &file_scheme( $_ ) ){
		$html_lvB_filescheme = 1;
		$html_lvB_is = 0;
	}
	if( $cont =~ /^mailto:/ ){ $html_lvB_mailto = 1; }
}

$lfh = 0;	# lfh = "@link" from here.(warai
#-- HTML lv.C -- 一般的なHTMLタグ
#- imgは調査済み
foreach( @body, @input, @object, @script, @table, 'lfh', @link ){

	if( $_ eq 'lfh' ){ $lfh = 1;  next; }

	if( !$html_lvC_filescheme && ($_ ne 'lfh') ){
		$html_lvC_is = 1;
	}

	if( &file_scheme( $_ ) ){
		$html_lvC_filescheme = 1;
		$html_lvC_is = 0;
	}
	if( !$lfh && /^mailto:/ ){ $html_lvC_mailto = 1; }
}

#-- JavaScriptのﾔｼ
foreach( @window_open, @history_go, @location_js, @location_href, @navigate, @src_js ){

	unless( $javascript_filescheme ){
		$javascript_is = 1;
	}

	if( &file_scheme( $_ ) ){
		$javascript_filescheme = 1;
		$javascript_is = 0;
	}
	if( /^mailto:/ ){ $javascript_mailto = 1; }
}

#-- スタイルシート
foreach( @style_prop, @in_style ){

	unless( $stylesheet_filescheme ){
		$stylesheet_is = 1;
	}

	if( m!file:[/|\\]+!i || m![a-zA-Z]:[/|\\]! ){
		$stylesheet_filescheme = 1;
		$stylesheet_is = 0;
	}
	if( /^mailto:/ ){ $stylesheet_mailto = 1; }
}

# <form>
foreach( @form ){
	if( &file_scheme( $_ ) ){
		$html_ank_filescheme = 1; # これはアンカータグと同じね
	}
}

# 意外と見落としがち
# <base>は全てのURLを汚染する
if( &file_scheme( $baseurl ) ){
	$baseurl = '';
	$html_base_filescheme = 1;
}


#-----------------------------------------------------------------------------
# メッセージ出力
#-----------------------------------------------------------------------------

_Print:

print "Content-type: text/html\n\n";

&title;

&form;

if( $data_not_enough == 1 ){
	print qq!<P align="center"><B>$timeout秒内にデータを完全に読み込めませんでした。</B></P>\n!;
}
elsif( $data_not_enough == 2 ){
	print qq!<P align="center"><B>$timeout秒内にデータを完全に読み込めませんでした。<BR>\n!;
	print qq!ただし，“&lt;/HTML&gt;”というデータまでは読み込めたはずです。</B></P>\n!;
}
elsif( $data_not_enough == 3 ){
	print qq!<P align="center"><B>データが200kbを超えているので，完全に読み込んでいません。<BR>\n!;
	print qq!ソ\ースを確認するのを忘れないで下さい。</B></P>\n!;
}

print qq!<TABLE border align="center"><TR><TD align="center"><B>対象URL＝$target_url</B><BR>!;

$warn_history = '';

if( $head_location_filescheme ){ $warn = 1;  # 警告を出したよ，という意味

	if( !$cashe ){ $warn_history .= ' - w_cloc'; }
	print <<"EOM";
<HR>
<BR>
<FONT size="7" color="red"><B>conconクラッシャー<BR>[Location]</B></FONT><BR>
<BR>
HTTPレスポンスヘッダ“Location”によりfileスキーマにアクセスします。<BR>
“conconクラッシャー”の中では，最も悪質なタイプです。<BR>
EOM
}

if( $html_base_filescheme ){ $warn = 1;
	if( !$cashe ){ $warn_history .= ' - w_cbase'; }
	print <<"EOM";
<HR>
<BR>
<FONT size="7" color="red"><B>conconクラッシャー<BR>[BASEタグ]</B></FONT><BR>
<BR>
BASEタグにより，基準URLがfileスキーマに設定されています。<BR>
このページの相対URLは全て汚染されています。<BR>
EOM
}

if( $html_table_nest ){ $warn = 1;
	if( !$cashe ){ $warn_history .= ' - w_nest'; }
	print <<"EOM";
<HR>
<FONT size="5" color="red"><B>Nested HTML</B></FONT><BR>
<BR>
TABLE タグが10段以上ネストされています。<BR>
バージョン4.7 以前のNetscapeはフリーズする可能\性があります。<BR>
EOM
}

if( 10 <= @frame ){ $warn = 1;
	if( !$cashe ){ $warn_history .= ' - w_frame'; }
	print <<"EOM";
<HR>
<FONT size="5" color="red"><B>大質量FRAME</B></FONT><BR>
<BR>
FRAME タグが多すぎると思いませんか？<BR>
悪意ありと考えられます。<BR>
EOM
}

if( $html_lvA_mailto || $html_lvB_mailto ||
	$html_img_mailto || $html_lvC_mailto ){ $warn = 1;
	if( !$cashe ){ $warn_history .= ' - w_mail'; }
	print <<"EOM";
<HR>
<FONT size="5" color="red"><B>mailtoストーム</B></FONT><BR>
<BR>
アンカータグではないタグで mailto: の記述が見つかりました。<BR>
一般的なパワーのマシンでは，ブラウザがフリーズする可能\性があります。<BR>
EOM
}

if( $javascript_mailto || $stylesheet_mailto ){ $warn = 1;
	if( !$cashe ){ $warn_history .= ' - w_mail'; }
	print <<"EOM";
<HR>
<FONT color="red"><B>mailtoストーム？</B></FONT><BR>
<BR>
JavaScript，もしくはスタイルシートで mailto: の記述が見つかりました。<BR>
“mailtoストーム”かもしれません。<BR>
EOM
}


if( $html_lvA_filescheme ){ $warn = 1;
	if( !$cashe ){ $warn_history .= ' - w_c1'; }
	print <<"EOM";
<HR>
<FONT size="5" color="red"><B>conconクラッシャー [META,FRAMEタグ]</B></FONT><BR>
<BR>
METAタグ もしくは FRAMEタグによりfileスキーマを参照します。<BR>
ブラウザがこのHTMLを解釈した瞬間，OSがクラッシュする可能\性があります。<BR>
EOM
}

if( $html_lvB_filescheme ){ $warn = 1;
	if( !$cashe ){ $warn_history .= ' - w_c2'; }
	print <<"EOM";
<HR>
<FONT size="5" color="red"><B>conconクラッシャー [EMBED,IFRAME,LAYERタグ]</B></FONT><BR>
<BR>
EMBEDタグ，IFRAMEタグ，もしくは LAYERタグによりfileスキーマを参照します。<BR>
お使いのブラウザによってはこのHTMLを解釈した瞬間，OSがクラッシュする可能\性があります。<BR>
EOM
}

if( $html_img_filescheme || $html_lvC_filescheme || $javascript_filescheme ){ $warn = 1;
	if( !$cashe ){ $warn_history .= ' - w_c3'; }
	print <<"EOM";
<HR>
<FONT color="red"><B>conconクラッシャー [HTMLタグ，JavaScript] / FDDアタック</B></FONT><BR>
<BR>
IMGタグやJavaScript等によりfileスキーマを参照します。<BR>
“conconクラッシャー”の場合は，ブラウザの設定によってはOSがクラッシュする可能\性があります。<BR>
“FDDアタック”の場合は，フロッピーディスクドライブへの不用なアクセスが続きます。<BR>
EOM
}

if( $stylesheet_filescheme ){ $warn = 1;
	if( !$cashe ){ $warn_history .= ' - w_c4'; }
	print <<"EOM";
<HR>
<FONT color="red"><B>conconクラッシャー [スタイルシート] / FDDアタック</B></FONT><BR>
<BR>
fileスキーマを参照するスタイルシートが組み込まれています。<BR>
“conconクラッシャー”か“FDDアタック”の可能\性があります。<BR>
ソ\ースを確認し，十\分に警戒してください。<BR>
EOM
}


if( $html_ank_filescheme ){ $warn = 1;
	if( !$cashe ){ $warn_history .= ' - w_c5'; }
	print <<"EOM";
<HR>
<FONT color="red"><B>conconクラッシャー [アンカータグ，FORMタグ]</B></FONT><BR>
<BR>
Aタグ，AREAタグ，もしくはFORMタグによりfileスキーマを参照します。<BR>
リンク先へジャンプしようとするかsumbitボタンを押すと，OSがクラッシュする可能\性があります。<BR>
EOM
}

if( $htaccess_filescheme ){ $warn = 1;
	if( !$cashe ){ $warn_history .= ' - w_c6'; }
	print <<"EOM";
<HR>
<BR>
<FONT size="7" color="red"><B>conconクラッシャー警報<BR>[.htaccess]</B></FONT><BR>
<BR>
この.htaccessにfileスキーマへアクセスするような文字列が含まれています。<BR>
十\分にお気を付けください。<BR>
EOM
}

if( $htaccess_forbidden ){ $warn = 1;
	if( !$cashe ){ $warn_history .= ' - w_htfbd'; }
	print <<"EOM";
<HR>
<FONT color="#770000"><B>接続拒否</B></FONT><BR>
この.htaccessは接続を拒否されました。<BR>
十\分にお気を付けください。<BR>
EOM
}

if( $css_filescheme ){ $warn = 1;
	if( !$cashe ){ $warn_history .= ' - w_c7'; }
	print <<"EOM";
<HR>
<BR>
<FONT size="7" color="red"><B>conconクラッシャー警報<BR>[カスケーディングスタイルシート]</B></FONT><BR>
<BR>
このカスケーディングスタイルシートはfileスキーマへアクセスするような文字列が含まれています。<BR>
十\分にお気を付けください。<BR>
EOM
}

foreach( @rel_of_link ){ $warn = 1;
	if( /stylesheet/i ){
		if( !$cashe ){ $warn_history .= ' - css_is'; }
		print <<"EOM";
<HR>
<FONT color="#770000"><B>警戒喚起</B></FONT><BR>
このURLは外部カスケードスタイルシートファイルを読み込みます。<BR>
下記<B>“LINK から呼び出されたURL”</B>に表\示されるURLもチェックして下さい。<BR>
EOM
		last;
	}
}

if( $html_lvA_is ){ $warn = 1;
	if( !$cashe ){ $warn_history .= ' - at1'; }
	print <<"EOM";
<HR>
<FONT color="#770000"><B>警戒喚起</B></FONT><BR>
METAタグ，FRAMEタグにより外部ファイルを読み込みます。<BR>
ファイルがNotFoundでないか，また，それぞれのファイルの内容にもお気を付けください。<BR>
EOM
}

if( $html_lvB_is ){ $warn = 1;
	if( !$cashe ){ $warn_history .= ' - at2'; }
	print <<"EOM";
<HR>
<FONT color="#770000"><B>警戒喚起</B></FONT><BR>
EMBEDタグ，IFRAMEタグ，LAYERタグにより外部ファイルを読み込みます。<BR>
ファイルがNotFoundでないかにお気を付けください。ブラウザによって危険さが異なります。<BR>
EOM
}

if( $html_img_is || $html_lvC_is || $javascript_is || $stylesheet_is ){ $warn = 1;
	if( !$cashe ){ $warn_history .= ' - at3'; }
	print <<"EOM";
<HR>
<B>注意喚起</B><BR>
このファイルにはIMGタグなどのHTMLタグ，外部ファイルを読み込むようなJavaScript，<BR>
もしくはカスケーディングスタイルシートが存在します。<BR>
外部ファイルを読み込む場合はそのファイルがNotFoundでないか，また，内容にもお気を付けください。<BR>
EOM
}


unless( $warn ){
	print "危険なページではないと思われます。\n";
}

#- で，ちなみに・・・
if( $status eq 'notfound' ){
	if( !$cashe ){ $warn_history .= ' - 404'; }
	print '<HR>参考 - このURLはNotFoundでした。';
}

print "</TD></TR></TABLE>\n";

#-----------------------------------------------------------------------------
#- 履歴に記録
#-----------------------------------------------------------------------------
&write_history( $target_url, $warn_history );


#-----------------------------------------------------------------------------
#- タグ内のJavaScript
#-----------------------------------------------------------------------------
print "<HR><B>タグの中に組み込まれているJavaScript：</B><BR>\n";

if( $body_onload[0] ){
	print "BODYタグ内の onLoad に組み込まれたJavaScript：<BR>\n";
	foreach( @body_onload ){ print "　", $_, "<BR>\n"; }
	print "<BR>\n";
}
if( $ank_onmouseover[0] ){
	print "アンカータグ内の onmouseover に組み込まれたJavaScript：<BR>\n";
	foreach( @ank_onmouseover ){ print "　", $_, "<BR>\n"; }
	print "<BR>\n";
}

#-----------------------------------------------------------------------------
#- リンク先の検出結果を出力
#-----------------------------------------------------------------------------

unless( $baseurl ){ $baseurl = $target_url };
$baseurl =~ s|^([^\?]*)/.*|$1/|;

#--- とりあえず.htacessを探してみる
if( $target_url =~ m!^(http://.*?/~.*?/)([^\?]*/)! ){  # ~ があるなら，多分 http://www.net.com/~hp/ という形式
	$rooturl = $1;
	$dir = $2;
}
elsif( $target_url =~ m!^(http://.*?/~.*?/)! ){
	$rooturl = $1;
	$dir = '';
}
elsif( $target_url =~ m!^(http://.*?/)([^\?]*/)! ){  # じゃなければ，多分 http://user.domain.com/ という形式
	$rooturl = $1;
	$dir = $2;
}
elsif( $target_url =~ m!^(http://.*?/)! ){
	$rooturl = $1;
	$dir = '';
}

@dirs = split('/',$dir);

print "<HR><B>基準URL：</B>$baseurl<BR>\n<BR>\n";

print "<B>.htaccessがあると思われる場所：</B>アクセスが許可されていない場合もあります<BR>\n";
&print_url("$rooturl.htaccess");
foreach( @dirs ){
	$rooturl .= "$_/";
	&print_url("$rooturl.htaccess");
}
print "\n<BR>\n";

print "<HR><B>以下のURLもチェックできます</B><BR>";

if( $head_location ){
	print "Location により移動するURL：<BR>\n";
	&print_url( $head_location );
	print "<BR>\n";
}

if( $meta ){
	print "META により移動するURL：<BR>\n";
	&print_url( $meta );
	print "<BR>\n";
}

&print_url_list( "FRAME から呼び出されたURL",@frame);

&print_url_list( "EMBED から呼び出されたURL", @embed);
&print_url_list( "IFRAME から呼び出されたURL",@iframe);
&print_url_list( "LAYER から呼び出されたURL", @layer);

&print_url_list( "BODY から呼び出されたURL", @body);
&print_url_list( "INPUT から呼び出されたURL",@input);
&print_url_list( "IMG から呼び出されたURL",  @img);
&print_url_list( "LINK から呼び出されたURL", @link);
&print_url_list( "OBJECT から呼び出されたURL", @object);
&print_url_list( "SCRIPT から呼び出されたURL", @script);
&print_url_list( "TABLE関連のタグで指定されたURL", @table);

&print_url_list( "JavaScript:window.openメソ\ッドで呼び出されたURL", @window_open );
&print_url_list( "JavaScript:history.goメソ\ッドで呼び出されたURL", @history_go );
&print_url_list( "JavaScript:locationプロパティに設定されたURL", @location_js );
&print_url_list( "JavaScript:hrefプロパティに設定されたURL",     @location_href );
&print_url_list( "JavaScript:navigateメソッドで呼び出されたURL", @navigate);
&print_url_list( "JavaScript:src,lowsrcなどのメソッドで呼び出されたURL", @src_js );

&print_url_list( "A,AREA から呼び出されたURL", @ank );
&print_url_list( "FORM から呼び出されたURL", @form );

print "<HR><PRE><B>ステータスとヘッダ</B>\n$head\n";

if( $head_location_filescheme ){
	print "<B>サーバから送られてきたデータは以下の通りです</B>\n";
	$text_view =~ s/</&lt;/g;
	print $text_view;
}
elsif( $head_location ){
	print "<B>今回のチェックは，移動先URLをチェックしたわけではありません</B>\n";
	print "念のために<A href=\"$cgi?$head_location\">移動先のURLもご確認ください</A>\n";
	print "\n";
	print "なお，今回のチェックでサーバから送られてきたデータは以下の通りです\n";
	$text_view =~ s/</&lt;/g;
	print $text_view;
}
elsif( $content =~ /text/ ){
	print qq!<A href="view-source:$target_url">ソ\ースを確認</A>\n!;
}
else{
	print "（このURLはソ\ースを確認できません。ご了承ください。）\n";
}

print qq!</PRE>\n$copyright</BODY></HTML>\n!;

exit;

#- スクリプト終了〜
#-----------------------------------------------------------------------------

#--- file scheme アクセスチェック
sub file_scheme{

	if( $_[0] =~ m!^file:[/|\\]+!i || $_[0] =~ m!^[a-zA-Z]:[/|\\]! ){
		return 1;
	}
	return 0;
}


#--- URLの貼り付け
sub print_url_list{

	my $mes = shift;

	if( $_[0] ){
		print( $mes, "：<BR>\n" );
		foreach( @_ ){ &print_url( $_ ); }
		print "<BR>\n";
	}
}

sub print_url{

	s/'//g;
	if( $_[0] =~ m!^#! ){ return; }
	if( $_[0] =~ m!^mailto:! ){ print qq!　!, $_[0], qq!<BR>\n!;  return; }

	if( $_[0] =~ m!^http://! ){
		print qq!　<A href="$cgi?$_[0]">$_[0]</A><BR>\n!;
	}
	elsif( $_[0] =~ m!file:[/|\\]+!i || $_[0] =~ m!^[a-zA-Z]:[/|\\]! ){
		print qq!　<FONT color="red"><B>$_[0]</B></FONT><BR>\n!;
	}
	else{
		print qq!　<A href="$cgi?$baseurl$_[0]">$_[0]</A><BR>\n!;
	}
}




#-----------------------------------------------------------------------------
#- タイトルを描く
#-----------------------------------------------------------------------------
sub title{

	print qq!<HTML><HEAD><TITLE>Browser Crasher Checker</TITLE></HEAD>\n!;
	print qq!<BODY bgcolor="white"><H3 align="center">Browser Crasher Checker ver.$version</H3>\n!;
#	print qq!今，ちょっと調整中です。これらの情報を信頼しないで下さい。<BR>!;
}


#-----------------------------------------------------------------------------
#- 入力フォーム
#-----------------------------------------------------------------------------
sub form{

	print <<"endof_html";
<FORM action="$cgi" method="GET">
URL:<INPUT type="text" name="url" size="60" value="$target_url"><INPUT type="submit" value="Check">
</FORM>
endof_html

}


#-----------------------------------------------------------------------------
#- 履歴記録
#-----------------------------------------------------------------------------
sub write_history{

	my $new_url = $_[0];
	my $new_warn = $_[1];

	my ($tm, $url, $warn, $i);
	my @lines;

#	if( &my_lock() ){
#		goto _denied;
#	}

	if( open DB,"./hist.dat" ){
		@lines = <DB>;
		close(DB);
	}
	else{
		@lines = ();
	}

	for( $i = 0; $i <= @lines; $i++ ){
		($tm, $url, $warn) = split(/,/, $lines[$i]);
		if( $url eq $new_url ) {
			splice( @lines,$i,1 );
			goto _nextstep;
		}
	}

	#- 初めて調べるURL（もしくは最近調べてなかったURL）
	if( !open(DB,">>./back.dat") ){
		open(DB,">./back.dat") or goto _nextstep;
	}
	print DB "$nowTime,$new_url,$new_warn\n";
	close(DB);

_nextstep:
	unshift( @lines, "$nowTime,$new_url,$new_warn\n" );

	#- ここはウザいので実行しない。何件でも記録すれ
	#$data_max = 50;
	#if( $data_max < @lines ){
	#	for( ; $data_max <= @lines; $data_max++ ){
	#		$lines[$data_max] = '';
	#	}
	#}

	open DB,">./hist.dat" or return 0;
	print DB (@lines);
	close(DB);

#	&my_unlock();

_denied:
	return 1;
}
#-----------------------------------------------------------------------------
# ロック処理
#-----------------------------------------------------------------------------
sub my_lock{

	my $count = 0;

	while( -e 'lock.tmp' ){
		sleep( 2 );
		if( 10 < $count++ ){
			goto _denied;
		}
	}

	if( open( FP, '>lock.tmp' ) ){
		close( FP );
	}
	return 0;

_denied:
	return 1;
}

sub my_unlock{
	unlink 'lock.tmp';
}


#-----------------------------------------------------------------------------
#- エラーを表示して終わる
#-----------------------------------------------------------------------------
sub error_html{

	print "Content-type: text/html\n\n";

	&title;
	&form;

	print "<DIV align=\"center\">$_[0]</DIV>";
	print "$copyright</BODY></HTML>";
	exit;
}