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.5 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
   7 $VERSION = 1.05_01;
   8
   9 use Encode qw(:fallbacks);
  10
  11 use base qw(Encode::Encoding);
  12 __PACKAGE__->Define('hz');
  13
  14 # HZ is a combination of ASCII and escaped GB, so we implement it
  15 # with the GB2312(raw) encoding here. Cf. RFCs 1842 & 1843.
  16
  17 # not ported for EBCDIC.  Which should be used, "~" or "\x7E"?
  18
  19 sub needs_lines  { 1 }
  20
  21 sub decode ($$;$)
  22 {
  23     my ($obj,$str,$chk) = @_;
  24
  25     my $GB = Encode::find_encoding('gb2312-raw');
  26     my $ret = '';
  27     my $in_ascii = 1; # default mode is ASCII.
  28
  29     while (length $str) {
  30         if ($in_ascii) { # ASCII mode
  31             if ($str =~ s/^([\x00-\x7D\x7F]+)//) { # no '~' => ASCII
  32                 $ret .= $1;
  33                 # EBCDIC should need ascii2native, but not ported.
  34             }
  35             elsif ($str =~ s/^\x7E\x7E//) { # escaped tilde
  36                 $ret .= '~';
  37             }
  38             elsif ($str =~ s/^\x7E\cJ//) { # '\cJ' == LF in ASCII
  39                 1; # no-op
  40             }
  41             elsif ($str =~ s/^\x7E\x7B//) { # '~{'
  42                 $in_ascii = 0; # to GB
  43             }
  44             else { # encounters an invalid escape, \x80 or greater
  45                 last;
  46             }
  47         }
  48         else { # GB mode; the byte ranges are as in RFC 1843.
  49             if ($str =~ s/^((?:[\x21-\x77][\x21-\x7E])+)//) {
  50                 $ret .= $GB->decode($1, $chk);
  51             }
  52             elsif ($str =~ s/^\x7E\x7D//) { # '~}'
  53                 $in_ascii = 1;
  54             }
  55             else { # invalid
  56                 last;
  57             }
  58         }
  59     }
  60     $_[1] = '' if $chk; # needs_lines guarantees no partial character
  61     return $ret;
  62 }
  63
  64 sub cat_decode {
  65     my ($obj, undef, $src, $pos, $trm, $chk) = @_;
  66     my ($rdst, $rsrc, $rpos) = \@_[1..3];
  67
  68     my $GB = Encode::find_encoding('gb2312-raw');
  69     my $ret = '';
  70     my $in_ascii = 1; # default mode is ASCII.
  71
  72     my $ini_pos = pos($$rsrc);
  73
  74     substr($src, 0, $pos) = '';
  75
  76     my $ini_len = bytes::length($src);
  77
  78     # $trm is the first of the pair '~~', then 2nd tilde is to be removed.
  79     # XXX: Is better C<$src =~ s/^\x7E// or die if ...>?
  80     $src =~ s/^\x7E// if $trm eq "\x7E";
  81
  82     while (length $src) {
  83         my $now;
  84         if ($in_ascii) { # ASCII mode
  85             if ($src =~ s/^([\x00-\x7D\x7F])//) { # no '~' => ASCII
  86                 $now = $1;
  87             }
  88             elsif ($src =~ s/^\x7E\x7E//) { # escaped tilde
  89                 $now = '~';
  90             }
  91             elsif ($src =~ s/^\x7E\cJ//) { # '\cJ' == LF in ASCII
  92                 next;
  93             }
  94             elsif ($src =~ s/^\x7E\x7B//) { # '~{'
  95                 $in_ascii = 0; # to GB
  96                 next;
  97             }
  98             else { # encounters an invalid escape, \x80 or greater
  99                 last;
 100             }
 101         }
 102         else { # GB mode; the byte ranges are as in RFC 1843.
 103             if ($src =~ s/^((?:[\x21-\x77][\x21-\x7F])+)//) {
 104                 $now = $GB->decode($1, $chk);
 105             }
 106             elsif ($src =~ s/^\x7E\x7D//) { # '~}'
 107                 $in_ascii = 1;
 108                 next;
 109             }
 110             else { # invalid
 111                 last;
 112             }
 113         }
 114
 115         next if ! defined $now;
 116
 117         $ret .= $now;
 118
 119         if ($now eq $trm) {
 120             $$rdst .= $ret;
 121             $$rpos = $ini_pos + $pos + $ini_len - bytes::length($src);
 122             pos($$rsrc) = $ini_pos;
 123             return 1;
 124         }
 125     }
 126
 127     $$rdst .= $ret;
 128     $$rpos = $ini_pos + $pos + $ini_len - bytes::length($src);
 129     pos($$rsrc) = $ini_pos;
 130     return ''; # terminator not found
 131 }
 132
 133
 134 sub encode($$;$)
 135 {
 136     my ($obj,$str,$chk) = @_;
 137
 138     my $GB = Encode::find_encoding('gb2312-raw');
 139     my $ret = '';
 140     my $in_ascii = 1; # default mode is ASCII.
 141
 142     no warnings 'utf8'; # $str may be malformed UTF8 at the end of a chunk.
 143
 144     while (length $str) {
 145         if ($str =~ s/^([[:ascii:]]+)//) {
 146             my $tmp = $1;
 147             $tmp =~ s/~/~~/g; # escapes tildes
 148             if (! $in_ascii) {
 149                 $ret .= "\x7E\x7D"; # '~}'
 150                 $in_ascii = 1;
 151             }
 152             $ret .= pack 'a*', $tmp; # remove UTF8 flag.
 153         }
 154         elsif ($str =~ s/(.)//) {
 155             my $tmp = $GB->encode($1, $chk);
 156             last if !defined $tmp;
 157             if (length $tmp == 2) { # maybe a valid GB char (XXX)
 158                 if ($in_ascii) {
 159                     $ret .= "\x7E\x7B"; # '~{'
 160                     $in_ascii = 0;
 161                 }
 162                 $ret .= $tmp;
 163             }
 164             elsif (length $tmp) { # maybe FALLBACK in ASCII (XXX)
 165                 if (!$in_ascii) {
 166                     $ret .= "\x7E\x7D"; # '~}'
 167                     $in_ascii = 1;
 168                 }
 169                 $ret .= $tmp;
 170             }
 171         }
 172         else { # if $str is malformed UTF8 *and* if length $str != 0.
 173             last;
 174         }
 175     }
 176     $_[1] = $str if $chk;
 177
 178   # The state at the end of the chunk is discarded, even if in GB mode.
 179   # That results in the combination of GB-OUT and GB-IN, i.e. "~}~{".
 180   # Parhaps it is harmless, but further investigations may be required...
 181
 182     if (! $in_ascii) {
 183         $ret .= "\x7E\x7D"; # '~}'
 184         $in_ascii = 1;
 185     }
 186     return $ret;
 187 }
 188
 189 1;
 190 __END__
 191
 192 =head1 NAME
 193
 194 Encode::CN::HZ -- internally used by Encode::CN
 195
 196 =cut