#!/usr/local/bin/perl 

print "Content-type: text/html; charset=iso-2022-jp\n\n";

eval{ require 'D:/APPDATA/IIS/Root/scripts/irc/qi-config.cgi' };
if($@){
	print map{ s/\n/<BR>/ } $@;
	exit;
}

my $server			= ${ServerHost} ;
my $port			= ${ServerPort} ;
my $user			= ${ListUserPrefix}. $$;
my $qiloginurl		= ${LoginCGI};
my $datafile		= ${ChannelListFile};
my $cache_expire	= ${CacheExpire}; 

# 引数があればキャッシュしない
my $no_cache = (length($ENV{QUERY_STRING}||'')?1:0);

# キャッシュの有効時間 単位は秒


###############################
my $now = time;

if( not $no_cache ){
	# 前回調査してから時間が経過していないならそれを読んで済ませる
	if( open(IN,$datafile) ){
		my $mt = (stat(IN))[9];
		if( $mt > (stat($ENV{SCRIPT_FILENAME}))[9]
		and $now - $mt < $cache_expire
		){
			while(<IN>){print;}
			print qq(<!-- cached now=$now cache=$mt expire=$cache_expire -->\n);
			exit;
		}
		close IN;
	}
}

###############################
# 残りの部分は必要なときだけeval される

my @code = <DATA>;
eval join "",@code;
if($@){
	my $a = $@;
	$a =~ s/[\r\n]+/<BR>/g;
	print $a;
}
exit;
__DATA__

require 'D:/APPDATA/IIS/Root/scripts/gb/jcode.pl';

###############################

# 素のテキストをHTMLに変換する(EUC)
# 改行のサポートを取り除いた簡易版
sub TextToHTML{
	my($text)=@_;
	defined $text or return;
	$text =~ s/[\x00-\x1f]//g;
	$text =~ s/\&/&amp;/g;
	$text =~ s/\</&lt;/g;
	$text =~ s/\>/&gt;/g;
	$text =~ s/\"/&quot;/g;
	$text =~ s/\s/&nbsp;/g;
	return $text;
}

############################################

my $http_URL_regex;
my $ftp_URL_regex;
my $mail_regex;
{
	my $alpha = q{[a-zA-Z]};
	my $digit = q{[0-9]};
	my $digits = qq{$digit+};
	my $alphanum = q{[a-zA-Z0-9]};
	my $hex = q{[0-9A-Fa-f]};
	my $escape = qq{%$hex$hex};

	# http URL の正規表現 $http_URL_regex
	{
		my $uric = q{(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]} . qq{|$escape)};
		my $fragment = qq{$uric*};
		my $query = qq{$uric*};
		my $pchar = q{(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]} . qq{|$escape)};
		my $param = qq{$pchar*};
		my $segment = qq{$pchar*(?:;$param)*};
		my $path_segments = qq{$segment(?:/$segment)*};
		my $abs_path = qq{/$path_segments};
		my $port = qq{$digit*};
		my $IPv4address = qq{$digit+\\.$digit+\\.$digit+\\.$digit+};
		my $toplabel = qq{$alpha(?:} . q{[-a-zA-Z0-9]*} . qq{$alphanum)?};
		my $domainlabel = qq{$alphanum(?:} . q{[-a-zA-Z0-9]*} . qq{$alphanum)?};
		my $hostname = qq{(?:$domainlabel\\.)*$toplabel\\.?};
		my $host = qq{(?:$hostname|$IPv4address)};
		my $http_URL =
		    qq{(?:https?|shttp)://$host(?::$port)?(?:$abs_path(?:\\?$query)?)?};
		my $http_URL_reference = qq{$http_URL(?:#$fragment)?};
		$http_URL_regex = q{\b} . $http_URL_reference .
		    q{(?![-_.!~*'()a-zA-Z0-9;/?:@&=+$,#])};
	}

	# ftp URL の正規表現 $ftp_URL_regex
	{
		my $domainlabel = qq{$alphanum(?:(?:$alphanum|-)*$alphanum)?};
		my $toplabel = qq{$alpha(?:(?:$alphanum|-)*$alphanum)?};
		my $hostname = qq{(?:$domainlabel\\.)*$toplabel};
		my $hostnumber = qq{$digits\\.$digits\\.$digits\\.$digits};
		my $host = qq{(?:$hostname|$hostnumber)};
		my $port = qq{$digit*};
		my $user = q{(?:[-a-zA-Z0-9_.!*'();&=~]|} . qq{$escape)*};
		my $password = $user;
		my $hostport = qq{$host(?::$port)?};
		my $login = qq{(?:$user(?::$password)?\@)?$hostport};
		my $fsegment = q{(?:[-a-zA-Z0-9_.!*'():@&=~]|} . qq{$escape)*};
		my $fpath = qq{$fsegment(?:/$fsegment)?};
		my $ftptype = q{[AIDaid]};
		my $ftp_URL = qq{ftp://$login(?:/$fpath(?:;type=$ftptype)?)?};
		$ftp_URL_regex = q{\b} . $ftp_URL . q{(?![-a-zA-Z0-9_.!*'():@&=~/])};
	}

	# メールアドレスの正規表現 $mail_regex
	{
		my $esc         = '\\\\';               
		my $Period      = '\.';
		my $space       = '\040';
		my $OpenBR      = '\[';                 
		my $CloseBR     = '\]';
		my $NonASCII    = '\x80-\xff';          
		my $ctrl        = '\000-\037';
		my $CRlist      = '\n\015';
		my $qtext       = qq/[^$esc$NonASCII$CRlist\"]/;
		my $dtext       = qq/[^$esc$NonASCII$CRlist$OpenBR$CloseBR]/;
		my $quoted_pair = qq<${esc}>.qq<[^$NonASCII]>;
		my $atom_char   = qq/[^($space)<>\@,;:\".$esc$OpenBR$CloseBR$ctrl$NonASCII]/;
		my $atom        = qq<$atom_char+(?!$atom_char)>;
		my $quoted_str  = qq<\"$qtext*(?:$quoted_pair$qtext*)*\">;
		my $word        = qq<(?:$atom|$quoted_str)>;
		my $domain_ref  = $atom;
		my $domain_lit  = qq<$OpenBR(?:$dtext|$quoted_pair)*$CloseBR>;
		my $sub_domain  = qq<(?:$domain_ref|$domain_lit)>;
		my $domain      = qq<$sub_domain(?:$Period$sub_domain)*>;
		my $local_part  = qq<$word(?:$Period$word)*>;
		my $addr_spec   = qq<$local_part\@$domain>;
		$mail_regex  = $addr_spec;
	}
}

# $str の中の URI(URL) にリンクを張った $result を作る
# $tag_regex と $tag_regex_ は別途参照
# $http_URL_regex と $ftp_URL_regex および $mail_regex は別途参照

my $text_regex = q{[^<]*};
my $tag_regex_ = q{[^"'>]*(?:"[^"]*"[^"'>]*|'[^']*'[^"'>]*)*}; #'}}}}
my $comment_tag_regex =
    '<!(?:--[^-]*(?:(?!--)-[^-]*)*--(?:(?!--)[^>])*)*(?:>|(?!\n)$|--.*$)';
my $tag_regex = qq{$comment_tag_regex|<$tag_regex_>};

sub AutoLinkURLAndTextToHTML{
	my($str)= @_;
	my $result = '';
	while ($str =~ /($http_URL_regex|$ftp_URL_regex|($mail_regex))/ ){
		$str = $';
		$result .= TextToHTML($`);
		my($org,$mail)=($1,$2);
		my $tmp = $org;
		$tmp =~ s/\"/&quot;/g;
		$result .= qq(<A HREF=") . (defined($mail)? 'mailto:' : '') . qq($tmp">$org</A>);
	}
	$result .= TextToHTML($str);
	return $result;
}

################################
use IO::Socket::INET;
my $ss = new IO::Socket::INET( 
	PeerAddr => $server,
	PeerPort => $port,
	Proto => 'tcp',
	Type => SOCK_STREAM
) or die "cant connect to $server,$port :$@ \n";
$ss->print( "user hoge hoge hoge hoge\r\nnick $user\r\nlist\n\rquit\r\n");

my @list;
my $users;
for(;;){
	$_ = $ss->getline;
	defined $_ or last;
	$_ = jcode::euc($_,'jis');
	my(undef,$num,$nick,$other)=split(/\s+/,$_,4);
	if ($num eq "322"){
		my($channel,$member,$topic)=split(/\s+/,$other,3);
		$topic =~ s/^://;
		$topic =~ s/[\x00-\x1f]//g;
		length $topic or $topic='-';
		# サーバ管理情報のチャンネルはリストしない
		next if 0==index($topic,'SERVER MESSAGES: ')
			and 0==index($channel,'&') 
			  ;

		next if $channel =~/^\*/;

		# tpchat 対応
		my $ch = $channel;
		$ch =~ s/(\W)/'%' . unpack('H2', $1)/eg;

		# HTMLのエスケープ
		$topic = AutoLinkURLAndTextToHTML($topic);
		$channel =TextToHTML($channel);
		$member = TextToHTML($member);
		push @list,[$ch,$channel,$topic,$member];
	}
	if ($num eq "251") {
		$other =~ /(\d+)/;
		$users = $1;
	}
}

$ENV{TZ}='JST-9';
my @lt=localtime($now);
$lt[5]+=1900;
$lt[4]+=1;

sub PrintHTML(@){ print OUT (jcode::jis($_,'euc')) for @_; }

our($ch,$channel,$topic,$member);

sub ExtractValue{
	my $a =shift;
	$a =~ s/\$(\w+)/defined(${$1})?${$1}:"undefined"/ge;
	return $a;
}

sub PrintTable{
	local $repeat = join("\n",map{
		($ch,$channel,$topic,$member)=@$_;
		ExtractValue($HTML_ChannelListItem);
	}sort{ $b->[3] <=> $a->[3] or $a->[1] cmp $b->[1] } @list );
	local $updateinfo = sprintf(qq(%d/%02d/%02d %02d:%02d:%02d 現在 $users人の参加者がいます。),reverse @lt[0..5]);
	PrintHTML ExtractValue( $HTML_ChannelList );

}


if( not $no_cache ){
	my $tmpfile = "$datafile.tmp.$$";
	sub error{
		unlink $tmpfile;
		print @_;
		exit;
	}
	# キャッシュに出力
	open(OUT,'>'.$tmpfile) or error("cant open $tmpfile:$!");
	PrintTable();
	close OUT or error("cant write $tmpfile:$!");
	rename($tmpfile,$datafile) or error("cant rename $tmpfile:$!");

	if( not open(IN,$datafile) ){
		print "cant open $datafile :$!";
	}else{
		while(<IN>){ print; }
	}
}else{
	*OUT=*STDOUT;
	PrintTable(\*STDOUT);
}

1;