ext/Encode/lib/Encode/CN/HZ.pm

   1 package Encode::CN::HZ;
   2
   3 use strict;
   4
   5 use vars qw($VERSION);
   6 $VERSION = do { my @r = (q$Revision: 1.0 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
   7
   8 use Encode ();
   9 use Encode::CN;
  10 use base 'Encode::Encoding';
  11
  12 # HZ is but escaped GB, so we implement it with the
  13 # GB2312(raw) encoding here. Cf. RFC 1842 & 1843.
  14
  15 my $canon = 'hz';
  16 my $obj = bless {name => $canon}, __PACKAGE__;
  17 $obj->Define($canon);
  18
  19 sub decode
  20 {
  21     my ($obj,$str,$chk) = @_;
  22     my $gb = Encode::find_encoding('gb2312-raw');
  23
  24     $str =~ s{~                 # starting tilde
  25         (?:
  26             (~)                 # another tilde - escaped (set $1)
  27                 |               #     or
  28             \n                  # \n - output nothing
  29                 |               #     or
  30             \{                  # opening brace of GB data
  31                 (               #  set $2 to any number of...
  32                     (?:
  33                         [^~]    #  non-tilde GB character
  34                             |   #     or
  35                         ~(?!\}) #  tilde not followed by a closing brace
  36                     )*
  37                 )
  38             ~\}                 # closing brace of GB data
  39                 |               # XXX: invalid escape - maybe die on $chk?
  40         )
  41     }{
  42         (defined $1)    ? '~'                   # two tildes make one tilde
  43             :
  44         (defined $2)    ? $gb->decode($2, $chk) # decode the characters
  45             :
  46         ''                                      # ~\n and invalid escape = ''
  47     }egx;
  48
  49     return $str;
  50 }
  51
  52 sub encode
  53 {
  54     my ($obj,$str,$chk) = @_;
  55     my ($out, $in_gb);
  56     my $gb = Encode::find_encoding('gb2312-raw');
  57
  58     $str =~ s/~/~~/g;
  59
  60     # XXX: Since CHECK and partial decoding has not been implemented yet,
  61     #      we'll use a very crude way to test for GB2312ness.
  62
  63     for my $index (0 .. length($str) - 1) {
  64         no warnings 'utf8';
  65
  66         my $char = substr($str, $index, 1);
  67         my $try  = $gb->encode($char);  # try to encode this character
  68
  69         if (defined($try)) {            # is a GB character:
  70             if ($in_gb) {
  71                 $out .= $try;           #  in GB mode - just append it
  72             }
  73             else {
  74                 $in_gb = 1;             #  enter GB mode, then append it
  75                 $out .= "~{$try";
  76             }
  77         }                               # not a GB character:
  78         elsif ($in_gb) {
  79             $in_gb = 0;                 #  leave GB mode, then append it
  80             $out .= "~}$char";
  81         }
  82         else {
  83             $out .= $char;              #  not in GB mode - just append it
  84         }
  85     }
  86
  87     $out .= '~}' if $in_gb;             # add closing brace if needed
  88
  89     return $out;
  90 }
  91
  92 1;
  93 __END__
  94
  95
  96 =head1 NAME
  97
  98 Encode::CN::HZ -- internally used by Encode::CN
  99
 100 =cut