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 ISO-2022-JP Limited Edition.
;#
;# PERL4 INTERFACE:
;#
;#	&jcode'getcode(*line)
;#	&jcode'convert(*line)
;#	&jcode'xxx2jis(*line)
;#	$jcode'convf{'xxx'}
;#	&jcode'init()
;#
;# PERL5 INTERFACE:
;#	jcode::getcode(\$line)
;#	jcode::convert(\$line)
;#	jcode::xxx2jis(\$line)
;#	&{$jcode::convf{'xxx'}}(\$line)
;#	jcode::init()
;#
;######################################################################

&init unless defined $version;

sub init {
    $version = $rcsid =~ /,v ([\d.]+)/ ? $1 . ':jisLimitedEdition' : 'unknown';
    $convf{'jis'} = *jis2jis;
    $convf{'euc'} = *euc2jis;
    $convf{'sjis'} = *sjis2jis;
}

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 sjis2jis {
    local(*s, $n) = @_;
    $s =~ s/(([\201-\237\340-\374][\100-\176\200-\374]|[\241-\337])+)/&_sjis2jis($1) . "\e(B"/geo;
    $n;
}

sub _sjis2jis {
    local($s) = shift;
    $s =~ s/(([\201-\237\340-\374][\100-\176\200-\374])+|([\241-\337])+)/&__sjis2jis($1)/geo;
    $s;
}

sub __sjis2jis {
    local($s) = shift;
    if ($s =~ /^[\241-\337]/o) {
	$n += $s =~ tr/\241-\337/\041-\137/;
	"\e(I" . $s;
    } else {
	$n += $s =~ s/([\201-\237\340-\374][\100-\176\200-\374])/&s2e($1)/geo;
	$s =~ tr/\241-\376/\041-\176/;
	"\e\$B" . $s;
    }
}

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 euc2jis {
    local(*s, $n) = @_;
    $s =~ s/(([\241-\376][\241-\376]|\216[\241-\337]|\217[\241-\376][\241-\376])+)/&_euc2jis($1) . "\e(B"/geo;
    $n;
}

sub _euc2jis {
    local($s) = shift;
    $s =~ s/(([\241-\376][\241-\376])+|(\216[\241-\337])+|(\217[\241-\376][\241-\376])+)/&__euc2jis($1)/geo;
    $s;
}

sub __euc2jis {
    local($s) = shift;
    local($esc);

    if ($s =~ tr/\216//d) {
	$esc = "\e(I";
    } elsif ($s =~ tr/\217//d) {
	$esc = "\e\$(D";
    } else {
	$esc = "\e\$B";
    }

    $n += $s =~ tr/\241-\376/\041-\176/;
    $esc . $s;
}

sub jis2jis {
    local(*s) = @_;
    $s =~ s/\e\$\@|\e\$B|\e&\@\e\$B/\e\$B/go;
    $s =~ s/\e\([BJ]/\e(B/go;
}

1;