home *** CD-ROM | disk | FTP | other *** search
/ DOS/V Power Report 2001 December (DVD) / VPR0112A.ISO / OLS / FSTAT / fstat.lzh / lib / jcode.pl < prev    next >
Perl Script  |  2000-12-23  |  22KB  |  788 lines
  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;
  786.  
  787.  
  788.