#!/usr/bin/perl

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 2000/09/29 16:10:05 utashiro Exp $;
;#
;######################################################################
;#
;# PERL4 INTERFACE:
;#
;#	&jcode'getcode(*line)
;#		Return 'jis', 'sjis', 'euc' or undef according to
;#		Japanese character code in $line.  Return 'binary' if
;#		the data has non-character code.
;#
;#		When evaluated in array context, it returns a list
;#		contains two items.  First value is the number of
;#		characters which matched to the expected code, and
;#		second value is the code name.  It is useful if and
;#		only if the number is not 0 and the code is undef;
;#		that case means it couldn't tell 'euc' or 'sjis'
;#		because the evaluation score was exactly same.  This
;#		interface is too tricky, though.
;#
;#		Code detection between euc and sjis is very difficult
;#		or sometimes impossible or even lead to wrong result
;#		when it includes JIS X0201 KANA characters.  So JIS
;#		X0201 KANA is ignored for automatic code detection.
;#
;#	&jcode'convert(*line, $ocode [, $icode [, $option]])
;#		Convert the contents of $line to the specified
;#		Japanese code given in the second argument $ocode.
;#		$ocode can be any of "jis", "sjis" or "euc", or use
;#		"noconv" when you don't want the code conversion.
;#		Input code is recognized automatically from the line
;#		itself when $icode is not supplied (JIS X0201 KANA is
;#		ignored in code detection.  See the above descripton
;#		of &getcode).  $icode also can be specified, but
;#		xxx2yyy routine is more efficient when both codes are
;#		known.
;#
;#		It returns the code of input string in scalar context,
;#		and a list of pointer of convert subroutine and the
;#		input code in array context.
;#
;#		Japanese character code JIS X0201, X0208, X0212 and
;#		ASCII code are supported.  X0212 characters can not be
;#		represented in SJIS and they will be replased by
;#		"geta" character when converted to SJIS.
;#
;#		See next paragraph for $option parameter.
;#
;#	&jcode'xxx2yyy(*line [, $option])
;#		Convert the Japanese code from xxx to yyy.  String xxx
;#		and yyy are any convination from "jis", "euc" or
;#		"sjis".  They return *approximate* number of converted
;#		bytes.  So return value 0 means the line was not
;#		converted at all.
;#
;#		Optional parameter $option is used to specify optional
;#		conversion method.  String "z" is for JIS X0201 KANA
;#		to X0208 KANA, and "h" is for reverse.
;#
;#	$jcode'convf{'xxx', 'yyy'}
;#		The value of this associative array is pointer to the
;#		subroutine jcode'xxx2yyy().
;#
;#	&jcode'to($ocode, $line [, $icode [, $option]])
;#	&jcode'jis($line [, $icode [, $option]])
;#	&jcode'euc($line [, $icode [, $option]])
;#	&jcode'sjis($line [, $icode [, $option]])
;#		These functions are prepared for easy use of
;#		call/return-by-value interface.  You can use these
;#		funcitons in s///e operation or any other place for
;#		convenience.
;#
;#	&jcode'jis_inout($in, $out)
;#		Set or inquire JIS start and end sequences.  Default
;#		is "ESC-$-B" and "ESC-(-B".  If you supplied only one
;#		character, "ESC-$" or "ESC-(" is prepended for each
;#		character respectively.  Acutually "ESC-(-B" is not a
;#		sequence to end JIS code but a sequence to start ASCII
;#		code set.  So `in' and `out' are somewhat misleading.
;#
;#	&jcode'get_inout($string)
;#		Get JIS start and end sequences from $string.
;#
;#	&jcode'cache()
;#	&jcode'nocache()
;#	&jcode'flush()
;#		Usually, converted character is cached in memory to
;#		avoid same calculations have to be done many times.
;#		To disable this caching, call &jcode'nocache().  It
;#		can be revived by &jcode'cache() and cache is flushed
;#		by calling &jcode'flush().  &cache() and &nocache()
;#		functions return previous caching state.
;#
;#	---------------------------------------------------------------
;#
;#	&jcode'h2z_xxx(*line)
;#		JIS X0201 KANA (so-called Hankaku-KANA) to X0208 KANA
;#		(Zenkaku-KANA) code conversion routine.  String xxx is
;#		any of "jis", "sjis" and "euc".  From the difficulty
;#		of recognizing code set from 1-byte KATAKANA string,
;#		automatic code recognition is not supported.
;#
;#	&jcode'z2h_xxx(*line)
;#		X0208 to X0201 KANA code conversion routine.  String
;#		xxx is any of "jis", "sjis" and "euc".
;#
;#	$jcode'z2hf{'xxx'}
;#	$jcode'h2zf{'xxx'}
;#		These are pointer to the corresponding function just
;#		as $jcode'convf.
;#
;#	---------------------------------------------------------------
;#
;#	&jcode'tr(*line, $from, $to [, $option])
;#		&jcode'tr emulates tr operator for 2 byte code.  Only 'd'
;#		is interpreted as an option.
;#
;#		Range operator like `A-Z' for 2 byte code is partially
;#		supported.  Code must be JIS or EUC, and first byte
;#		have to be same on first and last character.
;#
;#		CAUTION: Handling range operator is a kind of trick
;#		and it is not perfect.  So if you need to transfer `-' 
;#		character, please be sure to put it at the beginning
;#		or the end of $from and $to strings.
;#
;#	&jcode'trans($line, $from, $to [, $option)
;#		Same as &jcode'tr but accept string and return string
;#		after translation.
;#
;#	---------------------------------------------------------------
;#
;#	&jcode'init()
;#		Initialize the variables used in this package.  You
;#		don't have to call this when using jocde.pl by `do' or
;#		`require' interface.  Call it first if you embedded
;#		the jcode.pl at the end of your script.
;#
;######################################################################
;#
;# PERL5 INTERFACE:
;#
;# Current jcode.pl is written in Perl 4 but it is possible to use
;# from Perl 5 using `references'.  Fully perl5 capable version is
;# future issue.
;#
;# Since lexical variable is not a subject of typeglob, *string style
;# call doesn't work if the variable is declared as `my'.  Same thing
;# happens to special variable $_ if the perl is compiled to use
;# thread capability.  So using reference is generally recommented to
;# avoid the mysterious error.
;#
;#	jcode::getcode(\$line)
;#	jcode::convert(\$line, $ocode [, $icode [, $option]])
;#	jcode::xxx2yyy(\$line [, $option])
;#	&{$jcode::convf{'xxx', 'yyy'}}(\$line)
;#	jcode::to($ocode, $line [, $icode [, $option]])
;#	jcode::jis($line [, $icode [, $option]])
;#	jcode::euc($line [, $icode [, $option]])
;#	jcode::sjis($line [, $icode [, $option]])
;#	jcode::jis_inout($in, $out)
;#	jcode::get_inout($string)
;#	jcode::cache()
;#	jcode::nocache()
;#	jcode::flush()
;#	jcode::h2z_xxx(\$line)
;#	jcode::z2h_xxx(\$line)
;#	&{$jcode::z2hf{'xxx'}}(\$line)
;#	&{$jcode::h2zf{'xxx'}}(\$line)
;#	jcode::tr(\$line, $from, $to [, $option])
;#	jcode::trans($line, $from, $to [, $option)
;#	jcode::init()
;#
;######################################################################
;#
;# SAMPLES
;#
;# Convert any Kanji code to JIS and print each line with code name.
;#
;#	while (defined($s = <>)) {
;#	    $code = &jcode'convert(*s, 'jis');
;#	    print $code, "\t", $s;
;#	}
;#	
;# Convert all lines to JIS according to the first recognized line.
;#
;#	while (defined($s = <>)) {
;#	    print, next unless $s =~ /[\033\200-\377]/;
;#	    (*f, $icode) = &jcode'convert(*s, 'jis');
;#	    print;
;#	    defined(&f) || next;
;#	    while (<>) { &f(*s); print; }
;#	    last;
;#	}
;#
;# The safest way of JIS conversion.
;#
;#	while (defined($s = <>)) {
;#	    ($matched, $icode) = &jcode'getcode(*s);
;#	    if (@buf == 0 && $matched == 0) {
;#		print $s;
;#		next;
;#	    }
;#	    push(@buf, $s);
;#	    next unless $icode;
;#	    while (defined($s = shift(@buf))) {
;#		&jcode'convert(*s, 'jis', $icode);
;#		print $s;
;#	    }
;#	    while (defined($s = <>)) {
;#		&jcode'convert(*s, 'jis', $icode);
;#		print $s;
;#	    }
;#	    last;
;#	}
;#	print @buf if @buf;
;#		
;######################################################################

;#
;# Call initialize function if it is not called yet.  This may sound
;# strange but it makes easy to embed the jcode.pl at the end of
;# script.  Call &jcode'init at the beginning of the script in that
;# case.
;#
&init unless defined $version;

;#
;# Initialize variables.
;#
sub init {
    $version = $rcsid =~ /,v ([\d.]+)/ ? $1 : 'unknown';

    $re_bin  = '[\000-\006\177\377]';

    $re_jis0208_1978 = '\e\$\@';
    $re_jis0208_1983 = '\e\$B';
    $re_jis0208_1990 = '\e&\@\e\$B';
    $re_jis0208 = "$re_jis0208_1978|$re_jis0208_1983|$re_jis0208_1990";
    $re_jis0212 = '\e\$\(D';
    $re_jp      = "$re_jis0208|$re_jis0212";
    $re_asc     = '\e\([BJ]';
    $re_kana    = '\e\(I';

    $esc_0208 = "\e\$B";
    $esc_0212 = "\e\$(D";
    $esc_asc  = "\e(B";
    $esc_kana = "\e(I";

    $re_sjis_c    = '[\201-\237\340-\374][\100-\176\200-\374]';
    $re_sjis_kana = '[\241-\337]';

    $re_euc_c    = '[\241-\376][\241-\376]';
    $re_euc_kana = '\216[\241-\337]';
    $re_euc_0212 = '\217[\241-\376][\241-\376]';

    # Use `geta' for undefined character code
    $undef_sjis = "\x81\xac";

    $cache = 1;

    # X0201 -> X0208 KANA conversion table.  Looks weird?  Not that
    # much.  This is simply JIS text without escape sequences.
    ($h2z_high = $h2z = <<'__TABLE_END__') =~ tr/\041-\176/\241-\376/;
!	!#	$	!"	%	!&	"	!V	#	!W
^	!+	_	!,	0	!<
'	%!	(	%#	)	%%	*	%'	+	%)
,	%c	-	%e	.	%g	/	%C
1	%"	2	%$	3	%&	4	%(	5	%*
6	%+	7	%-	8	%/	9	%1	:	%3
6^	%,	7^	%.	8^	%0	9^	%2	:^	%4
;	%5	<	%7	=	%9	>	%;	?	%=
;^	%6	<^	%8	=^	%:	>^	%<	?^	%>
@	%?	A	%A	B	%D	C	%F	D	%H
@^	%@	A^	%B	B^	%E	C^	%G	D^	%I
E	%J	F	%K	G	%L	H	%M	I	%N
J	%O	K	%R	L	%U	M	%X	N	%[
J^	%P	K^	%S	L^	%V	M^	%Y	N^	%\
J_	%Q	K_	%T	L_	%W	M_	%Z	N_	%]
O	%^	P	%_	Q	%`	R	%a	S	%b
T	%d			U	%f			V	%h
W	%i	X	%j	Y	%k	Z	%l	[	%m
\	%o	]	%s	&	%r	3^	%t
__TABLE_END__
    %h2z = split(/\s+/, $h2z . $h2z_high);
    %z2h = reverse %h2z;

    $convf{'jis'  , 'jis' } = *jis2jis;
    $convf{'jis'  , 'sjis'} = *jis2sjis;
    $convf{'jis'  , 'euc' } = *jis2euc;
    $convf{'euc'  , 'jis' } = *euc2jis;
    $convf{'euc'  , 'sjis'} = *euc2sjis;
    $convf{'euc'  , 'euc' } = *euc2euc;
    $convf{'sjis' , 'jis' } = *sjis2jis;
    $convf{'sjis' , 'sjis'} = *sjis2sjis;
    $convf{'sjis' , 'euc' } = *sjis2euc;
    $h2zf{'jis' } = *h2z_jis;
    $z2hf{'jis' } = *z2h_jis;
    $h2zf{'euc' } = *h2z_euc;
    $z2hf{'euc' } = *z2h_euc;
    $h2zf{'sjis'} = *h2z_sjis;
    $z2hf{'sjis'} = *z2h_sjis;
}

;#
;# Set escape sequences which should be put before and after Japanese
;# (JIS X0208) string.
;#
sub jis_inout {
    $esc_0208 = shift || $esc_0208;
    $esc_0208 = "\e\$$esc_0208" if length($esc_0208) == 1;
    $esc_asc = shift || $esc_asc;
    $esc_asc = "\e\($esc_asc" if length($esc_asc) == 1;
    ($esc_0208, $esc_asc);
}

;#
;# Get JIS in and out sequences from the string.
;#
sub get_inout {
    local($esc_0208, $esc_asc);
    $_[$[] =~ /($re_jis0208)/o && ($esc_0208 = $1);
    $_[$[] =~ /($re_asc)/o && ($esc_asc = $1);
    ($esc_0208, $esc_asc);
}

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

    if ($s !~ /[\e\200-\377]/) {	# not Japanese
	$matched = 0;
	$code = undef;
    }					# 'jis'
    elsif ($s =~ /$re_jp|$re_asc|$re_kana/o) {
	$matched = 1;
	$code = 'jis';
    }
    elsif ($s =~ /$re_bin/o) {		# 'binary'
	$matched = 0;
	$code = 'binary';
    }
    else {				# should be 'euc' or 'sjis'
	local($sjis, $euc) = (0, 0);

	while ($s =~ /(($re_sjis_c)+)/go) {
	    $sjis += length($1);
	}
	while ($s =~ /(($re_euc_c|$re_euc_kana|$re_euc_0212)+)/go) {
	    $euc  += length($1);
	}
	$matched = &max($sjis, $euc);
	$code = ('euc', undef, 'sjis')[($sjis<=>$euc) + $[ + 1];
    }
    wantarray ? ($matched, $code) : $code;
}
sub max { $_[ $[ + ($_[ $[ ] < $_[ $[ + 1 ]) ]; }

;#
;# Convert any code to specified code.
;#
sub convert {
    local(*s, $ocode, $icode, $opt) = @_;
    return (undef, undef) unless $icode = $icode || &getcode(*s);
    return (undef, $icode) if $icode eq 'binary';
    $ocode = 'jis' unless $ocode;
    $ocode = $icode if $ocode eq 'noconv';
    local(*f) = $convf{$icode, $ocode};
    &f(*s, $opt);
    wantarray ? (*f, $icode) : $icode;
}

;#
;# Easy return-by-value interfaces.
;#
sub jis  { &to('jis',  @_); }
sub euc  { &to('euc',  @_); }
sub sjis { &to('sjis', @_); }
sub to {
    local($ocode, $s, $icode, $opt) = @_;
    &convert(*s, $ocode, $icode, $opt);
    $s;
}
sub what {
    local($s) = @_;
    &getcode(*s);
}
sub trans {
    local($s) = shift;
    &tr(*s, @_);
    $s;
}

;#
;# SJIS to JIS
;#
sub sjis2jis {
    local(*s, $opt, $n) = @_;
    &sjis2sjis(*s, $opt) if $opt;
    $s =~ s/(($re_sjis_c|$re_sjis_kana)+)/&_sjis2jis($1) . $esc_asc/geo;
    $n;
}
sub _sjis2jis {
    local($s) = shift;
    $s =~ s/(($re_sjis_c)+|($re_sjis_kana)+)/&__sjis2jis($1)/geo;
    $s;
}
sub __sjis2jis {
    local($s) = shift;
    if ($s =~ /^$re_sjis_kana/o) {
	$n += $s =~ tr/\241-\337/\041-\137/;
	$esc_kana . $s;
    } else {
	$n += $s =~ s/($re_sjis_c)/$s2e{$1}||&s2e($1)/geo;
	$s =~ tr/\241-\376/\041-\176/;
	$esc_0208 . $s;
    }
}

;#
;# EUC to JIS
;#
sub euc2jis {
    local(*s, $opt, $n) = @_;
    &euc2euc(*s, $opt) if $opt;
    $s =~ s/(($re_euc_c|$re_euc_kana|$re_euc_0212)+)/
	&_euc2jis($1) . $esc_asc
    /geo;
    $n;
}
sub _euc2jis {
    local($s) = shift;
    $s =~ s/(($re_euc_c)+|($re_euc_kana)+|($re_euc_0212)+)/&__euc2jis($1)/geo;
    $s;
}
sub __euc2jis {
    local($s) = shift;
    local($esc);

    if ($s =~ tr/\216//d) {
	$esc = $esc_kana;
    } elsif ($s =~ tr/\217//d) {
	$esc = $esc_0212;
    } else {
	$esc = $esc_0208;
    }

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

;#
;# JIS to EUC
;#
sub jis2euc {
    local(*s, $opt, $n) = @_;
    $s =~ s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2euc($1,$2)/geo;
    &euc2euc(*s, $opt) if $opt;
    $n;
}
sub _jis2euc {
    local($esc, $s) = @_;
    if ($esc !~ /^$re_asc/o) {
	$n += $s =~ tr/\041-\176/\241-\376/;
	if ($esc =~ /^$re_kana/o) {
	    $s =~ s/([\241-\337])/\216$1/g;
	}
	elsif ($esc =~ /^$re_jis0212/o) {
	    $s =~ s/([\241-\376][\241-\376])/\217$1/g;
	}
    }
    $s;
}

;#
;# JIS to SJIS
;#
sub jis2sjis {
    local(*s, $opt, $n) = @_;
    &jis2jis(*s, $opt) if $opt;
    $s =~ s/($re_jp|$re_asc|$re_kana)([^\e]*)/&_jis2sjis($1,$2)/geo;
    $n;
}
sub _jis2sjis {
    local($esc, $s) = @_;
    if ($esc =~ /^$re_jis0212/o) {
	$s =~ s/../$undef_sjis/g;
	$n = length;
    }
    elsif ($esc !~ /^$re_asc/o) {
	$n += $s =~ tr/\041-\176/\241-\376/;
	if ($esc =~ /^$re_jp/o) {
	    $s =~ s/($re_euc_c)/$e2s{$1}||&e2s($1)/geo;
	}
    }
    $s;
}

;#
;# SJIS to EUC
;#
sub sjis2euc {
    local(*s, $opt,$n) = @_;
    $n = $s =~ s/($re_sjis_c|$re_sjis_kana)/$s2e{$1}||&s2e($1)/geo;
    &euc2euc(*s, $opt) if $opt;
    $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);
    }
    if ($cache) {
	$s2e{$code} = pack('CC', $c1, $c2);
    } else {
	pack('CC', $c1, $c2);
    }
}

;#
;# EUC to SJIS
;#
sub euc2sjis {
    local(*s, $opt,$n) = @_;
    &euc2euc(*s, $opt) if $opt;
    $n = $s =~ s/($re_euc_c|$re_euc_kana|$re_euc_0212)/$e2s{$1}||&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 $undef_sjis;
    } elsif ($c1 % 2) {
	$c1 = ($c1>>1) + ($c1 < 0xdf ? 0x31 : 0x71);
	$c2 -= 0x60 + ($c2 < 0xe0);
    } else {
	$c1 = ($c1>>1) + ($c1 < 0xdf ? 0x30 : 0x70);
	$c2 -= 2;
    }
    if ($cache) {
	$e2s{$code} = pack('CC', $c1, $c2);
    } else {
	pack('CC', $c1, $c2);
    }
}

;#
;# JIS to JIS, SJIS to SJIS, EUC to EUC
;#
sub jis2jis {
    local(*s, $opt) = @_;
    $s =~ s/$re_jis0208/$esc_0208/go;
    $s =~ s/$re_asc/$esc_asc/go;
    &h2z_jis(*s) if $opt =~ /z/;
    &z2h_jis(*s) if $opt =~ /h/;
}
sub sjis2sjis {
    local(*s, $opt) = @_;
    &h2z_sjis(*s) if $opt =~ /z/;
    &z2h_sjis(*s) if $opt =~ /h/;
}
sub euc2euc {
    local(*s, $opt) = @_;
    &h2z_euc(*s) if $opt =~ /z/;
    &z2h_euc(*s) if $opt =~ /h/;
}

;#
;# Cache control functions
;#
sub cache {
    ($cache, $cache = 1)[$[];
}
sub nocache {
    ($cache, $cache = 0)[$[];
}
sub flushcache {
    undef %e2s;
    undef %s2e;
}

;#
;# X0201 -> X0208 KANA conversion routine
;#
sub h2z_jis {
    local(*s, $n) = @_;
    if ($s =~ s/$re_kana([^\e]*)/$esc_0208 . &_h2z_jis($1)/geo) {
	1 while $s =~ s/(($re_jis0208)[^\e]*)($re_jis0208)/$1/o;
    }
    $n;
}
sub _h2z_jis {
    local($s) = @_;
    $n += $s =~ s/(([\041-\137])([\136\137])?)/
	$h2z{$1} || $h2z{$2} . $h2z{$3}
    /ge;
    $s;
}

sub h2z_euc {
    local(*s) = @_;
    $s =~ s/\216([\241-\337])(\216([\336\337]))?/
	$h2z{"$1$3"} || $h2z{$1} . $h2z{$3}
    /ge;
}

sub h2z_sjis {
    local(*s, $n) = @_;
    $s =~ s/(($re_sjis_c)+)|(([\241-\337])([\336\337])?)/
	$1 || ($n++, $h2z{$3} ? $e2s{$h2z{$3}} || &e2s($h2z{$3})
			      : &e2s($h2z{$4}) . ($5 && &e2s($h2z{$5})))
    /geo;
    $n;
}

;#
;# X0208 -> X0201 KANA conversion routine
;#
sub z2h_jis {
    local(*s, $n) = @_;
    $s =~ s/($re_jis0208)([^\e]+)/&_z2h_jis($2)/geo;
    $n;
}
sub _z2h_jis {
    local($s) = @_;
    $s =~ s/((\%[!-~]|![\#\"&VW+,<])+|([^!%][!-~]|![^\#\"&VW+,<])+)/
	&__z2h_jis($1)
    /ge;
    $s;
}
sub __z2h_jis {
    local($s) = @_;
    return $esc_0208 . $s unless $s =~ /^%/ || $s =~ /^![\#\"&VW+,<]/;
    $n += length($s) / 2;
    $s =~ s/(..)/$z2h{$1}/g;
    $esc_kana . $s;
}

sub z2h_euc {
    local(*s, $n) = @_;
    &init_z2h_euc unless defined %z2h_euc;
    $s =~ s/($re_euc_c|$re_euc_kana)/
	$z2h_euc{$1} ? ($n++, $z2h_euc{$1}) : $1
    /geo;
    $n;
}

sub z2h_sjis {
    local(*s, $n) = @_;
    &init_z2h_sjis unless defined %z2h_sjis;
    $s =~ s/($re_sjis_c)/$z2h_sjis{$1} ? ($n++, $z2h_sjis{$1}) : $1/geo;
    $n;
}

;#
;# Initializing JIS X0208 to X0201 KANA table for EUC and SJIS.  This
;# can be done in &init but it's not worth doing.  Similarly,
;# precalculated table is not worth to occupy the file space and
;# reduce the readability.  The author personnaly discourages to use
;# X0201 Kana character in the any situation.
;#
sub init_z2h_euc {
    local($k, $s);
    while (($k, $s) = each %z2h) {
	$s =~ s/([\241-\337])/\216$1/g && ($z2h_euc{$k} = $s);
    }
}
sub init_z2h_sjis {
    local($s, $v);
    while (($s, $v) = each %z2h) {
	$s =~ /[\200-\377]/ && ($z2h_sjis{&e2s($s)} = $v);
    }
}

;#
;# TR function for 2-byte code
;#
sub tr {
    # $prev_from, $prev_to, %table are persistent variables
    local(*s, $from, $to, $opt) = @_;
    local(@from, @to);
    local($jis, $n) = (0, 0);
    
    $jis++, &jis2euc(*s) if $s =~ /$re_jp|$re_asc|$re_kana/o;
    $jis++ if $to =~ /$re_jp|$re_asc|$re_kana/o;

    if (!defined($prev_from) || $from ne $prev_from || $to ne $prev_to) {
	($prev_from, $prev_to) = ($from, $to);
	undef %table;
	&_maketable;
    }

    $s =~ s/([\200-\377][\000-\377]|[\000-\377])/
	defined($table{$1}) && ++$n ? $table{$1} : $1
    /ge;

    &euc2jis(*s) if $jis;

    $n;
}

sub _maketable {
    local($ascii) = '(\\\\[\\-\\\\]|[\0-\133\135-\177])';

    &jis2euc(*to) if $to =~ /$re_jp|$re_asc|$re_kana/o;
    &jis2euc(*from) if $from =~ /$re_jp|$re_asc|$re_kana/o;

    grep(s/(([\200-\377])[\200-\377]-\2[\200-\377])/&_expnd2($1)/ge,
	 $from, $to);
    grep(s/($ascii-$ascii)/&_expnd1($1)/geo,
	 $from, $to);

    @to   = $to   =~ /[\200-\377][\000-\377]|[\000-\377]/g;
    @from = $from =~ /[\200-\377][\000-\377]|[\000-\377]/g;
    push(@to, ($opt =~ /d/ ? '' : $to[$#to]) x (@from - @to)) if @to < @from;
    @table{@from} = @to;
}

sub _expnd1 {
    local($s) = @_;
    $s =~ s/\\(.)/$1/g;
    local($c1, $c2) = unpack('CxC', $s);
    if ($c1 <= $c2) {
	for ($s = ''; $c1 <= $c2; $c1++) {
	    $s .= pack('C', $c1);
	}
    }
    $s;
}

sub _expnd2 {
    local($s) = @_;
    local($c1, $c2, $c3, $c4) = unpack('CCxCC', $s);
    if ($c1 == $c3 && $c2 <= $c4) {
	for ($s = ''; $c2 <= $c4; $c2++) {
	    $s .= pack('CC', $c1, $c2);
	}
    }
    $s;
}

1;
######################## jcode end ########################

#*******************************設定項目*********************************
#$mimew = './mimew.pl';
$mailprog = '/usr/lib/sendmail';

#ファーストサーバの場合
#$mailprog = '/usr/sbin/sendmail';


#送信者名
$recepientname = '株式会社ダイナ';

#送信先メールアドレス クライアントのメールアドレスを入れる
#$mailto = 'info@daina.co.jp';
$mailto = 'info@daina.co.jp,dr@media5.co.jp';

#BCCアドレス 変更禁止
#$mailtoto = '';

# 送信前確認（YES/NO = 1/0）
$preview = 1;

# メールタイトル
$subject = 'お問い合わせ';

# 本体プログラムURL
$script = 'form.cgi';

# 確認画面テンプレート
$conf = 'conf.html';

# 一般エラー画面テンプレート
$err1 = 'error.html';

# 入力エラー画面テンプレート
$err2 = 'entry.html';

# 送信後画面テンプレート
$thx = 'thank.html';

# 送信後の形態（指定URLへ/完了メッセージ = 1/0）
$reload = 0;

# 送信後の戻り先
#  → http://から記述する
$back = 'http://www.daina.co.jp/';

# 送信は method=POST 限定（YES/NO = 1/0）
$postonly = 1;

# アラーム色
$alm_col = "#dd0000";

# ホスト取得方法（YES/NO = 1/0）
$gethostbyaddr = 0;

# 送信元へ控え (CC) を送る（YES/NO = 1/0）
$cc_mail = 1;

#★。、::。.::・'゜☆。.::・'゜★。、::。.::・'゜ 設定終了 ★。、::。.::・'゜☆。.::・'゜★。、::。.::・'゜


# フォームデコード
$ret = &decode;

# 基本処理
if (!$ret) { &error("不明な処理です"); }
elsif ($in{'mode'} eq "check") { &check; }

# POSTチェック
if ($postonly && !$postflag) { &error("不正なアクセスです"); }

# 汚染チェック
if ($in{'subject'} =~ /\r|\n/) { &error("メール件名が不正です"); }
$in{'subject'} =~ s/\@/＠/g;
$in{'subject'} =~ s/\./．/g;
$in{'subject'} =~ s/\+/＋/g;
$in{'subject'} =~ s/\-/−/g;
$in{'subject'} =~ s/\:/：/g;
$in{'subject'} =~ s/\;/；/g;
$in{'subject'} =~ s/\|/｜/g;

# メールプログラムの種類チェック
if ($mailprog =~ /blat/i) { $pgType = 2; } else { $pgType = 1; }

$copy = <<EOM;
<div align="center"></div>
EOM

# 必須入力チェック
if ($in{'required'}) {
	local(@tmp,@uniq,%seen);

	# requiredフィールドの値を必須配列に加える
	@tmp = split(/\s+/, $in{'required'});
	push(@required,@tmp);

	# 必須配列の重複要素を排除する
	foreach (@required) {
		push(@uniq,$_) unless $seen{$_}++;
	}

	# 必須項目の入力値をチェックする
	foreach (@uniq) {

		# フィールドの値が投げられてこないもの（ラジオボタン等）
		if (!defined($in{$_})) {
			$check++;
			push(@key,$_);
			push(@err,$_);

		# 入力なしの場合
		} elsif ($in{$_} eq "") {
			$check++;
			push(@err,$_);
		}
	}
}

# 入力内容マッチ
if ($in{'compare'}) {
	($compare1,$compare2) = split(/\s+/, $in{'compare'}, 2);

	if ($in{$compare1} ne $in{$compare2}) {
		&error("$compare1と$compare2の再入力内容が異なります");
	}
}

# 入力チェック確認画面
if ($check) { &err_check; }

# E-Mail書式チェック
if ($in{'e-Mail'} =~ /\,/) {
	&error("メールアドレスにコンマ ( , ) が含まれています");
}
if ($in{'e-Mail'} && $in{'e-Mail'} !~ /^[\w\.\-]+\@[\w\.\-]+\.[a-zA-Z]{2,6}$/) {
	&error("メールアドレスの書式が不正です");
}

# プレビュー
if ($preview && $in{'mode'} ne "send") {

	local($cp_flag,$flag,$cell,$tmp);
	open(IN,"$conf") || &error("Open Error: $conf");
	print "Content-type: text/html\n\n";
	while (<IN>) {
		if (/<!-- LOOPS -->/) {
			$flag=1;
		}
		if (/<!-- LOOPE -->/) {
			$flag=0;

			local($key,$bef,$tmp);

			print "<input type=hidden name=mode value=send>\n";

			foreach $key (@key) {
				next if ($bef eq $key);
				if ($key eq "required" || $key eq "compare" || $key eq "subject" || ($in{'compare'} && $key eq $compare2)) {
					print "<input type=hidden name=\"$key\" value=\"$in{$key}\">\n";
					next;
				}

				$in{$key} =~ s/\0/ /g;
				$in{$key} =~ s/\r\n/<br>/g;
				$in{$key} =~ s/\r/<br>/g;
				$in{$key} =~ s/\n/<br>/g;
				if ($in{$key} =~ /<br>$/) {
					while ($in{$key} =~ /<br>$/) {
						$in{$key} =~ s/<br>$//g;
					}
				}

				$tmp = $cell;
				$tmp =~ s/\$left/$key/;
				$tmp =~ s/\$right/$in{$key}/;

				print "$tmp\n";
				print "<input type=hidden name=\"$key\" value=\"$in{$key}\">\n";

				$bef = $key;
			}
			next;
		}
		if ($flag) {
			$cell .= $_;
			next;
		}

		s/\$script/$script/;

		if (/(<\/body([^>]*)>)/i) {
			$cp_flag=1;
			$tmp = $1;
			s/$tmp/$copy\n$tmp/;
		}

		print;
	}
	close(IN);

	if (!$cp_flag) { print "$copy\n</body></html>\n"; }

	exit;
}

# 時間・ホストを取得
($date,$dat2) = &get_time;
&get_host;

# コマンドタグで件名指定あり
if ($in{'subject'}) {
	$in{'subject'} =~ s/\|/｜/g;
	$in{'subject'} =~ s/;/；/g;
	$subject = $in{'subject'};
}

# blatj送信
if ($pgType == 2) {
	local($tmpfile,$bef,$param);

	# 一時ファイルを書き出し
	$tmpfile = "./$$\.tmp";
	open(OUT,">$tmpfile") || &error("Write Error: $tmpfile");
	print OUT "────────────────────────────\n";
	print OUT "▼$title送信内容\n";
	print OUT "────────────────────────────\n\n";

	foreach (@key) {
		next if ($_ eq "mode");
		next if ($_ eq "required");
		next if ($_ eq "compare");
		next if ($_ eq "subject");
		next if ($in{'compare'} && $_ eq $compare2);
		next if ($bef eq $_);

		$in{$_} =~ s/&lt;/</g;
		$in{$_} =~ s/&gt;/>/g;
		$in{$_} =~ s/&quot;/"/g;
		$in{$_} =~ s/&amp;/&/g;
		$in{$_} =~ s/\0/ /g;
		$in{$_} =~ s/<br>/\n/g;
		$in{$_} =~ s/\.\n/\. \n/g;

		# 添付ファイル拒否
		$in{$_} =~ s/Content-Disposition:\s*attachment;.*//ig;
		$in{$_} =~ s/Content-Transfer-Encoding:.*//ig;
		$in{$_} =~ s/Content-Type:\s*multipart\/mixed;\s*boundary=.*//ig;

		if ($in{$_} =~ /\n/) {
			print OUT "$_ = \n\n$in{$_}\n";
		} else {
			print OUT "$_ = $in{$_}\n";
		}

		$bef = $_;
	}

	print OUT "\n";
	print OUT "----------------------------------------------------------------------\n";
	print OUT "Date  : $date\n";
	print OUT "Host  : $host\n";
	print OUT "Agent : $ENV{'HTTP_USER_AGENT'}\n";
	print OUT "----------------------------------------------------------------------\n";
	close(OUT);

	# パラメータ
	$param = "$mailprog $tmpfile -t $mailto -s \"$subject\"";
	$param .= " -c $in{'e-Mail'}" if ($cc_mail && $in{'e-Mail'});

	# 送信処理
	open(MAIL,"| $param") || &error("メール送信失敗");
	close(MAIL);

	# 一時ファイル削除
	unlink($tmpfile);

# sendmail送信
} else {
	local($bef,$mbody,$email,$subject2);

	$mbody = <<EOM;
────────────────────────────
▼$title送信内容
────────────────────────────

EOM

	foreach (@key) {
		next if ($_ eq "mode");
		next if ($_ eq "required");
		next if ($_ eq "compare");
		next if ($_ eq "subject");
		next if ($in{'compare'} && $_ eq $compare2);
		next if ($bef eq $_);

		$in{$_} =~ s/&lt;/</g;
		$in{$_} =~ s/&gt;/>/g;
		$in{$_} =~ s/&quot;/\"/g;
		$in{$_} =~ s/&amp;/&/g;
		$in{$_} =~ s/\0/ /g;
		$in{$_} =~ s/<br>/\n/g;
		$in{$_} =~ s/\.\n/\. \n/g;

		# 添付ファイル拒否
		$in{$_} =~ s/Content-Disposition:\s*attachment;.*//ig;
		$in{$_} =~ s/Content-Transfer-Encoding:.*//ig;
		$in{$_} =~ s/Content-Type:\s*multipart\/mixed;\s*boundary=.*//ig;

		if ($in{$_} =~ /\n/) {
			$mbody .= "$_ = \n\n$in{$_}\n";
		} else {
			$mbody .= "$_ = $in{$_}\n";
		}
		$bef = $_;
	}

$recipientname = "$in{'お名前'}";

$confbody = <<EOM;
$recipientname様

この度は　株式会社ダイナにお問い合わせありがとうございます。
折り返しご連絡をさしあげますので、暫くお待ち下さい。

************************************
株式会社ダイナ
〒810-0001 福岡市中央区天神3-7-9
TEL：092-752-0601（代）
FAX：092-752-0624
URL：http://www.daina.co.jp/
************************************
EOM

	# メールアドレスがない場合は送信先に置き換え
	if ($in{'e-Mail'} eq "") { $email = $mailto; }
	else { $email = $in{''}; }

	# MIMEエンコード
	if (-e $mimew) {
		require $mimew;
		$subject2 = &mimeencode($subject);

		if ($in{'お名前'}) {
			$from = &mimeencode("From: \"$in{'お名前'}\" <$email>");
		} else {
			$from = "From: $email";
		}
	} else {
		$subject2 = &base64($subject);

		if ($in{'お名前'}) {
			$from = "From: " . &base64("\"$in{'お名前'}\"") . " <$email>";
		} else {
			$from = "From: $email";
		}
	}

	# sendmail起動
	open(MAIL,"| $mailprog -t -i") || &error("メール送信失敗");
	print MAIL "To: $mailto\n";
	print MAIL $from, "\n";
#	print MAIL "Cc: $email\n" if ($cc_mail && $e-Mail);
	print MAIL "Bcc: $mailtoto\n";


	print MAIL "Subject: $subject2\n";
	print MAIL "MIME-Version: 1.0\n";
	print MAIL "Content-type: text/plain; charset=ISO-2022-JP\n";
	print MAIL "Content-Transfer-Encoding: 7bit\n";
	print MAIL "Date: $dat2\n";
	print MAIL "X-Mailer: $ver\n\n";
	foreach ( split(/\n/, $mbody) ) {
		&jcode'convert(*_, 'jis' ,'sjis');
		print MAIL $_, "\n";
	}
	print MAIL "\n";
	print MAIL "----------------------------------------------------------------------\n";
	print MAIL "Date  : $date\n";
	print MAIL "Host  : $host\n";
	print MAIL "Agent : $ENV{'HTTP_USER_AGENT'}\n";
	print MAIL "----------------------------------------------------------------------\n";
	close(MAIL);

	$sndmailto = "From: " . &base64("\"$recepientname\"") . " <$mailto>";

	# sendmail起動
	open(MAIL,"| $mailprog -t -i") || &error("メール送信失敗");
	print MAIL "To: $in{'e-Mail'}\n";
	print MAIL $sndmailto, "\n";
#	print MAIL "Cc: $email\n" if ($cc_mail && $email);
	print MAIL "Subject: $subject2\n";
	print MAIL "MIME-Version: 1.0\n";
	print MAIL "Content-type: text/plain; charset=ISO-2022-JP\n";
	print MAIL "Content-Transfer-Encoding: 7bit\n";
	print MAIL "Date: $dat2\n";
	print MAIL "X-Mailer: $ver\n\n";
	foreach ( split(/\n/, $confbody) ) {
		&jcode'convert(*_, 'jis' ,'sjis');
		print MAIL $_, "\n";
	}
#	print MAIL "\n";
#	print MAIL "----------------------------------------------------------------------\n";
#	print MAIL "Date  : $date\n";
#	print MAIL "Host  : $host\n";
#	print MAIL "Agent : $ENV{'HTTP_USER_AGENT'}\n";
#	print MAIL "----------------------------------------------------------------------\n";
	close(MAIL);

}

# リロード
if ($reload) {
	if ($ENV{'PERLXS'} eq "PerlIS") {
		print "HTTP/1.0 302 Temporary Redirection\r\n";
		print "Content-type: text/html\n";
	}
	print "Location: $back\n\n";
	exit;

# 完了メッセージ
} else {

	local($cp_flag,$tmp);
	open(IN,"$thx") || &error("Open Error: $thx");
	print "Content-type: text/html\n\n";
	while (<IN>) {
		s/\$back/$back/;

		if (/(<\/body([^>]*)>)/i) {
			$cp_flag=1;
			$tmp = $1;
			s/$tmp/$copy\n$tmp/;
		}

		print;
	}
	close(IN);

	if (!$cp_flag) { print "$copy\n</body></html>\n"; }

	exit;
}

#-------------------------------------------------
#  入力チェック
#-------------------------------------------------
sub err_check {
	local($f,$bef,$err);

	local($cp_flag,$flag,$cell,$tmp);
	open(IN,"$err2") || &error("Open Error: $err2");
	print "Content-type: text/html\n\n";
	while (<IN>) {
		if (/<!-- LOOPS -->/) {
			$flag=1;
		}
		if (/<!-- LOOPE -->/) {
			$flag=0;

			local($key,$bef,$tmp);

			foreach $key (@key) {
				next if ($key eq "required");
				next if ($key eq "subject");
				next if ($key eq "compare");
				next if ($in{'compare'} && $key eq $compare2);
				next if ($_ eq "compare");
				next if ($bef eq $key);

				$tmp = $cell;
				$tmp =~ s/\$left/$key/;

				$f=0;
				foreach $err (@err) {
					if ($err eq $key) { $f++; last; }
				}
				if ($f) {
					$tmp =~ s|\$right|<span style="color:$alm_col">$keyは入力必須です</span>|;
				} else {
					$in{$key} =~ s/\r\n/<br>/g;
					$in{$key} =~ s/\r/<br>/g;
					$in{$key} =~ s/\n/<br>/g;
					$in{$key} =~ s/\0/ /g;

					$tmp =~ s/\$right/$in{$key}/;
				}

				print "$tmp\n";
				print "<input type=hidden name=\"$key\" value=\"$in{$key}\">\n";

				$bef = $key;
			}
		}
		if ($flag) {
			$cell .= $_;
			next;
		}

		if (/(<\/body([^>]*)>)/i) {
			$cp_flag=1;
			$tmp = $1;
			s/$tmp/$copy\n$tmp/;
		}

		print;
	}
	close(IN);

	if (!$cp_flag) { print "$copy\n</body></html>\n"; }

	exit;
}

#-------------------------------------------------
#  フォームデコード
#-------------------------------------------------
sub decode {
	local($key,$val,$buf);

	if ($ENV{'REQUEST_METHOD'} eq "POST") {
		$postflag=1;
		read(STDIN, $buf, $ENV{'CONTENT_LENGTH'});
	} else {
		$postflag=0;
		$buf = $ENV{'QUERY_STRING'};
	}

	undef(%in);
	@key=(); @required=(); @err=(); $check=0;
	foreach ( split(/&/, $buf) ) {
		($key, $val) = split(/=/);
		$key =~ tr/+/ /;
		$key =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("H2", $1)/eg;
		$val =~ tr/+/ /;
		$val =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("H2", $1)/eg;

		&jcode'convert(*key, 'sjis');
		&jcode'convert(*val, 'sjis');

		# タグ排除
		$key =~ s/&/&amp;/g;
		$key =~ s/"/&quot;/g;
		$key =~ s/</&lt;/g;
		$key =~ s/>/&gt;/g;
		$val =~ s/&/&amp;/g;
		$val =~ s/"/&quot;/g;
		$val =~ s/</&lt;/g;
		$val =~ s/>/&gt;/g;

		# 必須入力項目
		if ($key =~ /^_(.+)/) {
			$key = $1;
			push(@required,$key);

			if ($val eq "") { $check++; push(@err,$key); }
		}

		$in{$key} .= "\0" if (defined($in{$key}));
		$in{$key} .= $val;

		push(@key,$key);
	}

	# 返り値
	if ($buf) { return (1); } else { return (0); }
}

#-------------------------------------------------
#  エラー処理
#-------------------------------------------------
sub error {
	unlink($tmpfile) if (-e $tmpfile && $pgType == 2);

	print "Content-type: text/html\n\n";
	open(IN,"$err1");
	while (<IN>) {
		s/\$error/$_[0]/;

		print;
	}
	close(IN);

	exit;
}

#-------------------------------------------------
#  時間取得
#-------------------------------------------------
sub get_time {
	local($d1,$d2,@w,@m);

	$ENV{'TZ'} = "JST-9";
	local($sec,$min,$hour,$mday,$mon,$year,$wday) = localtime(time);
	@w = ('Sun','Mon','Tue','Wed','Thu','Fri','Sat');
	@m = ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');

	# 日時のフォーマット
	$d1 = sprintf("%04d/%02d/%02d(%s) %02d:%02d",
			$year+1900,$mon+1,$mday,$w[$wday],$hour,$min);
	$d2 = sprintf("%s, %02d %s %04d %02d:%02d:%02d",
			$w[$wday],$mday,$m[$mon],$year+1900,$hour,$min,$sec) . " +0900";

	return ($d1,$d2);
}

#-------------------------------------------------
#  ホスト名取得
#-------------------------------------------------
sub get_host {
	$host = $ENV{'REMOTE_HOST'};
	$addr = $ENV{'REMOTE_ADDR'};

	if ($gethostbyaddr && ($host eq "" || $host eq $addr)) {
		$host = gethostbyaddr(pack("C4", split(/\./, $addr)), 2);
	}
	if ($host eq "") { $host = $addr; }
}

#-------------------------------------------------
#  BASE64変換
#-------------------------------------------------
#	とほほのWWW入門で公開されているルーチンを参考にしました。
#	http://tohoho.wakusei.ne.jp/
sub base64 {
	local($sub) = @_;
	&jcode'convert(*sub, 'jis', 'sjis');

	$sub =~ s/\x1b\x28\x42/\x1b\x28\x4a/g;
	$sub = "=?iso-2022-jp?B?" . &b64enc($sub) . "?=";
	$sub;
}
sub b64enc {
	local($ch)="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";
	local($x, $y, $z, $i);
	$x = unpack("B*", $_[0]);
	for ($i=0; $y=substr($x,$i,6); $i+=6) {
		$z .= substr($ch, ord(pack("B*", "00" . $y)), 1);
		if (length($y) == 2) {
			$z .= "==";
		} elsif (length($y) == 4) {
			$z .= "=";
		}
	}
	$z;
}