package jcode;
;######################################################################
;#
;# jcode.pl: Perl library for Japanese character code conversion
;#
;# Copyright (c) 1995-2000 Kazumasa Utashiro <utashiro@iij.ad.jp>
;# Internet Initiative Japan Inc.
;# 3-13 Kanda Nishiki-cho, Chiyoda-ku, Tokyo 101-0054, Japan
;#
;# Copyright (c) 1992,1993,1994 Kazumasa Utashiro
;# Software Research Associates, Inc.
;#
;# Use and redistribution for ANY PURPOSE are granted as long as all
;# copyright notices are retained.  Redistribution with modification
;# is allowed provided that you make your modified version obviously
;# distinguishable from the original one.  THIS SOFTWARE IS PROVIDED
;# BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES ARE
;# DISCLAIMED.
;#
;# Original version was developed under the name of srekcah@sra.co.jp
;# February 1992 and it was called kconv.pl at the beginning.  This
;# address was a pen name for group of individuals and it is no longer
;# valid.
;#
;# The latest version is available here:
;#
;#	ftp://ftp.iij.ad.jp/pub/IIJ/dist/utashiro/perl/
;#
;; $rcsid = q$Id: jcode.pl,v 2.13.3.2 2002/04/07 08:13:57 utashiro Exp $;
;#
;######################################################################
;#
;# v 2.13 Based EUC-JP Limited Edition.
;#
;# PERL4 INTERFACE:
;#	&jcode'getcode(*line)
;#	&jcode'convert(*line)
;#	&jcode'xxx2euc(*line)
;#	$jcode'convf{'xxx'}
;#	&jcode'init()
;#
;# PERL5 INTERFACE:
;#	jcode::getcode(\$line)
;#	jcode::convert(\$line)
;#	jcode::xxx2euc(\$line)
;#	&{$jcode::convf{'xxx'}}(\$line)
;#	jcode::init()
;#
;######################################################################

&init unless defined $version;

sub init {
    $version = $rcsid =~ /,v ([\d.]+)/ ? $1 . ':eucLimitedEdition' : 'unknown';
    $convf{'jis'} = *jis2euc;
    $convf{'euc'} = *euc2euc;
    $convf{'sjis'} = *sjis2euc;
}

sub getcode {
    local(*s) = @_;
    local($matched, $code);

    if ($s !~ /[\e\200-\377]/) {	# not Japanese
	$matched = 0;
	$code = undef;
    }					# 'jis'
    elsif ($s =~ /\e\$\@|\e\$B|\e&\@\e\$B|\e\$\(D|\e\([BJ]|\e\(I/o) {
	$matched = 1;
	$code = 'jis';
    }
    elsif ($s =~ /[\000-\006\177\377]/o) {		# 'binary'
	$matched = 0;
	$code = 'binary';
    }
    elsif ($s =~ /[\201-\215\220-\240]/) {
	$code = 'sjis';
    }
    elsif ($s =~ /\216[^\241-\337]/) {
	$code = 'sjis';
    }
    elsif ($s =~ /\217[^\241-\376]/) {
	$code = 'sjis';
    }
    elsif ($s =~ /\217[\241-\376][^\241-\376]/) {
	$code = 'sjis';
    }
    elsif ($s =~ /(^|[\000-\177])[\241-\374]((\216[\241-\374]){2})*([\000-\177]|$)/) {
	$code = 'sjis';
    }
    else {				# should be 'euc' or 'sjis'
	local($sjis, $euc) = (0, 0);

	while ($s =~ /(([\201-\237\340-\374][\100-\176\200-\374])+)/go) {
	    $sjis += length($1);
	}
	while ($s =~ /(([\241-\376][\241-\376]|\216[\241-\337]|\217[\241-\376][\241-\376])+)/go) {
	    $euc  += length($1);
	}
	$matched = &max($sjis, $euc);
	$code = ('euc', undef, 'sjis')[($sjis<=>$euc) + $[ + 1];
    }
    wantarray ? ($matched, $code) : $code;
}

sub max { $_[ $[ + ($_[ $[ ] < $_[ $[ + 1 ]) ]; }

sub convert {
    local(*s, $icode) = @_;
    return (undef, undef) unless $icode = &getcode(*s);
    return (undef, $icode) if $icode eq 'binary';
    local(*f) = $convf{$icode};
    &f(*s);
    wantarray ? (*f, $icode) : $icode;
}

sub jis2euc {
    local(*s, $n) = @_;
    $s =~ s/(\e\$\@|\e\$B|\e&\@\e\$B|\e\$\(D|\e\([BJ]|\e\(I)([^\e]*)/&_jis2euc($1,$2)/geo;
    $n;
}
sub _jis2euc {
    local($esc, $s) = @_;
    if ($esc !~ /^\e\([BJ]/o) {
	$n += $s =~ tr/\041-\176/\241-\376/;
	if ($esc =~ /^\e\(I/o) {
	    $s =~ s/([\241-\337])/\216$1/g;
	}
	elsif ($esc =~ /^\e\$\(D/o) {
	    $s =~ s/([\241-\376][\241-\376])/\217$1/g;
	}
    }
    $s;
}

sub sjis2euc {
    local(*s, $n) = @_;
    $n = $s =~ s/([\201-\237\340-\374][\100-\176\200-\374]|[\241-\337])/&s2e($1)/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);
    }
	pack('CC', $c1, $c2);
}

sub euc2euc {
    local(*s) = @_;
}

1;