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