develooper Front page | perl.perl5.porters | Postings from July 2001

[PATCH] Encode::Tcl. add "HZ" encoding and bugfix

Thread Next
From:
SADAHIRO Tomoyuki
Date:
July 9, 2001 08:30
Subject:
[PATCH] Encode::Tcl. add "HZ" encoding and bugfix
Message ID:
20010710002756.B497.BQW10602@nifty.com

Hello,
this is a patch to perl@11225 for Encode::Tcl and Tcl.t. 

Changes:
 * add type 'H' and Encode::Tcl::HanZi class for 'HZ' encoding
   (see RFC-1843, "HZ - A Data Format for Exchanging Files of
             Arbitrarily Mixed Chinese and ASCII characters").
   -- the code in the Encode::Tcl::HanZi class is similar
      to that in the Encode::Tcl::Escape class,
      but HanZi has a unique format and 
      does not accords to [ISO2022],
      so it is quite difficult to merge HanZi in type 'E'....
      Is it not appropriate?

 * "iso2022-jp.enc" is to be that in RFC-1468, and 
   "iso2022-kr.enc" is to be that in RFC-1577.
   they'd be fixed.

  so, "7bit-kr.enc" would be removed as it is identical
  to "iso2022-kr.enc".

  but "7bit-jis.enc" is retained, since it includes half-width
  kana letters, while "iso2022-jp.enc" does not.
  (jcode.pl supports the former [one containing half-width kana],
  so, I guess, "7bit-jis.enc" need not be discarded) 

Bug Fix:
 * When an escape-seq. encoding comprises two single-byte encodings,
  ASCII may not be invoked on control chars (NUL, LF, etc.).
  Therefore, ::Escape::encode retrieves the char to be encoded
  from the ASCII table first.
  (the table to which the prev. char belongs is the next.)


[PATCH BEGIN]
diff -ruN orig\Encode/7bit-kana.enc Encode/7bit-kana.enc
--- orig\Encode/7bit-kana.enc	Sat Jun 30 22:47:10 2001
+++ Encode/7bit-kana.enc	Sun Jul 08 22:16:30 2001
@@ -2,8 +2,8 @@
 S
 0025 0 1
 00
-0000000100020003000400050006000700080009000A000B000C000D00000000
-0010001100120013001400150016001700180019001A0000001C001D001E001F
+0000000000000000000000000000000000000000000000000000000000000000
+0000000000000000000000000000000000000000000000000000000000000000
 0000FF61FF62FF63FF64FF65FF66FF67FF68FF69FF6AFF6BFF6CFF6DFF6EFF6F
 FF70FF71FF72FF73FF74FF75FF76FF77FF78FF79FF7AFF7BFF7CFF7DFF7EFF7F
 FF80FF81FF82FF83FF84FF85FF86FF87FF88FF89FF8AFF8BFF8CFF8DFF8EFF8F
Only in orig\Encode: 7bit-kr.enc
diff -ruN orig\Encode/HZ.enc Encode/HZ.enc
--- orig\Encode/HZ.enc	Thu Jan 01 09:00:00 1970
+++ Encode/HZ.enc	Mon Jul 09 21:12:24 2001
@@ -0,0 +1,7 @@
+# Encoding file: HZ, HanZi
+H
+name		HZ
+init		{}
+final		{}
+ascii		\x7e\x7d
+gb2312		\x7e\x7b
diff -ruN orig\Encode/Tcl.pm Encode/Tcl.pm
--- orig\Encode/Tcl.pm	Tue Jul 03 03:08:20 2001
+++ Encode/Tcl.pm	Mon Jul 09 21:17:04 2001
@@ -78,7 +78,7 @@
      $type = substr($line,0,1);
      last unless $type eq '#';
     }
-   my $class = ref($obj).('::'.(($type eq 'E') ? 'Escape' : 'Table'));
+   my $class = ref($obj).('::'.(($type eq 'H') ? 'HanZi' : ($type eq 'E') ? 'Escape' : 'Table'));
    # carp "Loading $file";
    bless $obj,$class;
    return $obj if $obj->read($fh,$obj->name,$type);
@@ -323,46 +323,152 @@
 
  while (length($uni)){
   my $ch = chr(ord(substr($uni,0,1,'')));
-  my $x  = ref($tbl->{$pre}) eq 'Encode::XS'
-	? $tbl->{$pre}->encode($ch,1)
-	: $tbl->{$pre}->{FmUni}->{$ch};
-
-  unless(defined $x){
-   foreach my $e_seq (@$seq){
-    $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
-	? $tbl->{$e_seq}->encode($ch,1)
-	: $tbl->{$e_seq}->{FmUni}->{$ch};
-    $cur = $e_seq and last if defined $x;
-   }
+  my $x;
+  foreach my $e_seq ($std, $pre, @$seq){
+   $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
+    ? $tbl->{$e_seq}->encode($ch,1)
+    : $tbl->{$e_seq}->{FmUni}->{$ch};
+   $cur = $e_seq and last if defined $x;
   }
-  if($x == 0x0d && !($ini eq '' && $fin eq '') && substr($uni,0,1) eq "\x0a")
+  if(ref($tbl->{$cur}) ne 'Encode::XS')
    {
-    $str .= $cur unless $cur eq $pre;
-    $str .= $fin."\x0d\x0a".$ini;
-    substr($uni,0,1,'');
-    $pre = $std;
-    next;
+    my $def = $tbl->{$cur}->{'Def'};
+    my $rep = $tbl->{$cur}->{'Rep'};
+    unless (defined $x){
+     last if ($chk);
+     $x = $def;
+    }
+    $x = pack(&$rep($x),$x);
    }
-  if(ref($tbl->{$cur}) eq 'Encode::XS'){
-   $str .= $cur unless $cur eq $pre;
-   $str .= $x; # "DEF" is lost
-   $pre = $cur;
-   next;
-  }
-  my $def = $tbl->{$cur}->{'Def'};
-  my $rep = $tbl->{$cur}->{'Rep'};
-  unless (defined $x){
-   last if ($chk);
-   $x = $def;
-  }
-  $str .= $cur unless $cur eq $pre;
-  $str .= pack(&$rep($x),$x);
-  $pre = $cur;
+  $str .= $cur eq $pre ? $x : ($pre = $cur).$x;
  }
  $str .= $std unless $cur eq $std;
  $str .= $fin;
  $_[1] = $uni if $chk;
  return $str;
 }
+
+package Encode::Tcl::HanZi;
+use base 'Encode::Encoding';
+
+use Carp;
+
+sub read
+{
+ my ($obj,$fh,$name) = @_;
+ my(%tbl, @seq, $enc);
+ while (<$fh>)
+  {
+   my ($key,$val) = /^(\S+)\s+(.*)$/;
+   $val =~ s/^\{(.*?)\}/$1/g;
+   $val =~ s/\\x([0-9a-f]{2})/chr(hex($1))/ge;
+   if($enc = Encode->getEncoding($key)){
+     $tbl{$val} = ref($enc) eq 'Encode::Tcl' ? $enc->loadEncoding : $enc;
+     push @seq, $val;
+   }else{
+     $obj->{$key} = $val;
+   }
+  }
+ $obj->{'Seq'} = \@seq; # escape sequences
+ $obj->{'Tbl'} = \%tbl; # encoding tables
+ return $obj;
+}
+
+sub decode
+{
+ my ($obj,$str,$chk) = @_;
+ my $tbl = $obj->{'Tbl'};
+ my $seq = $obj->{'Seq'};
+ my $std = $seq->[0];
+ my $cur = $std;
+ my $uni;
+ while (length($str)){
+   my $uch = substr($str,0,1,'');
+   if($uch eq "~"){
+    if($str =~ s/^\cJ//)
+     {
+      next;
+     }
+    elsif($str =~ s/^\~//)
+     {
+      1;
+     }
+    elsif($str =~ s/^([{}])//)
+     {
+      $cur = "~$1";
+      next;
+     }
+    else
+     {
+      $str =~ s/^([^~])//;
+      carp "unknown HanZi escape sequence: ~$1";
+      next;
+     }
+   }
+   if(ref($tbl->{$cur}) eq 'Encode::XS'){
+     $uni .= $tbl->{$cur}->decode($uch);
+     next;
+   }
+   my $ch    = ord($uch);
+   my $rep   = $tbl->{$cur}->{'Rep'};
+   my $touni = $tbl->{$cur}->{'ToUni'};
+   my $x;
+   if (&$rep($ch) eq 'C')
+    {
+     $x = $touni->[0][$ch];
+    }
+   else
+    {
+     $x = $touni->[$ch][ord(substr($str,0,1,''))];
+    }
+   unless (defined $x)
+    {
+     last if $chk;
+     # What do we do here ?
+     $x = '';
+    }
+   $uni .= $x;
+  }
+ $_[1] = $str if $chk;
+ return $uni;
+}
+
+sub encode
+{
+ my ($obj,$uni,$chk) = @_;
+ my $tbl = $obj->{'Tbl'};
+ my $seq = $obj->{'Seq'};
+ my $std = $seq->[0];
+ my $str;
+ my $pre = $std;
+ my $cur = $pre;
+
+ while (length($uni)){
+  my $ch = chr(ord(substr($uni,0,1,'')));
+  my $x;
+  foreach my $e_seq (@$seq){
+   $x = ref($tbl->{$e_seq}) eq 'Encode::XS'
+    ? $tbl->{$e_seq}->encode($ch,1)
+    : $tbl->{$e_seq}->{FmUni}->{$ch};
+   $cur = $e_seq and last if defined $x;
+  }
+  if(ref($tbl->{$cur}) ne 'Encode::XS')
+   {
+    my $def = $tbl->{$cur}->{'Def'};
+    my $rep = $tbl->{$cur}->{'Rep'};
+    unless (defined $x){
+     last if ($chk);
+     $x = $def;
+    }
+    $x = pack(&$rep($x),$x);
+   }
+  $str .= $cur eq $pre ? $x : ($pre = $cur).$x;
+  $str .= '~' if $x eq '~'; # to '~~'
+ }
+ $str .= $std unless $cur eq $std;
+ $_[1] = $uni if $chk;
+ return $str;
+}
+
 1;
 __END__
diff -ruN orig\Encode/Tcl.t Encode/Tcl.t
--- orig\Encode/Tcl.t	Tue Jul 03 03:20:22 2001
+++ Encode/Tcl.t	Mon Jul 09 23:51:40 2001
@@ -42,7 +42,7 @@
 my @ideodigit = qw(one two three four five six seven eight nine ten);
 
 my $jis = '7bit-jis';
-my $kr  = '7bit-kr';
+my $kr  = 'iso2022-kr';
 my %esc_str;
 
 $esc_str{$jis} = {qw(
@@ -70,8 +70,19 @@
 my $num_esc = $n * keys(%esc_str);
 foreach (values %esc_str){ $num_esc += $n * keys %$_ }
 
+my $hz = 'HZ'; # HanZi
+
+my @hz_txt = (
+  "~~in GB.~{<:Ky2;S{#,NpJ)l6HK!#~}Bye.~~",
+  "~~in GB.~{<:Ky2;S{#,~}~\cJ~{NpJ)l6HK!#~}Bye.~~",
+  "~~in GB.~\cJ~{<:Ky2;S{#,NpJ)l6HK!#~}~\cJBye.~~",
+);
+
+my $hz_exp = '007e0069006e002000470042002e5df162404e0d6b32'
+ . 'ff0c52ff65bd65bc4eba3002004200790065002e007e';
+
 plan test => $n*@encodings + $n*@encodings*@greek
-  + $n*@encodings*@ideodigit + $num_esc;
+  + $n*@encodings*@ideodigit + $num_esc + $n + @hz_txt;
 
 foreach my $enc (@encodings)
  {
@@ -141,5 +152,33 @@
     }
    ok(to_unicode($enc, keys %strings), join('', values %strings),
    "$enc mangled translating to Unicode");
+  }
+}
+
+
+{
+ my $hz_to_unicode = sub
+  {
+   return unpack('H*', pack 'n*', unpack 'U*', decode $hz, shift);
+  };
+
+ my $hz_from_unicode = sub
+  {
+   return encode($hz, pack 'U*', unpack 'n*', pack 'H*', shift);
+  };
+
+ foreach my $enc ($hz)
+  {
+   my $tab = Encode->getEncoding($enc);
+   ok(1,defined($tab),"Could not load $enc");
+
+   ok(&$hz_from_unicode($hz_exp), $hz_txt[0],
+       "$enc mangled translating from Unicode");
+
+   foreach my $str (@hz_txt)
+    {
+     ok(&$hz_to_unicode($str), $hz_exp,
+      "$enc mangled translating to Unicode");
+    }
   }
 }
diff -ruN orig\Encode/iso2022-jp.enc Encode/iso2022-jp.enc
--- orig\Encode/iso2022-jp.enc	Tue Jun 26 22:27:06 2001
+++ Encode/iso2022-jp.enc	Mon Jul 09 02:07:00 2001
@@ -3,10 +3,7 @@
 name		iso2022-jp
 init		{}
 final		{}
-iso8859-1	\x1b(B
-jis0201		\x1b(J
-jis0208		\x1b$@
+ascii		\x1b(B
+ascii		\x1b(J
 jis0208		\x1b$B
-jis0212		\x1b$(D
-gb2312		\x1b$A
-ksc5601		\x1b$(C
+jis0208		\x1b$@
diff -ruN orig\Encode/iso2022-kr.enc Encode/iso2022-kr.enc
--- orig\Encode/iso2022-kr.enc	Tue Jun 26 22:27:06 2001
+++ Encode/iso2022-kr.enc	Mon Jul 09 02:04:12 2001
@@ -3,5 +3,5 @@
 name		iso2022-kr
 init		\x1b$)C
 final		{}
-iso8859-1	\x0f
+ascii		\x0f
 ksc5601		\x0e
[PATCH END]

-----
SADAHIRO Tomoyuki
E-mail: bqw10602@nifty.com


Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About