
package main;
;#----------------------------------------------------------------------------
;# socket.pl : ソケット関連 Perl パッケージ
;# http://www.junkperl.com/
;# Copyright (C) 2006- By HeRO
;# Ver 1.00 2006/08/09
;# Ver 1.01 2006/08/10 request_head
;# Ver 1.02 2006/08/19 URLマッチング修正
;# Ver 1.03 2006/08/19 scan_port 改善
;# 
;# このプログラムはフリーソフトウェアです。あなたはこれを、フリーソフトウェア
;# 財団によって発行された GNU 一般公衆利用許諾契約書(バージョン2か、希望によっ
;# てはそれ以降のバージョンのうちどれか)の定める条件の下で再頒布または改変する
;# ことができます。
;#
;# このプログラムは有用であることを願って頒布されますが、*全くの無保証* です。
;# 商業可能性の保証や特定の目的への適合性は、言外に示されたものも含め全く存在
;# しません。詳しくはGNU 一般公衆利用許諾契約書をご覧ください。
;#
;# あなたはこのプログラムと共に、GNU 一般公衆利用許諾契約書の複製物を一部受け
;# 取ったはずです。もし受け取っていなければ、フリーソフトウェア財団まで請求し
;# てください(宛先は the Free Software Foundation, Inc., 59 Temple Place,
;# Suite 330, Boston, MA 02111-1307 USA)。
;#----------------------------------------------------------------------------
$HEAD_TIMEOUT = 3 if $HEAD_TIMEOUT eq "";
$GET_TIMEOUT = 3 if $GET_TIMEOUT eq "";
;#----------------------------------------------------------------------------
sub request_head
{
	local( $url, $host, $file, $ctype ) = @_;
	local( @HEAD );

	$url =~ /http:\/\/([-_.!~*'()a-zA-Z0-9;:\@&=+\$,%#]+)(\/*[-_.!~*'()a-zA-Z0-9;:\@&=+\$,%#\/]*)/i;
	$host = $1;
	$file = $2;

	if( $host eq "" ){
		$ERR_MSG = "アドレス指定ミス(http:// からアドレスを指定してください。)";
		return 0;
	}
	$file = "/" unless $file;

	return 0 if &html_head( $host, $file, "dana/1.00 (HTTP client sample)", *HEAD ) == 0;
	if( $file !~ /\/$/ && $HEAD[0] !~ /200/ ){
		$file .= "/";
		return 0 if &html_head( $host, $file, "dana/1.00 (HTTP client sample)", *HEAD ) == 0;
		if( $HEAD[0] !~ /200/ ){
			$ERR_MSG = "$HEAD[0]";
			return 0;
		}
	}

	foreach my $HEAD ( @HEAD ){
		if( $HEAD =~ /Content-Type:\s*([^\s]*)/i ){
			$ctype = $1;
			last;
		}
	}

	$_[1] = $host;
	$_[2] = $file;
	$_[3] = $ctype;

	return 1;
}
;#----------------------------------------------------------------------------
sub html_head
{
	local( $host, $file, $user_agent, *HEAD ) = @_;
	my $ret = &html_method( $host, $file, "HEAD", $user_aegnt, "", $HEAD_TIMEOUT, *HEAD );
	return $ret;
}
;#----------------------------------------------------------------------------
sub html_get
{
	local( $host, $file, $user_agent, $stop_string, *BODY ) = @_;
	my $ret = &html_method( $host, $file, "GET", $user_aegnt, $stop_string, $GET_TIMEOUT, *HEAD, *BODY );
	return $ret;
}
;#----------------------------------------------------------------------------
sub html_method
{
	local( $host, $file, $method, $user_agent, $stop_string, $timeout, *HEAD, *BODY ) = @_;
	eval {
		local $SIG{ALRM} = sub { die "TIMEOUT"; };
		alarm $timeout;

		my $ip = inet_aton( $host );
		my $socketpack = sockaddr_in( 80, $ip );
		unless( socket( SOCKET, PF_INET, SOCK_STREAM, 0 ) ){
			$ERR_MSG = "ソケットエラー。";
			return 0;
		}
		unless( connect( SOCKET, $socketpack ) ){
			$ERR_MSG = "ポート[80]に接続できません。";
			close( SOCKET );
			return 0;
		}
		select( SOCKET ); $|=1; select( STDOUT );
		print SOCKET "$method $file HTTP/1.0\r\n";
		print SOCKET "Host: $host:80\r\n";
		print SOCKET "User-Agent: $user_agent\r\n";
		print SOCKET "\r\n";
		@HEAD = ();
		while (<SOCKET>){
			push @HEAD, $_;
			m/^\r\n$/ and last;
		}
		if( $method eq "GET" ){
			@BODY = ();
			while (<SOCKET>){
				push @BODY, $_;
				last if $stop_string ne '' && $_ =~ /$stop_string/i;
			}
		}
		alarm 0;
	};
	alarm 0;
	close( SOCKET );

	if( $@ ){
		if($@ =~ /TIMEOUT/) {	$ERR_MSG = "タイムアウトしました。[$timeout sec]";	}
		else{					$ERR_MSG = "処理中にエラーが発生しました。[$@]";	}
		return 0;
	}

	return 1;
}
;#----------------------------------------------------------------------------
sub scan_port
{
	# well-known PORT のチェック
	local( $port, $ip, $timeout ) = @_;

	eval {
		local $SIG{ALRM} = sub { die "TIMEOUT"; };
		alarm $timeout;

		$ip = inet_aton( $ip );
		my $socketpack = sockaddr_in( $port, $ip );
		socket( SOCKET, PF_INET, SOCK_STREAM, 0) || die "SOCKET_ERROR";
		connect( SOCKET, $socketpack ) || die "PORT_ERROR";

		alarm 0;
	};
	alarm 0;
	close( SOCKET );

	if( $@ ){
		if($@ =~ /TIMEOUT/) {			$ERR_MSG = "タイムアウトしました。[$timeout sec]";	}
		elsif($@ =~ /SOCKET_ERROR/){	$ERR_MSG = "ソケットエラーが発生しました。";		}
		elsif($@ =~ /PORT_ERROR/){		$ERR_MSG = "ポートエラーが発生しました。";			}
		else{							$ERR_MSG = "処理中にエラーが発生しました。[$@]";	}
		return 0;
	}

	return 1;
}
;#----------------------------------------------------------------------------

1;

