1 package Encode::Tcl::Escape;
3 our $VERSION = do {my @r=(q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r};
4 use base 'Encode::Encoding';
8 use constant SI => "\cO";
9 use constant SO => "\cN";
10 use constant SS2 => "\eN";
11 use constant SS3 => "\eO";
15 my ($obj,$fh,$name) = @_;
16 my(%tbl, @seq, $enc, @esc, %grp);
19 next unless /^(\S+)\s+(.*)$/;
20 my ($key,$val) = ($1,$2);
21 $val =~ s/^\{(.*?)\}/$1/g;
22 $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
24 if($enc = Encode->getEncoding($key))
26 $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
29 $val =~ m|[(]| ? 0 : # G0 : SI eq "\cO"
30 $val =~ m|[)-]| ? 1 : # G1 : SO eq "\cN"
31 $val =~ m|[*.]| ? 2 : # G2 : SS2 eq "\eN"
32 $val =~ m|[+/]| ? 3 : # G3 : SS3 eq "\eO"
41 push(@esc, quotemeta $1);
44 $obj->{'Grp'} = \%grp; # graphic chars
45 $obj->{'Seq'} = \@seq; # escape sequences
46 $obj->{'Tbl'} = \%tbl; # encoding tables
47 $obj->{'Esc'} = join('|', @esc); # regex of sequences following ESC
53 my ($obj,$str,$chk) = @_;
54 my $name = $obj->{'Name'};
55 my $tbl = $obj->{'Tbl'};
56 my $seq = $obj->{'Seq'};
57 my $grp = $obj->{'Grp'};
58 my $esc = $obj->{'Esc'};
59 my $ini = $obj->{'init'};
60 my $fin = $obj->{'final'};
63 my @sta = ($std, undef, undef, undef); # G0 .. G3 state
64 my $s = 0; # state of SO-SI. 0 (G0) or 1 (G1);
65 my $ss = 0; # state of SS2,SS3. 0 (G0), 2 (G2) or 3 (G3);
69 my $cc = substr($str,0,1,'');
72 if($str =~ s/^($esc)//)
75 $sta[ $grp->{$e} ] = $e if $tbl->{$e};
77 # appearance of "\eN\eO" or "\eO\eN" isn't supposed.
78 # but in that case, the former will be ignored.
89 # strictly, ([\x20-\x2F]*[\x30-\x7E]). '?' for chopped.
90 $str =~ s/^([\x20-\x2F]*[\x30-\x7E]?)//;
91 if($chk && ! length $str)
93 $str = "\e$1"; # split sequence
96 croak "unknown escape sequence: ESC $1";
109 $cur = $ss ? $sta[$ss] : $sta[$s];
111 if(ref($tbl->{$cur}) ne 'Encode::Tcl::Table')
113 $uni .= $tbl->{$cur}->decode($cc);
118 my $rep = $tbl->{$cur}->{'Rep'};
119 my $touni = $tbl->{$cur}->{'ToUni'};
121 if (&$rep($ch) eq 'C')
123 $x = $touni->[0][$ch];
129 $str = $cc; # split leading byte
132 my $c2 = substr($str,0,1,'');
134 $x = $touni->[$ch][ord($c2)];
138 Encode::Tcl::no_map_in_decode($name, $cc.$str);
145 my $back = join('', grep defined($_) && $_ ne $std, @sta);
147 $back .= $ss == 2 ? SS2 : SS3 if $ss;
155 my ($obj,$uni,$chk) = @_;
156 my $name = $obj->{'Name'};
157 my $tbl = $obj->{'Tbl'};
158 my $seq = $obj->{'Seq'};
159 my $grp = $obj->{'Grp'};
160 my $ini = $obj->{'init'};
161 my $fin = $obj->{'final'};
164 my @sta = ($std,undef,undef,undef); # G0 .. G3 state
166 my $pG = 0; # previous G: 0 or 1.
167 my $cG = 0; # current G: 0,1,2,3.
169 if($ini && defined $grp->{$ini})
171 $sta[ $grp->{$ini} ] = $ini;
176 my $ch = substr($uni,0,1,'');
178 foreach my $e_seq (@$seq)
180 $x = ref($tbl->{$e_seq}) eq 'Encode::Tcl::Table'
181 ? $tbl->{$e_seq}->{FmUni}->{$ch}
182 : $tbl->{$e_seq}->encode($ch,1);
183 $cur = $e_seq, last if defined $x;
189 Encode::Tcl::no_map_in_encode(ord($ch), $name)
193 if(ref($tbl->{$cur}) eq 'Encode::Tcl::Table')
195 my $def = $tbl->{$cur}->{'Def'};
196 my $rep = $tbl->{$cur}->{'Rep'};
197 $x = pack(&$rep($x),$x);
200 $str .= $sta[$cG] = $cur unless $cG < 2 && $cur eq $sta[$cG];
202 $str .= $cG == 0 && $pG == 1 ? SI :
203 $cG == 1 && $pG == 0 ? SO :
207 $pG = $cG if $cG < 2;
209 $str .= SI if $pG == 1; # back to G0
210 $str .= $std unless $std eq $sta[0]; # GO to ASCII
211 $str .= $fin; # necessary?
212 $_[1] = $uni if $chk;