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

&init unless defined $version;

sub init {
    $version = $rcsid =~ /,v ([\d.]+)/ ? $1 . ':sjisLimitedEdition' : 'unknown';
    $convf{'jis'} = *jis2sjis;
    $convf{'euc'} = *euc2sjis;
    $convf{'sjis'} = *sjis2sjis;
}

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 jis2sjis {
    local(*s, $n) = @_;
    $s =~ s/(\e\$\@|\e\$B|\e&\@\e\$B|\e\$\(D|\e\([BJ]|\e\(I)([^\e]*)/&_jis2sjis($1,$2)/geo;
    $n;
}

sub _jis2sjis {
    local($esc, $s) = @_;
    if ($esc =~ /^\e\$\(D/o) {
	$s =~ s/../\x81\xac/g;
	$n = length;
    }
    elsif ($esc !~ /^\e\([BJ]/o) {
	$n += $s =~ tr/\041-\176/\241-\376/;
	if ($esc =~ /^\e\$\@|\e\$B|\e&\@\e\$B|\e\$\(D/o) {
	    $s =~ s/([\241-\376][\241-\376])/&e2s($1)/geo;
	}
    }
    $s;
}

sub euc2sjis {
    local(*s, $n) = @_;
    $n = $s =~ s/([\241-\376][\241-\376]|\216[\241-\337]|\217[\241-\376][\241-\376])/&e2s($1)/geo;
}

sub e2s {
    local($c1, $c2, $code);
    ($c1, $c2) = unpack('CC', $code = shift);
    if ($c1 == 0x8e) {		# SS2
	return substr($code, 1, 1);
    } elsif ($c1 == 0x8f) {	# SS3
	return "\x81\xac";
    } elsif ($c1 % 2) {
	$c1 = ($c1>>1) + ($c1 < 0xdf ? 0x31 : 0x71);
	$c2 -= 0x60 + ($c2 < 0xe0);
    } else {
	$c1 = ($c1>>1) + ($c1 < 0xdf ? 0x30 : 0x70);
	$c2 -= 2;
    }
	pack('CC', $c1, $c2);
}

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

1;