lib/jcode.pl

   1 package jcode;
   2 ;######################################################################
   3 ;#
   4 ;# jcode.pl: Perl library for Japanese character code conversion
   5 ;#
   6 ;# Copyright (c) 1995-2000 Kazumasa Utashiro <utashiro@iij.ad.jp>
   7 ;# Internet Initiative Japan Inc.
   8 ;# 3-13 Kanda Nishiki-cho, Chiyoda-ku, Tokyo 101-0054, Japan
   9 ;#
  10 ;# Copyright (c) 1992,1993,1994 Kazumasa Utashiro
  11 ;# Software Research Associates, Inc.
  12 ;#
  13 ;# Use and redistribution for ANY PURPOSE are granted as long as all
  14 ;# copyright notices are retained.  Redistribution with modification
  15 ;# is allowed provided that you make your modified version obviously
  16 ;# distinguishable from the original one.  THIS SOFTWARE IS PROVIDED
  17 ;# BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES ARE
  18 ;# DISCLAIMED.
  19 ;#
  20 ;# Original version was developed under the name of srekcah@sra.co.jp
  21 ;# February 1992 and it was called kconv.pl at the beginning.  This
  22 ;# address was a pen name for group of individuals and it is no longer
  23 ;# valid.
  24 ;#
  25 ;# The latest version is available here:
  26 ;#
  27 ;#      ftp://ftp.iij.ad.jp/pub/IIJ/dist/utashiro/perl/
  28 ;#
  29 ;; $rcsid = q$Id: jcode.pl,v 2.13 2000/09/29 16:10:05 utashiro Exp $;
  30 ;#
  31 ;######################################################################
  32 ;#
  33 ;# PERL4 INTERFACE:
  34 ;#
  35 ;#      &jcode'getcode(*line)
  36 ;#              Return 'jis', 'sjis', 'euc' or undef according to
  37 ;#              Japanese character code in $line.  Return 'binary' if
  38 ;#              the data has non-character code.
  39 ;#
  40 ;#              When evaluated in array context, it returns a list
  41 ;#              contains two items.  First value is the number of
  42 ;#              characters which matched to the expected code, and
  43 ;#              second value is the code name.  It is useful if and
  44 ;#              only if the number is not 0 and the code is undef;
  45 ;#              that case means it couldn't tell 'euc' or 'sjis'
  46 ;#              because the evaluation score was exactly same.  This
  47 ;#              interface is too tricky, though.
  48 ;#
  49 ;#              Code detection between euc and sjis is very difficult
  50 ;#              or sometimes impossible or even lead to wrong result
  51 ;#              when it includes JIS X0201 KANA characters.  So JIS
  52 ;#              X0201 KANA is ignored for automatic code detection.
  53 ;#
  54 ;#      &jcode'convert(*line, $ocode [, $icode [, $option]])
  55 ;#              Convert the contents of $line to the specified
  56 ;#              Japanese code given in the second argument $ocode.
  57 ;#              $ocode can be any of "jis", "sjis" or "euc", or use
  58 ;#              "noconv" when you don't want the code conversion.
  59 ;#              Input code is recognized automatically from the line
  60 ;#              itself when $icode is not supplied (JIS X0201 KANA is
  61 ;#              ignored in code detection.  See the above descripton
  62 ;#              of &getcode).  $icode also can be specified, but
  63 ;#              xxx2yyy routine is more efficient when both codes are
  64 ;#              known.
  65 ;#
  66 ;#              It returns the code of input string in scalar context,
  67 ;#              and a list of pointer of convert subroutine and the
  68 ;#              input code in array context.
  69 ;#
  70 ;#              Japanese character code JIS X0201, X0208, X0212 and
  71 ;#              ASCII code are supported.  X0212 characters can not be
  72 ;#              represented in SJIS and they will be replased by
  73 ;#              "geta" character when converted to SJIS.
  74 ;#
  75 ;#              See next paragraph for $option parameter.
  76 ;#
  77 ;#      &jcode'xxx2yyy(*line [, $option])
  78 ;#              Convert the Japanese code from xxx to yyy.  String xxx
  79 ;#              and yyy are any convination from "jis", "euc" or
  80 ;#              "sjis".  They return *approximate* number of converted
  81 ;#              bytes.  So return value 0 means the line was not
  82 ;#              converted at all.
  83 ;#
  84 ;#              Optional parameter $option is used to specify optional
  85 ;#              conversion method.  String "z" is for JIS X0201 KANA
  86 ;#              to X0208 KANA, and "h" is for reverse.
  87 ;#
  88 ;#      $jcode'convf{'xxx', 'yyy'}
  89 ;#              The value of this associative array is pointer to the
  90 ;#              subroutine jcode'xxx2yyy().
  91 ;#
  92 ;#      &jcode'to($ocode, $line [, $icode [, $option]])
  93 ;#      &jcode'jis($line [, $icode [, $option]])
  94 ;#      &jcode'euc($line [, $icode [, $option]])
  95 ;#      &jcode'sjis($line [, $icode [, $option]])
  96 ;#              These functions are prepared for easy use of
  97 ;#              call/return-by-value interface.  You can use these
  98 ;#              funcitons in s///e operation or any other place for
  99 ;#              convenience.
 100 ;#
 101 ;#      &jcode'jis_inout($in, $out)
 102 ;#              Set or inquire JIS start and end sequences.  Default
 103 ;#              is "ESC-$-B" and "ESC-(-B".  If you supplied only one
 104 ;#              character, "ESC-$" or "ESC-(" is prepended for each
 105 ;#              character respectively.  Acutually "ESC-(-B" is not a
 106 ;#              sequence to end JIS code but a sequence to start ASCII
 107 ;#              code set.  So `in' and `out' are somewhat misleading.
 108 ;#
 109 ;#      &jcode'get_inout($string)
 110 ;#              Get JIS start and end sequences from $string.
 111 ;#
 112 ;#      &jcode'cache()
 113 ;#      &jcode'nocache()
 114 ;#      &jcode'flush()
 115 ;#              Usually, converted character is cached in memory to
 116 ;#              avoid same calculations have to be done many times.
 117 ;#              To disable this caching, call &jcode'nocache().  It
 118 ;#              can be revived by &jcode'cache() and cache is flushed
 119 ;#              by calling &jcode'flush().  &cache() and &nocache()
 120 ;#              functions return previous caching state.
 121 ;#
 122 ;#      ---------------------------------------------------------------
 123 ;#
 124 ;#      &jcode'h2z_xxx(*line)
 125 ;#              JIS X0201 KANA (so-called Hankaku-KANA) to X0208 KANA
 126 ;#              (Zenkaku-KANA) code conversion routine.  String xxx is
 127 ;#              any of "jis", "sjis" and "euc".  From the difficulty
 128 ;#              of recognizing code set from 1-byte KATAKANA string,
 129 ;#              automatic code recognition is not supported.
 130 ;#
 131 ;#      &jcode'z2h_xxx(*line)
 132 ;#              X0208 to X0201 KANA code conversion routine.  String
 133 ;#              xxx is any of "jis", "sjis" and "euc".
 134 ;#
 135 ;#      $jcode'z2hf{'xxx'}
 136 ;#      $jcode'h2zf{'xxx'}
 137 ;#              These are pointer to the corresponding function just
 138 ;#              as $jcode'convf.
 139 ;#
 140 ;#      ---------------------------------------------------------------
 141 ;#
 142 ;#      &jcode'tr(*line, $from, $to [, $option])
 143 ;#              &jcode'tr emulates tr operator for 2 byte code.  Only 'd'
 144 ;#              is interpreted as an option.
 145 ;#
 146 ;#              Range operator like `A-Z' for 2 byte code is partially
 147 ;#              supported.  Code must be JIS or EUC, and first byte
 148 ;#              have to be same on first and last character.
 149 ;#
 150 ;#              CAUTION: Handling range operator is a kind of trick
 151 ;#              and it is not perfect.  So if you need to transfer `-'
 152 ;#              character, please be sure to put it at the beginning
 153 ;#              or the end of $from and $to strings.
 154 ;#
 155 ;#      &jcode'trans($line, $from, $to [, $option)
 156 ;#              Same as &jcode'tr but accept string and return string
 157 ;#              after translation.
 158 ;#
 159 ;#      ---------------------------------------------------------------
 160 ;#
 161 ;#      &jcode'init()
 162 ;#              Initialize the variables used in this package.  You
 163 ;#              don't have to call this when using jocde.pl by `do' or
 164 ;#              `require' interface.  Call it first if you embedded
 165 ;#              the jcode.pl at the end of your script.
 166 ;#
 167 ;######################################################################
 168 ;#
 169 ;# PERL5 INTERFACE:
 170 ;#
 171 ;# Current jcode.pl is written in Perl 4 but it is possible to use
 172 ;# from Perl 5 using `references'.  Fully perl5 capable version is
 173 ;# future issue.
 174 ;#
 175 ;# Since lexical variable is not a subject of typeglob, *string style
 176 ;# call doesn't work if the variable is declared as `my'.  Same thing
 177 ;# happens to special variable $_ if the perl is compiled to use
 178 ;# thread capability.  So using reference is generally recommented to
 179 ;# avoid the mysterious error.
 180 ;#
 181 ;#      jcode::getcode(\$line)
 182 ;#      jcode::convert(\$line, $ocode [, $icode [, $option]])
 183 ;#      jcode::xxx2yyy(\$line [, $option])
 184 ;#      &{$jcode::convf{'xxx', 'yyy'}}(\$line)
 185 ;#      jcode::to($ocode, $line [, $icode [, $option]])
 186 ;#      jcode::jis($line [, $icode [, $option]])
 187 ;#      jcode::euc($line [, $icode [, $option]])
 188 ;#      jcode::sjis($line [, $icode [, $option]])
 189 ;#      jcode::jis_inout($in, $out)
 190 ;#      jcode::get_inout($string)
 191 ;#      jcode::cache()
 192 ;#      jcode::nocache()
 193 ;#      jcode::flush()
 194 ;#      jcode::h2z_xxx(\$line)
 195 ;#      jcode::z2h_xxx(\$line)
 196 ;#      &{$jcode::z2hf{'xxx'}}(\$line)
 197 ;#      &{$jcode::h2zf{'xxx'}}(\$line)
 198 ;#      jcode::tr(\$line, $from, $to [, $option])
 199 ;#      jcode::trans($line, $from, $to [, $option)
 200 ;#      jcode::init()
 201 ;#
 202 ;######################################################################
 203 ;#
 204 ;# SAMPLES
 205 ;#
 206 ;# Convert any Kanji code to JIS and print each line with code name.
 207 ;#
 208 ;#      while (defined($s = <>)) {
 209 ;#          $code = &jcode'convert(*s, 'jis');
 210 ;#          print $code, "\t", $s;
 211 ;#      }
 212 ;#
 213 ;# Convert all lines to JIS according to the first recognized line.
 214 ;#
 215 ;#      while (defined($s = <>)) {
 216 ;#          print, next unless $s =~ /[\033\200-\377]/;
 217 ;#          (*f, $icode) = &jcode'convert(*s, 'jis');
 218 ;#          print;
 219 ;#          defined(&f) || next;
 220 ;#          while (<>) { &f(*s); print; }
 221 ;#          last;
 222 ;#      }
 223 ;#
 224 ;# The safest way of JIS conversion.
 225 ;#
 226 ;#      while (defined($s = <>)) {
 227 ;#          ($matched, $icode) = &jcode'getcode(*s);
 228 ;#          if (@buf == 0 && $matched == 0) {
 229 ;#              print $s;
 230 ;#              next;
 231 ;#          }
 232 ;#          push(@buf, $s);
 233 ;#          next unless $icode;
 234 ;#          while (defined($s = shift(@buf))) {
 235 ;#              &jcode'convert(*s, 'jis', $icode);
 236 ;#              print $s;
 237 ;#          }
 238 ;#          while (defined($s = <>)) {
 239 ;#              &jcode'convert(*s, 'jis', $icode);
 240 ;#              print $s;
 241 ;#          }
 242 ;#          last;
 243 ;#      }
 244 ;#      print @buf if @buf;
 245 ;#
 246 ;######################################################################
 247
 248 ;#
 249 ;# Call initialize function if it is not called yet.  This may sound
 250 ;# strange but it makes easy to embed the jcode.pl at the end of
 251 ;# script.  Call &jcode'init at the beginning of the script in that
 252 ;# case.
 253 ;#
 254 &init unless defined $version;
 255
 256 ;#
 257 ;# Initialize variables.
 258 ;#
 259 sub init {
 260     $version = $rcsid =~ /,v ([\d.]+)/ ? $1 : 'unknown';
 261
 262     $re_bin  = '[\000-\006\177\377]';
 263
 264     $re_jis0208_1978 = '\e\$\@';
 265     $re_jis0208_1983 = '\e\$B';
 266     $re_jis0208_1990 = '\e&\@\e\$B';
 267     $re_jis0208 = "$re_jis0208_1978|$re_jis0208_1983|$re_jis0208_1990";
 268     $re_jis0212 = '\e\$\(D';
 269     $re_jp      = "$re_jis0208|$re_jis0212";
 270     $re_asc     = '\e\([BJ]';
 271     $re_kana    = '\e\(I';
 272
 273     $esc_0208 = "\e\$B";
 274     $esc_0212 = "\e\$(D";
 275     $esc_asc  = "\e(B";
 276     $esc_kana = "\e(I";
 277
 278     $re_sjis_c    = '[\201-\237\340-\374][\100-\176\200-\374]';
 279     $re_sjis_kana = '[\241-\337]';
 280
 281     $re_euc_c    = '[\241-\376][\241-\376]';
 282     $re_euc_kana = '\216[\241-\337]';
 283     $re_euc_0212 = '\217[\241-\376][\241-\376]';
 284
 285     # Use `geta' for undefined character code
 286     $undef_sjis = "\x81\xac";
 287
 288     $cache = 1;
 289
 290     # X0201 -> X0208 KANA conversion table.  Looks weird?  Not that
 291     # much.  This is simply JIS text without escape sequences.
 292     ($h2z_high = $h2z = <<'__TABLE_END__') =~ tr/\041-\176/\241-\376/;
 293 !       !#      $       !"      %       !&      "       !V      #       !W
 294 ^       !+      _       !,      0       !<
 295 '       %!      (       %#      )       %%      *       %'      +       %)
 296 ,       %c      -       %e      .       %g      /       %C
 297 1       %"      2       %$      3       %&      4       %(      5       %*
 298 6       %+      7       %-      8       %/      9       %1      :       %3
 299 6^      %,      7^      %.      8^      %0      9^      %2      :^      %4
 300 ;       %5      <       %7      =       %9      >       %;      ?       %=
 301 ;^      %6      <^      %8      =^      %:      >^      %<      ?^      %>
 302 @       %?      A       %A      B       %D      C       %F      D       %H
 303 @^      %@      A^      %B      B^      %E      C^      %G      D^      %I
 304 E       %J      F       %K      G       %L      H       %M      I       %N
 305 J       %O      K       %R      L       %U      M       %X      N       %[
 306 J^      %P      K^      %S      L^      %V      M^      %Y      N^      %\
 307 J_      %Q      K_      %T      L_      %W      M_      %Z      N_      %]
 308 O       %^      P       %_      Q       %`      R       %a      S       %b
 309 T       %d                      U       %f                      V       %h
 310 W       %i      X       %j      Y       %k      Z       %l      [       %m
 311 \       %o      ]       %s      &       %r      3^      %t
 312 __TABLE_END__
 313     %h2z = split(/\s+/, $h2z . $h2z_high);
 314     %z2h = reverse %h2z;
 315
 316     $convf{'jis'  , 'jis' } = *jis2jis;
 317     $convf{'jis'  , 'sjis'} = *jis2sjis;
 318     $convf{'jis'  , 'euc' } = *jis2euc;
 319     $convf{'euc'  , 'jis' } = *euc2jis;
 320     $convf{'euc'  , 'sjis'} = *euc2sjis;
 321     $convf{'euc'  , 'euc' } = *euc2euc;
 322     $convf{'sjis' , 'jis' } = *sjis2jis;
 323     $convf{'sjis' , 'sjis'} = *sjis2sjis;
 324     $convf{'sjis' , 'euc' } = *sjis2euc;
 325     $h2zf{'jis' } = *h2z_jis;
 326     $z2hf{'jis' } = *z2h_jis;
 327     $h2zf{'euc' } = *h2z_euc;
 328     $z2hf{'euc' } = *z2h_euc;
 329     $h2zf{'sjis'} = *h2z_sjis;
 330     $z2hf{'sjis'} = *z2h_sjis;
 331 }
 332
 333 ;#
 334 ;# Set escape sequences which should be put before and after Japanese
 335 ;# (JIS X0208) string.
 336 ;#
 337 sub jis_inout {
 338     $esc_0208 = shift || $esc_0208;
 339     $esc_0208 = "\e\$$esc_0208" if length($esc_0208) == 1;
 340     $esc_asc = shift || $esc_asc;
 341     $esc_asc = "\e\($esc_asc" if length($esc_asc) == 1;
 342     ($esc_0208, $esc_asc);
 343 }
 344
 345 ;#
 346 ;# Get JIS in and out sequences from the string.
 347 ;#
 348 sub get_inout {
 349     local($esc_0208, $esc_asc);
 350     $_[$[] =~ /($re_jis0208)/o && ($esc_0208 = $1);
 351     $_[$[] =~ /($re_asc)/o && ($esc_asc = $1);
 352     ($esc_0208, $esc_asc);
 353 }
 354
 355 ;#
 356 ;# Recognize character code.
 357 ;#
 358 sub getcode {
 359     local(*s) = @_;
 360     local($matched, $code);
 361
 362     if ($s !~ /[\e\200-\377]/) {        # not Japanese
 363         $matched = 0;
 364         $code = undef;
 365     }                                   # 'jis'
 366     elsif ($s =~ /$re_jp|$re_asc|$re_kana/o) {
 367         $matched = 1;
 368         $code = 'jis';
 369     }
 370     elsif ($s =~ /$re_bin/o) {          # 'binary'
 371         $matched = 0;
 372         $code = 'binary';
 373     }
 374     else {                              # should be 'euc' or 'sjis'
 375         local($sjis, $euc) = (0, 0);
 376
 377         while ($s =~ /(($re_sjis_c)+)/go) {
 378             $sjis += length($1);
 379         }
 380         while ($s =~ /(($re_euc_c|$re_euc_kana|$re_euc_0212)+)/go) {
 381             $euc  += length($1);
 382         }
 383         $matched = &max($sjis, $euc);
 384         $code = ('euc', undef, 'sjis')[($sjis<=>$euc) + $[ + 1];
 385     }
 386     wantarray ? ($matched, $code) : $code;
 387 }
 388 sub max { $_[ $[ + ($_[ $[ ] < $_[ $[ + 1 ]) ]; }
 389
 390 ;#
 391 ;# Convert any code to specified code.
 392 ;#
 393 sub convert {
 394     local(*s, $ocode, $icode, $opt) = @_;
 395     return (undef, undef) unless $icode = $icode || &getcode(*s);
 396     return (undef, $icode) if $icode eq 'binary';
 397     $ocode = 'jis' unless $ocode;
 398     $ocode = $icode if $ocode eq 'noconv';
 399     local(*f) = $convf{$icode, $ocode};
 400     &f(*s, $opt);
 401     wantarray ? (*f, $icode) : $icode;
 402 }
 403
 404 ;#
 405 ;# Easy return-by-value interfaces.
 406 ;#
 407 sub jis  { &to('jis',  @_); }
 408 sub euc  { &to('euc',  @_); }
 409 sub sjis { &to('sjis', @_); }
 410 sub to {
 411     local($ocode, $s, $icode, $opt) = @_;
 412     &convert(*s, $ocode, $icode, $opt);
 413     $s;
 414 }
 415 sub what {
 416     local($s) = @_;
 417     &getcode(*s);
 418 }
 419 sub trans {
 420     local($s) = shift;
 421     &tr(*s, @_);
 422     $s;
 423 }
 424
 425 ;#
 426 ;# SJIS to JIS
 427 ;#
 428 sub sjis2jis {
 429     local(*s, $opt, $n) = @_;
 430     &sjis2sjis(*s, $opt) if $opt;
 431     $s =~ s/(($re_sjis_c|$re_sjis_kana)+)/&_sjis2jis($1) . $esc_asc/geo;
 432     $n;
 433 }
 434 sub _sjis2jis {
 435     local($s) = shift;
 436     $s =~ s/(($re_sjis_c)+|($re_sjis_kana)+)/&__sjis2jis($1)/geo;
 437     $s;
 438 }
 439 sub __sjis2jis {
 440     local($s) = shift;
 441     if ($s =~ /^$re_sjis_kana/o) {
 442         $n += $s =~ tr/\241-\337/\041-\137/;
 443         $esc_kana . $s;
 444     } else {
 445         $n += $s =~ s/($re_sjis_c)/$s2e{$1}||&s2e($1)/geo;
 446         $s =~ tr/\241-\376/\041-\176/;
 447         $esc_0208 . $s;
 448     }
 449 }
 450
 451 ;#
 452 ;# EUC to JIS
 453 ;#
 454 sub euc2jis {
 455     local(*s, $opt, $n) = @_;
 456     &euc2euc(*s, $opt) if $opt;
 457     $s =~ s/(($re_euc_c|$re_euc_kana|$re_euc_0212)+)/
 458         &_euc2jis($1) . $esc_asc
 459     /geo;
 460     $n;
 461 }
 462 sub _euc2jis {
 463     local($s) = shift;
 464     $s =~ s/(($re_euc_c)+|($re_euc_kana)+|($re_euc_0212)+)/&__euc2jis($1)/geo;
 465     $s;
 466 }
 467 sub __euc2jis {
 468     local($s) = shift;
 469     local($esc);
 470
 471     if ($s =~ tr/\216//d) {
 472         $esc = $esc_kana;
 473     } elsif ($s =~ tr/\217//d) {
 474         $esc = $esc_0212;
 475     } else {
 476         $esc = $esc_0208;
 477     }
 478
 479     $n += $s =~ tr/\241-\376/\041-\176/;
 480     $esc . $s;
 481 }
 482
 483 ;#
 484 ;# JIS to EUC
 485 ;#
 486 sub jis2euc {
 487     local(*s, $opt, $n) = @_;
 488     $s =~ s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2euc($1,$2)/geo;
 489     &euc2euc(*s, $opt) if $opt;
 490     $n;
 491 }
 492 sub _jis2euc {
 493     local($esc, $s) = @_;
 494     if ($esc !~ /^$re_asc/o) {
 495         $n += $s =~ tr/\041-\176/\241-\376/;
 496         if ($esc =~ /^$re_kana/o) {
 497             $s =~ s/([\241-\337])/\216$1/g;
 498         }
 499         elsif ($esc =~ /^$re_jis0212/o) {
 500             $s =~ s/([\241-\376][\241-\376])/\217$1/g;
 501         }
 502     }
 503     $s;
 504 }
 505
 506 ;#
 507 ;# JIS to SJIS
 508 ;#
 509 sub jis2sjis {
 510     local(*s, $opt, $n) = @_;
 511     &jis2jis(*s, $opt) if $opt;
 512     $s =~ s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2sjis($1,$2)/geo;
 513     $n;
 514 }
 515 sub _jis2sjis {
 516     local($esc, $s) = @_;
 517     if ($esc =~ /^$re_jis0212/o) {
 518         $s =~ s/../$undef_sjis/g;
 519         $n = length;
 520     }
 521     elsif ($esc !~ /^$re_asc/o) {
 522         $n += $s =~ tr/\041-\176/\241-\376/;
 523         if ($esc =~ /^$re_jp/o) {
 524             $s =~ s/($re_euc_c)/$e2s{$1}||&e2s($1)/geo;
 525         }
 526     }
 527     $s;
 528 }
 529
 530 ;#
 531 ;# SJIS to EUC
 532 ;#
 533 sub sjis2euc {
 534     local(*s, $opt,$n) = @_;
 535     $n = $s =~ s/($re_sjis_c|$re_sjis_kana)/$s2e{$1}||&s2e($1)/geo;
 536     &euc2euc(*s, $opt) if $opt;
 537     $n;
 538 }
 539 sub s2e {
 540     local($c1, $c2, $code);
 541     ($c1, $c2) = unpack('CC', $code = shift);
 542
 543     if (0xa1 <= $c1 && $c1 <= 0xdf) {
 544         $c2 = $c1;
 545         $c1 = 0x8e;
 546     } elsif (0x9f <= $c2) {
 547         $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe0 : 0x60);
 548         $c2 += 2;
 549     } else {
 550         $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe1 : 0x61);
 551         $c2 += 0x60 + ($c2 < 0x7f);
 552     }
 553     if ($cache) {
 554         $s2e{$code} = pack('CC', $c1, $c2);
 555     } else {
 556         pack('CC', $c1, $c2);
 557     }
 558 }
 559
 560 ;#
 561 ;# EUC to SJIS
 562 ;#
 563 sub euc2sjis {
 564     local(*s, $opt,$n) = @_;
 565     &euc2euc(*s, $opt) if $opt;
 566     $n = $s =~ s/($re_euc_c|$re_euc_kana|$re_euc_0212)/$e2s{$1}||&e2s($1)/geo;
 567 }
 568 sub e2s {
 569     local($c1, $c2, $code);
 570     ($c1, $c2) = unpack('CC', $code = shift);
 571
 572     if ($c1 == 0x8e) {          # SS2
 573         return substr($code, 1, 1);
 574     } elsif ($c1 == 0x8f) {     # SS3
 575         return $undef_sjis;
 576     } elsif ($c1 % 2) {
 577         $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x31 : 0x71);
 578         $c2 -= 0x60 + ($c2 < 0xe0);
 579     } else {
 580         $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x30 : 0x70);
 581         $c2 -= 2;
 582     }
 583     if ($cache) {
 584         $e2s{$code} = pack('CC', $c1, $c2);
 585     } else {
 586         pack('CC', $c1, $c2);
 587     }
 588 }
 589
 590 ;#
 591 ;# JIS to JIS, SJIS to SJIS, EUC to EUC
 592 ;#
 593 sub jis2jis {
 594     local(*s, $opt) = @_;
 595     $s =~ s/$re_jis0208/$esc_0208/go;
 596     $s =~ s/$re_asc/$esc_asc/go;
 597     &h2z_jis(*s) if $opt =~ /z/;
 598     &z2h_jis(*s) if $opt =~ /h/;
 599 }
 600 sub sjis2sjis {
 601     local(*s, $opt) = @_;
 602     &h2z_sjis(*s) if $opt =~ /z/;
 603     &z2h_sjis(*s) if $opt =~ /h/;
 604 }
 605 sub euc2euc {
 606     local(*s, $opt) = @_;
 607     &h2z_euc(*s) if $opt =~ /z/;
 608     &z2h_euc(*s) if $opt =~ /h/;
 609 }
 610
 611 ;#
 612 ;# Cache control functions
 613 ;#
 614 sub cache {
 615     ($cache, $cache = 1)[$[];
 616 }
 617 sub nocache {
 618     ($cache, $cache = 0)[$[];
 619 }
 620 sub flushcache {
 621     undef %e2s;
 622     undef %s2e;
 623 }
 624
 625 ;#
 626 ;# X0201 -> X0208 KANA conversion routine
 627 ;#
 628 sub h2z_jis {
 629     local(*s, $n) = @_;
 630     if ($s =~ s/$re_kana([^\e]*)/$esc_0208 . &_h2z_jis($1)/geo) {
 631         1 while $s =~ s/(($re_jis0208)[^\e]*)($re_jis0208)/$1/o;
 632     }
 633     $n;
 634 }
 635 sub _h2z_jis {
 636     local($s) = @_;
 637     $n += $s =~ s/(([\041-\137])([\136\137])?)/
 638         $h2z{$1} || $h2z{$2} . $h2z{$3}
 639     /ge;
 640     $s;
 641 }
 642
 643 sub h2z_euc {
 644     local(*s) = @_;
 645     $s =~ s/\216([\241-\337])(\216([\336\337]))?/
 646         $h2z{"$1$3"} || $h2z{$1} . $h2z{$3}
 647     /ge;
 648 }
 649
 650 sub h2z_sjis {
 651     local(*s, $n) = @_;
 652     $s =~ s/(($re_sjis_c)+)|(([\241-\337])([\336\337])?)/
 653         $1 || ($n++, $h2z{$3} ? $e2s{$h2z{$3}} || &e2s($h2z{$3})
 654                               : &e2s($h2z{$4}) . ($5 && &e2s($h2z{$5})))
 655     /geo;
 656     $n;
 657 }
 658
 659 ;#
 660 ;# X0208 -> X0201 KANA conversion routine
 661 ;#
 662 sub z2h_jis {
 663     local(*s, $n) = @_;
 664     $s =~ s/($re_jis0208)([^\e]+)/&_z2h_jis($2)/geo;
 665     $n;
 666 }
 667 sub _z2h_jis {
 668     local($s) = @_;
 669     $s =~ s/((\%[!-~]|![\#\"&VW+,<])+|([^!%][!-~]|![^\#\"&VW+,<])+)/
 670         &__z2h_jis($1)
 671     /ge;
 672     $s;
 673 }
 674 sub __z2h_jis {
 675     local($s) = @_;
 676     return $esc_0208 . $s unless $s =~ /^%/ || $s =~ /^![\#\"&VW+,<]/;
 677     $n += length($s) / 2;
 678     $s =~ s/(..)/$z2h{$1}/g;
 679     $esc_kana . $s;
 680 }
 681
 682 sub z2h_euc {
 683     local(*s, $n) = @_;
 684     &init_z2h_euc unless defined %z2h_euc;
 685     $s =~ s/($re_euc_c|$re_euc_kana)/
 686         $z2h_euc{$1} ? ($n++, $z2h_euc{$1}) : $1
 687     /geo;
 688     $n;
 689 }
 690
 691 sub z2h_sjis {
 692     local(*s, $n) = @_;
 693     &init_z2h_sjis unless defined %z2h_sjis;
 694     $s =~ s/($re_sjis_c)/$z2h_sjis{$1} ? ($n++, $z2h_sjis{$1}) : $1/geo;
 695     $n;
 696 }
 697
 698 ;#
 699 ;# Initializing JIS X0208 to X0201 KANA table for EUC and SJIS.  This
 700 ;# can be done in &init but it's not worth doing.  Similarly,
 701 ;# precalculated table is not worth to occupy the file space and
 702 ;# reduce the readability.  The author personnaly discourages to use
 703 ;# X0201 Kana character in the any situation.
 704 ;#
 705 sub init_z2h_euc {
 706     local($k, $s);
 707     while (($k, $s) = each %z2h) {
 708         $s =~ s/([\241-\337])/\216$1/g && ($z2h_euc{$k} = $s);
 709     }
 710 }
 711 sub init_z2h_sjis {
 712     local($s, $v);
 713     while (($s, $v) = each %z2h) {
 714         $s =~ /[\200-\377]/ && ($z2h_sjis{&e2s($s)} = $v);
 715     }
 716 }
 717
 718 ;#
 719 ;# TR function for 2-byte code
 720 ;#
 721 sub tr {
 722     # $prev_from, $prev_to, %table are persistent variables
 723     local(*s, $from, $to, $opt) = @_;
 724     local(@from, @to);
 725     local($jis, $n) = (0, 0);
 726
 727     $jis++, &jis2euc(*s) if $s =~ /$re_jp|$re_asc|$re_kana/o;
 728     $jis++ if $to =~ /$re_jp|$re_asc|$re_kana/o;
 729
 730     if (!defined($prev_from) || $from ne $prev_from || $to ne $prev_to) {
 731         ($prev_from, $prev_to) = ($from, $to);
 732         undef %table;
 733         &_maketable;
 734     }
 735
 736     $s =~ s/([\200-\377][\000-\377]|[\000-\377])/
 737         defined($table{$1}) && ++$n ? $table{$1} : $1
 738     /ge;
 739
 740     &euc2jis(*s) if $jis;
 741
 742     $n;
 743 }
 744
 745 sub _maketable {
 746     local($ascii) = '(\\\\[\\-\\\\]|[\0-\133\135-\177])';
 747
 748     &jis2euc(*to) if $to =~ /$re_jp|$re_asc|$re_kana/o;
 749     &jis2euc(*from) if $from =~ /$re_jp|$re_asc|$re_kana/o;
 750
 751     grep(s/(([\200-\377])[\200-\377]-\2[\200-\377])/&_expnd2($1)/ge,
 752          $from, $to);
 753     grep(s/($ascii-$ascii)/&_expnd1($1)/geo,
 754          $from, $to);
 755
 756     @to   = $to   =~ /[\200-\377][\000-\377]|[\000-\377]/g;
 757     @from = $from =~ /[\200-\377][\000-\377]|[\000-\377]/g;
 758     push(@to, ($opt =~ /d/ ? '' : $to[$#to]) x (@from - @to)) if @to < @from;
 759     @table{@from} = @to;
 760 }
 761
 762 sub _expnd1 {
 763     local($s) = @_;
 764     $s =~ s/\\(.)/$1/g;
 765     local($c1, $c2) = unpack('CxC', $s);
 766     if ($c1 <= $c2) {
 767         for ($s = ''; $c1 <= $c2; $c1++) {
 768             $s .= pack('C', $c1);
 769         }
 770     }
 771     $s;
 772 }
 773
 774 sub _expnd2 {
 775     local($s) = @_;
 776     local($c1, $c2, $c3, $c4) = unpack('CCxCC', $s);
 777     if ($c1 == $c3 && $c2 <= $c4) {
 778         for ($s = ''; $c2 <= $c4; $c2++) {
 779             $s .= pack('CC', $c1, $c2);
 780         }
 781     }
 782     $s;
 783 }
 784
 785 1;