List of bbs-ex2/chkurl.pl

Thu Apr 26 03:38:29 2018

戻る

TEXTAREA で表示(カット&ペーストむき)

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 を1行だけ読むように変更
#   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>;                       # 最初の1行だけ読む
    chomp;
    close(SOCK);

    return($_);
}
1;

戻る