This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Changes should mirror version number
[perl5.git] / ext / Encode / lib / Encode / JP / Tr.pm
1 #
2 # $Id: Tr.pm,v 0.77 2002/01/14 11:06:55 dankogai Exp $
3 #
4
5 package Jcode::Tr;
6
7 use strict;
8 use vars qw($VERSION $RCSID);
9
10 $RCSID = q$Id: Tr.pm,v 0.77 2002/01/14 11:06:55 dankogai Exp $;
11 $VERSION = do { my @r = (q$Revision: 0.77 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
12
13 use Carp;
14
15 use Jcode::Constants qw(:all);
16 use vars qw(%_TABLE);
17
18 sub 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
36 sub _maketable{
37     my( $from, $to, $opt ) = @_;
38  
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
56 sub _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
68 sub _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
79 sub _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
90 1;