package jcode;
;######################################################################
;#
;# jcode.pl: Perl library for Japanese character code conversion
;#
;# Copyright (c) 1995,1996 Kazumasa Utashiro <utashiro@iij.ad.jp>
;# Internet Initiative Japan Inc.
;# 1-4 Sanban-cho, Chiyoda-ku, Tokyo 102, Japan
;#
;# Copyright (c) 1992,1993,1994 Kazumasa Utashiro
;# Software Research Associates, Inc.
;# Original by srekcah@sra.co.jp, Feb 1992
;#
;# Redistribution for any purpose, without significant modification,
;# is granted as long as all copyright notices are retained.  THIS
;# SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
;# IMPLIED WARRANTIES ARE DISCLAIMED.
;#
;; $rcsid = q$Id: jcode.pl,v 2.0 1996/10/02 16:02:38 utashiro Rel $;
;#
;######################################################################
;#注意！！
;#このjcodeELE.plは、チャットスクリプト　ゆいぼっと専用に利用するために、
;#余分な機能を削除した、機能限定版(Limited Edition)です。
;#不要なサブルーチンの削除と、それにともなう一部のルーチンの修正だけしています。
;#オリジナルのjcode.plは、多機能かつ汎用性に優れているものです。
;#ちなみに、この限定jcodeELE.plは、
;#&jcode'convert(*value,'euc');#通常のeucへの変換
;#のみ可能です。sjis変換機能はありません。
;#他のCGIスクリプトで上記の機能しか使わないのなら、jcodeELE.plでも大丈夫でしょう。
;#でも...jcodeELE.plを御利用のさいには、かならずオリジナルのjcode.pl-2.0も入手しておいてください。
;#ftp://ftp.iij.ad.jp/pub/published/oreilly/nutshell/ujip/perl/です。
;#1997年9月18日 
;# 改変責任者　Suzuki Yui <E-mail:yui@cup.com>
;######################################################################
&init unless defined $version;
sub init {
    $version = $rcsid =~ /,v ([\d.]+)/ ? $1 : 'unkown';
    $re_bin  = '[\000-\006\177\377]';
    $re_jp   = '\e\$[\@B]';
    $re_asc  = '\e\([BJ]';
    $re_kana = '\e\(I';
    ($esc_jp, $esc_asc, $esc_kana) = ("\e\$B", "\e(B", "\e(I");
    $re_sjis_c = '[\201-\237\340-\374][\100-\176\200-\374]';
    $re_sjis_kana = '[\241-\337]';
    $re_euc_c = '[\241-\376][\241-\376]';
    $re_euc_kana = '\216[\241-\337]';
    $re_euc_s = "($re_euc_c)+";
    $re_sjis_s = "($re_sjis_c)+";
    $cache = 1;
    $_ = '';
	$convf{'jis', 'euc'} = *jis2euc;
	$convf{'sjis', 'euc'} = *sjis2euc;
	$convf{'euc', 'euc'} = *euc2euc;
}
sub getcode {
    local(*_) = @_;
    return undef unless /[\e\200-\377]/;
    return 'jis' if /$re_jp|$re_asc|$re_kana/o;
    return 'binary' if /$re_bin/o;

    local($sjis, $euc);
    $sjis += length($&) while /($re_sjis_c)+/go;
    $euc  += length($&) while /($re_euc_c)+/go;
    (&max($sjis, $euc), ('euc', undef, 'sjis')[($sjis<=>$euc) + $[ + 1]);
}
sub max { $_[ $[ + ($_[$[] < $_[$[+1]) ]; }
sub convert {
    local(*_, $ocode, $icode) = @_;
    return (undef, undef) unless $icode = $icode || &getcode(*_);
    return (undef, $icode) if $icode eq 'binary';
    local(*convf) = $convf{$icode, $ocode};
    do convf(*_);
    (*convf, $icode);
}
sub jis2euc {
    local(*_, $n) = @_;
    s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2euc($1,$2)/geo;
    $n;
}
sub _jis2euc {
    local($esc, $_) = @_;
    if ($esc !~ /$re_asc/o) {
	$n += tr/\041-\176/\241-\376/;
	s/[\241-\337]/\216$&/g if $esc =~ /$re_kana/o;
    }
    $_;
}
sub sjis2euc {
    local(*_, $n) = @_;
    $n = s/$re_sjis_kana|$re_sjis_c/$s2e{$&}||&s2e($&)/geo;
    $n;
}
sub s2e {
    local($c1, $c2, $code);
    ($c1, $c2) = unpack('CC', $code = shift);
    if (0xa1 <= $c1 && $c1 <= 0xdf) {
	$c2 = $c1;
	$c1 = 0x8e;
    } elsif (0x9f <= $c2) {
	$c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe0 : 0x60);
	$c2 += 2;
    } else {
	$c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe1 : 0x61);
	$c2 += 0x60 + ($c2 < 0x7f);
    }
    if ($cache) {
	$s2e{$code} = pack('CC', $c1, $c2);
    } else {
	pack('CC', $c1, $c2);
    }
}
sub euc2euc {
    local(*_) = @_;
}
1;