jcode.pl

WEBGAME 机器人大战EBS(无尽的战争) 架設方法 WIN2K系列主機

package jcode;
;######################################################################
;#
;# jcode.pl: Perl library for Japanese character code conversion
;#
;# Copyright (c) 1995-2000 Kazumasa Utashiro <[e-mail]>
;# Internet Initiative Japan Inc.
;# 3-13 Kanda Nishiki-cho, Chiyoda-ku, Tokyo 101-0054, Japan
;#
;# Copyright (c) 1992,1993,1994 Kazumasa Utashiro
;# Software Research Associates, Inc.
;#
;# Use and redistribution for ANY PURPOSE are granted as long as all
;# copyright notices are retained.  Redistribution with modification
;# is allowed provided that you make your modified version obviously
;# distinguishable from the original one.  THIS SOFTWARE IS PROVIDED
;# BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES ARE
;# DISCLAIMED.
;#
;# Original version was developed under the name of [e-mail]
;# February 1992 and it was called kconv.pl at the beginning.  This
;# address was a pen name for group of individuals and it is no longer
;# valid.
;#
;# The latest version is available here:
;#
;#	ftp://ftp.iij.ad.jp/pub/IIJ/dist/utashiro/perl/
;#
;; $rcsid = q$Id: jcode.pl,v 2.13 2000/09/29 16:10:05 utashiro Exp $;
;#
;######################################################################
;#
;# PERL4 INTERFACE:
;#
;#	&jcode'getcode(*line)
;#		Return 'jis', 'sjis', 'euc' or undef according to
;#		Japanese character code in $line.  Return 'binary' if
;#		the data has non-character code.
;#
;#		When evaluated in array context, it returns a list
;#		contains two items.  First value is the number of
;#		characters which matched to the expected code, and
;#		second value is the code name.  It is useful if and
;#		only if the number is not 0 and the code is undef;
;#		that case means it couldn't tell 'euc' or 'sjis'
;#		because the evaluation score was exactly same.  This
;#		interface is too tricky, though.
;#
;#		Code detection between euc and sjis is very difficult
;#		or sometimes impossible or even lead to wrong result
;#		when it includes JIS X0201 KANA characters.  So JIS
;#		X0201 KANA is ignored for automatic code detection.
;#
;#	&jcode'convert(*line, $ocode [, $icode [, $option]])
;#		Convert the contents of $line to the specified
;#		Japanese code given in the second argument $ocode.
;#		$ocode can be any of "jis", "sjis" or "euc", or use
;#		"noconv" when you don't want the code conversion.
;#		Input code is recognized automatically from the line
;#		itself when $icode is not supplied (JIS X0201 KANA is
;#		ignored in code detection.  See the above descripton
;#		of &getcode).  $icode also can be specified, but
;#		xxx2yyy routine is more efficient when both codes are
;#		known.
;#
;#		It returns the code of input string in scalar context,
;#		and a list of pointer of convert subroutine and the
;#		input code in array context.
;#
;#		Japanese character code JIS X0201, X0208, X0212 and
;#		ASCII code are supported.  X0212 characters can not be
;#		represented in SJIS and they will be replased by
;#		"geta" character when converted to SJIS.
;#
;#		See next paragraph for $option parameter.
;#
;#	&jcode'xxx2yyy(*line [, $option])
;#		Convert the Japanese code from xxx to yyy.  String xxx
;#		and yyy are any convination from "jis", "euc" or
;#		"sjis".  They return *approximate* number of converted
;#		bytes.  So return value 0 means the line was not
;#		converted at all.
;#
;#		Optional parameter $option is used to specify optional
;#		conversion method.  String "z" is for JIS X0201 KANA
;#		to X0208 KANA, and "h" is for reverse.
;#
;#	$jcode'convf{'xxx', 'yyy'}
;#		The value of this associative array is pointer to the
;#		subroutine jcode'xxx2yyy().
;#
;#	&jcode'to($ocode, $line [, $icode [, $option]])
;#	&jcode'jis($line [, $icode [, $option]])
;#	&jcode'euc($line [, $icode [, $option]])
;#	&jcode'sjis($line [, $icode [, $option]])
;#		These functions are prepared for easy use of
;#		call/return-by-value interface.  You can use these
;#		funcitons in s///e operation or any other place for
;#		convenience.
;#
;#	&jcode'jis_inout($in, $out)
;#		Set or inquire JIS start and end sequences.  Default
;#		is "ESC-$-B" and "ESC-(-B".  If you supplied only one
;#		character, "ESC-$" or "ESC-(" is prepended for each
;#		character respectively.  Acutually "ESC-(-B" is not a
;#		sequence to end JIS code but a sequence to start ASCII
;#		code set.  So `in' and `out' are somewhat misleading.
;#
;#	&jcode'get_inout($string)
;#		Get JIS start and end sequences from $string.
;#
;#	&jcode'cache()
;#	&jcode'nocache()
;#	&jcode'flush()
;#		Usually, converted character is cached in memory to
;#		avoid same calculations have to be done many times.
;#		To disable this caching, call &jcode'nocache().  It
;#		can be revived by &jcode'cache() and cache is flushed
;#		by calling &jcode'flush().  &cache() and &nocache()
;#		functions return previous caching state.
;#
;#	---------------------------------------------------------------
;#
;#	&jcode'h2z_xxx(*line)
;#		JIS X0201 KANA (so-called Hankaku-KANA) to X0208 KANA
;#		(Zenkaku-KANA) code conversion routine.  String xxx is
;#		any of "jis", "sjis" and "euc".  From the difficulty
;#		of recognizing code set from 1-byte KATAKANA string,
;#		automatic code recognition is not supported.
;#
;#	&jcode'z2h_xxx(*line)
;#		X0208 to X0201 KANA code conversion routine.  String
;#		xxx is any of "jis", "sjis" and "euc".
;#
;#	$jcode'z2hf{'xxx'}
;#	$jcode'h2zf{'xxx'}
;#		These are pointer to the corresponding function just
;#		as $jcode'convf.
;#
;#	---------------------------------------------------------------
;#
;#	&jcode'tr(*line, $from, $to [, $option])
;#		&jcode'tr emulates tr operator for 2 byte code.  Only 'd'
;#		is interpreted as an option.
;#
;#		Range operator like `A-Z' for 2 byte code is partially
;#		supported.  Code must be JIS or EUC, and first byte
;#		have to be same on first and last character.
;#
;#		CAUTION: Handling range operator is a kind of trick
;#		and it is not perfect.  So if you need to transfer `-' 
;#		character, please be sure to put it at the beginning
;#		or the end of $from and $to strings.
;#
;#	&jcode'trans($line, $from, $to [, $option)
;#		Same as &jcode'tr but accept string and return string
;#		after translation.
;#
;#	---------------------------------------------------------------
;#
;#	&jcode'init()
;#		Initialize the variables used in this package.  You
;#		don't have to call this when using jocde.pl by `do' or
;#		`require' interface.  Call it first if you embedded
;#		the jcode.pl at the end of your script.
;#
;######################################################################
;#
;# PERL5 INTERFACE:
;#
;# Current jcode.pl is written in Perl 4 but it is possible to use
;# from Perl 5 using `references'.  Fully perl5 capable version is
;# future issue.
;#
;# Since lexical variable is not a subject of typeglob, *string style
;# call doesn't work if the variable is declared as `my'.  Same thing
;# happens to special variable $_ if the perl is compiled to use
;# thread capability.  So using reference is generally recommented to
;# avoid the mysterious error.
;#
;#	jcode::getcode(\$line)
;#	jcode::convert(\$line, $ocode [, $icode [, $option]])
;#	jcode::xxx2yyy(\$line [, $option])
;#	&{$jcode::convf{'xxx', 'yyy'}}(\$line)
;#	jcode::to($ocode, $line [, $icode [, $option]])
;#	jcode::jis($line [, $icode [, $option]])
;#	jcode::euc($line [, $icode [, $option]])
;#	jcode::sjis($line [, $icode [, $option]])
;#	jcode::jis_inout($in, $out)
;#	jcode::get_inout($string)
;#	jcode::cache()
;#	jcode::nocache()
;#	jcode::flush()
;#	jcode::h2z_xxx(\$line)
;#	jcode::z2h_xxx(\$line)
;#	&{$jcode::z2hf{'xxx'}}(\$line)
;#	&{$jcode::h2zf{'xxx'}}(\$line)
;#	jcode::tr(\$line, $from, $to [, $option])
;#	jcode::trans($line, $from, $to [, $option)
;#	jcode::init()
;#
;######################################################################
;#
;# SAMPLES
;#
;# Convert any Kanji code to JIS and print each line with code name.
;#
;#	while (defined($s = <>)) {
;#	    $code = &jcode'convert(*s, 'jis');
;#	    print $code, "\t", $s;
;#	}
;#	
;# Convert all lines to JIS according to the first recognized line.
;#
;#	while (defined($s = <>)) {
;#	    print, next unless $s =~ /[\033\200-\377]/;
;#	    (*f, $icode) = &jcode'convert(*s, 'jis');
;#	    print;
;#	    defined(&f) || next;
;#	    while (<>) { &f(*s); print; }
;#	    last;
;#	}
;#
;# The safest way of JIS conversion.
;#
;#	while (defined($s = <>)) {
;#	    ($matched, $icode) = &jcode'getcode(*s);
;#	    if (@buf == 0 && $matched == 0) {
;#		print $s;
;#		next;
;#	    }
;#	    push(@buf, $s);
;#	    next unless $icode;
;#	    while (defined($s = shift(@buf))) {
;#		&jcode'convert(*s, 'jis', $icode);
;#		print $s;
;#	    }
;#	    while (defined($s = <>)) {
;#		&jcode'convert(*s, 'jis', $icode);
;#		print $s;
;#	    }
;#	    last;
;#	}
;#	print @buf if @buf;
;#		
;######################################################################

;#
;# Call initialize function if it is not called yet.  This may sound
;# strange but it makes easy to embed the jcode.pl at the end of
;# script.  Call &jcode'init at the beginning of the script in that
;# case.
;#
&init unless defined $version;

;#
;# Initialize variables.
;#
sub init {
    $version = $rcsid =~ /,v ([\d.]+)/ ? $1 : 'unknown';

    $re_bin  = '[\000-\006\177\377]';

    $re_jis0208_1978 = '\e\$\@';
    $re_jis0208_1983 = '\e\$B';
    $re_jis0208_1990 = '\e&\@\e\$B';
    $re_jis0208 = "$re_jis0208_1978|$re_jis0208_1983|$re_jis0208_1990";
    $re_jis0212 = '\e\$\(D';
    $re_jp      = "$re_jis0208|$re_jis0212";
    $re_asc     = '\e\([BJ]';
    $re_kana    = '\e\(I';

    $esc_0208 = "\e\$B";
    $esc_0212 = "\e\$(D";
    $esc_asc  = "\e(B";
    $esc_kana = "\e(I";

    $re_sjis_c    = '[\201-\237\340-\374][\100-\176\200-\374]';
    $re_sjis_kana = '[\241-\337]';

    $re_euc_c    = '[\241-\376][\241-\376]';
    $re_euc_kana = '\216[\241-\337]';
    $re_euc_0212 = '\217[\241-\376][\241-\376]';

    # Use `geta' for undefined character code
    $undef_sjis = "\x81\xac";

    $cache = 1;

    # X0201 -> X0208 KANA conversion table.  Looks weird?  Not that
    # much.  This is simply JIS text without escape sequences.
    ($h2z_high = $h2z = <<'__TABLE_END__') =~ tr/\041-\176/\241-\376/;
!	!#	$	!"	%	!&	"	!V	#	!W
^	!+	_	!,	0	!<
'	%!	(	%#	)	%%	*	%'	+	%)
,	%c	-	%e	.	%g	/	%C
1	%"	2	%$	3	%&	4	%(	5	%*
6	%+	7	%-	8	%/	9	%1	:	%3
6^	%,	7^	%.	8^	%0	9^	%2	:^	%4
;	%5	<	%7	=	%9	>	%;	?	%=
;^	%6	<^	%8	=^	%:	>^	%<	?^	%>
@	%?	A	%A	B	%D	C	%F	D	%H
@^	%@	A^	%B	B^	%E	C^	%G	D^	%I
E	%J	F	%K	G	%L	H	%M	I	%N
J	%O	K	%R	L	%U	M	%X	N	%[
J^	%P	K^	%S	L^	%V	M^	%Y	N^	%\
J_	%Q	K_	%T	L_	%W	M_	%Z	N_	%]
O	%^	P	%_	Q	%`	R	%a	S	%b
T	%d			U	%f			V	%h
W	%i	X	%j	Y	%k	Z	%l	[	%m
\	%o	]	%s	&	%r	3^	%t
__TABLE_END__
    %h2z = split(/\s+/, $h2z . $h2z_high);
    %z2h = reverse %h2z;

    $convf{'jis'  , 'jis' } = *jis2jis;
    $convf{'jis'  , 'sjis'} = *jis2sjis;
    $convf{'jis'  , 'euc' } = *jis2euc;
    $convf{'euc'  , 'jis' } = *euc2jis;
    $convf{'euc'  , 'sjis'} = *euc2sjis;
    $convf{'euc'  , 'euc' } = *euc2euc;
    $convf{'sjis' , 'jis' } = *sjis2jis;
    $convf{'sjis' , 'sjis'} = *sjis2sjis;
    $convf{'sjis' , 'euc' } = *sjis2euc;
    $h2zf{'jis' } = *h2z_jis;
    $z2hf{'jis' } = *z2h_jis;
    $h2zf{'euc' } = *h2z_euc;
    $z2hf{'euc' } = *z2h_euc;
    $h2zf{'sjis'} = *h2z_sjis;
    $z2hf{'sjis'} = *z2h_sjis;
}

;#
;# Set escape sequences which should be put before and after Japanese
;# (JIS X0208) string.
;#
sub jis_inout {
    $esc_0208 = shift || $esc_0208;
    $esc_0208 = "\e\$$esc_0208" if length($esc_0208) == 1;
    $esc_asc = shift || $esc_asc;
    $esc_asc = "\e\($esc_asc" if length($esc_asc) == 1;
    ($esc_0208, $esc_asc);
}

;#
;# Get JIS in and out sequences from the string.
;#
sub get_inout {
    local($esc_0208, $esc_asc);
    $_[$[] =~ /($re_jis0208)/o && ($esc_0208 = $1);
    $_[$[] =~ /($re_asc)/o && ($esc_asc = $1);
    ($esc_0208, $esc_asc);
}

;#
;# Recognize character code.
;#
sub getcode {
    local(*s) = @_;
    local($matched, $code);

    if ($s !~ /[\e\200-\377]/) {	# not Japanese
	$matched = 0;
	$code = undef;
    }					# 'jis'
    elsif ($s =~ /$re_jp|$re_asc|$re_kana/o) {
	$matched = 1;
	$code = 'jis';
    }
    elsif ($s =~ /$re_bin/o) {		# 'binary'
	$matched = 0;
	$code = 'binary';
    }
    else {				# should be 'euc' or 'sjis'
	local($sjis, $euc) = (0, 0);

	while ($s =~ /(($re_sjis_c)+)/go) {
	    $sjis += length($1);
	}
	while ($s =~ /(($re_euc_c|$re_euc_kana|$re_euc_0212)+)/go) {
	    $euc  += length($1);
	}
	$matched = &max($sjis, $euc);
	$code = ('euc', undef, 'sjis')[($sjis<=>$euc) + $[ + 1];
    }
    wantarray ? ($matched, $code) : $code;
}
sub max { $_[ $[ + ($_[ $[ ] < $_[ $[ + 1 ]) ]; }

;#
;# Convert any code to specified code.
;#
sub convert {