# euc-jp encode

# gzip_trans.pl 1.0t （一時ファイル作成バージョン）
# 2006 Gorigon


# 任意の perl 製 cgi を gzip 転送に対応させる。
# 大抵の cgi で適用可能なはず。
#
# ●使い方
# 　
# 　適用させたい cgi のなるべく先頭の方に
# 　
# 　require "gzip_trans.pl";
# 　
# 　を追加する。
# 
# ●制限
# 　
# 　以下の事を行っている cgi では利用できないはず。
# 　・END {***} 構文を使っている。
# 　・open(STDOUT, ***) 等で標準出力をフックしている。
#
# ●動作確認
# 　
# 　「さくらのレンタルサーバ ライト」に設置した BBS NOTE 8.0b19


# ↓必要に応じて gzip のパスを設定しておく
$gzip_trans_pth = "gzip";
*gzip_trans_old;
$gzip_trans_tmp;

sub gzip_trans_init {
	open(gzip_trans_old, ">&STDOUT");
	while(1){
		$gzip_trans_tmp = ".tmp.".substr("00000".(rand(1000000)), -6);
		open(STDOUT, ">$gzip_trans_tmp");
		if(flock(STDOUT, 6) == 0){
			close(STDOUT);
			next;
		}else{
			last;
		};
	};
}
sub gzip_trans_exit {
	$| = 1;
	my $hd;
	open($hd, "$gzip_trans_tmp");
	seek($hd, 0, 2);
	my $sz = tell($hd);
	seek($hd, 0, 0);
	my $data = "";
	read($hd, $data, $sz);
	unlink($gzip_trans_tmp);
	close($hd);
	close(STDIO);
	open(STDOUT, ">&gzip_trans_old");
	&gzip_trans_write($data);
	exit();
}
sub gzip_trans_write {
	$| = 1;
	my $data = $_[0];
	my $sj = index($data, "\n\n") + 2;
	if($sj == 1){
		$sj = index($data, "\r\n\r\n") + 4;
		if($sj == 3){
			$sj = length($data);
		};
	};
	my $head = substr($data, 0, $sj);
	my $html = substr($data, $sj);
	
	if($ENV{'HTTP_ACCEPT_ENCODING'} =~ /^(?:.*,)? *(x-)?gzip *(?:,.*)?$/){
		print STDOUT "Content-encoding: $1gzip\n";
		print STDOUT $head;
		open(STDOUT, "|$gzip_trans_pth -c --fast");
		print STDOUT $html;
	}else{
		print STDOUT $head.$html;
	};
}

&gzip_trans_init();

END {
	&gzip_trans_exit();
}

1;