diff options
Diffstat (limited to 'cpan/lib/Jcode.pm')
| -rw-r--r-- | cpan/lib/Jcode.pm | 754 |
1 files changed, 754 insertions, 0 deletions
diff --git a/cpan/lib/Jcode.pm b/cpan/lib/Jcode.pm new file mode 100644 index 00000000..317bb34a --- /dev/null +++ b/cpan/lib/Jcode.pm @@ -0,0 +1,754 @@ +# +# $Id: Jcode.pm,v 0.66 2000/12/21 12:04:40 dankogai Exp dankogai $ +# + +=head1 NAME + +Jcode - Japanese Charset Handler + +=head1 SYNOPSIS + + use Jcode; + + # traditional + Jcode::convert(\$str, $ocode, $icode, "z"); + # or OOP! + print Jcode->new($str)->h2z->tr($from, $to)->utf8; + +=cut + +=head1 DESCRIPTION + +Jcode.pm supports both object and traditional approach. +With object approach, you can go like; + +$iso_2022_jp = Jcode->new($str)->h2z->jis; + +Which is more elegant than; + +$iso_2022_jp = &jcode::convert(\$str,'jis',jcode::getcode(\str), "z"); + +For those unfamiliar with objects, Jcode.pm still supports getcode() +and convert(). + +=cut + +package Jcode; +require 5.004; + +use strict; +use vars qw($RCSID $VERSION); + +$RCSID = q$Id: Jcode.pm,v 0.66 2000/12/21 12:04:40 dankogai Exp dankogai $; +$VERSION = do { my @r = (q$Revision: 0.66 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use Carp; + +BEGIN { + use Exporter; + use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + @ISA = qw(Exporter); + @EXPORT = qw(jcode getcode); + @EXPORT_OK = qw($RCSID $VERSION $DEBUG $USE_CACHE); + %EXPORT_TAGS = ( all => [ @EXPORT_OK, @EXPORT ] ); +} + +use vars @EXPORT_OK; + +$DEBUG = 0; +$USE_CACHE = 1; + +print $RCSID, "\n" if $DEBUG; + +use Jcode::Constants qw(:all); + +=head1 Methods + +Methods mentioned here all return Jcode object unless otherwise mentioned. + +=over 4 + +=cut + +use overload + '""' => sub { ${$_[0]->[0]} }, + '==' => sub {overload::StrVal($_[0]) eq overload::StrVal($_[1])}, + fallback => 1, + ; + +=item $j = Jcode->new($str [, $icode]); + +Creates Jcode object $j from $str. Input code is automatically checked +unless you explicitly set $icode. For available charset, see L<getcode()> +below. + +The object keeps the string in EUC format enternaly. When the object +itself is evaluated, it returns the EUC-converted string so you can +"print $j;" without calling access method if you are using EUC +(thanks to function overload). + +=item Passing Reference + +Instead of scalar value, You can use reference as + +Jcode->new(\$str); + +This saves time a little bit. In exchange of the value of $str being +converted. (In a way, $str is now "tied" to jcode object). + +=cut + +sub new { + my $class = shift; + my ($thingy, $icode) = @_; + my $r_str = _mkbuf($thingy); + my $nmatch; + ($icode, $nmatch) = getcode($r_str) unless $icode; + convert($r_str, 'euc', $icode); + my $self = [ + $r_str, + $icode, + $nmatch, + ]; + carp "Object of class $class created" if $DEBUG >= 2; + bless $self, $class; +} + +sub r_str { $_[0]->[0] } +sub icode { $_[0]->[1] } +sub nmatch { $_[0]->[2] } + +=item $j->set($str [, $icode]); + +Sets $j's internal string to $str. Handy when you use Jcode object repeatedly +(saves time and memory to create object). + + # converts mailbox to SJIS format + my $jconv = new Jcode; + while(<>){ + print $jconv->set(\$_)->mime_decode->sjis; + } + +=cut + +sub set { + my $self = shift; + my ($thingy, $icode) = @_; + my $r_str = _mkbuf($thingy); + my $nmatch; + ($icode, $nmatch) = getcode($r_str) unless $icode; + convert($r_str, 'euc', $icode); + $self->[0] = $r_str; + $self->[1] = $icode; + $self->[2] = $nmatch; + return $self; +} + +=item $j->append($str [, $icode]); + +Appends $str to $j's internal string. + +=cut + +sub append { + my $self = shift; + my ($thingy, $icode) = @_; + my $r_str = _mkbuf($thingy); + my $nmatch; + ($icode, $nmatch) = getcode($r_str) unless $icode; + convert($r_str, 'euc', $icode); + ${$self->[0]} .= $$r_str; + $self->[1] = $icode; + $self->[2] = $nmatch; + return $self; +} + + +=item $j = jcode($str [, $icode]); + +shortcut for Jcode->new() so you can go like; + +$sjis = jcode($str)->sjis; + +=item $euc = $j->euc; + +=item $jis = $j->jis; + +=item $sjis = $j->sjis; + +What you code is what you get :) + +=cut + +sub jcode { return Jcode->new(@_) } +sub euc { return ${$_[0]->[0]} } +sub jis { return &euc_jis(${$_[0]->[0]})} +sub sjis { return &euc_sjis(${$_[0]->[0]})} + +=item $iso_2022_jp = $j->iso_2022_jp + +Same as $j->z2h->jis. +Hankaku Kanas are forcibly converted to Zenkaku. + +=cut + +sub iso_2022_jp{return $_[0]->h2z->jis} + +=item [@lines =] $jcode->jfold([$bytes_per_line, $newline_str]); + +folds lines in jcode string every $bytes_per_line (default: 72) +in a way that does not clobber the multibyte string. +(Sorry, no Kinsoku done!) +with a newline string spified by $newline_str (default: \n). + +=cut + +sub jfold{ + my $self = shift; + my ($bpl, $nl) = @_; + $bpl ||= 72; + $nl ||= "\n"; + my $r_str = $self->[0]; + my (@lines, $len, $i); + while ($$r_str =~ m/([\x8f\x8e]$RE{EUC_C}|$RE{EUC_C}|[\x00-\xff])/sgo){ + if ($len + length($1) > $bpl){ # fold! + $i++; + $len = 0; + } + $lines[$i] .= $1; + $len += length($1); + } + $lines[$i] or pop @lines; + $$r_str = join($nl, @lines); + return wantarray ? @lines : $self; +} + + +=head2 Methods that use MIME::Base64 + +To use methods below, you need MIME::Base64. To install, simply + + perl -MCPAN -e 'CPAN::Shell->install("MIME::Base64")' + +=item $mime_header = $j->mime_encode([$lf, $bpl]); + +Converts $str to MIME-Header documented in RFC1522. +When $lf is specified, it uses $lf to fold line (default: \n); +When $bpl is specified, it uses $bpl for the number of bytes (default: 76); + +=cut + +sub mime_encode{ + my $self = shift; + my $r_str = $self->[0]; + my $lf = shift || "\n"; + my $bpl = shift || 76; + + my ($trailing_crlf) = ($$r_str =~ /(\n|\r|\x0d\x0a)$/o); + my $str = _mime_unstructured_header($$r_str, $lf, $bpl); + not $trailing_crlf and $str =~ s/(\n|\r|\x0d\x0a)$//o; + $str; +} + +# +# shamelessly stolen from +# http://www.din.or.jp/~ohzaki/perl.htm#JP_Base64 +# + +sub _add_encoded_word { + require MIME::Base64; + my($str, $line) = @_; + my $result = ''; + while (length($str)) { + my $target = $str; + $str = ''; + if (length($line) + 22 + + ($target =~ /^(?:$RE{EUC_0212}|$RE{EUC_C})/o) * 8 > 76) { + $line =~ s/[ \t\n\r]*$/\n/; + $result .= $line; + $line = ' '; + } + while (1) { + my $encoded = '=?ISO-2022-JP?B?' . + MIME::Base64::encode_base64( + jcode($target, 'euc')->iso_2022_jp, '') + . '?='; + if (length($encoded) + length($line) > 76) { + $target =~ s/(RE{EUC_0212}|$RE{EUC_C}|$RE{ASCII})$//o; + $str = $1 . $str; + } else { + $line .= $encoded; + last; + } + } + } + return $result . $line; +} + + +sub _mime_unstructured_header { + my ($oldheader, $lf, $bpl) = @_; + my(@words, @wordstmp, $i); + my $header = ''; + $oldheader =~ s/\s+$//; + @wordstmp = split /\s+/, $oldheader; + for ($i = 0; $i < $#wordstmp; $i++) { + if ($wordstmp[$i] !~ /^[\x21-\x7E]+$/ and + $wordstmp[$i + 1] !~ /^[\x21-\x7E]+$/) { + $wordstmp[$i + 1] = "$wordstmp[$i] $wordstmp[$i + 1]"; + } else { + push(@words, $wordstmp[$i]); + } + } + push(@words, $wordstmp[-1]); + for my $word (@words) { + if ($word =~ /^[\x21-\x7E]+$/) { + $header =~ /(?:.*\n)?(.*)/; + if (length($1) + length($word) > $bpl) { + $header .= "$lf $word"; + } else { + $header .= $word; + } + } else { + $header = _add_encoded_word($word, $header); + } + $header =~ /(?:.*\n)?(.*)/; + if (length($1) == $bpl) { + $header .= "$lf "; + } else { + $header .= ' '; + } + } + $header =~ s/\n? $/\n/; + $header; +} + +=item $j->mime_decode; + +Decodes MIME-Header in Jcode object. + +You can retrieve the number of matches via $j->nmatch; + +=cut + +# see http://www.din.or.jp/~ohzaki/perl.htm#JP_Base64 +#$lws = '(?:(?:\x0d\x0a)?[ \t])+'; +#$ew_regex = '=\?ISO-2022-JP\?B\?([A-Za-z0-9+/]+=*)\?='; +#$str =~ s/($ew_regex)$lws(?=$ew_regex)/$1/gio; +#$str =~ s/$lws/ /go; $str =~ s/$ew_regex/decode_base64($1)/egio; + +sub mime_decode{ + require MIME::Base64; # not use + my $self = shift; + my $r_str = $self->[0]; + my $re_lws = '(?:(?:\r|\n|\x0d\x0a)?[ \t])+'; + my $re_ew = '(?i:=\?ISO-2022-JP\?B\?)([A-Za-z0-9+/]+=*)\?='; + $$r_str =~ s/($re_ew)$re_lws(?=$re_ew)/$1/sgo; + $$r_str =~ s/$re_lws/ /go; + $self->[2] = + ($$r_str =~ + s/$re_ew/jis_euc(MIME::Base64::decode_base64($1))/ego + ); + $self; +} + +=head2 Methods implemented by Jcode::H2Z + +Methods below are actually implemented in Jcode::H2Z. + +=item $j->h2z([$keep_dakuten]); + +Converts X201 kana (Hankaku) to X208 kana (Zenkaku). +When $keep_dakuten is set, it leaves dakuten as is +(That is, "ka + dakuten" is left as is instead of +being converted to "ga") + +You can retrieve the number of matches via $j->nmatch; + +=cut + +sub h2z { + require Jcode::H2Z; # not use + my $self = shift; + $self->[2] = Jcode::H2Z::h2z($self->[0], @_); + return $self; +} + +=item $j->z2h; + +Converts X208 kana (Zenkaku) to X201 kana (Hankazu). + +You can retrieve the number of matches via $j->nmatch; + +=cut + +sub z2h { + require Jcode::H2Z; # not use + my $self = shift; + $self->[2] = &Jcode::H2Z::z2h($self->[0], @_); + return $self; +} + +=head2 Methods implemented in Jcode::Tr + +Methods here are actually implemented in Jcode::Tr. + +=item $j->tr($from, $to); + +Applies tr on Jcode object. $from and $to can contain EUC Japanese. + +You can retrieve the number of matches via $j->nmatch; + +=cut + +sub tr{ + require Jcode::Tr; # not use + my $self = shift; + $self->[2] = Jcode::Tr::tr($self->[0], @_); + return $self; +} + +# +# load needed module depending on the configuration just once! +# + +use vars qw(%PKG_LOADED); +sub load_module{ + my $pkg = shift; + return $pkg if $PKG_LOADED{$pkg}++; + eval qq( require $pkg; ); + unless ($@){ + carp "$pkg loaded." if $DEBUG; + }else{ + $pkg .= "::NoXS"; + eval qq( require $pkg; ); + unless ($@){ + carp "$pkg loaded" if $DEBUG; + }else{ + croak "Loading $pkg failed!"; + } + } + $pkg; +} + +=head2 Methods implemented in Jcode::Unicode + +If your perl does not support XS (or you can't C<perl Makefile.PL>, +Jcode::Unicode::NoXS will be used. + +See L<Jcode::Unicode> and L<Jcode::Unicode::NoXS> for details + +=item $ucs2 = $j->ucs2; + +Returns UCS2 (Raw Unicode) string. + +=cut + +sub ucs2{ + load_module("Jcode::Unicode"); + euc_ucs2(${$_[0]->[0]}); +} + +=item $ucs2 = $j->utf8; + +Returns utf8 String. + +=cut + +sub utf8{ + load_module("Jcode::Unicode"); + euc_utf8(${$_[0]->[0]}); +} + +=head2 Instance Variables + +If you need to access instance variables of Jcode object, use access +methods below instead of directly accessing them (That's what OOP +is all about) + +FYI, Jcode uses a ref to array instead of ref to hash (common way) to +optimize speed (Actually you don't have to know as long as you use +access methods instead; Once again, that's OOP) + +=item $j->r_str + +Reference to the EUC-coded String. + +=item $j->icode + +Input charcode in recent operation. + +=item $j->nmatch + +Number of matches (Used in $j->tr, etc.) + +=cut + +=head1 Subroutines + +=item ($code, [$nmatch]) = getcode($str); + +Returns char code of $str. Return codes are as follows + + ascii Ascii (Contains no Japanese Code) + binary Binary (Not Text File) + euc EUC-JP + sjis SHIFT_JIS + jis JIS (ISO-2022-JP) + ucs2 UCS2 (Raw Unicode) + utf8 UTF8 + +When array context is used instead of scaler, it also returns how many +character codes are found. As mentioned above, $str can be \$str +instead. + +=item jcode.pl Users: + +This function is 100% upper-conpatible with jcode::getcode() -- well, almost; + + * When its return value is an array, the order is the opposite; + jcode::getcode() returns $nmatch first. + + * jcode::getcode() returns 'undef' when the number of EUC characters + is equal to that of SJIS. Jcode::getcode() returns EUC. for + Jcode.pm is no in-betweens. + +=cut + +sub getcode { + my $thingy = shift; + my $r_str = _mkbuf($thingy); + my ($code, $nmatch, $sjis, $euc, $utf8) = ("", 0, 0, 0, 0); + + if ($$r_str =~ /$RE{BIN}/o) { # 'binary' + my $ucs2; + $ucs2 += length($1) + while $$r_str =~ /(\x00$RE{ASCII})+/go; + if ($ucs2){ # smells like raw unicode + ($code, $nmatch) = ('ucs2', $ucs2); + }else{ + ($code, $nmatch) = ('binary', 0); + } + } + elsif ($$r_str !~ /[\e\x80-\xff]/o) { # not Japanese + ($code, $nmatch) = ('ascii', 1); + } # 'jis' + elsif ($$r_str =~ + m[ + $RE{JIS_0208}|$RE{JIS_0212}|$RE{JIS_ASC}|$RE{JIS_KANA} + ]ox) + { + ($code, $nmatch) = ('jis', 1); + } + else { # should be euc|sjis|utf8 + # use of (?:) by Hiroki Ohzaki <ohzaki@iod.ricoh.co.jp> + $sjis += length($1) + while $$r_str =~ /((?:$RE{SJIS_C})+)/go; + $euc += length($1) + while $$r_str =~ /((?:$RE{EUC_C}|$RE{EUC_KANA}|$RE{EUC_0212})+)/go; + $utf8 += length($1) + while $$r_str =~ /((?:$RE{UTF8})+)/go; + $nmatch = _max($utf8, $sjis, $euc); + carp ">DEBUG:sjis = $sjis, euc = $euc, utf8 = $utf8" if $DEBUG >= 3; + $code = + ($euc > $sjis and $euc > $utf8) ? 'euc' : + ($sjis > $euc and $sjis > $utf8) ? 'sjis' : + ($utf8 > $euc and $utf8 > $sjis) ? 'utf8' : undef; + } + return wantarray ? ($code, $nmatch) : $code; +} + +=item Jcode::convert($str, [$ocode, $icode, $opt]); + +Converts $str to char code specified by $ocode. When $icode is specified +also, it assumes $icode for input string instead of the one checked by +getcode(). As mentioned above, $str can be \$str instead. + +=item jcode.pl Users: + +This function is 100% upper-conpatible with jcode::convert() ! + +=cut + +sub convert{ + my $thingy = shift; + my $r_str = _mkbuf($thingy); + my ($ocode, $icode, $opt) = @_; + + my $nmatch; + ($icode, $nmatch) = getcode($r_str) unless $icode; + + return $$r_str if $icode eq $ocode; # do nothin' + + no strict qw(refs); + my $method; + + # convert to EUC + + load_module("Jcode::Unicode") if $icode =~ /ucs2|utf8/o; + if ($icode and defined &{$method = $icode . "_euc"}){ + carp "Dispatching \&$method" if $DEBUG >= 2; + &{$method}($r_str) ; + } + + # h2z or z2h + + if ($opt){ + my $cmd = ($opt =~ /^z/o) ? "h2z" : ($opt =~ /^h/o) ? "z2h" : undef; + if ($cmd){ + require Jcode::H2Z; + &{'Jcode::H2Z::' . $cmd}($r_str); + } + } + + # convert to $ocode + + load_module("Jcode::Unicode") if $ocode =~ /ucs2|utf8/o; + if ($ocode and defined &{$method = "euc_" . $ocode}){ + carp "Dispatching \&$method" if $DEBUG >= 2; + &{$method}($r_str) ; + } + $$r_str; +} + +# JIS<->EUC + +sub jis_euc { + my $thingy = shift; + my $r_str = _mkbuf($thingy); + $$r_str =~ s( + ($RE{JIS_0212}|$RE{JIS_0208}|$RE{JIS_ASC}|$RE{JIS_KANA}) + ([^\e]*) + ) + { + my ($esc, $str) = ($1, $2); + if ($esc !~ /$RE{JIS_ASC}/o) { + $str =~ tr/\x21-\x7e/\xa1-\xfe/; + if ($esc =~ /$RE{JIS_KANA}/o) { + $str =~ s/([\xa1-\xdf])/\x8e$1/og; + } + elsif ($esc =~ /$RE{JIS_0212}/o) { + $str =~ s/([\xa1-\xfe][\xa1-\xfe])/\x8f$1/og; + } + } + $str; + }geox; + $$r_str; +} + +# +sub euc_jis { + my $thingy = shift; + my $r_str = _mkbuf($thingy); + $$r_str =~ s{ + (($RE{EUC_C}|$RE{EUC_KANA}|$RE{EUC_0212})+) + } + { + my $str = $1; + my $esc = ($str =~ tr/\x8e//d) ? $ESC{KANA} : + ($str =~ tr/\x8f//d) ? $ESC{JIS_0212} : $ESC{JIS_0208}; + $str =~ tr/\xa1-\xfe/\x21-\x7e/; + $esc . $str . $ESC{ASC} + }geox; + $$r_str; +} + +# EUC<->SJIS + +my %_S2E = (); +my %_E2S = (); + +sub sjis_euc { + my $thingy = shift; + my $r_str = _mkbuf($thingy); + $$r_str =~ s( + ($RE{SJIS_C}|$RE{SJIS_KANA}) + ) + { + my $str = $1; + unless ($_S2E{$1}){ + my ($c1, $c2) = unpack('CC', $str); + 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); + } + $_S2E{$str} = pack('CC', $c1, $c2); + } + $_S2E{$str}; + }geox; + $$r_str; +} + +# + +sub euc_sjis { + my $thingy = shift; + my $r_str = _mkbuf($thingy); + $$r_str =~ s( + ($RE{EUC_C}|$RE{EUC_KANA}|$RE{EUC_0212}) + ) + { + my $str = $1; + unless ($_E2S{$str}){ + my ($c1, $c2) = unpack('CC', $str); + if ($c1 == 0x8e) { # SS2 + $_E2S{$str} = chr($c2); + } elsif ($c1 == 0x8f) { # SS3 + $_E2S{$str} = $CHARCODE{UNDEF_SJIS}; + }else { #SS1 or X0208 + if ($c1 % 2) { + $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x31 : 0x71); + $c2 -= 0x60 + ($c2 < 0xe0); + } else { + $c1 = ($c1>>1) + ($c1 < 0xdf ? 0x30 : 0x70); + $c2 -= 2; + } + $_E2S{$str} = pack('CC', $c1, $c2); + } + } + $_E2S{$str}; + }geox; + $$r_str; +} + +# + +1; + +__END__ + +=head1 BUGS + +=item Unicode support by Jcode is far from efficient! + +=head1 ACKNOWLEDGEMENTS + +This package owes a lot in motivation, design, and code, to the jcode.pl +for Perl4 by Kazumasa Utashiro <utashiro@iij.ad.jp>. + +Hiroki Ohzaki <ohzaki@iod.ricoh.co.jp> has helped me polish regexp from the +very first stage of development. + +And folks at Jcode Mailing list <jcode5@ring.gr.jp>. Without them, I +couldn't have coded this far. + +=head1 SEE ALSO + +=item L<Jcode::Unicode> + +=item L<Jcode::Unicode::NoXS> + +=head1 COPYRIGHT + +Copyright 1999 Dan Kogai <dankogai@dan.co.jp> + +This library is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=cut |
