# Last updated: "Mon, 06 May 2002 11:08:13 JST-9"
package Envchk;
use strict;

use vars qw($VERSION);
$VERSION = '0.00';
sub version { $VERSION; }

require 5.004;

=head1 NAME なまえ

Envchk - プロクシ判断 [診断くん v0.80 + Proxy Judge v2.35] クラス

=head1 SYNOPSIS がいよう

 my $chk = new Envchk;
 my ($proxy, $doubt, $more, $proxy_msg, $more_msg, $sougou, $sougou_msg, $doubt_msg ) = $chk->proxy_check()->judge();
 print "プロクシと思われる箇所が $proxy 箇所\n";
 print "プロクシと思われる疑惑箇所が $proxy 箇所\n";
 print "漏れていると思われる箇所が $more 箇所\n";
 exit;

=head1 DESCRIPTION せつめい

このEnvchkクラスは環境変数を調べプロクシであるか判断します。
ベースは診断くん v0.80ですが、一部 Proxy Judge v2.35 を参考にしています。

=head1 AUTHOR かいたひと

診断くん v0.80 written by TaruO!

Proxy Judge v2.35 written by PRX4EVER

module written by ◆sUY48rs.E<lt>I<momokotan@s3.xrea.com>E<gt> in 2002

◆sUY48rs. is very idler.

=cut

sub new
{
	my $e = shift;
	return if ref $e;
	my $s = bless {}, $e;
	$s->initialize(\@_);
	$s;
}
sub initialize
{
	my %a = @{$_[1]}; # a は args

	$_[0]->{'list_env'} = { # リストのリファレンスが入る
		'http'	=> undef,
		'proxy'	=> undef,
		'doubt'	=> undef,
		'rest'	=> undef,
		'gen'	=> undef,
		'spill'	=> undef,
		'xxx'	=> undef,
		'yyy'	=> undef,
		'zzz'	=> undef,
		'proxy_detect' => undef,
		'doubt_detect' => undef,
		'debug' => undef,
	};
	$_[0]->{'counter'} = {
		'proxy'	=> 0,
		'doubt'	=> 0,
		'more'	=> 0,
		'score'	=> 0,
	};
	my ($k1,$k2); # key1 key2
	while ( $k1 = each %a ) {
		$_[0]->{$k1} = $a{$k1}, next unless ref $a{$k1} eq 'HASH';
		$_[0]->{$k1}->{$k2} = $a{$k1}->{$k2} while $k2 = each %{$a{$k1}};
	}
}
sub counter
{
	return each %{$_[0]->{'counter'}}	unless exists $_[1];
	return $_[0]->{'counter'}->{$_[1]}	unless exists $_[2];
	my $s = shift; my %a = @_; my $k;
	$s->{'counter'}->{$k} = $a{$k} while( $k = each %a );
	$s;
}
sub list_env
{
	return each %{$_[0]->{'list_env'}}	unless exists $_[1];
	return $_[0]->{'list_env'}->{$_[1]}	unless exists $_[2];
	my $s = shift; my %a = @_; my $k;
	$s->{'list_env'}->{$k} = $a{$k} while( $k = each %a );
	$s;
}
sub proxy_check
{
	my @http_env = @{$_[0]->get_env()}; # 環境変数ぜんぶ
	my @rest_env; # @http_env から一般的な変数を取り除いた環境変数
	my @gen_env; # @httptmp_env のなかから常時表示変数を取り除いた環境変数
	my @proxy_env; # 串特有の環境変数
	my @doubt_env; # それ以外の串の疑惑がある環境変数
	my @proxy_detect;
	my @doubt_detect;
	my $proxy = 0; # 串判定カウント
	my $doubt = 0; #
	my $tmp;

	foreach $tmp( @http_env ) {
		if ( $tmp =~ /HTTP_(?:ACCEPT|HOST|USER_AGENT|PRAGMA|REFERER|CONNECTION)/ ) {

			push(@gen_env, $tmp) unless $tmp =~ /HTTP_(?:REFERER|CONNECTION)/;

		} else {
			push @rest_env, $tmp;
			if ( $tmp =~ /HTTP_(VIA|CACHE_INFO|SP_HOST|FORWARDED|FORWARDED_FOR|X_FORWARDED_FOR|CLIENT_IP)/ ) {

				push(@gen_env, $tmp) unless $tmp =~ /HTTP_(?:REFERER|CONNECTION)/;

				push @proxy_env, $tmp;
				$proxy++;
				push @proxy_detect, qq{"proxy detect $tmp"};

			} else {

				push @doubt_env, $tmp;
				$doubt++ ;
				push @doubt_detect, qq{"doubt detect $tmp"};

			}
		}
	}
	$_[0]->list_env( 'http'  => \@http_env );
	$_[0]->list_env( 'rest'  => \@rest_env );
	$_[0]->list_env( 'gen'   => \@gen_env );
	$_[0]->list_env( 'proxy' => \@proxy_env );
	$_[0]->list_env( 'doubt' => \@doubt_env );
	$_[0]->list_env( 'proxy_detect' => \@proxy_detect );
	$_[0]->list_env( 'doubt_detect' => \@doubt_detect );

	$_[0]->counter( 'proxy' => $proxy );
	$_[0]->counter( 'doubt' => $doubt );

	$_[0]->_proxy_check_step1()->_proxy_check_step2()->_proxy_check_step3()->_proxy_check_step4();
	$_[0];
}
sub _proxy_check_step1
{
	my @rest_env = @{$_[0]->list_env('rest')};
	my @xxx;
	my $n;
	my $v;
	# @restenv からホスト名と思しき数字／英文字を抽出し @xxx に格納
	foreach( @rest_env ) {
		($n, $v) = split /=/, $_, 2;
		# ドメイン名らしいものを抽出
		push( @xxx, "$1.$2.$3" ) if $v =~ /(\S+)\.([^(\.|\s)]{2,4})\.([a-zA-Z]{2,4})/;
		# IP らしいものを抽出
		push( @xxx, "$1.$2.$3.$4" ) if $v =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/;
	}
	# Client-Ip への 16進漏れを検出
	push( @xxx, join('.', hex($1), hex($2), hex($3), hex($4)) ) if $ENV{'HTTP_CLIENT_IP'} =~ /^([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})$/i;
	$_[0]->list_env( 'xxx' => \@xxx );
	$_[0];
}
sub _proxy_check_step2
{
	my @xxx = @{$_[0]->list_env('xxx')};
	my @yyy;
	my $tmp;
	my $addr = $ENV{'REMOTE_ADDR'};
	my $remote_host = $_[0]->ns1( $ENV{'REMOTE_ADDR'} );
	# @xxx から アクセス者自身の IPアドレス/FQDN を除去して @yyy へ
	foreach $tmp(@xxx) {
		$tmp = $_[0]->ns2($tmp);
		$tmp =~ s/(?:$addr)//;
		$tmp =~ s/(?:$remote_host)//i;
		# IP のみ @yyy
		push(@yyy, $tmp) if length($tmp) > 3 && $tmp =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/;
	}
	$_[0]->list_env( 'yyy' => \@yyy );
	$_[0];
}
sub _proxy_check_step3
{
	my @yyy = @{$_[0]->list_env('yyy')};
	my @zzz;
	my $ipno;
	# @yyy から private address/local loopback を除去して @zzz へ
	foreach(@yyy) {
		s/127\.0\.0\.1//;
		# private IP addressを消します(dotlessに変換するとらくちん)
		/(\d+)\.(\d+)\.(\d+)\.(\d+)/;
		$ipno = 16777216 * $1 + 65536 * $2 + 256 * $3 + $4;
		$_ = '' if $ipno >= 167772160 && $ipno <= 184549375;# {$_='';};
		$_ = '' if $ipno >= 2886729728 && $ipno <= 2886795263;# {$_='';};
		$_ = '' if $ipno >= 3232235520 && $ipno <= 3232301055;#{$_='';};
		push(@zzz,$_) if ( length($_) > 3 ) && ( $_ =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)/ );
	}
	$_[0]->list_env( 'zzz' => \@zzz );
	$_[0];
}
sub _proxy_check_step4
{
	my @zzz = @{$_[0]->list_env('zzz')};
	my @http_env = @{$_[0]->list_env('http')};
	my @spill_env;
	my @proxy_detect = @{$_[0]->list_env('proxy_detect')};
	my @doubt_detect =@{$_[0]->list_env('doubt_detect')};
	my $nam;
	my $remote_host = $_[0]->ns1($ENV{'REMOTE_ADDR'});
	my $proxy = $_[0]->counter('proxy');
	my $doubt = $_[0]->counter('doubt');
	my $more;
	my $debug;
	# @zzz に gethostbyaddr をかけて、引けたら @spillenv へ # これはDNSサーバが泣くかも
	foreach(@zzz){
		$proxy++ if $proxy == 0;
		$nam = $_[0]->ns1($_);
		$nam .= " ($_)" if $nam ne $_;
		push @spill_env, $nam;
	}
	# いいがかりに近いプロクシ検出ルーチン。取り調べ官はきびしいのだよ（意味不明）
	#ホスト名による判別
	if ( $remote_host =~ /(www.*cache|www.*proxy|webcache|delegate|firewall|proxy|prox|squid|cache|www|dns|^ns|gateway|gatekeeper|gate|^gw|^fw|^bbs|^http|^www|^web|^ftp|^mail|^news|^cgi|^gate|^server|^pop|^smtp|^w3\.|^ns\d{0,2}|^fw\d{0,2})/i ) {
		$proxy++;
		push @proxy_detect, qq{doubt host name($&)};
	}
	if ( $ENV{'HTTP_USER_AGENT'} =~ /via\s/i || $ENV{'HTTP_USER_AGENT'} =~ /proxy\s/i || $ENV{'HTTP_USER_AGENT'} =~ /gate/i ) {
		$proxy++;
		push @proxy_detect, 'via detected in User-Agent';
	} elsif ( @http_env =~ /via/ || @http_env =~ /proxy/ ) {
		$proxy++;
		push @proxy_detect, 'via/proxy detected';
	}
	# HTTP_CONNECTION がなかったら proxy
	if ( $ENV{'HTTP_CONNECTION'} !~ /Keep-Alive/i ) {
		$proxy++;
		push @proxy_detect, 'missinng HTTP_CONNECTION';
	}
	# jpドメインじゃなかったらあやしい…けど。
#	unless ( ( $remote_host =~ /\.jp$/i ) && ( $remote_host =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)/ ) ) {
#		$proxy++;
#		push @proxy_detect, 'not jp domain';
#	}
	# ここから下は疑惑点をあらいだすルーチン。疑わしきは罰すナリ。
	#'mail|www'等とつくホストはあやしい
	if ( $remote_host =~ /^(cgi|ftp|mail|pop|news|server|^secure)\d{0,2}/gi ) {
		$doubt++;
		push @doubt_detect, 'doubtful hostname';
	}
	#名前に数字が含まれないホストはあやしい
	if ( !($remote_host =~ /\d/) ) {
		$doubt++;
		push @doubt_detect, 'missing figure in hostname';
	}
	$more = @spill_env;
	$_[0]->counter( 'more'  => $more );
	$_[0]->counter( 'proxy' => $proxy );
	$_[0]->counter( 'doubt' => $doubt );
	$_[0]->counter( 'score' => ($proxy + $more * 2) );
	$_[0]->list_env( 'spill'        => \@spill_env );
	$_[0]->list_env( 'proxy_detect' => \@proxy_detect );
	$_[0]->list_env( 'doubt_detect' => \@doubt_detect );
	$_[0];
}
# 総合判定
sub judge
{
	my @spill_env = @{$_[0]->list_env('spill')};
	my $proxy = $_[0]->counter('proxy');
	my $doubt = $_[0]->counter('doubt');
	my $more = $_[0]->counter('more');
	my $host_name;
	my $proxy_msg = '(未判定)';
	my $more_msg = '(未判定)';
	my $sougou;
	my $score = $proxy + $more * 2;
	my $sougou_msg;
	my $doubt_msg;

	if ( @spill_env ) {
		$host_name = join "\,", @spill_env;
	} else {
		$host_name = $_[0]->ns1($ENV{'REMOTE_ADDR'});
		$host_name .= qq{ ($ENV{'REMOTE_ADDR'})};
	}
	if ( $proxy != 0 ) {
		$proxy_msg = qq{プロクシです。proxy判定箇所が$proxy箇所、疑惑点が$doubt箇所ありました。};
		if ( $more != 0 ) {
			$more_msg = "$more箇所に漏れている疑いがあります。";
		} else {
			$more_msg = "漏れてはいないようです。";
		}
	}

	$sougou = '？ (A 以上 or 生 IP)' if $score == 0;
	$sougou = 'A' if $score == 1;
	$sougou = 'B' if $score == 2;
	$sougou = 'C' if $score == 3;
	$sougou = 'D' if $score == 4;
	$sougou = 'E' if $score == 5;
	$sougou = '評価不能(論外)' if $score >= 6;

	if ( $proxy > 0 ) {
		$sougou .= '+' if $doubt <= 0 && $score < 6;
		$sougou .= '-' if $doubt >= 2 && $score < 6;
	}

  	$score = 6 if $score > 6;
  	$doubt = 6 if $doubt > 6;

	($sougou_msg, $doubt_msg) = $_[0]->_judge_msg( $score, $doubt );
	return( $proxy, $doubt, $more, $proxy_msg, $more_msg, $sougou, $sougou_msg, $doubt_msg );
}
# envをまとめて処理
sub get_env
{
	my @http_env;
	my $k;
	my $v;
	while ( ($k,$v) = each %ENV ) {
		push( @http_env, "$k=$v" ) if ( $k =~ /^HTTP_/ );
	}
	return \@http_env;
}
sub _judge_msg
{
	my @proxy_msg = (
		'',
		'極めて物静かなproxyです。proxy経由であることを示す情報がほとんどありません。',
		'優れたproxyです。しかし proxy 特有の情報が散見されますので場合によってはアクセス拒否されることがあるかもしれません。',
		'それなりの proxy です。しかしどうも中途半端です。速度面でのアドバンテージがない場合にはおすすめできません。',
		'自己主張の強い proxy です。キャッシュとしての能力に期待しましょう。',
		'饒舌な proxy です。匿名性などを期待してはいけません。',
		'評価不能。にぎやかで楽しそうな proxy です。おだいじに',
		''
	);
	my @doubt_msg = (
		'疑惑 0%：proxy の兆候は全く見られません。',
		'疑惑 〜20%：proxy の可能性もわずかにあります。',
		'疑惑 〜40%：なんとなく proxy のような気もします。',
		'疑惑 〜75%：かなり proxy のにおいがします。',
		'疑惑 〜100%：怪しい点がたくさんあって限りなく proxy の疑いが濃厚です。',
		'',
		''
	);

	return(@proxy_msg[$_[1]], @doubt_msg[$_[2]]);
}
# ホスト名逆引きルーチン(ip->host)
sub ns1
{
	my $ip = $_[1];
	my $temp_ip;
	my $temp_host;
	if( $ip =~ /([0-9]+)\.([0-9]+)\.([0-9]+)\.([0-9]+)/ ) {
		$temp_ip = "$1.$2.$3.$4";
		$temp_host = ( gethostbyaddr pack('C4',$1,$2,$3,$4), 2 )[0];
		if ( $temp_host ne '' ) { return $temp_host; } else { return $temp_ip; }
	}
	return $ip;
}
# ホスト名正引きルーチン(host->ip)
sub ns2
{
	my $host = $_[1];
	my $ip = join '.', unpack( 'C4', ( gethostbyname $host )[4] );
	return ( $ip ne '' ? $ip : $host );
}