This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
e8c41e45f98528c556864892278b15de51544523
[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).('::'.(($type eq 'H') ? 'HanZi' : ($type eq 'E') ? 'Escape' : 'Table'));
82    # carp "Loading $file";
83    bless $obj,$class;
84    return $obj if $obj->read($fh,$obj->name,$type);
85   }
86  else
87   {
88    croak("Cannot open $file for ".$obj->name);
89   }
90  $obj->Undefine($name);
91  return undef;
92 }
93
94 sub INC_find
95 {
96  my ($class,$name) = @_;
97  my $enc;
98  foreach my $dir (@INC)
99   {
100    last if ($enc = $class->loadEncoding($name,"$dir/Encode/$name.enc"));
101   }
102  return $enc;
103 }
104
105 package Encode::Tcl::Table;
106 use base 'Encode::Encoding';
107
108 use Data::Dumper;
109
110 sub read
111 {
112  my ($obj,$fh,$name,$type) = @_;
113  my($rep, @leading);
114  my ($def,$sym,$pages) = split(/\s+/,scalar(<$fh>));
115  my @touni;
116  my %fmuni;
117  my $count = 0;
118  $def = hex($def);
119  while ($pages--)
120   {
121    my $line = <$fh>;
122    chomp($line);
123    my $page = hex($line);
124    my @page;
125    $leading[$page] = 1 if $page;
126    my $ch = $page * 256;
127    for (my $i = 0; $i < 16; $i++)
128     {
129      my $line = <$fh>;
130      for (my $j = 0; $j < 16; $j++)
131       {
132        my $val = hex(substr($line,0,4,''));
133        if ($val || !$ch)
134         {
135          my $uch = pack('U', $val); # chr($val);
136          push(@page,$uch);
137          $fmuni{$uch} = $ch;
138          $count++;
139         }
140        else
141         {
142          push(@page,undef);
143         }
144        $ch++;
145       }
146     }
147    $touni[$page] = \@page;
148   }
149  $rep = $type ne 'M' ? $obj->can("rep_$type") :
150    sub { ($_[0] > 255) || $leading[$_[0]] ? 'n' : 'C'};
151  $obj->{'Rep'}   = $rep;
152  $obj->{'ToUni'} = \@touni;
153  $obj->{'FmUni'} = \%fmuni;
154  $obj->{'Def'}   = $def;
155  $obj->{'Num'}   = $count;
156  return $obj;
157 }
158
159 sub rep_S { 'C' }
160
161 sub rep_D { 'n' }
162
163 #sub rep_M { ($_[0] > 255) ? 'n' : 'C' }
164
165 sub representation
166 {
167  my ($obj,$ch) = @_;
168  $ch = 0 unless @_ > 1;
169  $obj->{'Rep'}->($ch);
170 }
171
172 sub decode
173 {
174  my ($obj,$str,$chk) = @_;
175  my $rep   = $obj->{'Rep'};
176  my $touni = $obj->{'ToUni'};
177  my $uni;
178  while (length($str))
179   {
180    my $ch = ord(substr($str,0,1,''));
181    my $x;
182    if (&$rep($ch) eq 'C')
183     {
184      $x = $touni->[0][$ch];
185     }
186    else
187     {
188      $x = $touni->[$ch][ord(substr($str,0,1,''))];
189     }
190    unless (defined $x)
191     {
192      last if $chk;
193      # What do we do here ?
194      $x = '';
195     }
196    $uni .= $x;
197   }
198  $_[1] = $str if $chk;
199  return $uni;
200 }
201
202
203 sub encode
204 {
205  my ($obj,$uni,$chk) = @_;
206  my $fmuni = $obj->{'FmUni'};
207  my $def   = $obj->{'Def'};
208  my $rep   = $obj->{'Rep'};
209  my $str;
210  while (length($uni))
211   {
212    my $ch = substr($uni,0,1,'');
213    my $x  = $fmuni->{chr(ord($ch))};
214    unless (defined $x)
215     {
216      last if ($chk);
217      $x = $def;
218     }
219    $str .= pack(&$rep($x),$x);
220   }
221  $_[1] = $uni if $chk;
222  return $str;
223 }
224
225 package Encode::Tcl::Escape;
226 use base 'Encode::Encoding';
227
228 use Carp;
229
230 sub read
231 {
232  my ($obj,$fh,$name) = @_;
233  my(%tbl, @seq, $enc, @esc, %grp);
234  while (<$fh>)
235   {
236    my ($key,$val) = /^(\S+)\s+(.*)$/;
237    $val =~ s/^\{(.*?)\}/$1/g;
238    $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
239
240    if($enc = Encode->getEncoding($key)){
241      $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
242      push @seq, $val;
243      $grp{$val} =
244         $val =~ m|[(]|  ? 0 : # G0 : SI  eq "\cO"
245         $val =~ m|[)-]| ? 1 : # G1 : SO  eq "\cN"
246         $val =~ m|[*.]| ? 2 : # G2 : SS2 eq "\eN"
247         $val =~ m|[+/]| ? 3 : # G3 : SS3 eq "\eO"
248                           0;  # G0
249    }else{
250      $obj->{$key} = $val;
251    }
252    if($val =~ /^\e(.*)/){ push(@esc, quotemeta $1) }
253   }
254  $obj->{'Grp'} = \%grp; # graphic chars
255  $obj->{'Seq'} = \@seq; # escape sequences
256  $obj->{'Tbl'} = \%tbl; # encoding tables
257  $obj->{'Esc'} = join('|', @esc); # regex of sequences following ESC
258  return $obj;
259 }
260
261 sub decode
262 {
263  my ($obj,$str,$chk) = @_;
264  my $tbl = $obj->{'Tbl'};
265  my $seq = $obj->{'Seq'};
266  my $grp = $obj->{'Grp'};
267  my $esc = $obj->{'Esc'};
268  my $ini = $obj->{'init'};
269  my $fin = $obj->{'final'};
270  my $std = $seq->[0];
271  my $cur = $std;
272  my @sta = ($std, undef, undef, undef); # G0 .. G3 state
273  my($g1,$g2,$g3) = (0,0,0);
274  my $uni;
275  while (length($str)){
276    my $uch = substr($str,0,1,'');
277    if($uch eq "\e"){
278     if($str =~ s/^($esc)//)
279      {
280       my $esc = "\e$1";
281       $sta[ $grp->{$esc} ] = $esc if $tbl->{$esc};
282      }
283     # appearance of "\eN\eO" or "\eO\eN" isn't supposed.
284     # but coincidental ON of G2 and G3 is explicitly avoided.
285     elsif($str =~ s/^N//)
286      {
287       $g2 = 1; $g3 = 0;
288      }
289     elsif($str =~ s/^O//)
290      {
291       $g3 = 1; $g2 = 0;
292      }
293     else
294      {
295       $str =~ s/^([\x20-\x2F]*[\x30-\x7E])//;
296       carp "unknown escape sequence: ESC $1";
297      }
298     next;
299    }
300    if($uch eq "\x0e"){
301     $g1 = 1; next;
302    }
303    if($uch eq "\x0f"){
304     $g1 = 0; next;
305    }
306
307    $cur = $g3 ? $sta[3] : $g2 ? $sta[2] : $g1 ? $sta[1] : $sta[0];
308
309    if(ref($tbl->{$cur}) eq 'Encode::XS'){
310      $uni .= $tbl->{$cur}->decode($uch);
311      $g2 = $g3 = 0;
312      next;
313    }
314    my $ch    = ord($uch);
315    my $rep   = $tbl->{$cur}->{'Rep'};
316    my $touni = $tbl->{$cur}->{'ToUni'};
317    my $x;
318    if (&$rep($ch) eq 'C')
319     {
320      $x = $touni->[0][$ch];
321     }
322    else
323     {
324      $x = $touni->[$ch][ord(substr($str,0,1,''))];
325     }
326    unless (defined $x)
327     {
328      last if $chk;
329      # What do we do here ?
330      $x = '';
331     }
332    $uni .= $x;
333    $g2 = $g3 = 0;
334   }
335  $_[1] = $str if $chk;
336  return $uni;
337 }
338
339 sub encode
340 {
341  my ($obj,$uni,$chk) = @_;
342  my $tbl = $obj->{'Tbl'};
343  my $seq = $obj->{'Seq'};
344  my $grp = $obj->{'Grp'};
345  my $ini = $obj->{'init'};
346  my $fin = $obj->{'final'};
347  my $std = $seq->[0];
348  my $str = $ini;
349  my @sta = ($std,undef,undef,undef);
350  my @pre = ($std,undef,undef,undef);
351  my $cur = $std;
352  my $pG = 0;
353  my $cG = 0;
354
355  if($ini)
356   {
357     $sta[ $grp->{$ini} ] = $pre[ $grp->{$ini} ] = $ini;
358   }
359
360  while (length($uni)){
361   my $ch = substr($uni,0,1,'');
362   my $x;
363   foreach my $e_seq (@$seq){
364    $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
365     ? $tbl->{$e_seq}->encode($ch,1)
366     : $tbl->{$e_seq}->{FmUni}->{$ch};
367    $cur = $e_seq, last if defined $x;
368   }
369   if(ref($tbl->{$cur}) ne 'Encode::XS')
370    {
371     my $def = $tbl->{$cur}->{'Def'};
372     my $rep = $tbl->{$cur}->{'Rep'};
373     unless (defined $x){
374      last if ($chk);
375      $x = $def;
376     }
377     $x = pack(&$rep($x),$x);
378    }
379   $cG   = $grp->{$cur};
380   $str .= $pre[ $cG ] = $cur if $cur ne $pre[ $cG ];
381
382   $str .= $cG == 0 && $pG == 1 ? "\cO" :
383           $cG == 1 && $pG == 0 ? "\cN" :
384           $cG == 2 ? "\eN" :
385           $cG == 3 ? "\eO" :        "";
386   $str .= $x;
387   $pG = $cG if $cG < 2;
388  }
389  $str .= $std  unless $cur eq $std;
390  $str .= "\cO" if $pG == 1; # back to G0
391  $str .= $fin; # necessary?
392  $_[1] = $uni if $chk;
393  return $str;
394 }
395
396 package Encode::Tcl::HanZi;
397 use base 'Encode::Encoding';
398
399 use Carp;
400
401 sub read
402 {
403  my ($obj,$fh,$name) = @_;
404  my(%tbl, @seq, $enc);
405  while (<$fh>)
406   {
407    my ($key,$val) = /^(\S+)\s+(.*)$/;
408    $val =~ s/^\{(.*?)\}/$1/g;
409    $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
410    if($enc = Encode->getEncoding($key)){
411      $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
412      push @seq, $val;
413    }else{
414      $obj->{$key} = $val;
415    }
416   }
417  $obj->{'Seq'} = \@seq; # escape sequences
418  $obj->{'Tbl'} = \%tbl; # encoding tables
419  return $obj;
420 }
421
422 sub decode
423 {
424  my ($obj,$str,$chk) = @_;
425  my $tbl = $obj->{'Tbl'};
426  my $seq = $obj->{'Seq'};
427  my $std = $seq->[0];
428  my $cur = $std;
429  my $uni;
430  while (length($str)){
431    my $uch = substr($str,0,1,'');
432    if($uch eq "~"){
433     if($str =~ s/^\cJ//)
434      {
435       next;
436      }
437     elsif($str =~ s/^\~//)
438      {
439       1;
440      }
441     elsif($str =~ s/^([{}])//)
442      {
443       $cur = "~$1";
444       next;
445      }
446     else
447      {
448       $str =~ s/^([^~])//;
449       carp "unknown HanZi escape sequence: ~$1";
450       next;
451      }
452    }
453    if(ref($tbl->{$cur}) eq 'Encode::XS'){
454      $uni .= $tbl->{$cur}->decode($uch);
455      next;
456    }
457    my $ch    = ord($uch);
458    my $rep   = $tbl->{$cur}->{'Rep'};
459    my $touni = $tbl->{$cur}->{'ToUni'};
460    my $x;
461    if (&$rep($ch) eq 'C')
462     {
463      $x = $touni->[0][$ch];
464     }
465    else
466     {
467      $x = $touni->[$ch][ord(substr($str,0,1,''))];
468     }
469    unless (defined $x)
470     {
471      last if $chk;
472      # What do we do here ?
473      $x = '';
474     }
475    $uni .= $x;
476   }
477  $_[1] = $str if $chk;
478  return $uni;
479 }
480
481 sub encode
482 {
483  my ($obj,$uni,$chk) = @_;
484  my $tbl = $obj->{'Tbl'};
485  my $seq = $obj->{'Seq'};
486  my $std = $seq->[0];
487  my $str;
488  my $pre = $std;
489  my $cur = $pre;
490
491  while (length($uni)){
492   my $ch = chr(ord(substr($uni,0,1,'')));
493   my $x;
494   foreach my $e_seq (@$seq){
495    $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
496     ? $tbl->{$e_seq}->encode($ch,1)
497     : $tbl->{$e_seq}->{FmUni}->{$ch};
498    $cur = $e_seq and last if defined $x;
499   }
500   if(ref($tbl->{$cur}) ne 'Encode::XS')
501    {
502     my $def = $tbl->{$cur}->{'Def'};
503     my $rep = $tbl->{$cur}->{'Rep'};
504     unless (defined $x){
505      last if ($chk);
506      $x = $def;
507     }
508     $x = pack(&$rep($x),$x);
509    }
510   $str .= $cur eq $pre ? $x : ($pre = $cur).$x;
511   $str .= '~' if $x eq '~'; # to '~~'
512  }
513  $str .= $std unless $cur eq $std;
514  $_[1] = $uni if $chk;
515  return $str;
516 }
517
518 1;
519 __END__