From: utashiro@sran230.sra.co.jp (Kazumasa Utashiro)
Subject: jcode.pl
Keywords: perl, Japanese, Kanji
Organization: Software Research Associates, Inc., Japan
Date: Tue, 13 Oct 1992 12:18:55 GMT
Reply-To: utashiro@sra.co.jp
Distribution: fj

jcode.pl		$BF|K\8lJ8;z%3!<%IJQ49%i%$%V%i%j(J
kconv_emulate.pl	perl-kconv $B%(%_%e%l!<%7%g%s%i%$%V%i%j(J
pkf			jcode.pl $B$r;H$C$?%5%s%W%k%W%m%0%i%`(J

$B@bL@$9$k$3$H$b$J$$$G$7$g$&!#<BAuJ}<0$d%$%s%?%U%'!<%9$J$I$K4X(J
$B$7$F%3%a%s%H$,$"$j$^$7$?$i!"1sN8$J$/$*4j$$CW$7$^$9!#(J

$B4D6-$,$J$$$N$G<+J,$G$O;n$7$F$$$^$;$s$,!"(Jjperl $B$G$OF0$+$J$$$=(J
$B$&$G$9!#(J

---
K. Utashiro

#!/bin/sh
# This is a shell archive (produced by shar 3.49)
# To extract the files from this archive, save it to a file, remove
# everything above the "!/bin/sh" line above, and type "sh file_name".
#
# made 10/13/1992 11:51 UTC by utashiro@sran230
# Source directory /auto/sras22/mnt/home/mmb/utashiro/cmd
#
# existing files will NOT be overwritten unless -c is specified
#
# This shar contains:
# length  mode       name
# ------ ---------- ------------------------------------------
#   5970 -r--r--r-- jcode.pl
#   1419 -r--r--r-- kconv_emulate.pl
#   2605 -r-xr-xr-x pkf
#
# ============= jcode.pl ==============
if test -f 'jcode.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping jcode.pl (File already exists)'
else
echo 'x - extracting jcode.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'jcode.pl' &&
package jcode;
;######################################################################
;#
;# jcode.pl: Japanese character code conversion library
;#
;# Copyright (c) 1991,1992 Software Research Associates, Inc.
;#	Original by srekcah@sra.co.jp, Feb 1992
;#
;#	Maintained by Kazumasa Utashiro <utashiro@sra.co.jp>
;#	Software Research Associates, Inc., Japan
;#
;; $rcsid = q$Id: jcode.pl,v 1.7 1992/10/13 11:48:15 utashiro Exp $;
;#
;######################################################################
;#
;# INTERFACE:
;#
;#	&jcode'getcode(*line)
;#		Return 'jis', 'sjis', 'euc' or undef according to
;#		Japanese character code in $line.
;#
;#	&jcode'convert(*line, $ocode [, $icode])
;#		Convert the line in any Japanese code to specified
;#		code in second argument $ocode.  $ocode is one of
;#		'jis', 'sjis' or 'euc'.  Input code is recognized
;#		automatically from the line itself when $icode is not
;#		supplied.  $icode also can be specified, but xxx2yyy
;#		routine is more efficient when both codes are known.
;#
;#		It returns a list of pointer of convert subroutine and
;#		input code.  It means that this routine returns the
;#		input code of the line in scalar context.
;#
;#	&jcode'xxx2yyy(*line)
;#		Convert Japanese code from xxx to yyy.  xxx and yyy
;#		are one of "jis", "sjis" or "euc".  These subroutines
;#		return number of converted substrings.  So return
;#		value 0 means the line was not converted at all.
;#
;#	&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 added as a prefix
;#		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'convf{'xxx', 'yyy'}
;#		The value of this associative array is pointer to the
;#		subroutine jcode'xxx2yyy().
;#
;######################################################################
;#
;# SAMPLES
;#
;# Convert any Kanji code to JIS and print each line with code name.
;#
;#	while (<>) {
;#	    $code = &jcode'convert(*_, 'jis');
;#	    print $code, "\t", $_;
;#	}
;#	
;# Convert all lines to JIS according to the first recognized line.
;#
;#	while (<>) {
;#	    print, next unless /[\033\200-\377]/;
;#	    (*f, $icode) = &jcode'convert(*_, 'jis');
;#	    print;
;#	    defined(&f) || next;
;#	    while (<>) { &f(*_); print; }
;#	    last;
;#	}
;#
;# The safest way for converting to JIS
;#
;#	while (<>) {
;#	    ($matched, $code) = &jcode'getcode(*_);
;#	    print, next unless (@buf || $matched);
;#	    push(@readahead, $_);
;#	    next unless $code;
;#	    eval "&jcode'${code}2jis(*_), print while (\$_ = shift(\@buf));";
;#	    eval "&jcode'${code}2jis(*_), print while (\$_ = <>);";
;#	    last;
;#	}
;#		
;######################################################################
X
($version) = ($rcsid =~ /,v ([\d.]+)/);
$re_sjis_c = '[\201-\237\340-\374][\100-\176\200-\374]';
$re_sjis_s = "($re_sjis_c)+";
$re_euc_c  = '[\241-\376][\241-\376]';
$re_euc_s  = "($re_euc_c)+";
$re_jin    = '\033\$[\@B]';
$re_jout   = '\033\([BJ]';
&jis_inout("\033\$B", "\033(B");
X
for $from ('jis', 'sjis', 'euc') {
X    for $to ('jis', 'sjis', 'euc') {
X	eval "\$convf{$from, $to} = *${from}2${to};";
X    }
}
X
;#
;# Set JIS in and out final characters.
;#
sub jis_inout {
X    $jin = shift || $jin;
X    $jout = shift || $jout;
X    $jin = "\033\$".$jin if length($jin) == 1;
X    $jout = "\033\(".$jout if length($jout) == 1;
X    ($jin, $jout);
}
X
;#
;# Character code recognition
;#
sub getcode {
X    local(*_) = @_;
X    return undef unless /[\033\200-\377]/;
X    return 'jis' if /$re_jin|$re_jout/o;
X
X    local($sjis, $euc);
X    $sjis += length($&) while /$re_sjis_s/go;
X    $euc  += length($&) while /$re_euc_s/go;
X    (&max($sjis, $euc), ('euc', undef, 'sjis')[($sjis<=>$euc) + $[ + 1]);
}
sub max { $_[ $[ + ($_[$[] < $_[$[+1]) ]; }
X
;#
;# Convert any code to specified code
;#
sub convert {
X    local(*_, $ocode, $icode) = @_;
X    return (undef, undef) unless $icode = $icode || &getcode(*_);
X    $ocode = 'jis' unless $ocode;
X    local(*convf) = $convf{$icode, $ocode};
X    do convf(*_);
X    (*convf, $icode);
}
X
;#
;# JIS to JIS
;#
sub jis2jis {
X    local(*_) = @_;
X    s/$re_jin/$jin/go;
X    s/$re_jout/$jout/go;
}
X
;#
;# SJIS to JIS
;#
sub sjis2jis {
X    local(*_) = @_;
X    s/$re_sjis_s/&_sjis2jis($&)/geo;
}
sub _sjis2jis {
X    local($_) = @_;
X    s/../$s2e{$&}||&s2e($&)/geo;
X    tr/\241-\376/\041-\176/;
X    $jin . $_ . $jout;
}
X
;#
;# EUC to JIS
;#
sub euc2jis {
X    local(*_) = @_;
X    s/$re_euc_s/&_euc2jis($&)/geo;
}
sub _euc2jis {
X    local($_) = @_;
X    tr/\241-\376/\041-\176/;
X    $jin . $_ . $jout;
}
X
;#
;# JIS to EUC
;#
sub jis2euc {
X    local(*_) = @_;
X    s/$re_jin([!-~]*)$re_jout/&_jis2euc($1)/geo;
}
sub _jis2euc {
X    local($_) = @_;
X    tr/\041-\176/\241-\376/;
X    $_;
}
X
;#
;# JIS to SJIS
;#
sub jis2sjis {
X    local(*_) = @_;
X    s/$re_jin([!-~]*)$re_jout/&_jis2sjis($1)/geo;
}
sub _jis2sjis {
X    local($_) = @_;
X    tr/\041-\176/\241-\376/;
X    s/../$e2s{$&}||&e2s($&)/ge;
X    $_;
}
X
;#
;# SJIS to EUC
;#
sub sjis2euc {
X    local(*_) = @_;
X    s/$re_sjis_c/$s2e{$&}||&s2e($&)/geo;
}
sub s2e {
X    ($c1, $c2) = unpack('CC', $code = shift);
X    if ($c2 >= 0x9f) {
X	$c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe0 : 0x60);
X	$c2 += 2;
X    } else {
X	$c1 = $c1 * 2 - ($c1 >= 0xe0 ? 0xe1 : 0x61);
X	$c2 += 0x60 + ($c2 < 0x7f);
X    }
X    $s2e{$code} = pack('CC', $c1, $c2);
}
X
;#
;# EUC to SJIS
;#
sub euc2sjis {
X    local(*_) = @_;
X    s/$re_euc_c/$e2s{$&}||&e2s($&)/geo;
}
sub e2s {
X    ($c1, $c2) = unpack('CC', $code = shift);
X    if ($c1 % 2) {
X	$c1 = ($c1>>1) + ($c1 < 0xdf ? 0x31 : 0x71);
X	$c2 -= 0x60 + ($c2 < 0xe0);
X    } else {
X	$c1 = ($c1>>1) + ($c1 < 0xdf ? 0x30 : 0x70);
X	$c2 -= 2;
X    }
X    $e2s{$code} = pack('CC', $c1, $c2);
}
X
;#
;# SJIS to SJIS, EUC to EUC
;#
sub sjis2sjis { 0; }
sub euc2euc { 0; }
X
1;
SHAR_EOF
chmod 0444 jcode.pl ||
echo 'restore of jcode.pl failed'
Wc_c="`wc -c < 'jcode.pl'`"
test 5970 -eq "$Wc_c" ||
	echo 'jcode.pl: original size 5970, current size' "$Wc_c"
fi
# ============= kconv_emulate.pl ==============
if test -f 'kconv_emulate.pl' -a X"$1" != X"-c"; then
	echo 'x - skipping kconv_emulate.pl (File already exists)'
else
echo 'x - extracting kconv_emulate.pl (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'kconv_emulate.pl' &&
package kconv_emulate;
require('jcode.pl');
;######################################################################
;#
;# kconv_emulate.pl: perl-kconv emulation routines
;#
;# Copyright (c) 1992 Kazumasa Utashiro <utashiro@sra.co.jp>
;#	Software Research Associates, Inc., Japan
;#
;# Perl-kconv is a modified version of perl made by Mr. Naoya Takao of
;# Matsushita Electric IND. CO., LTD. <ntp@isl.mei.co.jp>, which has
;# built-in functions for Japanese character code conversion.  This
;# library emulates perl-kconv's four functions &kconv, &tosjis,
;# &tojis and &toeuc by jcode.pl.
;#
;# NOTE:
;# Changing variables $_KanjiIn and $_KanjiOut doesn't effect at all.
;# Please use &jcode'jis_inout instead.
;#
;; $rcsid = q$Id: kconv_emulate.pl,v 1.2 1992/10/13 02:41:26 utashiro Exp $;
;#
;######################################################################
X
@maptable[0..3] = (undef, 'sjis', 'jis', 'euc');
X
package main;
X
($_AUTO, $_SJIS, $_JIS, $_EUC) = 0..3;
($_KanjiIn, $_KanjiOut) = (ord('@'), ord('J'));
&jcode'jis_inout('@', 'J');
X
sub kconv {
X    local($_, $out, $in) = @_;
X    $out = $_EUC unless $out;
X    &jcode'convert(*_, @kconv_emulate'maptable[$out, $in]);
X    $_;
}
X
sub tosjis {
X    local($_) = @_;
X    &jcode'convert(*_, 'sjis');
X    $_;
}
X
sub tojis {
X    local($_) = @_;
X    &jcode'convert(*_, 'jis');
X    $_;
}
X
sub toeuc {
X    local($_) = @_;
X    &jcode'convert(*_, 'euc');
X    $_;
}
X
1;
SHAR_EOF
chmod 0444 kconv_emulate.pl ||
echo 'restore of kconv_emulate.pl failed'
Wc_c="`wc -c < 'kconv_emulate.pl'`"
test 1419 -eq "$Wc_c" ||
	echo 'kconv_emulate.pl: original size 1419, current size' "$Wc_c"
fi
# ============= pkf ==============
if test -f 'pkf' -a X"$1" != X"-c"; then
	echo 'x - skipping pkf (File already exists)'
else
echo 'x - extracting pkf (Text)'
sed 's/^X//' << 'SHAR_EOF' > 'pkf' &&
#!/usr/local/bin/perl
;#
;# pkf: Perl Kanji Filter
;#
;# Copyright (c) 1991,1992 Software Research Associates, Inc.
;#	by srekcah@sra.co.jp, Febuary 1992
;#
;#	Maintained by Kazumasa Utashiro <utashiro@sra.co.jp>
;#	Software Research Associates, Inc., Japan
;#
;; $rcsid = q$Id: pkf,v 1.7 1992/10/13 05:24:59 utashiro Exp $;
;; $pkf = ('pkf', split('/', $0));
;;
;; Usage:				($usage = <<";#-") =~ s/(^|\n);#/\1/g;
;#	$pkf [option] [-[icode]ocode[in,out]] files
;#
;#	icode/ocode is one of [jse] (j=JIS, s=SJIS, e=EUC)
;#	ocode `j' can be followed by JIS in/out character
;#
;#	-b	buffered output (default)
;#	-u	unbuffered output
;#	-m	dynamic input code recognition
;#	-c	print code name
;#-
;# Input Kanji code is recognized automatically if not supplied. 
;# Usually this is done only once, but it will be done on each input
;# line when dynamic recognition is specified.
;#
;# Output Kanji code is JIS by default.
;#
;# Output JIS code can be followed by kanji in and out characters.
;# Default is "BB" which means kanji sequence start with ESC-$-B and
;# end with ESC-(-B
;#
;# Example:
;#	pkf file	convert to JIS code
;#	pkf -j@J file	convert to JIS code ("ESC-$-@", "ESC-(-J")
;#	pkf -es file	convert EUC to SJIS
;#	pkf -me file	convert mixed code file to EUC
;#	pkf -mc file	convert to JIS and print orginal code on each line
;#
require 'jcode.pl';
X
$ocode = 'jis';
%codename  = ('j', 'jis', 's', 'sjis', 'e', 'euc');
X
;#
;# Option handling
;#
while (($_ = @ARGV[$[]) =~ s/^-(.+)/\1/ && shift) {
X    next if $_ eq '';
X    /^v/ && do { print "$rcsid(jcode.pl=$jcode'version)\n"; exit(0); };
X    s/^[budmc]// && ++$opt{$&} && redo;
X    if (/^([jse]+)/) {
X	($ocode, $icode) = @codename{split(//, reverse($1))};
X	&jcode'jis_inout(split(//, $')) if $';
X	next;
X    }
X    print "Usage:\n", $usage;
X    exit(0);
}
$| = $opt{'u'} && !$opt{'b'};
($debug, $dynamic, $showcode) = @opt{'d', 'm', 'c'};
X
if ($showcode && !$dynamic) {
X    while (<>) {
X	next unless $icode = &jcode'getcode(*_) || (eof && "ascii");
X	print $ARGV, ": " if @ARGV .. 0;
X	print $icode, "\n";
X	close ARGV;
X    }
X    exit 0;
}
X	
while (<>) {
X    $c = &jcode'convert(*_, $ocode), print($showcode ? "$c\t" : '', $_), next
X	if $dynamic;
X    $showcode || print, next if !@readahead && !/[\033\200-\377]/;
X    push(@readahead, $_) unless $showcode;
X    next unless $icode || ($icode = &jcode'getcode(*_));
X    *convf = $jcode'convf{$icode, $ocode};
X    printf STDERR "in=$icode, out=$ocode, f=$convf\n" if $debug;
X    do convf(*_), print while $_ = shift(@readahead);
X    do convf(*_), print while <>;
X    last;
}
print @readahead;
exit $!;
SHAR_EOF
chmod 0555 pkf ||
echo 'restore of pkf failed'
Wc_c="`wc -c < 'pkf'`"
test 2605 -eq "$Wc_c" ||
	echo 'pkf: original size 2605, current size' "$Wc_c"
fi
exit 0