#!/usr/local/bin/perl5

#// [CGI] H"からアクセスした場合にWebsiteのリンクをたどったり
#// ちょっとしたPOSTが出来るようになったりしてるゲートウエイ気味
#// Ver.0.50.00
#// 
#// by YOUMEI
#// 
#// 2002/02/09 04:53:00 Ver.0.50.00
#// 	ひとまず作成
#//
#// ※注意事項
#// ・Perl5以降でご利用ください。
#// ・操作性が悪いので、仕様を練り直した方が良かったかも。
#// ・現在はAirH"Phoneなため試験出来ません・・・。
#// ・2年近く前に作った物を発掘したので、詳しいことはソースコードから。
#// ・思い出したらこの辺にコメントを追加しておきます。

require'jcode.pl';
use Socket;

#// このcgiの設置URL
$cgi_url="http://";

%QSTR=&read_get;
%SUBJ=&read_pdxsubj($QSTR{'pdxsubj'});

#//アドレスとポート取得、設定
$url=$QSTR{'u'};
$httprefer=$url;
$httpport='80';

#// メイン呼び出し
($result, $body)=&get_http($url, $httpport, $httprefer);
&pdx_text($url, $body);

#open LOG,">>test.log";
#print LOG "$result, $ENV{'QUERY_STRING'}\n";
#close LOG;
exit;


#// http:や//を削除
#// --------------------------------------------------
sub replace_http_str {
	$_[0]=~s/http\://i;
	$_[0]=~s/\/\///;
	return $_[0];
}

#// html->pdxmail変換、表示
#// --------------------------------------------------
sub pdx_text
{
	my ($title, $link, $dir, $tmp, @line);
	my ($from, $form_body, $atrb);
	my ($method, $subject);
	my ($count, $i);
	my $url=shift;
	my $body=shift;

	$url=&replace_http_str($url);
	$url=~/(.*\/)/;
	$dir=$1;
	$body=~/<title>(.*)<\/title>/s;
	$title=$1;

	print"Content-type: text/plain\n\n";
	print"X-PmailDX-CTRL:LineDisconnect\n" if($url eq '');

	$body=~/<body.*?>(.*)<\/body>/is;
	$body=$1;
	$body=~s/\r\n/\r/g;
	$body=~s/\n/\r/g;

	$body=~s/<img.+?alt="(.+?)">/grp:$1/g;

	#// はいぱーりんくをH"のタグに変換
	@line=split(/\r/, $body);
	$i=0;
	$count=1;
	$body='';
	for (0..$#line) {
		$tmp=$line[$i++];
		while( $tmp=~/<a href="(\S+?)".*?>(.+?)<\/a>/i ) {
			$link=$1;$str=$2;
			$link="http://$dir$link" if( $link!~/^http:\/\//i );
			$link=~s/\/\.\//\//g;
			$link=~s/([^\.\*\-_a-zA-Z0-9 ])/sprintf("%%%02lX",unpack("C",$1))/eg;
			$link=~tr/ /+/;
			$link="$cgi_url?u=$link";

			$str=~s/<.+?>//g;
			push(@sel_tag, "<SEL=$count;$link>\n");
			push(@sel_str, "\[$count\] $str ");
			$tmp=~s/<a href="(\S+?)".*?>(.+?)<\/a>/\[$count\] $2/i;
			$count++;
		}
		$body.=$tmp;
	}

	#// フォームタグ処理
	$body=~s/<form(.*?)>(.+?)<\/form>/\$\$form\$\$/is;
	if( length($1) > 0 ) {
		$atrb=$1;
		$form_body=$2;

		$atrb=~/action="(\S+?)"/i;
		$from="$cgi_url?u=$dir$1";
		$atrb=~/method\=(\S+)/i;
		$method=$1;
		$method=~s/\"//g;
		$method=~s/\'//g;
		$subject="mthd=${method}&";

		$i=1;
		do {
			$form_content='';
			$form_body=~/<input (.*?)>/i;
			$atrb=$1;
			$atrb=~/type=(\S+)/i;
			$type=$1;
			$atrb=~/name=(\S+)/i;
			$name=$1;
			$name=~s/\"//g;
			$name=~s/\'//g;
			$atrb=~/value=(\S+)/i;
			$value=$1;
			$value=~s/\"//g;
			$value=~s/\'//g;

			if($type=~/hidden/i) {
				$subject.="$name=$value&";
			} elsif($type=~/text/i) {
				$subject.="$name=\$t\$&";
				$form_content="$i>$name";
				$i++;
			}
		} while($form_body=~s/<input (.*?)>/$form_content/is);

		$body=~s/\$\$form\$\$/$form_body<br>/;
	} else {
		$from=$cgi_url;
	}

	#// HTML整形(?)
	$body=~s/<\/td>/\n/ig;
	$body=~s/<br>/\n/ig;
	$body=~s/<\/?p>/\n/ig;
	$body=~s/<\/?div>/\n/ig;
	$body=~s/<.+?>//g;
	$body=~s/</<</g;
	$body=~s/&gt;/>/g;
	$body=~s/&lt;/<</g;
	$body=~s/&amp;/&/g;
	$body=~s/&nbsp;/ /g;
	$body=~s/&quot;/"/g;
	$body=~s/\t//g;

	print"From: $from\n";
	print"Subject: $title\n";
	print"Content-Type: Text/X-PmailDX\n\n<SUB=$subject>\n";
	print @sel_tag;
	print @sel_str;
	print "\n$body\n";

}

#// httpソケット通信
#// --------------------------------------------------
sub get_http {

	my ($server, $path, $proto, $ent);
	my ($loop, $url, $port, $refer, $rescode, $data);
	my (%head);

	$url=shift;
	$port=shift;
	$refer=shift;
	$proto=getprotobyname('tcp');
	$SUBJ{'000mthd'}=~tr/a-z/A-Z/;

	do {
		$loop=0;
		$url=&replace_http_str($url);
		$url=~s/&amp;/&/;
		$url=~/([a-zA-Z0-9\-\.]+)(.*)/;
		$server=$1;
		$path="/$2";
		$path=~s/\/\//\//;

		socket(SOCK, PF_INET, SOCK_STREAM, $proto);
		$ent = sockaddr_in($port, inet_aton($server));
		eval'connect(SOCK, $ent) || die ">> HTTP Connection Error."';
		if ($@ ne '') {
			close(SOCK);
			print $@;
			return (0, '', $@);
		}
		select(SOCK); $| = 1; select(STDOUT);

		#// POSTメソッド送信内容作成
		$content='';
		if( $SUBJ{'000mthd'} eq 'POST') {
			$pdxdata=$QSTR{'pdxdata'};

			@values=split(/\r/, $pdxdata);
			$i=0;
			foreach $tmp(sort(keys(%SUBJ))) {
				if( $tmp ne '000mthd')	{
					if( $SUBJ{$tmp} eq '$t$') {
						$SUBJ{$tmp}=$values[$i++];
						$SUBJ{$tmp}=~s/([^\.\*\-_a-zA-Z0-9 ])/sprintf("%%%02lX",unpack("C",$1))/eg;
					}
					$tmp_name=substr($tmp,3);
					$content.="$tmp_name=$SUBJ{$tmp}&";
				}
			}
			#// POSTメソッドヘッダ送信
			print SOCK "POST $path HTTP/1.0\r\n";
			print SOCK "Content-Length: ".length($content)."\r\n";
		} else {
			#// GETメソッドヘッダ送信
			print SOCK "GET $path HTTP/1.0\r\n";
		}

		#// 残りのヘッダを適当に送信
		print SOCK "Host: $server\r\n";
		print SOCK "Accept: */*\r\n";
		print SOCK "User-Agent: Mozilla/4.5 [ja] (Win98; I)\r\n";
		print SOCK "Connection: close\r\n";
		print SOCK "\r\n";

		print SOCK $content;

		$rescode=<SOCK>;
		$rescode=~/HTTP\/\d.\d (\d{3})/;
		$rescode=$1;

		while(<SOCK>) {
			last if($_ eq "\r\n");
			chomp;
			($name, @values)=split(/\:/, $_);
			$name=~tr/A-Z/a-z/;
			$name=~s/ //g;
			$value=join(':',@values);
			$value=~s/ //g;
			$head{$name}=$value;
			if($name=~/^location/i) {
				$url=$value;
				$loop=1;
				goto NextLoop;
			}
		}
		$data='';
		$data.=$_ while(<SOCK>);

	NextLoop:
		close(SOCK);
	} while($loop);

	return ("1:${server}2:${path}", $data);
}

#// GETメソッド取得
#// --------------------------------------------------
sub read_get { 
	my	(%qstr, @pairs, $pair, $name, $value);

	if( length($ENV{'QUERY_STRING'}) > 0) {
		@pairs = split(/&/, $ENV{'QUERY_STRING'}); 
		foreach $pair(@pairs)
		{
			($name, $value) = split(/=/, $pair);
			$value =~ tr/+/ /;
			$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
			&jcode'convert(*value, 'sjis');
#			$value =~ s/\&/&amp;/g;
#			$value =~ s/\"/&quot;/g;
#			$value =~ s/</&lt;/g;
#			$value =~ s/>/&gt;/g;
#			$value =~ s/\t//g;
			$value =~ s/\r\n/\r/g;
			$value =~ s/\n/\r/g;
			$qstr{$name} = $value;
		}
	}
	return %qstr;
}

#// pdxsubj取得
#// --------------------------------------------------
sub read_pdxsubj { 
	my	(%subj, @pairs, $pair, $name, $value);

	my $pdxsubj=shift;

	if( length($pdxsubj) > 0) {
		$pdxsubj =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
		@pairs = split(/&/, $pdxsubj);
		$i=0;
		foreach $pair(@pairs)
		{
			($name, $value) = split(/=/, $pair);
			$value =~ tr/+/ /;
			$subj{sprintf("%03d%s",$i++, $name)} = $value;
		}
	}
	return %subj;
}
__END__