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