Mercurial > hg > Applications > casawiki
comparison jcode.pl @ 0:a2f0a2c135cf
hg init
author | Shoshi TAMAKI <shoshi@cr.ie.u-ryukyu.ac.jp> |
---|---|
date | Sun, 06 Jun 2010 22:00:38 +0900 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
-1:000000000000 | 0:a2f0a2c135cf |
---|---|
1 package jcode; | |
2 ;###################################################################### | |
3 ;# | |
4 ;# jcode.pl: Perl library for Japanese character code conversion | |
5 ;# | |
6 ;# Copyright (c) 1995-1999 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.11 1999/12/26 17:16:47 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 : 'unkown'; | |
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/([\41-\137]([\136\137])?)/$h2z{$1}/g; | |
638 $s; | |
639 } | |
640 | |
641 sub h2z_euc { | |
642 local(*s) = @_; | |
643 $s =~ s/\216([\241-\337])(\216([\336\337]))?/$h2z{"$1$3"}/g; | |
644 } | |
645 | |
646 sub h2z_sjis { | |
647 local(*s, $n) = @_; | |
648 $s =~ s/(($re_sjis_c)+)|(([\241-\337])([\336\337])?)/ | |
649 $1 || ($n++, $e2s{$h2z{$3}} || &e2s($h2z{$3})) | |
650 /geo; | |
651 $n; | |
652 } | |
653 | |
654 ;# | |
655 ;# X0208 -> X0201 KANA conversion routine | |
656 ;# | |
657 sub z2h_jis { | |
658 local(*s, $n) = @_; | |
659 $s =~ s/($re_jis0208)([^\e]+)/&_z2h_jis($2)/geo; | |
660 $n; | |
661 } | |
662 sub _z2h_jis { | |
663 local($s) = @_; | |
664 $s =~ s/((\%[!-~]|![\#\"&VW+,<])+|([^!%][!-~]|![^\#\"&VW+,<])+)/ | |
665 &__z2h_jis($1) | |
666 /ge; | |
667 $s; | |
668 } | |
669 sub __z2h_jis { | |
670 local($s) = @_; | |
671 return $esc_0208 . $s unless /^%/ || $s =~ /^![\#\"&VW+,<]/; | |
672 $n += length($s) / 2; | |
673 $s =~ s/(..)/$z2h{$1}/g; | |
674 $esc_kana . $s; | |
675 } | |
676 | |
677 sub z2h_euc { | |
678 local(*s, $n) = @_; | |
679 &init_z2h_euc unless defined %z2h_euc; | |
680 $s =~ s/($re_euc_c|$re_euc_kana)/ | |
681 $z2h_euc{$1} ? ($n++, $z2h_euc{$1}) : $1 | |
682 /geo; | |
683 $n; | |
684 } | |
685 | |
686 sub z2h_sjis { | |
687 local(*s, $n) = @_; | |
688 &init_z2h_sjis unless defined %z2h_sjis; | |
689 $s =~ s/($re_sjis_c)/$z2h_sjis{$1} ? ($n++, $z2h_sjis{$1}) : $1/geo; | |
690 $n; | |
691 } | |
692 | |
693 ;# | |
694 ;# Initializing JIS X0208 to X0201 KANA table for EUC and SJIS. This | |
695 ;# can be done in &init but it's not worth doing. Similarly, | |
696 ;# precalculated table is not worth to occupy the file space and | |
697 ;# reduce the readability. The author personnaly discourages to use | |
698 ;# X0201 Kana character in the any situation. | |
699 ;# | |
700 sub init_z2h_euc { | |
701 local($k, $s); | |
702 while (($k, $s) = each %z2h) { | |
703 $s =~ s/([\241-\337])/\216$1/g && ($z2h_euc{$k} = $s); | |
704 } | |
705 } | |
706 sub init_z2h_sjis { | |
707 local($s, $v); | |
708 while (($s, $v) = each %z2h) { | |
709 $s =~ /[\200-\377]/ && ($z2h_sjis{&e2s($s)} = $v); | |
710 } | |
711 } | |
712 | |
713 ;# | |
714 ;# TR function for 2-byte code | |
715 ;# | |
716 sub tr { | |
717 # $prev_from, $prev_to, %table are persistent variables | |
718 local(*s, $from, $to, $opt) = @_; | |
719 local(@from, @to); | |
720 local($jis, $n) = (0, 0); | |
721 | |
722 $jis++, &jis2euc(*s) if $s =~ /$re_jp|$re_asc|$re_kana/o; | |
723 $jis++ if $to =~ /$re_jp|$re_asc|$re_kana/o; | |
724 | |
725 if (!defined($prev_from) || $from ne $prev_from || $to ne $prev_to) { | |
726 ($prev_from, $prev_to) = ($from, $to); | |
727 undef %table; | |
728 &_maketable; | |
729 } | |
730 | |
731 $s =~ s/([\200-\377][\000-\377]|[\000-\377])/ | |
732 defined($table{$1}) && ++$n ? $table{$1} : $1 | |
733 /ge; | |
734 | |
735 &euc2jis(*s) if $jis; | |
736 | |
737 $n; | |
738 } | |
739 | |
740 sub _maketable { | |
741 local($ascii) = '(\\\\[\\-\\\\]|[\0-\133\135-\177])'; | |
742 | |
743 &jis2euc(*to) if $to =~ /$re_jp|$re_asc|$re_kana/o; | |
744 &jis2euc(*from) if $from =~ /$re_jp|$re_asc|$re_kana/o; | |
745 | |
746 grep(s/(([\200-\377])[\200-\377]-\2[\200-\377])/&_expnd2($1)/ge, | |
747 $from, $to); | |
748 grep(s/($ascii-$ascii)/&_expnd1($1)/geo, | |
749 $from, $to); | |
750 | |
751 @to = $to =~ /[\200-\377][\000-\377]|[\000-\377]/g; | |
752 @from = $from =~ /[\200-\377][\000-\377]|[\000-\377]/g; | |
753 push(@to, ($opt =~ /d/ ? '' : $to[$#to]) x (@from - @to)) if @to < @from; | |
754 @table{@from} = @to; | |
755 } | |
756 | |
757 sub _expnd1 { | |
758 local($s) = @_; | |
759 $s =~ s/\\(.)/$1/g; | |
760 local($c1, $c2) = unpack('CxC', $s); | |
761 if ($c1 <= $c2) { | |
762 for ($s = ''; $c1 <= $c2; $c1++) { | |
763 $s .= pack('C', $c1); | |
764 } | |
765 } | |
766 $s; | |
767 } | |
768 | |
769 sub _expnd2 { | |
770 local($s) = @_; | |
771 local($c1, $c2, $c3, $c4) = unpack('CCxCC', $s); | |
772 if ($c1 == $c3 && $c2 <= $c4) { | |
773 for ($s = ''; $c2 <= $c4; $c2++) { | |
774 $s .= pack('CC', $c1, $c2); | |
775 } | |
776 } | |
777 $s; | |
778 } | |
779 | |
780 1; |