1package 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;# 259sub 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 2971 %" 2 %$ 3 %& 4 %( 5 %* 2986 %+ 7 %- 8 %/ 9 %1 : %3 2996^ %, 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 304E %J F %K G %L H %M I %N 305J %O K %R L %U M %X N %[ 306J^ %P K^ %S L^ %V M^ %Y N^ %\ 307J_ %Q K_ %T L_ %W M_ %Z N_ %] 308O %^ P %_ Q %` R %a S %b 309T %d U %f V %h 310W %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;# 337sub 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;# 348sub 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;# 358sub 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} 388sub max { $_[ $[ + ($_[ $[ ] < $_[ $[ + 1 ]) ]; } 389 390;# 391;# Convert any code to specified code. 392;# 393sub 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;# 407sub jis { &to('jis', @_); } 408sub euc { &to('euc', @_); } 409sub sjis { &to('sjis', @_); } 410sub to { 411 local($ocode, $s, $icode, $opt) = @_; 412 &convert(*s, $ocode, $icode, $opt); 413 $s; 414} 415sub what { 416 local($s) = @_; 417 &getcode(*s); 418} 419sub trans { 420 local($s) = shift; 421 &tr(*s, @_); 422 $s; 423} 424 425;# 426;# SJIS to JIS 427;# 428sub 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} 434sub _sjis2jis { 435 local($s) = shift; 436 $s =~ s/(($re_sjis_c)+|($re_sjis_kana)+)/&__sjis2jis($1)/geo; 437 $s; 438} 439sub __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;# 454sub 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} 462sub _euc2jis { 463 local($s) = shift; 464 $s =~ s/(($re_euc_c)+|($re_euc_kana)+|($re_euc_0212)+)/&__euc2jis($1)/geo; 465 $s; 466} 467sub __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;# 486sub 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} 492sub _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;# 509sub 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} 515sub _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;# 533sub 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} 539sub 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;# 563sub 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} 568sub 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;# 593sub 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} 600sub sjis2sjis { 601 local(*s, $opt) = @_; 602 &h2z_sjis(*s) if $opt =~ /z/; 603 &z2h_sjis(*s) if $opt =~ /h/; 604} 605sub 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;# 614sub cache { 615 ($cache, $cache = 1)[$[]; 616} 617sub nocache { 618 ($cache, $cache = 0)[$[]; 619} 620sub flushcache { 621 undef %e2s; 622 undef %s2e; 623} 624 625;# 626;# X0201 -> X0208 KANA conversion routine 627;# 628sub 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} 635sub _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 643sub 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 650sub 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;# 662sub z2h_jis { 663 local(*s, $n) = @_; 664 $s =~ s/($re_jis0208)([^\e]+)/&_z2h_jis($2)/geo; 665 $n; 666} 667sub _z2h_jis { 668 local($s) = @_; 669 $s =~ s/((\%[!-~]|![\#\"&VW+,<])+|([^!%][!-~]|![^\#\"&VW+,<])+)/ 670 &__z2h_jis($1) 671 /ge; 672 $s; 673} 674sub __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 682sub z2h_euc { 683 local(*s, $n) = @_; 684 &init_z2h_euc unless %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 691sub z2h_sjis { 692 local(*s, $n) = @_; 693 &init_z2h_sjis unless %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;# 705sub 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} 711sub 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;# 721sub 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 745sub _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 762sub _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 774sub _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 7851; 786