-package jcode;\r
-;######################################################################\r
-;#\r
-;# jcode.pl: Perl library for Japanese character code conversion\r
-;#\r
-;# Copyright (c) 1995-1999 Kazumasa Utashiro <utashiro@iij.ad.jp>\r
-;# Internet Initiative Japan Inc.\r
-;# 3-13 Kanda Nishiki-cho, Chiyoda-ku, Tokyo 101-0054, Japan\r
-;#\r
-;# Copyright (c) 1992,1993,1994 Kazumasa Utashiro\r
-;# Software Research Associates, Inc.\r
-;#\r
-;# Use and redistribution for ANY PURPOSE are granted as long as all\r
-;# copyright notices are retained. Redistribution with modification\r
-;# is allowed provided that you make your modified version obviously\r
-;# distinguishable from the original one. THIS SOFTWARE IS PROVIDED\r
-;# BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES ARE\r
-;# DISCLAIMED.\r
-;#\r
-;# Original version was developed under the name of srekcah@sra.co.jp\r
-;# February 1992 and it was called kconv.pl at the beginning. This\r
-;# address was a pen name for group of individuals and it is no longer\r
-;# valid.\r
-;#\r
-;# The latest version is available here:\r
-;#\r
-;# ftp://ftp.iij.ad.jp/pub/IIJ/dist/utashiro/perl/\r
-;#\r
-;; $rcsid = q$Id: jcode.pl,v 1.1 2003/09/18 15:35:28 takezoe Exp $;\r
-;#\r
-;######################################################################\r
-;#\r
-;# PERL4 INTERFACE:\r
-;#\r
-;# &jcode'getcode(*line)\r
-;# Return 'jis', 'sjis', 'euc' or undef according to\r
-;# Japanese character code in $line. Return 'binary' if\r
-;# the data has non-character code.\r
-;#\r
-;# When evaluated in array context, it returns a list\r
-;# contains two items. First value is the number of\r
-;# characters which matched to the expected code, and\r
-;# second value is the code name. It is useful if and\r
-;# only if the number is not 0 and the code is undef;\r
-;# that case means it couldn't tell 'euc' or 'sjis'\r
-;# because the evaluation score was exactly same. This\r
-;# interface is too tricky, though.\r
-;#\r
-;# Code detection between euc and sjis is very difficult\r
-;# or sometimes impossible or even lead to wrong result\r
-;# when it includes JIS X0201 KANA characters. So JIS\r
-;# X0201 KANA is ignored for automatic code detection.\r
-;#\r
-;# &jcode'convert(*line, $ocode [, $icode [, $option]])\r
-;# Convert the contents of $line to the specified\r
-;# Japanese code given in the second argument $ocode.\r
-;# $ocode can be any of "jis", "sjis" or "euc", or use\r
-;# "noconv" when you don't want the code conversion.\r
-;# Input code is recognized automatically from the line\r
-;# itself when $icode is not supplied (JIS X0201 KANA is\r
-;# ignored in code detection. See the above descripton\r
-;# of &getcode). $icode also can be specified, but\r
-;# xxx2yyy routine is more efficient when both codes are\r
-;# known.\r
-;#\r
-;# It returns the code of input string in scalar context,\r
-;# and a list of pointer of convert subroutine and the\r
-;# input code in array context.\r
-;#\r
-;# Japanese character code JIS X0201, X0208, X0212 and\r
-;# ASCII code are supported. X0212 characters can not be\r
-;# represented in SJIS and they will be replased by\r
-;# "geta" character when converted to SJIS.\r
-;#\r
-;# See next paragraph for $option parameter.\r
-;#\r
-;# &jcode'xxx2yyy(*line [, $option])\r
-;# Convert the Japanese code from xxx to yyy. String xxx\r
-;# and yyy are any convination from "jis", "euc" or\r
-;# "sjis". They return *approximate* number of converted\r
-;# bytes. So return value 0 means the line was not\r
-;# converted at all.\r
-;#\r
-;# Optional parameter $option is used to specify optional\r
-;# conversion method. String "z" is for JIS X0201 KANA\r
-;# to X0208 KANA, and "h" is for reverse.\r
-;#\r
-;# $jcode'convf{'xxx', 'yyy'}\r
-;# The value of this associative array is pointer to the\r
-;# subroutine jcode'xxx2yyy().\r
-;#\r
-;# &jcode'to($ocode, $line [, $icode [, $option]])\r
-;# &jcode'jis($line [, $icode [, $option]])\r
-;# &jcode'euc($line [, $icode [, $option]])\r
-;# &jcode'sjis($line [, $icode [, $option]])\r
-;# These functions are prepared for easy use of\r
-;# call/return-by-value interface. You can use these\r
-;# funcitons in s///e operation or any other place for\r
-;# convenience.\r
-;#\r
-;# &jcode'jis_inout($in, $out)\r
-;# Set or inquire JIS start and end sequences. Default\r
-;# is "ESC-$-B" and "ESC-(-B". If you supplied only one\r
-;# character, "ESC-$" or "ESC-(" is prepended for each\r
-;# character respectively. Acutually "ESC-(-B" is not a\r
-;# sequence to end JIS code but a sequence to start ASCII\r
-;# code set. So `in' and `out' are somewhat misleading.\r
-;#\r
-;# &jcode'get_inout($string)\r
-;# Get JIS start and end sequences from $string.\r
-;#\r
-;# &jcode'cache()\r
-;# &jcode'nocache()\r
-;# &jcode'flush()\r
-;# Usually, converted character is cached in memory to\r
-;# avoid same calculations have to be done many times.\r
-;# To disable this caching, call &jcode'nocache(). It\r
-;# can be revived by &jcode'cache() and cache is flushed\r
-;# by calling &jcode'flush(). &cache() and &nocache()\r
-;# functions return previous caching state.\r
-;#\r
-;# ---------------------------------------------------------------\r
-;#\r
-;# &jcode'h2z_xxx(*line)\r
-;# JIS X0201 KANA (so-called Hankaku-KANA) to X0208 KANA\r
-;# (Zenkaku-KANA) code conversion routine. String xxx is\r
-;# any of "jis", "sjis" and "euc". From the difficulty\r
-;# of recognizing code set from 1-byte KATAKANA string,\r
-;# automatic code recognition is not supported.\r
-;#\r
-;# &jcode'z2h_xxx(*line)\r
-;# X0208 to X0201 KANA code conversion routine. String\r
-;# xxx is any of "jis", "sjis" and "euc".\r
-;#\r
-;# $jcode'z2hf{'xxx'}\r
-;# $jcode'h2zf{'xxx'}\r
-;# These are pointer to the corresponding function just\r
-;# as $jcode'convf.\r
-;#\r
-;# ---------------------------------------------------------------\r
-;#\r
-;# &jcode'tr(*line, $from, $to [, $option])\r
-;# &jcode'tr emulates tr operator for 2 byte code. Only 'd'\r
-;# is interpreted as an option.\r
-;#\r
-;# Range operator like `A-Z' for 2 byte code is partially\r
-;# supported. Code must be JIS or EUC, and first byte\r
-;# have to be same on first and last character.\r
-;#\r
-;# CAUTION: Handling range operator is a kind of trick\r
-;# and it is not perfect. So if you need to transfer `-' \r
-;# character, please be sure to put it at the beginning\r
-;# or the end of $from and $to strings.\r
-;#\r
-;# &jcode'trans($line, $from, $to [, $option)\r
-;# Same as &jcode'tr but accept string and return string\r
-;# after translation.\r
-;#\r
-;# ---------------------------------------------------------------\r
-;#\r
-;# &jcode'init()\r
-;# Initialize the variables used in this package. You\r
-;# don't have to call this when using jocde.pl by `do' or\r
-;# `require' interface. Call it first if you embedded\r
-;# the jcode.pl at the end of your script.\r
-;#\r
-;######################################################################\r
-;#\r
-;# PERL5 INTERFACE:\r
-;#\r
-;# Current jcode.pl is written in Perl 4 but it is possible to use\r
-;# from Perl 5 using `references'. Fully perl5 capable version is\r
-;# future issue.\r
-;#\r
-;# Since lexical variable is not a subject of typeglob, *string style\r
-;# call doesn't work if the variable is declared as `my'. Same thing\r
-;# happens to special variable $_ if the perl is compiled to use\r
-;# thread capability. So using reference is generally recommented to\r
-;# avoid the mysterious error.\r
-;#\r
-;# jcode::getcode(\$line)\r
-;# jcode::convert(\$line, $ocode [, $icode [, $option]])\r
-;# jcode::xxx2yyy(\$line [, $option])\r
-;# &{$jcode::convf{'xxx', 'yyy'}}(\$line)\r
-;# jcode::to($ocode, $line [, $icode [, $option]])\r
-;# jcode::jis($line [, $icode [, $option]])\r
-;# jcode::euc($line [, $icode [, $option]])\r
-;# jcode::sjis($line [, $icode [, $option]])\r
-;# jcode::jis_inout($in, $out)\r
-;# jcode::get_inout($string)\r
-;# jcode::cache()\r
-;# jcode::nocache()\r
-;# jcode::flush()\r
-;# jcode::h2z_xxx(\$line)\r
-;# jcode::z2h_xxx(\$line)\r
-;# &{$jcode::z2hf{'xxx'}}(\$line)\r
-;# &{$jcode::h2zf{'xxx'}}(\$line)\r
-;# jcode::tr(\$line, $from, $to [, $option])\r
-;# jcode::trans($line, $from, $to [, $option)\r
-;# jcode::init()\r
-;#\r
-;######################################################################\r
-;#\r
-;# SAMPLES\r
-;#\r
-;# Convert any Kanji code to JIS and print each line with code name.\r
-;#\r
-;# while (defined($s = <>)) {\r
-;# $code = &jcode'convert(*s, 'jis');\r
-;# print $code, "\t", $s;\r
-;# }\r
-;# \r
-;# Convert all lines to JIS according to the first recognized line.\r
-;#\r
-;# while (defined($s = <>)) {\r
-;# print, next unless $s =~ /[\033\200-\377]/;\r
-;# (*f, $icode) = &jcode'convert(*s, 'jis');\r
-;# print;\r
-;# defined(&f) || next;\r
-;# while (<>) { &f(*s); print; }\r
-;# last;\r
-;# }\r
-;#\r
-;# The safest way of JIS conversion.\r
-;#\r
-;# while (defined($s = <>)) {\r
-;# ($matched, $icode) = &jcode'getcode(*s);\r
-;# if (@buf == 0 && $matched == 0) {\r
-;# print $s;\r
-;# next;\r
-;# }\r
-;# push(@buf, $s);\r
-;# next unless $icode;\r
-;# while (defined($s = shift(@buf))) {\r
-;# &jcode'convert(*s, 'jis', $icode);\r
-;# print $s;\r
-;# }\r
-;# while (defined($s = <>)) {\r
-;# &jcode'convert(*s, 'jis', $icode);\r
-;# print $s;\r
-;# }\r
-;# last;\r
-;# }\r
-;# print @buf if @buf;\r
-;# \r
-;######################################################################\r
-\r
-;#\r
-;# Call initialize function if it is not called yet. This may sound\r
-;# strange but it makes easy to embed the jcode.pl at the end of\r
-;# script. Call &jcode'init at the beginning of the script in that\r
-;# case.\r
-;#\r
-&init unless defined $version;\r
-\r
-;#\r
-;# Initialize variables.\r
-;#\r
-sub init {\r
- $version = $rcsid =~ /,v ([\d.]+)/ ? $1 : 'unkown';\r
-\r
- $re_bin = '[\000-\006\177\377]';\r
-\r
- $re_jis0208_1978 = '\e\$\@';\r
- $re_jis0208_1983 = '\e\$B';\r
- $re_jis0208_1990 = '\e&\@\e\$B';\r
- $re_jis0208 = "$re_jis0208_1978|$re_jis0208_1983|$re_jis0208_1990";\r
- $re_jis0212 = '\e\$\(D';\r
- $re_jp = "$re_jis0208|$re_jis0212";\r
- $re_asc = '\e\([BJ]';\r
- $re_kana = '\e\(I';\r
-\r
- $esc_0208 = "\e\$B";\r
- $esc_0212 = "\e\$(D";\r
- $esc_asc = "\e(B";\r
- $esc_kana = "\e(I";\r
-\r
- $re_sjis_c = '[\201-\237\340-\374][\100-\176\200-\374]';\r
- $re_sjis_kana = '[\241-\337]';\r
-\r
- $re_euc_c = '[\241-\376][\241-\376]';\r
- $re_euc_kana = '\216[\241-\337]';\r
- $re_euc_0212 = '\217[\241-\376][\241-\376]';\r
-\r
- # Use `geta' for undefined character code\r
- $undef_sjis = "\x81\xac";\r
-\r
- $cache = 1;\r
-\r
- # X0201 -> X0208 KANA conversion table. Looks weird? Not that\r
- # much. This is simply JIS text without escape sequences.\r
- ($h2z_high = $h2z = <<'__TABLE_END__') =~ tr/\041-\176/\241-\376/;\r
-! !# $ !" % !& " !V # !W\r
-^ !+ _ !, 0 !<\r
-' %! ( %# ) %% * %' + %)\r
-, %c - %e . %g / %C\r
-1 %" 2 %$ 3 %& 4 %( 5 %*\r
-6 %+ 7 %- 8 %/ 9 %1 : %3\r
-6^ %, 7^ %. 8^ %0 9^ %2 :^ %4\r
-; %5 < %7 = %9 > %; ? %=\r
-;^ %6 <^ %8 =^ %: >^ %< ?^ %>\r
-@ %? A %A B %D C %F D %H\r
-@^ %@ A^ %B B^ %E C^ %G D^ %I\r
-E %J F %K G %L H %M I %N\r
-J %O K %R L %U M %X N %[\r
-J^ %P K^ %S L^ %V M^ %Y N^ %\\r
-J_ %Q K_ %T L_ %W M_ %Z N_ %]\r
-O %^ P %_ Q %` R %a S %b\r
-T %d U %f V %h\r
-W %i X %j Y %k Z %l [ %m\r
-\ %o ] %s & %r 3^ %t\r
-__TABLE_END__\r
- %h2z = split(/\s+/, $h2z . $h2z_high);\r
- %z2h = reverse %h2z;\r
-\r
- $convf{'jis' , 'jis' } = *jis2jis;\r
- $convf{'jis' , 'sjis'} = *jis2sjis;\r
- $convf{'jis' , 'euc' } = *jis2euc;\r
- $convf{'euc' , 'jis' } = *euc2jis;\r
- $convf{'euc' , 'sjis'} = *euc2sjis;\r
- $convf{'euc' , 'euc' } = *euc2euc;\r
- $convf{'sjis' , 'jis' } = *sjis2jis;\r
- $convf{'sjis' , 'sjis'} = *sjis2sjis;\r
- $convf{'sjis' , 'euc' } = *sjis2euc;\r
- $h2zf{'jis' } = *h2z_jis;\r
- $z2hf{'jis' } = *z2h_jis;\r
- $h2zf{'euc' } = *h2z_euc;\r
- $z2hf{'euc' } = *z2h_euc;\r
- $h2zf{'sjis'} = *h2z_sjis;\r
- $z2hf{'sjis'} = *z2h_sjis;\r
-}\r
-\r
-;#\r
-;# Set escape sequences which should be put before and after Japanese\r
-;# (JIS X0208) string.\r
-;#\r
-sub jis_inout {\r
- $esc_0208 = shift || $esc_0208;\r
- $esc_0208 = "\e\$$esc_0208" if length($esc_0208) == 1;\r
- $esc_asc = shift || $esc_asc;\r
- $esc_asc = "\e\($esc_asc" if length($esc_asc) == 1;\r
- ($esc_0208, $esc_asc);\r
-}\r
-\r
-;#\r
-;# Get JIS in and out sequences from the string.\r
-;#\r
-sub get_inout {\r
- local($esc_0208, $esc_asc);\r
- $_[$[] =~ /($re_jis0208)/o && ($esc_0208 = $1);\r
- $_[$[] =~ /($re_asc)/o && ($esc_asc = $1);\r
- ($esc_0208, $esc_asc);\r
-}\r
-\r
-;#\r
-;# Recognize character code.\r
-;#\r
-sub getcode {\r
- local(*s) = @_;\r
- local($matched, $code);\r
-\r
- if ($s !~ /[\e\200-\377]/) { # not Japanese\r
- $matched = 0;\r
- $code = undef;\r
- } # 'jis'\r
- elsif ($s =~ /$re_jp|$re_asc|$re_kana/o) {\r
- $matched = 1;\r
- $code = 'jis';\r
- }\r
- elsif ($s =~ /$re_bin/o) { # 'binary'\r
- $matched = 0;\r
- $code = 'binary';\r
- }\r
- else { # should be 'euc' or 'sjis'\r
- local($sjis, $euc) = (0, 0);\r
-\r
- while ($s =~ /(($re_sjis_c)+)/go) {\r
- $sjis += length($1);\r
- }\r
- while ($s =~ /(($re_euc_c|$re_euc_kana|$re_euc_0212)+)/go) {\r
- $euc += length($1);\r
- }\r
- $matched = &max($sjis, $euc);\r
- $code = ('euc', undef, 'sjis')[($sjis<=>$euc) + $[ + 1];\r
- }\r
- wantarray ? ($matched, $code) : $code;\r
-}\r
-sub max { $_[ $[ + ($_[ $[ ] < $_[ $[ + 1 ]) ]; }\r
-\r
-;#\r
-;# Convert any code to specified code.\r
-;#\r
-sub convert {\r
- local(*s, $ocode, $icode, $opt) = @_;\r
- return (undef, undef) unless $icode = $icode || &getcode(*s);\r
- return (undef, $icode) if $icode eq 'binary';\r
- $ocode = 'jis' unless $ocode;\r
- $ocode = $icode if $ocode eq 'noconv';\r
- local(*f) = $convf{$icode, $ocode};\r
- &f(*s, $opt);\r
- wantarray ? (*f, $icode) : $icode;\r
-}\r
-\r
-;#\r
-;# Easy return-by-value interfaces.\r
-;#\r
-sub jis { &to('jis', @_); }\r
-sub euc { &to('euc', @_); }\r
-sub sjis { &to('sjis', @_); }\r
-sub to {\r
- local($ocode, $s, $icode, $opt) = @_;\r
- &convert(*s, $ocode, $icode, $opt);\r
- $s;\r
-}\r
-sub what {\r
- local($s) = @_;\r
- &getcode(*s);\r
-}\r
-sub trans {\r
- local($s) = shift;\r
- &tr(*s, @_);\r
- $s;\r
-}\r
-\r
-;#\r
-;# SJIS to JIS\r
-;#\r
-sub sjis2jis {\r
- local(*s, $opt, $n) = @_;\r
- &sjis2sjis(*s, $opt) if $opt;\r
- $s =~ s/(($re_sjis_c|$re_sjis_kana)+)/&_sjis2jis($1) . $esc_asc/geo;\r
- $n;\r
-}\r
-sub _sjis2jis {\r
- local($s) = shift;\r
- $s =~ s/(($re_sjis_c)+|($re_sjis_kana)+)/&__sjis2jis($1)/geo;\r
- $s;\r
-}\r
-sub __sjis2jis {\r
- local($s) = shift;\r
- if ($s =~ /^$re_sjis_kana/o) {\r
- $n += $s =~ tr/\241-\337/\041-\137/;\r
- $esc_kana . $s;\r
- } else {\r
- $n += $s =~ s/($re_sjis_c)/$s2e{$1}||&s2e($1)/geo;\r
- $s =~ tr/\241-\376/\041-\176/;\r
- $esc_0208 . $s;\r
- }\r
-}\r
-\r
-;#\r
-;# EUC to JIS\r
-;#\r
-sub euc2jis {\r
- local(*s, $opt, $n) = @_;\r
- &euc2euc(*s, $opt) if $opt;\r
- $s =~ s/(($re_euc_c|$re_euc_kana|$re_euc_0212)+)/\r
- &_euc2jis($1) . $esc_asc\r
- /geo;\r
- $n;\r
-}\r
-sub _euc2jis {\r
- local($s) = shift;\r
- $s =~ s/(($re_euc_c)+|($re_euc_kana)+|($re_euc_0212)+)/&__euc2jis($1)/geo;\r
- $s;\r
-}\r
-sub __euc2jis {\r
- local($s) = shift;\r
- local($esc);\r
-\r
- if ($s =~ tr/\216//d) {\r
- $esc = $esc_kana;\r
- } elsif ($s =~ tr/\217//d) {\r
- $esc = $esc_0212;\r
- } else {\r
- $esc = $esc_0208;\r
- }\r
-\r
- $n += $s =~ tr/\241-\376/\041-\176/;\r
- $esc . $s;\r
-}\r
-\r
-;#\r
-;# JIS to EUC\r
-;#\r
-sub jis2euc {\r
- local(*s, $opt, $n) = @_;\r
- $s =~ s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2euc($1,$2)/geo;\r
- &euc2euc(*s, $opt) if $opt;\r
- $n;\r
-}\r
-sub _jis2euc {\r
- local($esc, $s) = @_;\r
- if ($esc !~ /^$re_asc/o) {\r
- $n += $s =~ tr/\041-\176/\241-\376/;\r
- if ($esc =~ /^$re_kana/o) {\r
- $s =~ s/([\241-\337])/\216$1/g;\r
- }\r
- elsif ($esc =~ /^$re_jis0212/o) {\r
- $s =~ s/([\241-\376][\241-\376])/\217$1/g;\r
- }\r
- }\r
- $s;\r
-}\r
-\r
-;#\r
-;# JIS to SJIS\r
-;#\r
-sub jis2sjis {\r
- local(*s, $opt, $n) = @_;\r
- &jis2jis(*s, $opt) if $opt;\r
- $s =~ s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2sjis($1,$2)/geo;\r
- $n;\r
-}\r
-sub _jis2sjis {\r
- local($esc, $s) = @_;\r
- if ($esc =~ /^$re_jis0212/o) {\r
- $s =~ s/../$undef_sjis/g;\r
- $n = length;\r
- }\r
- elsif ($esc !~ /^$re_asc/o) {\r
- $n += $s =~ tr/\041-\176/\241-\376/;\r
- if ($esc =~ /^$re_jp/o) {\r
- $s =~ s/($re_euc_c)/$e2s{$1}||&e2s($1)/geo;\r
- }\r
- }\r
- $s;\r
-}\r
-\r
-;#\r
-;# SJIS to EUC\r
-;#\r
-sub sjis2euc {\r
- local(*s, $opt,$n) = @_;\r
- $n = $s =~ s/($re_sjis_c|$re_sjis_kana)/$s2e{$1}||&s2e($1)/geo;\r
- &euc2euc(*s, $opt) if $opt;\r
- $n;\r
-}\r
-sub s2e {\r
- local($c1, $c2, $code);\r
- ($c1, $c2) = unpack('CC', $code = shift);\r
-\r
- if (0xa1 <= $c1 && $c1 <= 0xdf) {\r
- $c2 = $c1;\r
- $c1 = 0x8e;\r
- } elsif (0x9f <= $c2) {\r
- $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe0 : 0x60);\r
- $c2 += 2;\r
- } else {\r
- $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe1 : 0x61);\r
- $c2 += 0x60 + ($c2 < 0x7f);\r
- }\r
- if ($cache) {\r
- $s2e{$code} = pack('CC', $c1, $c2);\r
- } else {\r
- pack('CC', $c1, $c2);\r
- }\r
-}\r
-\r
-;#\r
-;# EUC to SJIS\r
-;#\r
-sub euc2sjis {\r
- local(*s, $opt,$n) = @_;\r
- &euc2euc(*s, $opt) if $opt;\r
- $n = $s =~ s/($re_euc_c|$re_euc_kana|$re_euc_0212)/$e2s{$1}||&e2s($1)/geo;\r
-}\r
-sub e2s {\r
- local($c1, $c2, $code);\r
- ($c1, $c2) = unpack('CC', $code = shift);\r
-\r
- if ($c1 == 0x8e) { # SS2\r
- return substr($code, 1, 1);\r
- } elsif ($c1 == 0x8f) { # SS3\r
- return $undef_sjis;\r
- } elsif ($c1 % 2) {\r
- $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x31 : 0x71);\r
- $c2 -= 0x60 + ($c2 < 0xe0);\r
- } else {\r
- $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x30 : 0x70);\r
- $c2 -= 2;\r
- }\r
- if ($cache) {\r
- $e2s{$code} = pack('CC', $c1, $c2);\r
- } else {\r
- pack('CC', $c1, $c2);\r
- }\r
-}\r
-\r
-;#\r
-;# JIS to JIS, SJIS to SJIS, EUC to EUC\r
-;#\r
-sub jis2jis {\r
- local(*s, $opt) = @_;\r
- $s =~ s/$re_jis0208/$esc_0208/go;\r
- $s =~ s/$re_asc/$esc_asc/go;\r
- &h2z_jis(*s) if $opt =~ /z/;\r
- &z2h_jis(*s) if $opt =~ /h/;\r
-}\r
-sub sjis2sjis {\r
- local(*s, $opt) = @_;\r
- &h2z_sjis(*s) if $opt =~ /z/;\r
- &z2h_sjis(*s) if $opt =~ /h/;\r
-}\r
-sub euc2euc {\r
- local(*s, $opt) = @_;\r
- &h2z_euc(*s) if $opt =~ /z/;\r
- &z2h_euc(*s) if $opt =~ /h/;\r
-}\r
-\r
-;#\r
-;# Cache control functions\r
-;#\r
-sub cache {\r
- ($cache, $cache = 1)[$[];\r
-}\r
-sub nocache {\r
- ($cache, $cache = 0)[$[];\r
-}\r
-sub flushcache {\r
- undef %e2s;\r
- undef %s2e;\r
-}\r
-\r
-;#\r
-;# X0201 -> X0208 KANA conversion routine\r
-;#\r
-sub h2z_jis {\r
- local(*s, $n) = @_;\r
- if ($s =~ s/$re_kana([^\e]*)/$esc_0208 . &_h2z_jis($1)/geo) {\r
- 1 while $s =~ s/(($re_jis0208)[^\e]*)($re_jis0208)/$1/o;\r
- }\r
- $n;\r
-}\r
-sub _h2z_jis {\r
- local($s) = @_;\r
- $n += $s =~ s/([\41-\137]([\136\137])?)/$h2z{$1}/g;\r
- $s;\r
-}\r
-\r
-sub h2z_euc {\r
- local(*s) = @_;\r
- $s =~ s/\216([\241-\337])(\216([\336\337]))?/$h2z{"$1$3"}/g;\r
-}\r
-\r
-sub h2z_sjis {\r
- local(*s, $n) = @_;\r
- $s =~ s/(($re_sjis_c)+)|(([\241-\337])([\336\337])?)/\r
- $1 || ($n++, $e2s{$h2z{$3}} || &e2s($h2z{$3}))\r
- /geo;\r
- $n;\r
-}\r
-\r
-;#\r
-;# X0208 -> X0201 KANA conversion routine\r
-;#\r
-sub z2h_jis {\r
- local(*s, $n) = @_;\r
- $s =~ s/($re_jis0208)([^\e]+)/&_z2h_jis($2)/geo;\r
- $n;\r
-}\r
-sub _z2h_jis {\r
- local($s) = @_;\r
- $s =~ s/((\%[!-~]|![\#\"&VW+,<])+|([^!%][!-~]|![^\#\"&VW+,<])+)/\r
- &__z2h_jis($1)\r
- /ge;\r
- $s;\r
-}\r
-sub __z2h_jis {\r
- local($s) = @_;\r
- return $esc_0208 . $s unless /^%/ || $s =~ /^![\#\"&VW+,<]/;\r
- $n += length($s) / 2;\r
- $s =~ s/(..)/$z2h{$1}/g;\r
- $esc_kana . $s;\r
-}\r
-\r
-sub z2h_euc {\r
- local(*s, $n) = @_;\r
- &init_z2h_euc unless defined %z2h_euc;\r
- $s =~ s/($re_euc_c|$re_euc_kana)/\r
- $z2h_euc{$1} ? ($n++, $z2h_euc{$1}) : $1\r
- /geo;\r
- $n;\r
-}\r
-\r
-sub z2h_sjis {\r
- local(*s, $n) = @_;\r
- &init_z2h_sjis unless defined %z2h_sjis;\r
- $s =~ s/($re_sjis_c)/$z2h_sjis{$1} ? ($n++, $z2h_sjis{$1}) : $1/geo;\r
- $n;\r
-}\r
-\r
-;#\r
-;# Initializing JIS X0208 to X0201 KANA table for EUC and SJIS. This\r
-;# can be done in &init but it's not worth doing. Similarly,\r
-;# precalculated table is not worth to occupy the file space and\r
-;# reduce the readability. The author personnaly discourages to use\r
-;# X0201 Kana character in the any situation.\r
-;#\r
-sub init_z2h_euc {\r
- local($k, $s);\r
- while (($k, $s) = each %z2h) {\r
- $s =~ s/([\241-\337])/\216$1/g && ($z2h_euc{$k} = $s);\r
- }\r
-}\r
-sub init_z2h_sjis {\r
- local($s, $v);\r
- while (($s, $v) = each %z2h) {\r
- $s =~ /[\200-\377]/ && ($z2h_sjis{&e2s($s)} = $v);\r
- }\r
-}\r
-\r
-;#\r
-;# TR function for 2-byte code\r
-;#\r
-sub tr {\r
- # $prev_from, $prev_to, %table are persistent variables\r
- local(*s, $from, $to, $opt) = @_;\r
- local(@from, @to);\r
- local($jis, $n) = (0, 0);\r
- \r
- $jis++, &jis2euc(*s) if $s =~ /$re_jp|$re_asc|$re_kana/o;\r
- $jis++ if $to =~ /$re_jp|$re_asc|$re_kana/o;\r
-\r
- if (!defined($prev_from) || $from ne $prev_from || $to ne $prev_to) {\r
- ($prev_from, $prev_to) = ($from, $to);\r
- undef %table;\r
- &_maketable;\r
- }\r
-\r
- $s =~ s/([\200-\377][\000-\377]|[\000-\377])/\r
- defined($table{$1}) && ++$n ? $table{$1} : $1\r
- /ge;\r
-\r
- &euc2jis(*s) if $jis;\r
-\r
- $n;\r
-}\r
-\r
-sub _maketable {\r
- local($ascii) = '(\\\\[\\-\\\\]|[\0-\133\135-\177])';\r
-\r
- &jis2euc(*to) if $to =~ /$re_jp|$re_asc|$re_kana/o;\r
- &jis2euc(*from) if $from =~ /$re_jp|$re_asc|$re_kana/o;\r
-\r
- grep(s/(([\200-\377])[\200-\377]-\2[\200-\377])/&_expnd2($1)/ge,\r
- $from, $to);\r
- grep(s/($ascii-$ascii)/&_expnd1($1)/geo,\r
- $from, $to);\r
-\r
- @to = $to =~ /[\200-\377][\000-\377]|[\000-\377]/g;\r
- @from = $from =~ /[\200-\377][\000-\377]|[\000-\377]/g;\r
- push(@to, ($opt =~ /d/ ? '' : $to[$#to]) x (@from - @to)) if @to < @from;\r
- @table{@from} = @to;\r
-}\r
-\r
-sub _expnd1 {\r
- local($s) = @_;\r
- $s =~ s/\\(.)/$1/g;\r
- local($c1, $c2) = unpack('CxC', $s);\r
- if ($c1 <= $c2) {\r
- for ($s = ''; $c1 <= $c2; $c1++) {\r
- $s .= pack('C', $c1);\r
- }\r
- }\r
- $s;\r
-}\r
-\r
-sub _expnd2 {\r
- local($s) = @_;\r
- local($c1, $c2, $c3, $c4) = unpack('CCxCC', $s);\r
- if ($c1 == $c3 && $c2 <= $c4) {\r
- for ($s = ''; $c2 <= $c4; $c2++) {\r
- $s .= pack('CC', $c1, $c2);\r
- }\r
- }\r
- $s;\r
-}\r
-\r
-1;\r
+package jcode;
+;######################################################################
+;#
+;# jcode.pl: Perl library for Japanese character code conversion
+;#
+;# Copyright (c) 1995-1999 Kazumasa Utashiro <utashiro@iij.ad.jp>
+;# 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 srekcah@sra.co.jp
+;# 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 1.1 2003/09/18 15:35:28 takezoe 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 : 'unkown';
+
+ $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 {
+ local(*s, $ocode, $icode, $opt) = @_;
+ return (undef, undef) unless $icode = $icode || &getcode(*s);
+ return (undef, $icode) if $icode eq 'binary';
+ $ocode = 'jis' unless $ocode;
+ $ocode = $icode if $ocode eq 'noconv';
+ local(*f) = $convf{$icode, $ocode};
+ &f(*s, $opt);
+ wantarray ? (*f, $icode) : $icode;
+}
+
+;#
+;# Easy return-by-value interfaces.
+;#
+sub jis { &to('jis', @_); }
+sub euc { &to('euc', @_); }
+sub sjis { &to('sjis', @_); }
+sub to {
+ local($ocode, $s, $icode, $opt) = @_;
+ &convert(*s, $ocode, $icode, $opt);
+ $s;
+}
+sub what {
+ local($s) = @_;
+ &getcode(*s);
+}
+sub trans {
+ local($s) = shift;
+ &tr(*s, @_);
+ $s;
+}
+
+;#
+;# SJIS to JIS
+;#
+sub sjis2jis {
+ local(*s, $opt, $n) = @_;
+ &sjis2sjis(*s, $opt) if $opt;
+ $s =~ s/(($re_sjis_c|$re_sjis_kana)+)/&_sjis2jis($1) . $esc_asc/geo;
+ $n;
+}
+sub _sjis2jis {
+ local($s) = shift;
+ $s =~ s/(($re_sjis_c)+|($re_sjis_kana)+)/&__sjis2jis($1)/geo;
+ $s;
+}
+sub __sjis2jis {
+ local($s) = shift;
+ if ($s =~ /^$re_sjis_kana/o) {
+ $n += $s =~ tr/\241-\337/\041-\137/;
+ $esc_kana . $s;
+ } else {
+ $n += $s =~ s/($re_sjis_c)/$s2e{$1}||&s2e($1)/geo;
+ $s =~ tr/\241-\376/\041-\176/;
+ $esc_0208 . $s;
+ }
+}
+
+;#
+;# EUC to JIS
+;#
+sub euc2jis {
+ local(*s, $opt, $n) = @_;
+ &euc2euc(*s, $opt) if $opt;
+ $s =~ s/(($re_euc_c|$re_euc_kana|$re_euc_0212)+)/
+ &_euc2jis($1) . $esc_asc
+ /geo;
+ $n;
+}
+sub _euc2jis {
+ local($s) = shift;
+ $s =~ s/(($re_euc_c)+|($re_euc_kana)+|($re_euc_0212)+)/&__euc2jis($1)/geo;
+ $s;
+}
+sub __euc2jis {
+ local($s) = shift;
+ local($esc);
+
+ if ($s =~ tr/\216//d) {
+ $esc = $esc_kana;
+ } elsif ($s =~ tr/\217//d) {
+ $esc = $esc_0212;
+ } else {
+ $esc = $esc_0208;
+ }
+
+ $n += $s =~ tr/\241-\376/\041-\176/;
+ $esc . $s;
+}
+
+;#
+;# JIS to EUC
+;#
+sub jis2euc {
+ local(*s, $opt, $n) = @_;
+ $s =~ s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2euc($1,$2)/geo;
+ &euc2euc(*s, $opt) if $opt;
+ $n;
+}
+sub _jis2euc {
+ local($esc, $s) = @_;
+ if ($esc !~ /^$re_asc/o) {
+ $n += $s =~ tr/\041-\176/\241-\376/;
+ if ($esc =~ /^$re_kana/o) {
+ $s =~ s/([\241-\337])/\216$1/g;
+ }
+ elsif ($esc =~ /^$re_jis0212/o) {
+ $s =~ s/([\241-\376][\241-\376])/\217$1/g;
+ }
+ }
+ $s;
+}
+
+;#
+;# JIS to SJIS
+;#
+sub jis2sjis {
+ local(*s, $opt, $n) = @_;
+ &jis2jis(*s, $opt) if $opt;
+ $s =~ s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2sjis($1,$2)/geo;
+ $n;
+}
+sub _jis2sjis {
+ local($esc, $s) = @_;
+ if ($esc =~ /^$re_jis0212/o) {
+ $s =~ s/../$undef_sjis/g;
+ $n = length;
+ }
+ elsif ($esc !~ /^$re_asc/o) {
+ $n += $s =~ tr/\041-\176/\241-\376/;
+ if ($esc =~ /^$re_jp/o) {
+ $s =~ s/($re_euc_c)/$e2s{$1}||&e2s($1)/geo;
+ }
+ }
+ $s;
+}
+
+;#
+;# SJIS to EUC
+;#
+sub sjis2euc {
+ local(*s, $opt,$n) = @_;
+ $n = $s =~ s/($re_sjis_c|$re_sjis_kana)/$s2e{$1}||&s2e($1)/geo;
+ &euc2euc(*s, $opt) if $opt;
+ $n;
+}
+sub s2e {
+ local($c1, $c2, $code);
+ ($c1, $c2) = unpack('CC', $code = shift);
+
+ if (0xa1 <= $c1 && $c1 <= 0xdf) {
+ $c2 = $c1;
+ $c1 = 0x8e;
+ } elsif (0x9f <= $c2) {
+ $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe0 : 0x60);
+ $c2 += 2;
+ } else {
+ $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe1 : 0x61);
+ $c2 += 0x60 + ($c2 < 0x7f);
+ }
+ if ($cache) {
+ $s2e{$code} = pack('CC', $c1, $c2);
+ } else {
+ pack('CC', $c1, $c2);
+ }
+}
+
+;#
+;# EUC to SJIS
+;#
+sub euc2sjis {
+ local(*s, $opt,$n) = @_;
+ &euc2euc(*s, $opt) if $opt;
+ $n = $s =~ s/($re_euc_c|$re_euc_kana|$re_euc_0212)/$e2s{$1}||&e2s($1)/geo;
+}
+sub e2s {
+ local($c1, $c2, $code);
+ ($c1, $c2) = unpack('CC', $code = shift);
+
+ if ($c1 == 0x8e) { # SS2
+ return substr($code, 1, 1);
+ } elsif ($c1 == 0x8f) { # SS3
+ return $undef_sjis;
+ } elsif ($c1 % 2) {
+ $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x31 : 0x71);
+ $c2 -= 0x60 + ($c2 < 0xe0);
+ } else {
+ $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x30 : 0x70);
+ $c2 -= 2;
+ }
+ if ($cache) {
+ $e2s{$code} = pack('CC', $c1, $c2);
+ } else {
+ pack('CC', $c1, $c2);
+ }
+}
+
+;#
+;# JIS to JIS, SJIS to SJIS, EUC to EUC
+;#
+sub jis2jis {
+ local(*s, $opt) = @_;
+ $s =~ s/$re_jis0208/$esc_0208/go;
+ $s =~ s/$re_asc/$esc_asc/go;
+ &h2z_jis(*s) if $opt =~ /z/;
+ &z2h_jis(*s) if $opt =~ /h/;
+}
+sub sjis2sjis {
+ local(*s, $opt) = @_;
+ &h2z_sjis(*s) if $opt =~ /z/;
+ &z2h_sjis(*s) if $opt =~ /h/;
+}
+sub euc2euc {
+ local(*s, $opt) = @_;
+ &h2z_euc(*s) if $opt =~ /z/;
+ &z2h_euc(*s) if $opt =~ /h/;
+}
+
+;#
+;# Cache control functions
+;#
+sub cache {
+ ($cache, $cache = 1)[$[];
+}
+sub nocache {
+ ($cache, $cache = 0)[$[];
+}
+sub flushcache {
+ undef %e2s;
+ undef %s2e;
+}
+
+;#
+;# X0201 -> X0208 KANA conversion routine
+;#
+sub h2z_jis {
+ local(*s, $n) = @_;
+ if ($s =~ s/$re_kana([^\e]*)/$esc_0208 . &_h2z_jis($1)/geo) {
+ 1 while $s =~ s/(($re_jis0208)[^\e]*)($re_jis0208)/$1/o;
+ }
+ $n;
+}
+sub _h2z_jis {
+ local($s) = @_;
+ $n += $s =~ s/([\41-\137]([\136\137])?)/$h2z{$1}/g;
+ $s;
+}
+
+sub h2z_euc {
+ local(*s) = @_;
+ $s =~ s/\216([\241-\337])(\216([\336\337]))?/$h2z{"$1$3"}/g;
+}
+
+sub h2z_sjis {
+ local(*s, $n) = @_;
+ $s =~ s/(($re_sjis_c)+)|(([\241-\337])([\336\337])?)/
+ $1 || ($n++, $e2s{$h2z{$3}} || &e2s($h2z{$3}))
+ /geo;
+ $n;
+}
+
+;#
+;# X0208 -> X0201 KANA conversion routine
+;#
+sub z2h_jis {
+ local(*s, $n) = @_;
+ $s =~ s/($re_jis0208)([^\e]+)/&_z2h_jis($2)/geo;
+ $n;
+}
+sub _z2h_jis {
+ local($s) = @_;
+ $s =~ s/((\%[!-~]|![\#\"&VW+,<])+|([^!%][!-~]|![^\#\"&VW+,<])+)/
+ &__z2h_jis($1)
+ /ge;
+ $s;
+}
+sub __z2h_jis {
+ local($s) = @_;
+ return $esc_0208 . $s unless /^%/ || $s =~ /^![\#\"&VW+,<]/;
+ $n += length($s) / 2;
+ $s =~ s/(..)/$z2h{$1}/g;
+ $esc_kana . $s;
+}
+
+sub z2h_euc {
+ local(*s, $n) = @_;
+ &init_z2h_euc unless defined %z2h_euc;
+ $s =~ s/($re_euc_c|$re_euc_kana)/
+ $z2h_euc{$1} ? ($n++, $z2h_euc{$1}) : $1
+ /geo;
+ $n;
+}
+
+sub z2h_sjis {
+ local(*s, $n) = @_;
+ &init_z2h_sjis unless defined %z2h_sjis;
+ $s =~ s/($re_sjis_c)/$z2h_sjis{$1} ? ($n++, $z2h_sjis{$1}) : $1/geo;
+ $n;
+}
+
+;#
+;# Initializing JIS X0208 to X0201 KANA table for EUC and SJIS. This
+;# can be done in &init but it's not worth doing. Similarly,
+;# precalculated table is not worth to occupy the file space and
+;# reduce the readability. The author personnaly discourages to use
+;# X0201 Kana character in the any situation.
+;#
+sub init_z2h_euc {
+ local($k, $s);
+ while (($k, $s) = each %z2h) {
+ $s =~ s/([\241-\337])/\216$1/g && ($z2h_euc{$k} = $s);
+ }
+}
+sub init_z2h_sjis {
+ local($s, $v);
+ while (($s, $v) = each %z2h) {
+ $s =~ /[\200-\377]/ && ($z2h_sjis{&e2s($s)} = $v);
+ }
+}
+
+;#
+;# TR function for 2-byte code
+;#
+sub tr {
+ # $prev_from, $prev_to, %table are persistent variables
+ local(*s, $from, $to, $opt) = @_;
+ local(@from, @to);
+ local($jis, $n) = (0, 0);
+
+ $jis++, &jis2euc(*s) if $s =~ /$re_jp|$re_asc|$re_kana/o;
+ $jis++ if $to =~ /$re_jp|$re_asc|$re_kana/o;
+
+ if (!defined($prev_from) || $from ne $prev_from || $to ne $prev_to) {
+ ($prev_from, $prev_to) = ($from, $to);
+ undef %table;
+ &_maketable;
+ }
+
+ $s =~ s/([\200-\377][\000-\377]|[\000-\377])/
+ defined($table{$1}) && ++$n ? $table{$1} : $1
+ /ge;
+
+ &euc2jis(*s) if $jis;
+
+ $n;
+}
+
+sub _maketable {
+ local($ascii) = '(\\\\[\\-\\\\]|[\0-\133\135-\177])';
+
+ &jis2euc(*to) if $to =~ /$re_jp|$re_asc|$re_kana/o;
+ &jis2euc(*from) if $from =~ /$re_jp|$re_asc|$re_kana/o;
+
+ grep(s/(([\200-\377])[\200-\377]-\2[\200-\377])/&_expnd2($1)/ge,
+ $from, $to);
+ grep(s/($ascii-$ascii)/&_expnd1($1)/geo,
+ $from, $to);
+
+ @to = $to =~ /[\200-\377][\000-\377]|[\000-\377]/g;
+ @from = $from =~ /[\200-\377][\000-\377]|[\000-\377]/g;
+ push(@to, ($opt =~ /d/ ? '' : $to[$#to]) x (@from - @to)) if @to < @from;
+ @table{@from} = @to;
+}
+
+sub _expnd1 {
+ local($s) = @_;
+ $s =~ s/\\(.)/$1/g;
+ local($c1, $c2) = unpack('CxC', $s);
+ if ($c1 <= $c2) {
+ for ($s = ''; $c1 <= $c2; $c1++) {
+ $s .= pack('C', $c1);
+ }
+ }
+ $s;
+}
+
+sub _expnd2 {
+ local($s) = @_;
+ local($c1, $c2, $c3, $c4) = unpack('CCxCC', $s);
+ if ($c1 == $c3 && $c2 <= $c4) {
+ for ($s = ''; $c2 <= $c4; $c2++) {
+ $s .= pack('CC', $c1, $c2);
+ }
+ }
+ $s;
+}
+
+1;
OSDN Git Service
