#!/usr/bin/perl
$|=1;

=commentout
	aw_infomasterバックナンバー表示プログラム
	ソケット通信によりgetbk.cgi
	初期設定はinit.plで行います
	【前バージョンとの違い】
	ローカルの同じ階層に置いた「dispbk.html」を読みに行きます
=cut

use CGI::Carp;
#use CGI::Carp qw(fatalsToBrowser);
use CGI qw(:cgi-lib :cgi);
use Socket;
use FileHandle;




$cgifile = $ENV{'SCRIPT_NAME'};

foreach (param) {
	next unless $_;
	if (param("$_") =~ /\0/) {
		@{$_} = split(/\0/, param("$_"));
	} else {
		${$_} = param("$_");
	}
}

unless ($mem_id) {die 'no mem_id'}
$tmpl = $template || 'dispbk.html';

#--一覧---------------------------------------------------------------------

#データ取得
$getdata = &gethttp("http://www.analogengine.jp:80/aw_infomaster/dispbk2.cgi?mem_id=$mem_id&offset=$offset&num=$num");

my $sec = $/;
undef $/;
open FILE, $tmpl;
$html = <FILE>;
close FILE;
$/ = $sec;
undef $sec;

($html{'head'}, $html{'foot'}) = split /<!--backnumber-->/, $html;
print "content-type: text/html; charset=SHIFT_JIS\n\n";
print $html{'head'};
print $getdata;
print $html{'foot'};

exit;

sub gethttp {

=commentout
	参考
	http://www.kasai.fm/perlHTTP/
	「perl から Web ページを読み込む」
	(C) 2001-2004 笠井 崇文 (web@kasai.fm) 最終更新日: 2004年 3月 5日
	(C) 2001-2004 Takafumi Kasai           Last modified: 5 May, 2004
	配布スクリプトgetHTTPより必要部分を頂戴した。
=cut

	local $\ = "";

	my $uri = $_[0];
	my $data;
	my $agent = "analogengine_system_module";

	my ( $scheme, $domain, $server_address, $server_port, $path );
	my ( $target_address, $target_port, $target_path, $target_ip );


	
	croak "uri error" if $uri !~ s!^(\w+?)://!!;
	$scheme = $1;
	
	( $domain, $path ) = split( /\//, $uri, 2 );
	( $server_address, $server_port ) = split( /:/, $domain, 2 );
	
	$server_address ||= "localhost";
	$server_port    ||= getservbyname( $scheme, "tcp" );

	### switch arguments according to if you use a proxy server
	
	( $target_address, $target_port, $target_path ) = (
			$server_address,
			$server_port,
			"/$path"
		);
	
	$target_ip    = inet_aton( $target_address ) || die("Can't connect to $target_address" );
	$sock_address = pack_sockaddr_in( $target_port, $target_ip );
	
	socket(SOCKET, PF_INET, SOCK_STREAM, 0) || die("Can't create socket on $target_address");
	
	connect(SOCKET, $sock_address) or die("Can't connect socket on $sock_address");
	autoflush SOCKET (1);


 ######### Send HTTP GET request

	print SOCKET "GET $target_path HTTP/1.1\n";
	print SOCKET "Host: $target_address\n";
	print SOCKET "Connection: close\n";
	print SOCKET "User-Agent: $agent\n"  if ($agent);
	print SOCKET "Accept: text/html; */*\n";
	print SOCKET "\n";

	while ( <SOCKET> ) {
		chomp;
		$data .= "$_\n";
	}


	close(SOCKET);


	return(&analysisHTTP($data));
}


sub analysisHTTP {
	my $data = $_[0];
	my %head;

	my ( $head, $body ) = split(/\r?\n\r?\n/, $data, 2);
	my ( $status, @headline ) = split(/\r?\n/, $head);

	foreach $line(@headline){
		my ($item, $val) = split(/:\s*/, $line, 2);
		$head{$item} = $val;
	}
	
	if ($head{'Transfer-Encoding'}){
		foreach $te( split(/\s*:\s*/, $head{'Transfer-Encoding'}) ){
			my ( $coding, @parameter ) = split(/\s*;\s/, $te);
			my %parameter;
			foreach $parameter(@parameter){
				my ( $item, $val ) = split(/\s*=\s/, $parameter, 2);
				$parameter{$item} = $val;
			}
			
			$body = &decodeChunk($body) if ($coding eq 'chunked');
		}
	}
	
	return ($body);
}

sub decodeChunk {
	my ($chunk_body, $data) = ($_[0]);
	
	do {
		my %chunk_ext;
		my ($topchunk_sizeline, $chunk_body) = split(/\r?\n/, $chunk_body, 2);
		my ($topchunk_size, @topchunk_ext) = split(/\s*;\s*/, $topchunk_sizeline);
		$topchunk_size = hex($topchunk_size);
		
		foreach $ext(@topchunk_ext){
				my ( $item, $val ) = split(/=/, $ext, 2);
				$chunk_ext{$item} = $val;
		}
	
		my $chunk_part;
		 ($chunk_part, $chunk_body)
		 = ( substr($chunk_body, 0, $topchunk_size), substr($chunk_body, $topchunk_size + 1) );
			
		$data .= $chunk_part;
	} while ($topchunk_size);

	$chunk_body =~ s/\r?\n\r?\n$//;
	
	return $data;
}