1package 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 1.3 2000/03/07 07:14:12 yar-3 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 : '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
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/([\41-\137]([\136\137])?)/$h2z{$1}/g;
638    $s;
639}
640
641sub h2z_euc {
642    local(*s) = @_;
643    $s =~ s/\216([\241-\337])(\216([\336\337]))?/$h2z{"$1$3"}/g;
644}
645
646sub 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;#
657sub z2h_jis {
658    local(*s, $n) = @_;
659    $s =~ s/($re_jis0208)([^\e]+)/&_z2h_jis($2)/geo;
660    $n;
661}
662sub _z2h_jis {
663    local($s) = @_;
664    $s =~ s/((\%[!-~]|![\#\"&VW+,<])+|([^!%][!-~]|![^\#\"&VW+,<])+)/
665	&__z2h_jis($1)
666    /ge;
667    $s;
668}
669sub __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
677sub 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
686sub 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;#
700sub 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}
706sub 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;#
716sub 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
740sub _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
757sub _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
769sub _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
7801;
781