#!/usr/bin/perl -w
#-----------------------------------------------------------------------------------------------
# simple env by Lilia [2003/10/10]
#-----------------------------------------------------------------------------------------------
use strict;
use CGI::Carp qw(fatalsToBrowser);
use POSIX qw(strftime);
use SelfLoader;
use vars qw(%Ini);
%Ini = (
Title => q[simple env],
Rev => q[0.13b],
Dist => q[http://nursery.s8.xrea.com/],
Sign => q[Lilia],
# ユーザー設定..
#-----------------------------------------------------------------------------------------------
# GMTとの時差
TimeDiff => 9 * 60 * 60, # 日本なら 9 * 60 * 60
# アクセスログ記録
Logging => 0, # ログを記録する: 1 記録しない: 0
# 記録する場合は下の2項目を設定
# LogFile => 'env.log', # 記録ファイルのパス（空のファイルをアップロード）
# LogMax => 500, # 最大記録件数
# 参照元（Referer）制限
# 下のどちらかが設定されていればそれを採用してアクセスを制限（わかる人だけ）
# NGRef_RE => qr%(?:1|15|2)ch|bbs(?:2\.jp|pink)|(?:j|machi|mega)bbs|ohayou|(?:ime|nun)\.nu%i,
# 正規表現：一致するもののアクセスを拒否
# OKRef_RE => qr%^http://[^\?]*?(?:$ENV{HTTP_HOST}|nursery|lilia|mizuiro|strange|taiyaki)%i,
# 正規表現：一致しないもののアクセスを拒否
# JavaScript等のチェック
OptCheck => 0, # チェックする: 1 チェックしない: 0
# xrea.com ユーザー用 [特殊]
XreaIns => 0, # xrea.com のバナーを挿入する: 1 挿入しない: 0
# ..ここまで
#-----------------------------------------------------------------------------------------------
# ファイル名の頭に「nph-」が付いていれば NPHスクリプトとして実行される
NPH => ($0 =~ m|\bnph-[^/\\]+$|i) || 0,
# 自国判定
JP => 1, # Japanese output
Domestic => qr/\.jp$/i,
# whois の 名前/説明/URI/フォーマット
Whois1 => {
N => 'ANSI Whois Gateway',
D => '©Asuka Network Service, Inc.',
U => 'http://whois.ansi.co.jp/',
F => 'http://whois.ansi.co.jp/?key=%s'
},
Whois2 => {
N => 'BW Whois',
D => '©William E. Weinman',
U => 'http://whois.bw.org/',
F => '*REDIR*http://nursery.s8.xrea.com/whois/?domain=%s'
},
);
#-----------------------------------------------------------------------------------------------
&ctrl if($ENV{HTTP_REFERER} && ($Ini{NGRef_RE} || $Ini{OKRef_RE}) && $ENV{HTTP_REFERER} =~ m%^(?:https?|ftp)://(?!localhost/|127\.0\.0\.1/)%i);
&redir($1) if($ENV{QUERY_STRING} && $ENV{QUERY_STRING} =~ m|^url=(https?://.+)$|i);
&html;
exit;
# サブルーチン
#-----------------------------------------------------------------------------------------------
sub html {
my @mark = $Ini{JP} ? ('',' △',' ☆') : ('',' ??',' !!');
my $date = strftime("%Y-%m-%d (%a) %H:%M:%S", gmtime(time + $Ini{TimeDiff}));
my($addr,$host,$referer,$agent) = getenv();
my($xhost,$v) = getxhost($host);
my $m_xhost = $xhost . $mark[$v];
logf($Ini{LogFile}, $Ini{LogMax}, "[%s] %s (%s) / %s - %s - %s", $date,$host,$m_xhost,$addr,$referer,$agent) if($Ini{Logging});
my %t = $Ini{JP}
? (
Anch => '♪',
Host => 'ホスト名',
Addr => 'IPアドレス',
UHost => 'あなたのホスト',
UHome => 'あなたのプロバイダのホームページ ',
LogV => '一般にアクセス・ログとして記録されそうな情報',
From => '〜',
Other => 'その他',
XREA => 'XREA の広告',
) : (
Anch => '>>',
Host => 'Hostname',
Addr => 'IP Addr',
UHost => 'Your Host',
UHome => 'Website of your ISP',
LogV => 'The following can be logged',
From => 'From:',
Other => 'Other information',
XREA => 'XREA Ad Banner',
);
my %c = (
# 背景, 文字1, 文字2, 未訪問リンク, 訪問済リンク, 選択中リンク
bg => '#d6dadc', text => '#333333', pale => '#666666', link => '#1111af', vlink => '#6666af', alink => '#1111ee',
# 強調表示するセル, 強調表示する文字, テーブルの縁
em => '#eaecec', warn => '#993333', border => '#667788'
);
my $body = qq();
my $css = qq`
body { background-color:$c{bg}; color:$c{text}; font-family:Arial,Helvetica,'MS PGothic',Osaka,sans-serif; margin:13px 10px; }
a { text-decoration:none; }
a:hover { background-color:transparent; color:$c{alink}; text-decoration:underline; }
.tlink { background-color:transparent; color:$c{text}; }
.tlink:hover { background-color:transparent; color:$c{pale}; }
.note { text-decoration:underline; }
table { border:1px solid $c{border}; margin-bottom:2px; }
td { border:1px solid $c{border}; }
.noline { border:0; }
.hidden { display:none; }
.css:after { padding-left:0.8em; content:' *CSS = on (and well supported)'; }
`;
# バナー
my($banner,$nobanner,$noembed) = ('','','');
($banner,$nobanner) = (<<"_XREA_",'') if($Ini{XreaIns} && $ENV{SERVER_NAME} && $ENV{SERVER_NAME} ne 'localhost');
# $t{XREA}...
_XREA_
# $nobanner = '' if($ENV{SERVER_NAME} && $ENV{SERVER_NAME} =~ /(?:netfirms|xrea)\.com/i);
# $noembed = "<![CDATA[\n\n" if($ENV{SERVER_NAME} && $ENV{SERVER_NAME} =~ /(?:virtualave|hypermart)\.net/i && !$Ini{NPH});
my($your_host,$your_xhost) = ($host,$m_xhost);
my($shost,$your_home) = shrink($host);
my($sxhost,$your_xhome) = shrink($xhost);
($your_xhost =~ s/\Q$mark[1]\E$/ (Local or Fake?)/)
or ($your_home = $your_xhome);
$your_xhost =~ s/\Q$mark[2]\E$/ (Spill?)/;
my %n;
foreach($shost,$sxhost) {
$n{$_} = (/^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) ? ' (unresolved)' : '';
}
#「あなたのホスト」で proxy っぽいものは強調表示（やりすぎかも）
($your_host =~ s%((?:webcache|delegate|gate(?:keeper|way)|firewall|proxy?|anonymizer|cache|squid|flow|fire-w.*?\b)\d*)
%<b>$1</b>%xi)
or ($your_host =~ s%^((?:www|w3\b|host|dns|web|dummy|prx|http|ftp|news|mail|cgi|bbs|gate|serv(?:er|\b)|pop|smtp|secure|system|relay)\d*)
%<b>$1</b>%xi)
or ($your_host =~ s%\b((?:dns?|anon|ns|fw|gw|sv|px|cf|fs|wc)\d*)\b%<b>$1</b>%i); # 上の方優先
$your_host = "<b>$your_host</b>" unless($your_host =~ /\.[a-z]+/i);
# おまけ - アノニマイザ系（参考） *old
if($your_host =~ /^209\.114\.223\.1(?:39|40)$/) {
$your_host = "<b>$your_host</b>";
$your_xhost.= ' (net HUSH?)';
} elsif($your_host =~ /^64-243-193-9[67]\.wireweb\.net$/) {
$your_host = "<b>$your_host</b>";
$your_xhost.= ' (schematic.org?)';
}
# 自国ドメインじゃない・数字が含まれていない
$your_host = "<u>$your_host</u>" if($your_host !~ /$Ini{Domestic}/ || $your_host !~ /\d/);
my $r_uri = $ENV{REQUEST_URI} || $ENV{SCRIPT_NAME} || ''; # or specify your existing redirector
$r_uri =~ s/\?.*//;
s/\*REDIR\*/$r_uri?url=/ foreach($Ini{Whois1}{F},$Ini{Whois2}{F});
my($uri1_host,$uri1_xhost,$uri1_addr) = (sprintf($Ini{Whois1}{F}, $shost),sprintf($Ini{Whois1}{F}, $sxhost),sprintf($Ini{Whois1}{F}, $addr));
my($uri2_host,$uri2_xhost,$uri2_addr) = (sprintf($Ini{Whois2}{F}, $shost),sprintf($Ini{Whois2}{F}, $sxhost),sprintf($Ini{Whois2}{F}, $addr));
local %ENV = %ENV;
$ENV{HTTP_CONNECTION} ||= '(none)';
s/&/&/g, s/</</g, s/>/>/g, s/"/"/g foreach($referer,$agent);
my $perl_ver = $^V ? (sprintf "%vd", $^V) : $];
my $perl_path = (eval { `which perl` }) ? (' ' . `which perl`) : '';
(my $perl_info = "Perl$perl_path [v$perl_ver]") =~ tr/\015\012//d;
$Ini{Title}.= '+' if($Ini{OptCheck} == 2);
my $snmp = ($Ini{OptCheck} == 2) ? (' SNMP - ' . chksnmp($addr) . ' <br>') : '<!-- No SNMP check -->';
my($status,$nl) = $Ini{NPH} ? ('HTTP/1.0',"\015\012") : ('Status:',"\012");
my($charset,$content_opt,$lang) = $Ini{JP}
? ('; charset=Shift_JIS', "Content-Language: ja$nl",' lang="ja"')
: ('; charset=ISO-8859-1',"Content-Language: en$nl",' lang="en"');
# 出力開始
print "$status 200 OK$nl", "Connection: close$nl",
"Content-Type: text/html$charset$nl$content_opt",
"Cache-Control: no-cache$nl", "Pragma: no-cache$nl$nl",
<<"_HTML_";
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html$lang>$nobanner
<head>
<meta name="robots" content="NONE">
<meta http-equiv="content-type" content="text/html$charset">
<meta http-equiv="content-style-type" content="text/css">@{[$Ini{OptCheck} ? qq(\n<meta http-equiv="content-script-type" content="text/javascript">) : '']}
<title>$Ini{Title}</title>
<base target="_blank">
<style type="text/css">
<!--$css-->
</style>
</head>
$body
<small title="$perl_info">$Ini{Title}</small><hr>
<small># $t{UHost}... <font color="$c{warn}">$your_host [$your_xhost]</font><br></small>
<table border=1 cellspacing=0 cellpadding=3 summary="host info">
<tr bgcolor="$c{em}"><td class="noline"><small>
<a href="$Ini{Whois1}{U}" class="tlink" title="$Ini{Whois1}{D}">$Ini{Whois1}{N}</a> : $t{Host} <a href="$uri1_host" title="$shost$n{$shost}" class="note">$t{Anch}</a>@{[
($shost ne $sxhost) ? qq(<small class="hidden"> </small><a href="$uri1_xhost" title="$sxhost$n{$sxhost}">~ </a>) : ' '
]} $t{Addr} <a href="$uri1_addr" title="$addr" class="note">$t{Anch}</a> <br>
<a href="$Ini{Whois2}{U}" class="tlink" title="$Ini{Whois2}{D}">$Ini{Whois2}{N}</a> : <a href="$uri2_host" title="$shost$n{$shost}" class="note">$t{Anch}</a>@{[
($shost ne $sxhost) ? qq(<small class="hidden"> </small><a href="$uri2_xhost" title="$sxhost$n{$sxhost}">~ </a>) : ' '
]} <a href="$uri2_addr" title="$addr" class="note">$t{Anch}</a> <br>
$t{UHome}? <a href="$your_home" class="note">$t{Anch}</a>@{[
($your_home ne $your_xhome) ? qq(<small class="hidden"> </small><a href="$your_xhome" title="maybe unreachable">~ </a>) : ' '
]} <br>
</small></td></tr>
</table>
<small># $t{LogV}...<br></small>
<table border=1 cellspacing=0 cellpadding=3 summary="access info">
<tr bgcolor="$c{em}"><td class="noline"><small>
[$date] $host ($m_xhost) / $addr <br>
$t{From} @{[($referer =~ /^http/i) ? qq(<a href="$referer" class="tlink"><u>$referer</u></a>) : $referer]} - $agent <br>
</small></td></tr>
</table>
_HTML_
if($Ini{OptCheck}) { # クリップボード抜きは悪質なので廃止
print <<"_OPT_";
<small># $t{Other}...<br></small>
<table border=1 cellspacing=0 cellpadding=3 summary="other info">
<tr bgcolor="$c{em}"><td class="noline"><small>
$snmp
<script language="JavaScript" type="text/javascript">
<!--
document.write('JavaScript = <b>on<\\/b> \\; \\;');
if(navigator.javaEnabled()) {
document.write('( Java = <b>on<\\/b> )');
} else {
document.write('( Java = off )');
}
// -->
</script></small><noscript><small>JavaScript = off</small></noscript><small><!--
--><span class="css" title="Cascading Style Sheets"><span class="hidden"> <br> <acronym title="Cascading Style Sheets">CSS</acronym> = off (or not fully supported)</span></span> <br>
</small></td></tr>
</table>
_OPT_
}
print qq(<hr>\n<table border=1 cellspacing=1 cellpadding=2 summary="environment variables">\n);
foreach my $key (sort keys %ENV) {
if($ENV{$key} eq '') {
$ENV{$key} = qq[<font color="$c{pale}">(none)</font>];
} else { # タグ・改行等の修正
$ENV{$key} =~ tr/\015\012/ /;
$ENV{$key} =~ s/&/&/g; $ENV{$key} =~ s/</</g; $ENV{$key} =~ s/>/>/g; $ENV{$key} =~ s/"/"/g;
}
if($key =~ /^HTTP_/) { # HTTP_XXXXXX の表示について
if($key eq 'HTTP_ACCEPT' || $key eq 'HTTP_ACCEPT_CHARSET' ||
$key eq 'HTTP_ACCEPT_ENCODING' || $key eq 'HTTP_ACCEPT_LANGUAGE' ||
$key eq 'HTTP_COOKIE' || $key eq 'HTTP_IF_MODIFIED_SINCE' ||
$key eq 'HTTP_HOST' || $key eq 'HTTP_PRAGMA' ||
$key eq 'HTTP_UA_COLOR' || $key eq 'HTTP_UA_CPU' ||
$key eq 'HTTP_UA_OS' || $key eq 'HTTP_UA_PIXELS') { # 以上はそのまま表示
print qq(<tr><td nowrap><small> $key </small></td>),
qq(<td><small> $ENV{$key} </small></td></tr>\n);
} elsif($key eq 'HTTP_REFERER') { # HTTP_REFERER はアンダーライン付きリンク
print qq(<tr><td nowrap><small> $key </small></td>),
qq(<td><small> <a href="$ENV{$key}" class="tlink"><u>$ENV{$key}</u></a> </small></td></tr>\n);
} elsif($key eq 'HTTP_USER_AGENT') { # HTTP_USER_AGENT は部分的に文字強調
$ENV{$key} =~ s%(\b(?:anon.*?\b|Turing|via\b)|BBS Write|D-Engine|Did\S+Elephant|dummy|gate(?:way)?\b|libwww-perl|Microsoft URL Control|proxy|\S*Surf|\Snonymouse)
%<font color="$c{warn}">$1</font>%xig;
print qq(<tr><td nowrap><small> $key </small></td>),
qq(<td><small> $ENV{$key} </small></td></tr>\n);
} elsif($key eq 'HTTP_CONNECTION') { # HTTP_CONNECTION は Keep-Alive 以外をセル＆文字強調
if($ENV{$key} =~ /^Keep-Alive$/i) { # Keep-Alive だったらそのまま表示
print qq(<tr><td nowrap><small> $key </small></td>),
qq(<td><small> $ENV{$key} </small></td></tr>\n);
} else { # それ以外は強調表示
print qq(<tr bgcolor="$c{em}"><td nowrap><small> $key </small></td>),
qq(<td><small> <font color="$c{warn}">$ENV{$key}</font> </small></td></tr>\n);
}
} elsif($key eq 'HTTP_KEEP_ALIVE') { # HTTP_KEEP_ALIVE は proxy 変数とみなされてしまうことが多いのでセル強調
print qq(<tr bgcolor="$c{em}"><td nowrap><small> $key </small></td>),
qq(<td><small> $ENV{$key} </small></td></tr>\n);
} elsif($key eq 'HTTP_SEPHIRA') { # Gabrienai *obso
print qq(<tr bgcolor="$c{em}"><td nowrap><small> $key </small></td>),
qq(<td><small> <font color="$c{warn}">$ENV{$key} # Gabrienai</font> </small></td></tr>\n);
} else { # 他の HTTP_XXXXXX はセル＆文字強調
print qq(<tr bgcolor="$c{em}"><td nowrap><small> $key </small></td>),
qq(<td><small> <font color="$c{warn}">$ENV{$key}</font> </small></td></tr>\n);
}
} elsif($key =~ /^REMOTE_/) { # REMOTE_XXXXXX はセル強調
print qq(<tr bgcolor="$c{em}"><td nowrap><small> $key </small></td>),
qq(<td><small> $ENV{$key} </small></td></tr>\n);
} else { # 他はそのまま表示
print qq(<tr><td nowrap><small> $key </small></td>),
qq(<td><small> $ENV{$key} </small></td></tr>\n);
}
}
print qq(</table>\n$banner<hr>\n),
qq(<small>*script by <a href="$Ini{Dist}" class="tlink" title="(*'-')~">$Ini{Sign}</a>, v$Ini{Rev}</small>\n),
qq(</body>\n</html>\n$noembed);
} # html end
sub ctrl {
return if(($Ini{NGRef_RE} && $ENV{HTTP_REFERER} !~ /$Ini{NGRef_RE}/) ||
($Ini{OKRef_RE} && $ENV{HTTP_REFERER} =~ /$Ini{OKRef_RE}/));
if($Ini{Logging}) {
my $date = strftime("%Y/%m/%d (%a) %H:%M:%S", gmtime(time + $Ini{TimeDiff}));
my($addr,$host,$referer,$agent) = getenv();
logf($Ini{LogFile}, $Ini{LogMax}, "[%s] %s (%s) / %s - %s - %s", $date,$host,'denied',$addr,$referer,$agent);
}
my($status,$nl) = $Ini{NPH} ? ('HTTP/1.0',"\015\012") : ('Status:',"\012");
print "$status 503 Service Unavailable$nl", "Retry-After: 3600$nl", "Connection: close$nl",
"Content-Type: text/html$nl$nl", # あまり刺激しない
<<"_DENY_"; # サーバーに合わせて編集可
<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">
<HTML><HEAD>
<TITLE>503 Service Unavailable</TITLE>
</HEAD><BODY>
<H1>503 Service Unavailable</H1>
<P>The server is temporarily unable to service your request
due to maintenance downtime or capacity problems.</P>
<P>Please try again later.</P>
</BODY></HTML>
_DENY_
exit;
} # ctrl end
sub redir {
my $url = shift;
my($self) = $0 =~ m|([^/\\]+)$|;
return if($url =~ /\b\Q$self\E\b/i); # 二重呼出し
return if($ENV{HTTP_REFERER} && $ENV{HTTP_REFERER} !~ m|^https?://\Q$ENV{HTTP_HOST}\E\b|i); # 不正な呼出し元
$url =~ tr/\015\012"<> //d;
my($status,$nl) = $Ini{NPH} ? ('HTTP/1.0',"\015\012") : ('Status:',"\012");
print "$status 200 OK$nl", "Connection: close$nl",
"Content-Type: text/html$nl$nl",
qq`<html><!--nobanner-->\n<head>\n<meta http-equiv="refresh" content="0;url=$url">\n`,
"<title>redirect</title>\n</head>\n<body>\njust a sec...\n</body>\n</html>\n<noembed>\n";
exit;
} # redir end
sub logf { # logf($logfile, $logmaxnr, "%s: %s - %s - %s", @array_or_LIST);
my($file,$max,$f,@list) = @_;
$f =~ s/\n?$/\n/;
open(LOG, "+<$file") or
die("Unable to open the specified file"); # ログファイルの名前を出すのはまずいので
eval { flock(LOG, 2) };
chomp(my @lines = <LOG>);
seek(LOG, 0, 0);
printf LOG ($f, @list);
for(my $i = 0; $i < ($max - 1) && $i < @lines; $i++) { print LOG "$lines[$i]\n"; }
truncate(LOG, tell);
close(LOG);
# # *old - flock, truncate 駄目なところ用
# open(LOG, $file) or
# die("Unable to open the specified file");
# chomp(my @lines = <LOG>);
# close(LOG);
# $#lines = $max - 2 if($max <= @lines);
# open(LOG, ">$file");
# printf LOG ($f, @list);
# print LOG "$_\n" foreach(@lines);
# close(LOG);
} # logf end
sub getenv {
my $host = ($ENV{REMOTE_HOST} && $ENV{REMOTE_HOST} ne $ENV{REMOTE_ADDR}) ? $ENV{REMOTE_HOST} : addr2name(1);
my $referer = $ENV{HTTP_REFERER} || 'none';
if($referer ne 'none') {
$referer =~ s/%([0-9a-f][0-9a-f])/pack('H2', $1)/ieg;
$referer =~ tr/\015\012<>"//d;
}
(my $agent = $ENV{HTTP_USER_AGENT} || '') =~ tr/\015\012<>"/ /;
return($ENV{REMOTE_ADDR},$host,$referer,$agent);
} # getenv end
sub getxhost {
my $host = shift || '';
my $addr_re = qr/\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}/;
my $host_re = qr/([a-z0-9][a-z0-9_\-.]+)\.([a-z]{2,}\.[a-z]{2}|com|net|org|edu|int|gov|mil|biz|info)\b/i;
my @xkeys = grep(/^HTTP_(?!ACCEPT|COOKIE|HOST|IF_MODIFIED_SINCE|PRAGMA|REFERER|USER_AGENT|VIA|X_FORWARDED_FOR)/i, (keys %ENV));
my @spill;
local %ENV = %ENV;
# 必要ないと思うけど念のため
$ENV{SERVER_NAME} ||= $ENV{HTTP_HOST};
$ENV{SERVER_ADDR} ||= name2addr($ENV{SERVER_NAME},1);
# proxy 変数っぽいものからアドレス・ホスト名らしき部分を見つけてチェック
foreach(@xkeys) {
$ENV{$_} =~ s!(?:https?|ftp)://[a-z0-9_\-./~%&]+!!igo;
$ENV{$_} =~ s/127\.0\.0\.1|\Q$ENV{SERVER_ADDR}\E|\Q$ENV{SERVER_NAME}\E|\Q$host\E//igo;
$ENV{$_} =~ s/($addr_re|$host_re)/($1 && $1 !~ m(^www\.)i) and unshift @spill, $1/ego;
$ENV{$_} =~ s/\b([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})\b
/unshift @spill, join('.', hex($1),hex($2),hex($3),hex($4))/xieg;
}
# HTTP_VIA と X_FORWARDED_FOR はちょっと別扱い
$ENV{HTTP_VIA} and
$ENV{HTTP_VIA} =~ s/($addr_re|$host_re(?!\S*\s\())
/($1 && $1 ne $host && $1 !~ m(^127\.0\.0\.1$|^\Q$ENV{SERVER_ADDR}\E$|\Q$ENV{SERVER_NAME}\E)i) and
unshift @spill, $1/xeg;
$ENV{HTTP_X_FORWARDED_FOR} and
$ENV{HTTP_X_FORWARDED_FOR} =~ s/($addr_re|$host_re)
/($1 && $1 ne $host && $1 !~ m(^127\.0\.0\.1$|^\Q$ENV{SERVER_ADDR}\E$|\Q$ENV{SERVER_NAME}\E)i) and
push @spill, $1/xeg;
if(@spill) {
my(%dup,%v,%is_addr);
@spill = grep(!$dup{$_}++, @spill); # 重複は除く
foreach(@spill) {
($_,my $v,my $is_addr) = look($_,$host);
($v{$_},$is_addr{$_}) = ($v,$is_addr);
}
# ホスト名の形で漏れてるのは見ればわかるからアドレス優先
@spill = sort {$v{$b} <=> $v{$a} or $is_addr{$b} <=> $is_addr{$a}} @spill;
return($spill[0],abs(int($v{$spill[0]}))) if($spill[0] && $v{$spill[0]} > -2);
}
return($host,0);
} # getxhost end
sub look {
my($susp,$host) = @_;
my($v,$is_addr) = (0,0);
if($susp =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
$is_addr = 1;
# -1 ... ローカル or フェイクっぽいアドレス
$v = -1 if($susp =~ /^(?:0|10|127|172\.(?:1[6-9]|2[0-9]|3[01])|192\.168|255)\.|\.(?:0|255)$/);
$susp = addr2name($susp,1);
$v = ($susp !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) ? 0 : $v ? $v : -0.5; # 0:ホスト名引ける / -1:上記 / -0.5:引けない
} else {
# -2 ... アドレスが引けない（ホスト名の形で誤認の可能性が高い）
$v = -2 unless(name2addr($susp));
}
# 2 ... ちゃんとアドレスが引けて REMOTE_HOST と同じでなく 自国ドメインなら漏れっぽい
$v = 2 if($susp ne $host && $susp =~ /$Ini{Domestic}/ && !$v);
return($susp,$v,$is_addr);
} # look end
sub addr2name {
my($addr,$r) = @_;
$addr = $ENV{REMOTE_ADDR} unless(defined $addr);
($addr,$r) = ($ENV{REMOTE_ADDR},1) if($addr eq '1');
my $name = gethostbyaddr(pack('C4', split(/\./, $addr)), 2);
return $name ? $name : $r ? $addr : undef;
} # addr2name end
sub name2addr {
my($name,$r) = @_;
return $name unless($name);
my $addr = join('.', unpack('C4', (gethostbyname($name))[4]));
return $addr ? $addr : $r ? $name : undef;
} # name2addr end
sub shrink {
my $host = shift;
# もっと厳密にもできるけどこんな感じでいいと思う
return($host,"http://www.$host/") if($host =~ s/.*?([a-z0-9\-]+\.(com|net|org|edu|int|gov|mil|biz|web|nom|rec|arpa|nato|firm|store|arts|info)(\.[a-z]{2})?)$/$1/i
|| $host =~ s/.*?([a-z0-9\-]{3,}\.[a-z]{2})$/$1/i
|| $host =~ s/.*?([a-z0-9\-]+\.[a-z0-9\-]+\.[a-z]+)$/$1/i);
return($host,"http://$host/"); # else
} # shrink end
__DATA__
sub chksnmp { # SNMPチェック - borrowed from Himiko Himeno's envcheck.cgi
#* $Ini{OptCheck} == 2 の場合のみ（無料サーバーの大部分では不能）
use Socket;
local $| = 1;
local(*SOCKET);
my $chkhost = shift;
my($retry,$timeout,$port,$count,$data,$raddr,$rin,$rout,$found_no) = (3,2,161,1,'','','','',0);
my $packet = pack('C*',
0x30,0x27, # length 0x27 = 39
0x02,0x01,0x00, # version 0x00 = 0
0x04,0x06,0x70,0x75,0x62,0x6c,0x69,0x63,
# community name "public"
0xa1,0x1a, # get_next_request
0x02,0x01,0x01, # request_id 0x01
0x02,0x01,0x00,0x02,0x01,0x00, # no error
0x30,0x0f, # length 0x0f = 15
0x30,0x0d, # length 0x0d = 13
0x06,0x09,0x2b,0x06,0x01,0x02,0x01,0x06,0x0d,0x01,0x04,
# tcpConnRemAddress 1.3.6.1.2.1.6.13.1.4
0x05,0x00 # null pudding
);
my $chkaddr = inet_aton($chkhost) or
return "invalid host: $chkhost";
my $paddr = sockaddr_in($port, $chkaddr);
my $proto = getprotobyname('udp');
socket(SOCKET, PF_INET, SOCK_DGRAM, $proto) or
return "socket error: $!";
connect(SOCKET, $paddr) or
return "connect error: $!";
while(1) {
send(SOCKET, $packet, 0) or
return "send error: $!";
$rin = '';
vec($rin, fileno(SOCKET), 1) = 1;
$found_no = select($rout = $rin, undef, undef, $timeout);
if($found_no == 1) {
$raddr = recv(SOCKET, $data, 128, 0);
close(SOCKET);
return "closed: $count time(s)" if(!defined $raddr || $raddr eq '');
return "<b>open</b>: $count time(s)"; # else
}
if($count >= $retry) {
close(SOCKET);
return "invalid community name: $count times";
}
$count++;
}
} # chksnmp end
# 参考
#-----------------------------------------------------------------------------------------------
# Force 264, PRX4EVER, たるおのうたたね部屋, Grand Cru, とくめいアクセス 他
# & special thanks to << Team MIZUIRO >>
# Script END
]]>