package JConv;
# $Id: JConv.pm,v 1.16 2000/12/25 05:46:48 tom Exp $
################################################################

=head1 NAME

 JConv - japanese kanji converter

=cut

# $Id: JConv.pm,v 1.16 2000/12/25 05:46:48 tom Exp $
################################################################

use Exporter;
use strict qw(vars);
use vars qw(@ISA @EXPORT
	    $Mode $DefaultOutputJcode $DefaultInputJcode %CodeTable %cheat);

@ISA = qw(Exporter);
@EXPORT = qw(jconv jconv_a2i jconv_auto mkjconv SetDefaultJcode);

BEGIN{
    ### NKF.pmの利用可否の判定
    eval 'use NKF';
    unless ($@){    # NKF.pm がある
	$Mode = "NKF";
	return;
    }

    ### jcode.plの利用可否の判定
    eval 'require "jcode.pl"';
    unless ($@){
	$Mode = "jcode";
	return;
    }

    # die "'NKF.pm' or 'jcode.pl' required.\n";
    $Mode = "none";
}

%CodeTable = ('jis'  => 'jis',	'iso-2022-jp' => 'jis',
	      'euc'  => 'euc',	'ujis' => 'euc',
	      'sjis' => 'sjis', 'shift_jis' => 'sjis',
	      'us-ascii' => 'us-ascii',
	      );

$DefaultOutputJcode = 'euc';
$DefaultInputJcode   = 'auto';
%cheat = ();

sub mkjconv(;$$);

### 入力を、$System::InputJcodeと仮定して、$System::InternalJcodeかEUCコ
### ードに変換する。
### $System::InternalJcode や $System::InputJcodeを、途中で変更しても反映
### されないので注意。
sub jconv;
#*jconv = mkjconv($DefaultInputJcode, $DefaultOutputJcode);

# jconv() は、汎用関数として、auto 判定とする
*jconv = mkjconv();

sub jconv_a2i;
#*jconv_a2i = mkjconv('auto', $DefaultInputJcode);

### 引数の文字コードを自動判定して、$System::InternalJcodeかEUCコードに
### 変換する。入力文字コードが判明している場合は、Jconv::mkjconv()で得ら
### れるコードリファレンスを利用する方が速い。
### $System::InternalJcodeを途中で変更した場合に反映されないので注意。
sub jconv_auto;
#*jconv_auto = mkjconv();

### mkjconv($jcode_in, $jcode_out)
### 指定された文字コードに変換する関数へのリファレンスを返す。
### 引数が無効か省略した場合は、jconv_auto()と同じなので、特に問題がなけれ
### ば、直接 jconv_auto() を利用すること。
### 尚、生成された関数の返り値が不定という奇妙な仕様がありますが、高速化の為
### ですので、どうかご了承ください。m(__)m
sub mkjconv (;$$){
    my ($jcode_in, $jcode_out) = @_;

    ### $jcode_outが、'auto'になることはない。
    $jcode_out = namecheck($jcode_out) || $DefaultOutputJcode;
    $jcode_in  = namecheck($jcode_in)  || $DefaultInputJcode;

    ### 変換が必要なければ、何もしない関数へのリファレンスを返す。
    if (($jcode_in eq $jcode_out) or ($Mode eq 'none')
     or ($jcode_in eq 'us-ascii')) {
	return sub{};
    }
    ### 入力文字コードがus-ascii以外の場合、us-asciiへの変換は認めない。
    die "can't convert $jcode_in -> us-ascii!" if ($jcode_out eq 'us-ascii');

    ### すでに同じ引数のクロージャがあればそれを返す。
    my $opt_jconv = "${Mode}\:${jcode_in}2${jcode_out}";
    my $rc_jconv = $cheat{$opt_jconv};
    if (defined($rc_jconv) and (ref($rc_jconv) eq 'CODE')) {
	return $rc_jconv;
    }

    if ($Mode eq 'NKF') {
	my %opt_in  = ('jis'=>'J', 'euc'=>'E', 'sjis'=>'S', 'auto'=> '');
	my %opt_out = ('jis'=>'j', 'euc'=>'e', 'sjis'=>'s');
	my $opt = "-$opt_out{$jcode_out}$opt_in{$jcode_in}m0";    # m0 で iso-2022-jp?= を変換しないように
	### この行かなり不安。文字列をそのまま返すのは論外だが、1でいいのか？(^^;)
    
	#$rc_jconv = sub {${$_[0]} = nkf($opt, ${$_[0]});1;}; # perl-mode がおかしくなるので変更しました    
	$rc_jconv = sub {my $r_text = shift; $$r_text = nkf($opt, $$r_text);1;};
    } elsif ($Mode eq 'jcode') {
	# print "content-type: text/html\n\n";
        if ($jcode_in eq 'auto') {
	    ### クロージャの生成。$jcode_optは、このブロックを抜けた後でも、クロージャの中
	    ### で、値を保持し続ける。
	    my $jcode_opt = $jcode_out;
            #$rc_jconv = sub {jcode::convert($_[0], $jcode_opt);};
            $rc_jconv = sub {
	      #jcode::convert($_[0], $jcode_opt);
#		my $r_text = shift;
		&jcode::convert($_[0], $jcode_opt);
#		print "t:$$r_text, ";
	    };
	    
	} else {
	    ### %jcode::convfはPerl4との互換の為に型グロブを保持しているので、そのまま代入
	    ### すると、*jconv_html = Jconv::mkjconv('euc', 'jis');で、$jconv_htmlが破壊さ
	    ### れてしまう。そこで、\&{}で括ってコードリファレンスのみを返している。
	    #print "$jcode_in, $jcode_out";
	    $rc_jconv = \&{$jcode::convf{$jcode_in, $jcode_out}};
	}
    } else {
    ### $Mode が 'none' の場合はここまで落ちないので、安らかに死んでください。(ぉ
	die "Mode:$Mode can't use.";
    }
    $cheat{$opt_jconv} = $rc_jconv;
    return $rc_jconv;
}

#引数の文字列をチェックして、Jconv.pm内で有効な文字コード名を返す。
#無効な場合は空文字列を返す。
sub namecheck ($) {
    my ($name) = @_;
    return '' unless defined($name);
    $name = lc($name);
    if (exists($CodeTable{$name})) {
	return $CodeTable{$name};
    } else {
	return '';
    }
}

#
sub SetDefaultJcode($$)
{
    my ($in, $out) = @_;

    $DefaultInputJcode = $in;
    $DefaultOutputJcode = $out;

    *jconv = mkjconv($in, $out);
    *jconv_a2i = mkjconv('auto', $in);
}
################################################################
sub GetCharset($)
{
    my $code = shift;
    
    my $default = "us-ascii";
    my %table = (euc=>'EUC-JP',
		 sjis=>'Shift_JIS',
		 jis=>'ISO-2022-JP');
    return $table{$code} || $default;
}
1;
