This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Encode::Tcl.pm, EUC-JP with jis-x0212
[perl5.git] / ext / Encode / Encode / Tcl.pm
1 package Encode::Tcl;
2 use strict;
3 use Encode qw(find_encoding);
4 use base 'Encode::Encoding';
5 use Carp;
6
7 =head1 NAME
8
9 Encode::Tcl - Tcl encodings
10
11 =cut
12
13 sub INC_search
14 {
15  foreach my $dir (@INC)
16   {
17    if (opendir(my $dh,"$dir/Encode"))
18     {
19      while (defined(my $name = readdir($dh)))
20       {
21        if ($name =~ /^(.*)\.enc$/)
22         {
23          my $canon = $1;
24          my $obj = find_encoding($canon);
25          if (!defined($obj))
26           {
27            my $obj = bless { Name => $canon, File => "$dir/Encode/$name"},__PACKAGE__;
28            $obj->Define( $canon );
29            # warn "$canon => $obj\n";
30           }
31         }
32       }
33      closedir($dh);
34     }
35   }
36 }
37
38 sub import
39 {
40  INC_search();
41 }
42
43 sub encode
44 {
45  my $obj = shift;
46  my $new = $obj->loadEncoding;
47  return undef unless (defined $new);
48  return $new->encode(@_);
49 }
50
51 sub new_sequence
52 {
53  my $obj = shift;
54  my $new = $obj->loadEncoding;
55  return undef unless (defined $new);
56  return $new->new_sequence(@_);
57 }
58
59 sub decode
60 {
61  my $obj = shift;
62  my $new = $obj->loadEncoding;
63  return undef unless (defined $new);
64  return $new->decode(@_);
65 }
66
67 sub loadEncoding
68 {
69  my $obj = shift;
70  my $file = $obj->{'File'};
71  my $name = $obj->name;
72  if (open(my $fh,$file))
73   {
74    my $type;
75    while (1)
76     {
77      my $line = <$fh>;
78      $type = substr($line,0,1);
79      last unless $type eq '#';
80     }
81    my $class = ref($obj).('::'.(
82         ($type eq 'X') ? 'Extended' :
83         ($type eq 'H') ? 'HanZi' :
84         ($type eq 'E') ? 'Escape' : 'Table'
85         ));
86    # carp "Loading $file";
87    bless $obj,$class;
88    return $obj if $obj->read($fh,$obj->name,$type);
89   }
90  else
91   {
92    croak("Cannot open $file for ".$obj->name);
93   }
94  $obj->Undefine($name);
95  return undef;
96 }
97
98 sub INC_find
99 {
100  my ($class,$name) = @_;
101  my $enc;
102  foreach my $dir (@INC)
103   {
104    last if ($enc = $class->loadEncoding($name,"$dir/Encode/$name.enc"));
105   }
106  return $enc;
107 }
108
109 package Encode::Tcl::Table;
110 use base 'Encode::Encoding';
111
112 use Data::Dumper;
113
114 sub read
115 {
116  my ($obj,$fh,$name,$type) = @_;
117  my($rep, @leading);
118  my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
119  my @touni;
120  my %fmuni;
121  my $count = 0;
122  $def = hex($def);
123  while ($pages--)
124   {
125    my $line = <$fh>;
126    chomp($line);
127    my $page = hex($line);
128    my @page;
129    $leading[$page] = 1 if $page;
130    my $ch = $page * 256;
131    for (my $i = 0; $i < 16; $i++)
132     {
133      my $line = <$fh>;
134      for (my $j = 0; $j < 16; $j++)
135       {
136        my $val = hex(substr($line,0,4,''));
137        if ($val || !$ch)
138         {
139          my $uch = pack('U', $val); # chr($val);
140          push(@page,$uch);
141          $fmuni{$uch} = $ch;
142          $count++;
143         }
144        else
145         {
146          push(@page,undef);
147         }
148        $ch++;
149       }
150     }
151    $touni[$page] = \@page;
152   }
153  $rep = $type ne 'M' ? $obj->can("rep_$type") :
154    sub { ($_[0] > 255) || $leading[$_[0]] ? 'n' : 'C'};
155  $obj->{'Rep'}   = $rep;
156  $obj->{'ToUni'} = \@touni;
157  $obj->{'FmUni'} = \%fmuni;
158  $obj->{'Def'}   = $def;
159  $obj->{'Num'}   = $count;
160  return $obj;
161 }
162
163 sub rep_S { 'C' }
164
165 sub rep_D { 'n' }
166
167 #sub rep_M { ($_[0] > 255) ? 'n' : 'C' }
168
169 sub representation
170 {
171  my ($obj,$ch) = @_;
172  $ch = 0 unless @_ > 1;
173  $obj->{'Rep'}->($ch);
174 }
175
176 sub decode
177 {
178  my ($obj,$str,$chk) = @_;
179  my $rep   = $obj->{'Rep'};
180  my $touni = $obj->{'ToUni'};
181  my $uni;
182  while (length($str))
183   {
184    my $ch = ord(substr($str,0,1,''));
185    my $x;
186    if (&$rep($ch) eq 'C')
187     {
188      $x = $touni->[0][$ch];
189     }
190    else
191     {
192      $x = $touni->[$ch][ord(substr($str,0,1,''))];
193     }
194    unless (defined $x)
195     {
196      last if $chk;
197      # What do we do here ?
198      $x = '';
199     }
200    $uni .= $x;
201   }
202  $_[1] = $str if $chk;
203  return $uni;
204 }
205
206
207 sub encode
208 {
209  my ($obj,$uni,$chk) = @_;
210  my $fmuni = $obj->{'FmUni'};
211  my $def   = $obj->{'Def'};
212  my $rep   = $obj->{'Rep'};
213  my $str;
214  while (length($uni))
215   {
216    my $ch = substr($uni,0,1,'');
217    my $x  = $fmuni->{chr(ord($ch))};
218    unless (defined $x)
219     {
220      last if ($chk);
221      $x = $def;
222     }
223    $str .= pack(&$rep($x),$x);
224   }
225  $_[1] = $uni if $chk;
226  return $str;
227 }
228
229 package Encode::Tcl::Escape;
230 use base 'Encode::Encoding';
231
232 use Carp;
233
234 sub read
235 {
236  my ($obj,$fh,$name) = @_;
237  my(%tbl, @seq, $enc, @esc, %grp);
238  while (<$fh>)
239   {
240    my ($key,$val) = /^(\S+)\s+(.*)$/;
241    $val =~ s/^\{(.*?)\}/$1/g;
242    $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
243
244    if($enc = Encode->getEncoding($key)){
245      $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
246      push @seq, $val;
247      $grp{$val} =
248         $val =~ m|[(]|  ? 0 : # G0 : SI  eq "\cO"
249         $val =~ m|[)-]| ? 1 : # G1 : SO  eq "\cN"
250         $val =~ m|[*.]| ? 2 : # G2 : SS2 eq "\eN"
251         $val =~ m|[+/]| ? 3 : # G3 : SS3 eq "\eO"
252                           0;  # G0
253    }else{
254      $obj->{$key} = $val;
255    }
256    if($val =~ /^\e(.*)/){ push(@esc, quotemeta $1) }
257   }
258  $obj->{'Grp'} = \%grp; # graphic chars
259  $obj->{'Seq'} = \@seq; # escape sequences
260  $obj->{'Tbl'} = \%tbl; # encoding tables
261  $obj->{'Esc'} = join('|', @esc); # regex of sequences following ESC
262  return $obj;
263 }
264
265 sub decode
266 {
267  my ($obj,$str,$chk) = @_;
268  my $tbl = $obj->{'Tbl'};
269  my $seq = $obj->{'Seq'};
270  my $grp = $obj->{'Grp'};
271  my $esc = $obj->{'Esc'};
272  my $ini = $obj->{'init'};
273  my $fin = $obj->{'final'};
274  my $std = $seq->[0];
275  my $cur = $std;
276  my @sta = ($std, undef, undef, undef); # G0 .. G3 state
277  my $s   = 0; # state of SO-SI.   0 (G0) or 1 (G1);
278  my $ss  = 0; # state of SS2,SS3. 0 (G0), 2 (G2) or 3 (G3);
279  my $uni;
280  while (length($str)){
281    my $uch = substr($str,0,1,'');
282    if($uch eq "\e"){
283     if($str =~ s/^($esc)//)
284      {
285       my $e = "\e$1";
286       $sta[ $grp->{$e} ] = $e if $tbl->{$e};
287      }
288     # appearance of "\eN\eO" or "\eO\eN" isn't supposed.
289     elsif($str =~ s/^N//)
290      {
291       $ss = 2;
292      }
293     elsif($str =~ s/^O//)
294      {
295       $ss = 3;
296      }
297     else
298      {
299       $str =~ s/^([\x20-\x2F]*[\x30-\x7E])//;
300       carp "unknown escape sequence: ESC $1";
301      }
302     next;
303    }
304    if($uch eq "\x0e"){
305     $s = 1; next;
306    }
307    if($uch eq "\x0f"){
308     $s = 0; next;
309    }
310
311    $cur = $ss ? $sta[$ss] : $sta[$s];
312
313    if(ref($tbl->{$cur}) eq 'Encode::XS'){
314      $uni .= $tbl->{$cur}->decode($uch);
315      $ss = 0;
316      next;
317    }
318    my $ch    = ord($uch);
319    my $rep   = $tbl->{$cur}->{'Rep'};
320    my $touni = $tbl->{$cur}->{'ToUni'};
321    my $x;
322    if (&$rep($ch) eq 'C')
323     {
324      $x = $touni->[0][$ch];
325     }
326    else
327     {
328      $x = $touni->[$ch][ord(substr($str,0,1,''))];
329     }
330    unless (defined $x)
331     {
332      last if $chk;
333      # What do we do here ?
334      $x = '';
335     }
336    $uni .= $x;
337    $ss = 0;
338   }
339  $_[1] = $str if $chk;
340  return $uni;
341 }
342
343 sub encode
344 {
345  my ($obj,$uni,$chk) = @_;
346  my $tbl = $obj->{'Tbl'};
347  my $seq = $obj->{'Seq'};
348  my $grp = $obj->{'Grp'};
349  my $ini = $obj->{'init'};
350  my $fin = $obj->{'final'};
351  my $std = $seq->[0];
352  my $str = $ini;
353  my @sta = ($std,undef,undef,undef); # G0 .. G3 state
354  my $cur = $std;
355  my $pG = 0; # previous G: 0 or 1.
356  my $cG = 0; # current G: 0,1,2,3. 
357
358  if($ini && defined $grp->{$ini})
359   {
360     $sta[ $grp->{$ini} ] = $ini;
361   }
362
363  while (length($uni)){
364   my $ch = substr($uni,0,1,'');
365   my $x;
366   foreach my $e_seq (@$seq){
367    $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
368     ? $tbl->{$e_seq}->encode($ch,1)
369     : $tbl->{$e_seq}->{FmUni}->{$ch};
370    $cur = $e_seq, last if defined $x;
371   }
372   if(ref($tbl->{$cur}) ne 'Encode::XS')
373    {
374     my $def = $tbl->{$cur}->{'Def'};
375     my $rep = $tbl->{$cur}->{'Rep'};
376     unless (defined $x){
377      last if ($chk);
378      $x = $def;
379     }
380     $x = pack(&$rep($x),$x);
381    }
382   $cG   = $grp->{$cur};
383   $str .= $sta[$cG] = $cur unless $cG < 2 && $cur eq $sta[$cG];
384
385   $str .= $cG == 0 && $pG == 1 ? "\cO" :
386           $cG == 1 && $pG == 0 ? "\cN" :
387           $cG == 2 ? "\eN" :
388           $cG == 3 ? "\eO" : "";
389   $str .= $x;
390   $pG = $cG if $cG < 2;
391  }
392  $str .= "\cO" if $pG == 1; # back to G0
393  $str .= $std  unless $std eq $sta[0]; # GO to ASCII
394  $str .= $fin; # necessary?
395  $_[1] = $uni if $chk;
396  return $str;
397 }
398
399
400 package Encode::Tcl::Extended;
401 use base 'Encode::Encoding';
402
403 use Carp;
404
405 sub read
406 {
407  my ($obj,$fh,$name) = @_;
408  my(%tbl, $enc, %ssc, @key);
409  while (<$fh>)
410   {
411    my ($key,$val) = /^(\S+)\s+(.*)$/;
412    $val =~ s/\{(.*?)\}/$1/;
413    $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
414
415    if($enc = Encode->getEncoding($key)){
416      push @key, $val;
417      $tbl{$val} = ref($enc) eq 'Encode::Tcl'
418         ? $enc->loadEncoding : $enc;
419      $ssc{$val} = substr($val,1) if $val =~ /^>/;
420    }else{
421      $obj->{$key} = $val;
422    }
423   }
424  $obj->{'SSC'} = \%ssc; # single shift char
425  $obj->{'Tbl'} = \%tbl; # encoding tables
426  $obj->{'Key'} = \@key; # keys of table hash
427  return $obj;
428 }
429
430 sub decode
431 {
432  my ($obj,$str,$chk) = @_;
433  my $tbl = $obj->{'Tbl'};
434  my $ssc = $obj->{'SSC'};
435  my $cur = ''; # current state
436  my $uni;
437  while (length($str)){
438    my $uch = substr($str,0,1,'');
439    my $ch  = ord($uch);
440    if(!$cur && $ch > 0x7F)
441     {
442      $cur = '>';
443      $cur .= $uch, next if $ssc->{$cur.$uch};
444     }
445    $ch ^= 0x80 if $cur;
446
447    if(ref($tbl->{$cur}) eq 'Encode::XS'){
448      $uni .= $tbl->{$cur}->decode(chr($ch));
449      $cur = '';
450      next;
451    }
452    my $rep   = $tbl->{$cur}->{'Rep'};
453    my $touni = $tbl->{$cur}->{'ToUni'};
454    my $x;
455    if (&$rep($ch) eq 'C')
456     {
457      $x = $touni->[0][$ch];
458     }
459    else
460     {
461      $x = $touni->[$ch][0x80 ^ ord(substr($str,0,1,''))];
462     }
463    unless (defined $x)
464     {
465      last if $chk;
466      # What do we do here ?
467      $x = '';
468     }
469    $uni .= $x;
470    $cur = '';
471   }
472  $_[1] = $str if $chk;
473  return $uni;
474 }
475
476 sub encode
477 {
478  my ($obj,$uni,$chk) = @_;
479  my $tbl = $obj->{'Tbl'};
480  my $ssc = $obj->{'SSC'};
481  my $key = $obj->{'Key'};
482  my $str;
483  my $cur;
484
485  while (length($uni)){
486   my $ch = substr($uni,0,1,'');
487   my $x;
488   foreach my $k (@$key){
489    $x = ref($tbl->{$k}) eq 'Encode::XS'
490     ? $k =~ /^>/
491       ? $tbl->{$k}->encode(chr(0x80 ^ ord $ch),1)
492       : $tbl->{$k}->encode($ch,1)
493     : $tbl->{$k}->{FmUni}->{$ch};
494    $cur = $k, last if defined $x;
495   }
496   if(ref($tbl->{$cur}) ne 'Encode::XS')
497    {
498     my $def = $tbl->{$cur}->{'Def'};
499     my $rep = $tbl->{$cur}->{'Rep'};
500     unless (defined $x){
501      last if ($chk);
502      $x = $def;
503     }
504     my $r = &$rep($x);
505     $x = pack($r,
506       $cur =~ /^>/
507         ? $r eq 'C' ? 0x80 ^ $x : 0x8080 ^ $x
508         : $x);
509    }
510
511   $str .= $ssc->{$cur} if defined $ssc->{$cur};
512   $str .= $x;
513  }
514  $_[1] = $uni if $chk;
515  return $str;
516 }
517
518 package Encode::Tcl::HanZi;
519 use base 'Encode::Encoding';
520
521 use Carp;
522
523 sub read
524 {
525  my ($obj,$fh,$name) = @_;
526  my(%tbl, @seq, $enc);
527  while (<$fh>)
528   {
529    my ($key,$val) = /^(\S+)\s+(.*)$/;
530    $val =~ s/^\{(.*?)\}/$1/g;
531    $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
532    if($enc = Encode->getEncoding($key)){
533      $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
534      push @seq, $val;
535    }else{
536      $obj->{$key} = $val;
537    }
538   }
539  $obj->{'Seq'} = \@seq; # escape sequences
540  $obj->{'Tbl'} = \%tbl; # encoding tables
541  return $obj;
542 }
543
544 sub decode
545 {
546  my ($obj,$str,$chk) = @_;
547  my $tbl = $obj->{'Tbl'};
548  my $seq = $obj->{'Seq'};
549  my $std = $seq->[0];
550  my $cur = $std;
551  my $uni;
552  while (length($str)){
553    my $uch = substr($str,0,1,'');
554    if($uch eq "~"){
555     if($str =~ s/^\cJ//)
556      {
557       next;
558      }
559     elsif($str =~ s/^\~//)
560      {
561       1;
562      }
563     elsif($str =~ s/^([{}])//)
564      {
565       $cur = "~$1";
566       next;
567      }
568     else
569      {
570       $str =~ s/^([^~])//;
571       carp "unknown HanZi escape sequence: ~$1";
572       next;
573      }
574    }
575    if(ref($tbl->{$cur}) eq 'Encode::XS'){
576      $uni .= $tbl->{$cur}->decode($uch);
577      next;
578    }
579    my $ch    = ord($uch);
580    my $rep   = $tbl->{$cur}->{'Rep'};
581    my $touni = $tbl->{$cur}->{'ToUni'};
582    my $x;
583    if (&$rep($ch) eq 'C')
584     {
585      $x = $touni->[0][$ch];
586     }
587    else
588     {
589      $x = $touni->[$ch][ord(substr($str,0,1,''))];
590     }
591    unless (defined $x)
592     {
593      last if $chk;
594      # What do we do here ?
595      $x = '';
596     }
597    $uni .= $x;
598   }
599  $_[1] = $str if $chk;
600  return $uni;
601 }
602
603 sub encode
604 {
605  my ($obj,$uni,$chk) = @_;
606  my $tbl = $obj->{'Tbl'};
607  my $seq = $obj->{'Seq'};
608  my $std = $seq->[0];
609  my $str;
610  my $pre = $std;
611  my $cur = $pre;
612
613  while (length($uni)){
614   my $ch = chr(ord(substr($uni,0,1,'')));
615   my $x;
616   foreach my $e_seq (@$seq){
617    $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
618     ? $tbl->{$e_seq}->encode($ch,1)
619     : $tbl->{$e_seq}->{FmUni}->{$ch};
620    $cur = $e_seq and last if defined $x;
621   }
622   if(ref($tbl->{$cur}) ne 'Encode::XS')
623    {
624     my $def = $tbl->{$cur}->{'Def'};
625     my $rep = $tbl->{$cur}->{'Rep'};
626     unless (defined $x){
627      last if ($chk);
628      $x = $def;
629     }
630     $x = pack(&$rep($x),$x);
631    }
632   $str .= $cur eq $pre ? $x : ($pre = $cur).$x;
633   $str .= '~' if $x eq '~'; # to '~~'
634  }
635  $str .= $std unless $cur eq $std;
636  $_[1] = $uni if $chk;
637  return $str;
638 }
639
640 1;
641 __END__