Commit | Line | Data |
df1df145 |
1 | package Encode::Tcl::Extended; |
2 | use strict; |
3 | our $VERSION = do {my @r=(q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r}; |
4 | use base 'Encode::Encoding'; |
5 | |
6 | use Carp; |
7 | |
8 | sub read |
9 | { |
10 | my ($obj,$fh,$name) = @_; |
11 | my(%tbl, $enc, %ssc, @key); |
12 | while (<$fh>) |
13 | { |
14 | next unless /^(\S+)\s+(.*)$/; |
15 | my ($key,$val) = ($1,$2); |
16 | $val =~ s/\{(.*?)\}/$1/; |
17 | $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge; |
18 | |
19 | if($enc = Encode->getEncoding($key)) |
20 | { |
21 | push @key, $val; |
22 | $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc; |
23 | $ssc{$val} = substr($val,1) if $val =~ /^>/; |
24 | } |
25 | else |
26 | { |
27 | $obj->{$key} = $val; |
28 | } |
29 | } |
30 | $obj->{'SSC'} = \%ssc; # single shift char |
31 | $obj->{'Tbl'} = \%tbl; # encoding tables |
32 | $obj->{'Key'} = \@key; # keys of table hash |
33 | return $obj; |
34 | } |
35 | |
36 | sub decode |
37 | { |
38 | my ($obj,$str,$chk) = @_; |
39 | my $name = $obj->{'Name'}; |
40 | my $tbl = $obj->{'Tbl'}; |
41 | my $ssc = $obj->{'SSC'}; |
42 | my $cur = ''; # current state |
43 | my $uni; |
44 | while (length($str)) |
45 | { |
46 | my $cc = substr($str,0,1,''); |
47 | my $ch = ord($cc); |
48 | if(!$cur && $ch > 0x7F) |
49 | { |
50 | $cur = '>'; |
51 | $cur .= $cc, next if $ssc->{$cur.$cc}; |
52 | } |
53 | $ch ^= 0x80 if $cur; |
54 | |
55 | if(ref($tbl->{$cur}) ne 'Encode::Tcl::Table') |
56 | { |
57 | $uni .= $tbl->{$cur}->decode($cc); |
58 | $cur = ''; |
59 | next; |
60 | } |
61 | my $rep = $tbl->{$cur}->{'Rep'}; |
62 | my $touni = $tbl->{$cur}->{'ToUni'}; |
63 | my $x; |
64 | if (&$rep($ch) eq 'C') |
65 | { |
66 | $x = $touni->[0][$ch]; |
67 | } |
68 | else |
69 | { |
70 | if(! length $str) |
71 | { |
72 | $str = $cc; # split leading byte |
73 | last; |
74 | } |
75 | my $c2 = substr($str,0,1,''); |
76 | $cc .= $c2; |
77 | $x = $touni->[$ch][0x80 ^ ord($c2)]; |
78 | } |
79 | unless (defined $x) |
80 | { |
81 | Encode::Tcl::no_map_in_decode($name, $cc.$str); |
82 | } |
83 | $uni .= $x; |
84 | $cur = ''; |
85 | } |
86 | if($chk) |
87 | { |
88 | $cur =~ s/>//; |
89 | $_[1] = $cur ne '' ? $cur.$str : $str; |
90 | } |
91 | return $uni; |
92 | } |
93 | |
94 | sub encode |
95 | { |
96 | my ($obj,$uni,$chk) = @_; |
97 | my $name = $obj->{'Name'}; |
98 | my $tbl = $obj->{'Tbl'}; |
99 | my $ssc = $obj->{'SSC'}; |
100 | my $key = $obj->{'Key'}; |
101 | my $str; |
102 | my $cur; |
103 | |
104 | while (length($uni)) |
105 | { |
106 | my $ch = substr($uni,0,1,''); |
107 | my $x; |
108 | foreach my $k (@$key) |
109 | { |
110 | $x = ref($tbl->{$k}) ne 'Encode::Tcl::Table' |
111 | ? $k =~ /^>/ |
112 | ? $tbl->{$k}->encode(chr(0x80 ^ ord $ch),1) |
113 | : $tbl->{$k}->encode($ch,1) |
114 | : $tbl->{$k}->{FmUni}->{$ch}; |
115 | $cur = $k, last if defined $x; |
116 | } |
117 | unless (defined $x) |
118 | { |
119 | unless($chk) |
120 | { |
121 | Encode::Tcl::no_map_in_encode(ord($ch), $name) |
122 | } |
123 | return undef; |
124 | } |
125 | if(ref($tbl->{$cur}) eq 'Encode::Tcl::Table') |
126 | { |
127 | my $def = $tbl->{$cur}->{'Def'}; |
128 | my $rep = $tbl->{$cur}->{'Rep'}; |
129 | my $r = &$rep($x); |
130 | $x = pack($r, |
131 | $cur =~ /^>/ |
132 | ? $r eq 'C' ? 0x80 ^ $x : 0x8080 ^ $x |
133 | : $x); |
134 | } |
135 | $str .= $ssc->{$cur} if defined $ssc->{$cur}; |
136 | $str .= $x; |
137 | } |
138 | $_[1] = $uni if $chk; |
139 | return $str; |
140 | } |
141 | 1; |
142 | __END__ |
6b6c03af |
143 | |
144 | =head1 NAME |
145 | |
146 | Encode::Tcl::Extended - Tcl EUC encodings |
147 | |
148 | =head1 SYNOPSIS |
149 | |
150 | none |
151 | |
152 | =head1 DESCRIPTION |
153 | |
154 | This module is used internally by Encode::Tcl |
155 | and handles type X of Tcl encodings (a Perl extenstion). |
156 | |
157 | Only F<euc-jp-0212.enc> belongs to type X. |
158 | This is a variant of EUC-JP with JIS X 0212 in G3. |
159 | If another Encode:: module would support the above encoding, |
160 | this module should be removed. |
161 | |
162 | =head1 SEE ALSO |
163 | |
164 | L<Encode> |
165 | |
166 | L<Encode::Tcl> |
167 | |
168 | L<Encode::JP> |
169 | |
170 | =cut |