1package Encode::CN::HZ; 2 3use strict; 4 5use 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 9use Encode qw(:fallbacks); 10 11use 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 19sub needs_lines { 1 } 20 21sub 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 64sub 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 134sub 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 1891; 190__END__ 191 192=head1 NAME 193 194Encode::CN::HZ -- internally used by Encode::CN 195 196=cut 197