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.3 $ =~ /\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 only escaped GB, so we implement it with the
  13 # GB2312(raw) encoding here. Cf. RFCs 1842 & 1843.
  14
  15 my $canon = 'hz';
  16 my $obj = bless {name => $canon}, __PACKAGE__;
  17 $obj->Define($canon);
  18
  19 sub needs_lines  { 1 }
  20
  21 sub perlio_ok {
  22     return 0; # for the time being
  23 }
  24
  25 sub decode
  26 {
  27     my ($obj,$str,$chk) = @_;
  28     my $gb = Encode::find_encoding('gb2312-raw');
  29
  30     $str =~ s{~                 # starting tilde
  31         (?:
  32             (~)                 # another tilde - escaped (set $1)
  33                 |               #     or
  34             \n                  # \n - output nothing
  35                 |               #     or
  36             \{                  # opening brace of GB data
  37                 (               #  set $2 to any number of...
  38                     (?:
  39                         [^~]    #  non-tilde GB character
  40                             |   #     or
  41                         ~(?!\}) #  tilde not followed by a closing brace
  42                     )*
  43                 )
  44             ~\}                 # closing brace of GB data
  45                 |               # XXX: invalid escape - maybe die on $chk?
  46         )
  47     }{
  48         (defined $1)    ? '~'                   # two tildes make one tilde
  49             :
  50         (defined $2)    ? $gb->decode($2, $chk) # decode the characters
  51             :
  52         ''                                      # ~\n and invalid escape = ''
  53     }egx;
  54
  55     return $str;
  56 }
  57
  58 sub encode
  59 {
  60     my ($obj,$str,$chk) = @_;
  61     my ($out, $in_gb);
  62     my $gb = Encode::find_encoding('gb2312-raw');
  63
  64     $str =~ s/~/~~/g;
  65
  66     # XXX: Since CHECK and partial decoding has not been implemented yet,
  67     #      we'll use a very crude way to test for GB2312ness.
  68
  69     for my $index (0 .. length($str) - 1) {
  70         no warnings 'utf8';
  71
  72         my $char = substr($str, $index, 1);
  73         # try to encode this character
  74         # with CHECK on so it stops at proper place.
  75         # also note that the assignement was braced in eval
  76         #  -- dankogai
  77         my $try;
  78         eval{ $try = $gb->encode($char, 1) };
  79
  80         if (defined($try)) {            # is a GB character:
  81             if ($in_gb) {
  82                 $out .= $try;           #  in GB mode - just append it
  83             }
  84             else {
  85                 $in_gb = 1;             #  enter GB mode, then append it
  86                 $out .= "~{$try";
  87             }
  88         }                               # not a GB character:
  89         elsif ($in_gb) {
  90             $in_gb = 0;                 #  leave GB mode, then append it
  91             $out .= "~}$char";
  92         }
  93         else {
  94             $out .= $char;              #  not in GB mode - just append it
  95         }
  96     }
  97
  98     $out .= '~}' if $in_gb;             # add closing brace if needed
  99
 100     return $out;
 101 }
 102
 103 1;
 104 __END__
 105
 106
 107 =head1 NAME
 108
 109 Encode::CN::HZ -- internally used by Encode::CN
 110
 111 =cut