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.1 $ =~ /\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         # try to encode this character
  68         # with CHECK on so it stops at proper place.
  69         # also note that the assignement was braced in eval
  70         #  -- dankogai
  71         my $try;
  72         eval{ $try = $gb->encode($char, 1) };
  73
  74         if (defined($try)) {            # is a GB character:
  75             if ($in_gb) {
  76                 $out .= $try;           #  in GB mode - just append it
  77             }
  78             else {
  79                 $in_gb = 1;             #  enter GB mode, then append it
  80                 $out .= "~{$try";
  81             }
  82         }                               # not a GB character:
  83         elsif ($in_gb) {
  84             $in_gb = 0;                 #  leave GB mode, then append it
  85             $out .= "~}$char";
  86         }
  87         else {
  88             $out .= $char;              #  not in GB mode - just append it
  89         }
  90     }
  91
  92     $out .= '~}' if $in_gb;             # add closing brace if needed
  93
  94     return $out;
  95 }
  96
  97 1;
  98 __END__
  99
 100
 101 =head1 NAME
 102
 103 Encode::CN::HZ -- internally used by Encode::CN
 104
 105 =cut