package chkurl;
#-------------------------------------------------------------
# chkurl
# URL をチェックする
#
# 1997/11/21 Ver.0.00
# 1997/12/08 Ver.0.01
# 1998/02/08 Ver.0.02
# 1998/02/16 Ver.0.03 ホストの IP アドレスでの指定に対応。
# chkurl.pl ファイル名の変更
# 1998/04/07 Ver.0.04 package 化
# 1998/09/25 Ver.0.05 内部エラーでの Message
# http:// のチェックなど
# 1998/12/16 Ver.0.06 HTTP1.1 対応
# 1999/02/23 Ver.0.07 response を１行だけ読むように変更
# 1999/05/02 Ver.0.08
# 1999/06/30 Ver.0.10 500 のとき GET でリトライ
# 1999/07/08 Ver.0.11
#
# Copyright (C) 1997-99 がま
# e-mail addr : gama@mvg.biglobe.ne.jp
#
# USAGE
# &chkurl'chkurl($url);
#-------------------------------------------------------------
$user_agent = 'chkurl/0.11'
.' (http://www2d.biglobe.ne.jp/~gama/cgi/index.cgi)';
#-------------------------------------------------------------
use Socket;
$CRLF = "\r\n";
#-------------------------------------------------------------
sub chkurl {
#-------------------------------------------------------------
$url = $_[0];
$url =~ s/^(http\:\/\/)//i; # http:// を削除
unless ( $1 ) {
return ("Format Error in chkurl");
}
($hostname, $filename) = split('/', $url, 2); # / で区切る
$filename = '/'.$filename;
#-------------------------------------------------------------
$Inet = &AF_INET;
$Stream = &SOCK_STREAM;
$Port = 80;
#-------------------------------------------------------------
# ホスト名からアドレスへ変換する
if ( $hostname =~ /^[0-9]+(\.[0-9]+)+$/) {
my(@temp)=split('\.', $hostname);
$destaddr = pack('C4',@temp);
} else {
unless ($destaddr = gethostbyname($hostname)) {
return ("Can't get Host Address in chkurl");
}
}
$Proto = getprotobyname('tcp');
$destproc = pack('S n a4 x8', $Inet, $Port, $destaddr);
# Request & Response -----------------------------------------
$_= &req("HEAD");
# ------------------------------------------------------------
# 500 のとき GET でリトライ
if ($_=~ /500/) {
$_= &req("GET");
$_ .= "(Retry by GET method)";
} else {
$_ .= "(first request)";
}
# ------------------------------------------------------------
# 200 が含まれなければエラー 呼び出し側で判断する
return($_);
}
#-------------------------------------------------------------
sub req{
my($method)=$_[0];
#-------------------------------------------------------------
unless (socket(SOCK, $Inet, $Stream, $Proto)) {
return ("Can't open socket in chkurl");
}
unless (connect(SOCK, $destproc)) {
return ("Can't connect in chkurl");
}
# SOCK を バッファリングしないようにする ---------------------
select(SOCK);
$|=1;
select(STDOUT);
my($request) = "$method $filename HTTP/1.1$CRLF"
. "Host: $hostname$CRLF"
. "User-Agent: $user_agent$CRLF"
. $CRLF;
print SOCK $request;
$_ = <SOCK>; # 最初の１行だけ読む
chomp;
close(SOCK);
return($_);
}
1;