package kmHTTP;

use Socket;
use strict;

my $G_VIEW_REQEST = 0;   # STDERR にリクエストを出力する？

my $G_TIMEOUT = 30;  # recv のタイムアウト時間を秒単位で



my $g_proxy_server = undef;# 'localhost';
my $g_proxy_port = 8080;
my $g_referer = undef;
my $g_user_agent = 'kmHTTP.pm/1.3 (script by tkuri _at_ fat.coara.or.jp; using HTTP/1.1)';

#==============================================================================
# プロクシを設定
#   kmHTTP::useProxy( 'proxy.server.net', 8080 );
sub useProxy {
	$g_proxy_server = shift;
	$g_proxy_port   = shift if (@_);
}


#==============================================================================
# リファラを設定
sub setReferer {
	$g_referer = shift;
}


#==============================================================================
# User-Agent 文字列を設定
sub setUA {
	$g_user_agent = shift;
}

#-----------------------------------------------------------------------------
#-   GET
#-----------------------------------------------------------------------------
sub GET {
	return &do_request('GET', $_[0]);
}

#-----------------------------------------------------------------------------
#-   HEAD
#-----------------------------------------------------------------------------
sub HEAD {
	return &do_request('HEAD', $_[0]);
}

#------------------------------------------------------------------------------
sub do_request {

	my $method = shift;
	my $target_url = shift;

	my $server = '';
	my $host = '';
	my $port = 0;
	my $url = '';

	if ($target_url =~ m[^http://(.+?)/(.*)]) {

		my ($user, $serverport) = split( /\@/, $1, 2 );
		$serverport = $user unless $serverport;
		($host, $port) = split( /:/, $serverport );
		$port = 80 unless $port;

		if ($g_proxy_server) {
			$url = $target_url;
			$server = $g_proxy_server;
			$port = $g_proxy_port;
		} else {
			$url = '/' . $2;
			$server = $host;
		}
	}
	else{
		return wantarray ? ('invalid url') : 'invalid url';
	}



	#- ソケットのオープン
	socket( SOCK, AF_INET, SOCK_STREAM, getprotobyname( 'tcp' ) ) or die;

	#- ホスト名からIPアドレスを取得
	my $ipaddr = inet_aton( $server );
	unless ($ipaddr) {
		return wantarray ? ('no host') : 'no host';
	}

	#- ホスト，ポートへの接続
	# if( !connect( SOCK, pack( 'S n a4 x8', AF_INET, $port, $ipaddr) ) ) {
	if( !connect( SOCK, sockaddr_in( $port, $ipaddr ) ) ) {
		close( SOCK );
		return wantarray ? ("can't connect") : "can't connect";
	}

	#- ソケットのバッファリングを止める
	select( SOCK ); $| = 1; select( STDOUT );

	#--------------------------------------------------------------------------
	#- リクエストをサーバに送る
	#--------------------------------------------------------------------------
	sub request {
		my $handle = $_[0];
		print $handle $_[1];
		print STDERR $_[1] if ($G_VIEW_REQEST);
	}

REQUEST: {
	my $handle = *SOCK;
	&request( $handle, "$method $url HTTP/1.1\r\n" );
	&request( $handle, "Host: $host\r\n" );
	&request( $handle, "User-Agent: $g_user_agent\r\n" ) if ($g_user_agent);
	&request( $handle, "Accept: text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,image/jpeg,image/gif;q=0.2,*/*;q=0.1\r\n" );
	&request( $handle, "Accept-Language: ja,en-us;q=0.7,en;q=0.3\r\n" );
	&request( $handle, "Accept-Encoding: gzip,deflate,compress;q=0.9\r\n" );
	&request( $handle, "Accept-Charset: ISO-8859-1,utf-8;q=0.7,*;q=0.7\r\n" );
	&request( $handle, "Connection: close\r\n" );
	&request( $handle, "Referer: $g_referer\r\n" ) if ($g_referer);
	&request( $handle, "\r\n" );
} # end of REQUEST



	#--------------------------------------------------------------------------
	#- 受信
	#--------------------------------------------------------------------------


	#- タイムアウト処理ルーチン --------
	sub timeout_server{
		close( SOCK );
	}

	my $header = '';
	my $entity = '';

RECEIVING: {

	eval {$SIG{'ALRM'} = \&timeout_server;};

	my $handle = &new_exStream( *SOCK, $G_TIMEOUT );
	my $chunked = 0;
	my $content_length = 0;
	my $connection_close = 0;

	# レスポンスヘッダ取得 -------------------
	for (;;) {
		my $line = '';

		&exStream_getLine( $handle, \$line ) or last RECEIVING;

		if ( $line eq "\r\n" || $line eq "\n" ) {
			last;
		}

		if ( $line =~ /Transfer\-Encoding:\s*chunked/i ) {
			$chunked = 1;
		}
		elsif ( $line =~ /Content\-Length:\s*(\d+)/i ) {
			$content_length = $1 - 0;
		}
		elsif ( $line =~ /^Connection/ && $line =~ /close/ ) {
			$connection_close = 1;
		}
		$header .= $line;
	}

	#
	#  リクエストが HEAD ならば，ここで last RECEIVING; でもよいかも？
	#

	# エンティティボディを取得 -----------

	if ( $chunked ) {

		# chunked なエンティティボディを取得 -----------
		for (;;) {

			my $line = '';
			&exStream_getLine( $handle, \$line ) or last RECEIVING;
			my $length = hex( $line );
			#print STDERR "chunk length: $length\n";
			last unless( $length );

			# サイズを満たすまで，チャンクを取得
			&exStream_getSize( $handle, $length, \$entity ) or last RECEIVING;

			# チャンク後のなんだかわからないものがあれば，取得
			&exStream_getLine( $handle, \$line );
		}

	}
	elsif ( $content_length > 0 ) {
		&exStream_getSize( $handle, $content_length, \$entity );
	}
	elsif ( $connection_close ) {
		&exStream_flushStock( $handle, \$entity );
		for (;;) {
			my $buf;
			recv ( SOCK, $buf, 1000, 0 ) or last;
			if ( length($buf) == 0 ) { last; }
			$entity .= $buf;
		}
	}

} # end of RECEIVING

	eval { alarm( 0 ) };
	close( SOCK );

	return wantarray ? ($header, $entity) : $header.$entity;
}


###############################################################################
#
#       exStream

# メンバ宣言
my $es_sd = 'desc';
my $es_stock = 'stock';
my $es_timeout = 'timeout';

#------------------------------------------------------------------------------
#  ストリームディスクリプタ (のグロブ) をもとに exStream ハンドルを生成
#   my $handle = &new_exStream( *SOCK );  # グロブを使う
sub new_exStream {
	my $tm = 10;

	$tm = $_[1] if ($_[1]);

	return {
		$es_sd => $_[0],
		$es_timeout => $tm,
		$es_stock => '',
	};
}

#------------------------------------------------------------------------------
# LF までを得る
#  行は $$result に格納される
sub exStream_getLine {
	my ($handle, $result) = @_;

	$$result = '';
	for (;;) {
		if ( length($handle->{$es_stock}) == 0 ) {
			eval{ alarm($handle->{$es_timeout}); };
			recv( $handle->{$es_sd}, $handle->{$es_stock}, 1000, 0 ) or return 0;
			if ( length($handle->{$es_stock}) == 0 ) { return 0; }
		}

		if ( $handle->{$es_stock} =~ /\n/ ) {
			$$result .= $`.$&;
			$handle->{$es_stock} = $';  #'
 			last;
		}
		$$result .= $handle->{$es_stock};
		$handle->{$es_stock} = '';
	}

	return 1;
}

#------------------------------------------------------------------------------
# size を満たすまで得る
# @param $handle  .. ハンドル (規定のハッシュのリファレンス)
# @param $size    .. サイズ
# @param $result  .. データを格納するスカラのリファレンス
#                    元々データがあれば，新しいデータは後ろに追記される

sub exStream_getSize {
	my ($handle, $size, $result) = @_;

	my $stock_size = length( $handle->{$es_stock} );
	while ($size) {
		if ( $stock_size == 0) {
			eval{ alarm($handle->{$es_timeout}); };
			recv( $handle->{$es_sd}, $handle->{$es_stock}, 1000, 0 ) or return 0;
			$stock_size = length( $handle->{$es_stock} );
			if ( $stock_size == 0 ) { return 0; }
		}
		my $len = $size < $stock_size ? $size : $stock_size;
		$$result .= substr( $handle->{$es_stock}, 0, $len );
		substr( $handle->{$es_stock}, 0, $len ) = '';
		$size -= $len;
		$stock_size -= $len;
	}

	return 1;
}


# ストックに残っているデータを全て得る
sub exStream_flushStock {
	my ($handle, $rbuf) = @_;
	$$rbuf = $handle->{$es_stock};
	$handle->{$es_stock} = '';
}


1;

__END__

=head1 NAME

kmHTTP.pm - HTTP/1.1 で web 上のリソースを得るモジュール

=head1 SYNOPSIS

  # HTTP レスポンスヘッダとボディを別々に得る
  use kmHTTP;
  my ( $head, $body ) = kmHTTP::GET( 'http://some.server.net/' );

  # ヘッダとボディを一度に得る
  use kmHTTP;
  my $head_body = kmHTTP::GET( 'http://some.server.net/' );

=head1 FUNCTIONS

=head2 kmHTTP::useProxy

プロクシの設定をします。
第 1 引数はプロクシサーバ名もしくは IP アドレス，
第 2 引数はポート番号を入力します。

  use kmHTTP;
  kmHTTP::useProxy( 'proxy.server.net', 3129 );
  my $data = kmHTTP::GET( 'http://some.server.net/' ); # HTTP プロクシを通した結果


第 2 引数は省略可能です。省略した場合，前回使用されたポート番号をそのまま用います。
初期状態は 8080 が設定されています。

  kmHTTP::useProxy( 'proxy.server.net' );


=head2 kmHTTP::setReferer

リファラを設定します。

  use kmHTTP;
  kmHTTP::setReferer( 'http://some.server.net/page1' );

初期値は undef です。undef の場合，リファラを送りません。

  my $url = 'http://some.server.net/';
  use kmHTTP;
  kmHTTP::GET( $url );  # リファラ送らない

  kmHTTP::setReferer( 'http://some.server.net/' );
  kmHTTP::GET( $url );  # リファラ送る

  kmHTTP::setReferer( undef );
  kmHTTP::GET( $url );  # リファラ送らない

=head2 kmHTTP::setUA

ユーザエージェント文字列を設定します。

  use kmHTTP;
  kmHTTP::setUA( 'HTTPGetter/1.3 (comment here...)' );

=head2 kmHTTP::GET

GET メソッドで web からデータを取得します。
HTTP ヘッダも含まれます。

  # ヘッダとボディを別々に収録
  use kmHTTP;
  my ( $head, $body )  = kmHTTP::GET( 'http://some.server.bet/' );

  # ヘッダとボディを一緒に取得
  use kmHTTP;
  my $data = kmHTTP::GET( 'http://some.server.net/' );

=head2 kmHTTP::HEAD

HEAD メソッドで HTTP ヘッダを取得します。

  # ヘッダとボディを別々に
  # HEAD メソッドでも，まれに body を返してくるサーバがある。。。
  use kmHTTP;
  my ( $head, $body ) = kmHTTP::HEAD( 'http://some.server.net/' );

  use kmHTTP;
  my $data = kmHTTP::HEAD( 'http://some.server.net/' );

=cut