home *** CD-ROM | disk | FTP | other *** search
/ Internet 1996 World Exposition / park.org.s3.amazonaws.com.7z / park.org.s3.amazonaws.com / cgi-bin / Japan / DNP / MTN / jcode.pl next >
Perl Script  |  2017-09-21  |  7KB  |  284 lines
  1. package jcode;
  2. ;######################################################################
  3. ;#
  4. ;# jcode.pl: Japanese character code conversion library
  5. ;#
  6. ;# Copyright (c) 1991,1992 Software Research Associates, Inc.
  7. ;#    Original by srekcah@sra.co.jp, Feb 1992
  8. ;#
  9. ;#    Maintained by Kazumasa Utashiro <utashiro@sra.co.jp>
  10. ;#    Software Research Associates, Inc., Japan
  11. ;#
  12. ;; $rcsid = q$Id: jcode.pl,v 1.9 1994/02/14 06:16:29 utashiro Exp $;
  13. ;#
  14. ;######################################################################
  15. ;#
  16. ;# INTERFACE:
  17. ;#
  18. ;#    &jcode'getcode(*line)
  19. ;#        Return 'jis', 'sjis', 'euc' or undef according to
  20. ;#        Japanese character code in $line.
  21. ;#
  22. ;#    &jcode'convert(*line, $ocode [, $icode])
  23. ;#        Convert the line in any Japanese code to specified
  24. ;#        code in second argument $ocode.  $ocode is one of
  25. ;#        'jis', 'sjis' or 'euc'.  Input code is recognized
  26. ;#        automatically from the line itself when $icode is not
  27. ;#        supplied.  $icode also can be specified, but xxx2yyy
  28. ;#        routine is more efficient when both codes are known.
  29. ;#
  30. ;#        It returns a list of pointer of convert subroutine and
  31. ;#        input code.  It means that this routine returns the
  32. ;#        input code of the line in scalar context.
  33. ;#
  34. ;#    &jcode'xxx2yyy(*line)
  35. ;#        Convert Japanese code from xxx to yyy.  xxx and yyy
  36. ;#        are one of "jis", "sjis" or "euc".  These subroutines
  37. ;#        return number of converted substrings.  So return
  38. ;#        value 0 means the line was not converted at all.
  39. ;#
  40. ;#    &jcode'jis_inout($in, $out)
  41. ;#        Set or inquire JIS start and end sequences.  Default
  42. ;#        is "ESC-$-B" and "ESC-(-B".  If you supplied only one
  43. ;#        character, "ESC-$" or "ESC-(" is added as a prefix
  44. ;#        for each character respectively.  Acutually "ESC-(-B"
  45. ;#        is not a sequence to end JIS code but a sequence to
  46. ;#        start ASCII code set.  So `in' and `out' are somewhat
  47. ;#        misleading.
  48. ;#
  49. ;#    &jcode'get_inout($string)
  50. ;#        Get JIS start and end sequences from $string.
  51. ;#
  52. ;#    $jcode'convf{'xxx', 'yyy'}
  53. ;#        The value of this associative array is pointer to the
  54. ;#        subroutine jcode'xxx2yyy().
  55. ;#
  56. ;#    ---------------------------------------------------------------
  57. ;#
  58. ;#    &jcode'init()
  59. ;#        Initialize the variables used in other functions.  You
  60. ;#        don't have to call this when using jocde.pl by do or
  61. ;#        require.  Call it first if you embedded the jcode.pl
  62. ;#        in your script.
  63. ;#
  64. ;######################################################################
  65. ;#
  66. ;# SAMPLES
  67. ;#
  68. ;# Convert any Kanji code to JIS and print each line with code name.
  69. ;#
  70. ;#    while (<>) {
  71. ;#        $code = &jcode'convert(*_, 'jis');
  72. ;#        print $code, "\t", $_;
  73. ;#    }
  74. ;#    
  75. ;# Convert all lines to JIS according to the first recognized line.
  76. ;#
  77. ;#    while (<>) {
  78. ;#        print, next unless /[\033\200-\377]/;
  79. ;#        (*f, $icode) = &jcode'convert(*_, 'jis');
  80. ;#        print;
  81. ;#        defined(&f) || next;
  82. ;#        while (<>) { &f(*_); print; }
  83. ;#        last;
  84. ;#    }
  85. ;#
  86. ;# The safest way for converting to JIS
  87. ;#
  88. ;#    while (<>) {
  89. ;#        ($matched, $code) = &jcode'getcode(*_);
  90. ;#        print, next unless (@buf || $matched);
  91. ;#        push(@readahead, $_);
  92. ;#        next unless $code;
  93. ;#        eval "&jcode'${code}2jis(*_), print while (\$_ = shift(\@buf));";
  94. ;#        eval "&jcode'${code}2jis(*_), print while (\$_ = <>);";
  95. ;#        last;
  96. ;#    }
  97. ;#        
  98. ;######################################################################
  99.  
  100. ;#
  101. ;# Call initialize function if not called yet.  This sounds strange
  102. ;# but this makes easy to embed the jcode.pl in the script.  Call
  103. ;# &jcode'init at the beginning of the script in that case.
  104. ;#
  105. &init unless defined $version;
  106.  
  107. ;#
  108. ;# Initialize variables.
  109. ;#
  110. sub init {
  111.     ($version) = ($rcsid =~ /,v ([\d.]+)/);
  112.     $re_sjis_c = '[\201-\237\340-\374][\100-\176\200-\374]';
  113.     $re_sjis_s = "($re_sjis_c)+";
  114.     $re_euc_c  = '[\241-\376][\241-\376]';
  115.     $re_euc_s  = "($re_euc_c)+";
  116.     $re_jin    = '\033\$[\@B]';
  117.     $re_jout   = '\033\([BJ]';
  118.     &jis_inout("\033\$B", "\033(B");
  119.  
  120.     for $from ('jis', 'sjis', 'euc') {
  121.     for $to ('jis', 'sjis', 'euc') {
  122.         eval "\$convf{$from, $to} = *${from}2${to};";
  123.     }
  124.     }
  125. }
  126.  
  127. ;#
  128. ;# Set JIS in and out final characters.
  129. ;#
  130. sub jis_inout {
  131.     $jin = shift || $jin;
  132.     $jout = shift || $jout;
  133.     $jin = "\033\$".$jin if length($jin) == 1;
  134.     $jout = "\033\(".$jout if length($jout) == 1;
  135.     ($jin, $jout);
  136. }
  137.  
  138. ;#
  139. ;# Get JIS in and out sequences from the string.
  140. ;#
  141. sub get_inout {
  142.     local($jin, $jout);
  143.     $_[$[] =~ /$re_jin/o && ($jin = $&);
  144.     $_[$[] =~ /$re_jout/o && ($jout = $&);
  145.     ($jin, $jout);
  146. }
  147.  
  148. ;#
  149. ;# Character code recognition
  150. ;#
  151. sub getcode {
  152.     local(*_) = @_;
  153.     return undef unless /[\033\200-\377]/;
  154.     return 'jis' if /$re_jin|$re_jout/o;
  155.  
  156.     local($sjis, $euc);
  157.     $sjis += length($&) while /$re_sjis_s/go;
  158.     $euc  += length($&) while /$re_euc_s/go;
  159.     (&max($sjis, $euc), ('euc', undef, 'sjis')[($sjis<=>$euc) + $[ + 1]);
  160. }
  161. sub max { $_[ $[ + ($_[$[] < $_[$[+1]) ]; }
  162.  
  163. ;#
  164. ;# Convert any code to specified code
  165. ;#
  166. sub convert {
  167.     local(*_, $ocode, $icode) = @_;
  168.     return (undef, undef) unless $icode = $icode || &getcode(*_);
  169.     $ocode = 'jis' unless $ocode;
  170.     local(*convf) = $convf{$icode, $ocode};
  171.     do convf(*_);
  172.     (*convf, $icode);
  173. }
  174.  
  175. ;#
  176. ;# JIS to JIS
  177. ;#
  178. sub jis2jis {
  179.     local(*_) = @_;
  180.     s/$re_jin/$jin/go;
  181.     s/$re_jout/$jout/go;
  182. }
  183.  
  184. ;#
  185. ;# SJIS to JIS
  186. ;#
  187. sub sjis2jis {
  188.     local(*_) = @_;
  189.     s/$re_sjis_s/&_sjis2jis($&)/geo;
  190. }
  191. sub _sjis2jis {
  192.     local($_) = @_;
  193.     s/../$s2e{$&}||&s2e($&)/geo;
  194.     tr/\241-\376/\041-\176/;
  195.     $jin . $_ . $jout;
  196. }
  197.  
  198. ;#
  199. ;# EUC to JIS
  200. ;#
  201. sub euc2jis {
  202.     local(*_) = @_;
  203.     s/$re_euc_s/&_euc2jis($&)/geo;
  204. }
  205. sub _euc2jis {
  206.     local($_) = @_;
  207.     tr/\241-\376/\041-\176/;
  208.     $jin . $_ . $jout;
  209. }
  210.  
  211. ;#
  212. ;# JIS to EUC
  213. ;#
  214. sub jis2euc {
  215.     local(*_) = @_;
  216.     s/$re_jin([!-~]*)$re_jout/&_jis2euc($1)/geo;
  217. }
  218. sub _jis2euc {
  219.     local($_) = @_;
  220.     tr/\041-\176/\241-\376/;
  221.     $_;
  222. }
  223.  
  224. ;#
  225. ;# JIS to SJIS
  226. ;#
  227. sub jis2sjis {
  228.     local(*_) = @_;
  229.     s/$re_jin([!-~]*)$re_jout/&_jis2sjis($1)/geo;
  230. }
  231. sub _jis2sjis {
  232.     local($_) = @_;
  233.     tr/\041-\176/\241-\376/;
  234.     s/../$e2s{$&}||&e2s($&)/ge;
  235.     $_;
  236. }
  237.  
  238. ;#
  239. ;# SJIS to EUC
  240. ;#
  241. sub sjis2euc {
  242.     local(*_) = @_;
  243.     s/$re_sjis_c/$s2e{$&}||&s2e($&)/geo;
  244. }
  245. sub s2e {
  246.     ($c1, $c2) = unpack('CC', $code = shift);
  247.     if ($c2 >= 0x9f) {
  248.     $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe0 : 0x60);
  249.     $c2 += 2;
  250.     } else {
  251.     $c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe1 : 0x61);
  252.     $c2 += 0x60 + ($c2 < 0x7f);
  253.     }
  254.     $s2e{$code} = pack('CC', $c1, $c2);
  255. }
  256.  
  257. ;#
  258. ;# EUC to SJIS
  259. ;#
  260. sub euc2sjis {
  261.     local(*_) = @_;
  262.     s/$re_euc_c/$e2s{$&}||&e2s($&)/geo;
  263. }
  264. sub e2s {
  265.     ($c1, $c2) = unpack('CC', $code = shift);
  266.     if ($c1 % 2) {
  267.     $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x31 : 0x71);
  268.     $c2 -= 0x60 + ($c2 < 0xe0);
  269.     } else {
  270.     $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x30 : 0x70);
  271.     $c2 -= 2;
  272.     }
  273.     $e2s{$code} = pack('CC', $c1, $c2);
  274. }
  275.  
  276. ;#
  277. ;# SJIS to SJIS, EUC to EUC
  278. ;#
  279. sub sjis2sjis { 0; }
  280. sub euc2euc { 0; }
  281.  
  282. 1;
  283.  
  284.