package chkjis;
use strict;
#---------------------------------------------------------------------
# 機種依存文字フィルター・ライブラリ
#   JIS X 0208:1997 外の文字を下駄文字「〓」に変換
#   Copyright(C) 2002 MORIYAMA Masayuki (森山 将之)
#
# 再配布について
#   このライブラリを利用したアプリケーションを書かれた場合には、この
#   ライブラリそのものを添付していただいて構いません。
#   改造版の再配布については、ファイル名を変更して配布するようにして
#   ください。
#
# 無保証
#   このプログラムを使用することにより生じた損害については、作者はい
#   かなる理由においても責任を負いません。使用される方の責任において
#   お使いください。 
#
# ※注意点
#   &chkjis::filter(\$line, 'jis'); # (ISO-2022-JP)
#     ・2バイトコード文字列中に [\x80-\xFF] のコードが混じっている
#       と、それ以降の文字列を変換しません。
#     ・変換対象の文字集合は JIS X 0208 に限定され、JIS X 0213 や 
#       JIS X 0212 に関しては何も処理を行いません。
#     ・JIS X 0208 への切替を示すエスケープシーケンス ESC $ @ と 
#       ESC $ B そして ESC & @ ESC $ B の厳密な区別は行っていませ
#       ん。
# 
#   &chkjis::filter(\$line, 'euc'); # (EUC-JP)
#     ・文字列中に [\xA0\xFF] のコードが混じっているとそれ以降の文
#       字列を変換しません。
#     ・変換対象の文字集合は JIS X 0208 に限定され、JIS X 0212 に関
#       何も処理を行いません。
# 
#   &chkjis::filter(\$line, 'sjis'); # (Shift_JIS)
#     ・文字列中に 
#       [\x80\xA0\xFD-\xFF]|[\x81-\x9F\xE0-\xFC][\x00-\x3F\x7F\xFD-\xFF]
#       のコードが混じっていると、それ以降の文字を変換しません。
# 
#   - 変換打ち切りの動作で euc と sjis に関しては $euc, $sjis の正
#     規表現を変更する事で緩和する事は可能です。jis の動作に関して
#     は、エンスケープシーケンスの処理が絡むので、$jis の変更だけ
#     ではうまくいかないと思われます。
# 
#   文字コード指定について
#     chkjis.pl では、判定は行っていませんので、正しく文字コードを
#     指定する必要があります。
#     文字コードの指定がなかった場合は変換は行われません。
# 
#   JIS X 0208:1997 未定義領域のデータの信頼性について
#     一応チェックはしてありますが、正しい事を保証はいたしません。
#     もし間違い等を見つけましたらご連絡ください。
#---------------------------------------------------------------------
# 履歴
#   Version 0.17
#     2002/10/23 仮公開
#   Version 0.18
#     2002/10/23 get_version() 廃止 (Perl5 形式で our を使えばパッケー
#                の外から $chkjis::version を参照できると判ったため)
#---------------------------------------------------------------------

our $version = '0.18';

my $f_strict     = 0;
my $f_useG1kana  = 0;

my $geta_jis     = "\x22\x2E";
my $geta_euc     = "\xA2\xAE";
my $geta_sjis    = "\x81\xAC";

my $re_x0208     =  q{\e\$[\@B]};
my $re_x0212     =  q{\e\$\(D};
my $re_x0213     =  q{\e\$\([OP]};
my $re_asc       =  q{\e\([BJ]};
my $re_kana      =  q{\e\(I};
my $re_k7        =  q{\x21-\x5F};
my $re_k8        =  q{\xA1-\xDF};
my $re_jis_esc   = qq{$re_asc|$re_kana|$re_x0208|$re_x0212|$re_x0213};

my $esc_asc      = "\e(J";
my $esc_kana     = "\e(I";
my $SO           = "\x0E";
my $SI           = "\x0F";

# 7ビットJIS にマッチ
my $jis =
	   '[\x00-\x20\x7F]'
	. '|[\x21-\x7E][\x21-\x7E]';

# 7ビットJIS で JIS X 0208:1997 未定義領域(区単位)
my $undef_j = '[\x29-\x2F\x75-\x7E][\x21-\x7E]';

# 7ビットJIS で JIS X 0208:1997 未定義領域(厳密)
my $undef_j_strict =
	   '[\x29-\x2F\x75-\x7E][\x21-\x7E]'
	. '|\x22[\x2F-\x39\x42-\x49\x51-\x5B\x6B-\x71\x7A-\x7D]'
	. '|\x23[\x21-\x2F\x3A-\x40\x5B-\x60\x7B-\x7E]'
	. '|\x24[\x74-\x7E]'
	. '|\x25[\x77-\x7E]'
	. '|\x26[\x39-\x40\x59-\x7E]'
	. '|\x27[\x42-\x50\x72-\x7E]'
	. '|\x28[\x41-\x7E]'
	. '|\x4F[\x54-\x7E]'
	. '|\x74[\x27-\x7E]';

# EUC-JP にマッチ
my $euc =
	   '[\x00-\x7F]'
	. '|[\x8E\xA1-\xFE][\xA1-\xFE]'
	. '|\x8F[\xA1-\xFE][\xA1-\xFE]';

# EUC-JP で JIS X 0208:1997 未定義領域(区単位)
my $undef_e ='[\xA9-\xAF\xF5-\xFE][\xA1-\xFE]';

# EUC-JP で JIS X 0208:1997 未定義領域(厳密)
my $undef_e_strict = 
	   '[\xA9-\xAF\xF5-\xFE][\xA1-\xFE]'
	. '|\xA2[\xAF-\xB9\xC2-\xC9\xD1-\xDB\xEB-\xF1\xFA-\xFD]'
	. '|\xA3[\xA1-\xAF\xBA-\xC0\xDB-\xE0\xFB-\xFE]'
	. '|\xA4[\xF4-\xFE]'
	. '|\xA5[\xF7-\xFE]'
	. '|\xA6[\xB9-\xC0\xD9-\xFE]'
	. '|\xA7[\xC2-\xD0\xF2-\xFE]'
	. '|\xA8[\xC1-\xFE]'
	. '|\xCF[\xD4-\xFE]'
	. '|\xF4[\xA7-\xFE]';

# シフトJIS にマッチ
my $sjis =
	   '[\x00-\x7F\xA1-\xDF]'
	. '|[\x81-\x9F\xE0-\xFC][\x40-\x7E\x80-\xFC]';

# シフトJIS で JIS X 0208:1997 未定義領域(区単位)
my $undef_s =
	   '[\x85-\x87\xEB-\xFC][\x40-\x7E\x80-\xFC]'
	. '|\x88[\x40-\x7E\x80-\x9E]';

# シフトJIS で JIS X 0208:1997 未定義領域(厳密)
my $undef_s_strict =
	   '[\x85-\x87\xEB-\xFC][\x40-\x7E\x80-\xFC]'
	. '|\x81[\xAD-\xB7\xC0-\xC7\xCF-\xD9\xE9-\xEF\xF8-\xFB]'
	. '|\x82[\x40-\x4E\x59-\x5F\x7A-\x7E\x80\x9B-\x9E\xF2-\xFC]'
	. '|\x83[\x97-\x9E\xB7-\xBE\xD7-\xFC]'
	. '|\x84[\x61-\x6F\x92-\x9E\xBF-\xFC]'
	. '|\x88[\x40-\x7E\x80-\x9E]'
	. '|\x98[\x73-\x7E\x80-\x9E]'
	. '|\xEA[\xA5-\xFC]';

sub filter {
	my ($s, $code) = @_;
	my  $m;

	if    ($code eq 'sjis') { $m = &filter_sjis($s); }
	elsif ($code eq 'euc')  { $m = &filter_euc($s);  }
	elsif ($code eq 'jis')  { $m = &filter_jis($s);  }
	$m;
}

sub filter_jis {
	my ($s) = @_;
	my ($k, $m) = (0, 0);

	if ($f_useG1kana) {
		if (index($$s, $SO) > -1) {
			$k = $$s =~ s/$SO([$re_k7]*)$SI/$esc_kana$1$esc_asc/go;
			$$s =~ s/$re_kana$re_asc//go if $k;
		}
		$k += $$s =~ s/([$re_k8]+)/$esc_kana.chr(ord($1)-0x80).$esc_asc/geo;
		$$s =~ s/$re_asc($re_x0208)/$1/go if $k;
	}
	$$s =~ s/($re_x0208)([^\e]*)/&_filter_jis($1, $2, \$m)/geo;
	$m;
}

sub _filter_jis {
	my ($esc, $t, $rm) = @_;

	if ($f_strict) {
		$$rm += $t =~ s/\G((?:$jis)*?)(?:$undef_j_strict)/$1$geta_jis/go;
	} else {
		$$rm += $t =~ s/\G((?:$jis)*?)(?:$undef_j)/$1$geta_jis/go;
	}
	$esc . $t;
}

sub _del_esc {
	my ($t) = @_;

	$t =~ s/$re_jis_esc//go;
	$t;
}

sub filter_euc {
	my ($s) = @_;
	my  $m;

	if ($f_strict) {
		$m = $$s =~ s/\G((?:$euc)*?)(?:$undef_e_strict)/$1$geta_euc/go;
	} else {
		$m = $$s =~ s/\G((?:$euc)*?)(?:$undef_e)/$1$geta_euc/go;
	}
	$m;
}

sub filter_sjis {
	my ($s) = @_;
	my  $m;

	if ($f_strict) {
		$m = $$s =~ s/\G((?:$sjis)*?)(?:$undef_s_strict)/$1$geta_sjis/go;
	} else {
		$m = $$s =~ s/\G((?:$sjis)*?)(?:$undef_s)/$1$geta_sjis/go;
	}
	$m;
}

# オプション設定

sub ascii_esc {
	$esc_asc = shift || $esc_asc;
	$esc_asc = "\e\($esc_asc" if length($esc_asc) == 1;
}

sub strict      { $f_strict = 1;    }
sub nostrict    { $f_strict = 0;    }
sub useG1kana   { $f_useG1kana = 1; }
sub nouseG1kana { $f_useG1kana = 0; }
1;