1# 2# $Id: Tr.pm,v 1.1.1.1 2003/08/02 23:39:43 takezoe Exp $ 3# 4 5package Jcode::Tr; 6 7use strict; 8use vars qw($VERSION $RCSID); 9 10$RCSID = q$Id: Tr.pm,v 1.1.1.1 2003/08/02 23:39:43 takezoe Exp $; 11$VERSION = do { my @r = (q$Revision: 1.1.1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; 12 13use Carp; 14 15use Jcode::Constants qw(:all); 16use vars qw(%_TABLE); 17 18sub tr { 19 # $prev_from, $prev_to, %table are persistent variables 20 my ($r_str, $from, $to, $opt) = @_; 21 my (@from, @to); 22 my $n = 0; 23 24 undef %_TABLE; 25 &_maketable($from, $to, $opt); 26 27 $$r_str =~ s( 28 ([\x80-\xff][\x00-\xff]|[\x00-\xff]) 29 ) 30 {defined($_TABLE{$1}) && ++$n ? 31 $_TABLE{$1} : $1}ogex; 32 33 return $n; 34} 35 36sub _maketable{ 37 my( $from, $to, $opt ) = @_; 38 $opt ||= ''; 39 $from =~ s/($RE{EUC_0212}-$RE{EUC_0212})/&_expnd3($1)/geo; 40 $from =~ s/($RE{EUC_KANA}-$RE{EUC_KANA})/&_expnd2($1)/geo; 41 $from =~ s/($RE{EUC_C }-$RE{EUC_C })/&_expnd2($1)/geo; 42 $from =~ s/($RE{ASCII }-$RE{ASCII })/&_expnd1($1)/geo; 43 $to =~ s/($RE{EUC_0212}-$RE{EUC_0212})/&_expnd3($1)/geo; 44 $to =~ s/($RE{EUC_KANA}-$RE{EUC_KANA})/&_expnd2($1)/geo; 45 $to =~ s/($RE{EUC_C }-$RE{EUC_C })/&_expnd2($1)/geo; 46 $to =~ s/($RE{ASCII }-$RE{ASCII })/&_expnd1($1)/geo; 47 48 my @from = $from =~ /$RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|[\x00-\xff]/go; 49 my @to = $to =~ /$RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|[\x00-\xff]/go; 50 51 push @to, ($opt =~ /d/ ? '' : $to[-1]) x ($#from - $#to) if $#to < $#from; 52 @_TABLE{@from} = @to; 53 54} 55 56sub _expnd1 { 57 my ($str) = @_; 58 # s/\\(.)/$1/og; # I dunno what this was doing!? 59 my($c1, $c2) = unpack('CxC', $str); 60 if ($c1 <= $c2) { 61 for ($str = ''; $c1 <= $c2; $c1++) { 62 $str .= pack('C', $c1); 63 } 64 } 65 return $str; 66} 67 68sub _expnd2 { 69 my ($str) = @_; 70 my ($c1, $c2, $c3, $c4) = unpack('CCxCC', $str); 71 if ($c1 == $c3 && $c2 <= $c4) { 72 for ($str = ''; $c2 <= $c4; $c2++) { 73 $str .= pack('CC', $c1, $c2); 74 } 75 } 76 return $str; 77} 78 79sub _expnd3 { 80 my ($str) = @_; 81 my ($c1, $c2, $c3, $c4, $c5, $c6) = unpack('CCCxCCC', $str); 82 if ($c1 == $c4 && $c2 == $c5 && $c3 <= $c6) { 83 for ($str = ''; $c3 <= $c6; $c3++) { 84 $str .= pack('CCC', $c1, $c2, $c3); 85 } 86 } 87 return $str; 88} 89 901; 91