1N/Apackage Encode::CN::HZ;
1N/A
1N/Ause strict;
1N/A
1N/Ause vars qw($VERSION);
1N/A#$VERSION = do { my @r = (q$Revision: 1.5 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
1N/A$VERSION = 1.05_01;
1N/A
1N/Ause Encode qw(:fallbacks);
1N/A
1N/Ause base qw(Encode::Encoding);
1N/A__PACKAGE__->Define('hz');
1N/A
1N/A# HZ is a combination of ASCII and escaped GB, so we implement it
1N/A# with the GB2312(raw) encoding here. Cf. RFCs 1842 & 1843.
1N/A
1N/A# not ported for EBCDIC. Which should be used, "~" or "\x7E"?
1N/A
1N/Asub needs_lines { 1 }
1N/A
1N/Asub decode ($$;$)
1N/A{
1N/A my ($obj,$str,$chk) = @_;
1N/A
1N/A my $GB = Encode::find_encoding('gb2312-raw');
1N/A my $ret = '';
1N/A my $in_ascii = 1; # default mode is ASCII.
1N/A
1N/A while (length $str) {
1N/A if ($in_ascii) { # ASCII mode
1N/A if ($str =~ s/^([\x00-\x7D\x7F]+)//) { # no '~' => ASCII
1N/A $ret .= $1;
1N/A # EBCDIC should need ascii2native, but not ported.
1N/A }
1N/A elsif ($str =~ s/^\x7E\x7E//) { # escaped tilde
1N/A $ret .= '~';
1N/A }
1N/A elsif ($str =~ s/^\x7E\cJ//) { # '\cJ' == LF in ASCII
1N/A 1; # no-op
1N/A }
1N/A elsif ($str =~ s/^\x7E\x7B//) { # '~{'
1N/A $in_ascii = 0; # to GB
1N/A }
1N/A else { # encounters an invalid escape, \x80 or greater
1N/A last;
1N/A }
1N/A }
1N/A else { # GB mode; the byte ranges are as in RFC 1843.
1N/A if ($str =~ s/^((?:[\x21-\x77][\x21-\x7E])+)//) {
1N/A $ret .= $GB->decode($1, $chk);
1N/A }
1N/A elsif ($str =~ s/^\x7E\x7D//) { # '~}'
1N/A $in_ascii = 1;
1N/A }
1N/A else { # invalid
1N/A last;
1N/A }
1N/A }
1N/A }
1N/A $_[1] = '' if $chk; # needs_lines guarantees no partial character
1N/A return $ret;
1N/A}
1N/A
1N/Asub cat_decode {
1N/A my ($obj, undef, $src, $pos, $trm, $chk) = @_;
1N/A my ($rdst, $rsrc, $rpos) = \@_[1..3];
1N/A
1N/A my $GB = Encode::find_encoding('gb2312-raw');
1N/A my $ret = '';
1N/A my $in_ascii = 1; # default mode is ASCII.
1N/A
1N/A my $ini_pos = pos($$rsrc);
1N/A
1N/A substr($src, 0, $pos) = '';
1N/A
1N/A my $ini_len = bytes::length($src);
1N/A
1N/A # $trm is the first of the pair '~~', then 2nd tilde is to be removed.
1N/A # XXX: Is better C<$src =~ s/^\x7E// or die if ...>?
1N/A $src =~ s/^\x7E// if $trm eq "\x7E";
1N/A
1N/A while (length $src) {
1N/A my $now;
1N/A if ($in_ascii) { # ASCII mode
1N/A if ($src =~ s/^([\x00-\x7D\x7F])//) { # no '~' => ASCII
1N/A $now = $1;
1N/A }
1N/A elsif ($src =~ s/^\x7E\x7E//) { # escaped tilde
1N/A $now = '~';
1N/A }
1N/A elsif ($src =~ s/^\x7E\cJ//) { # '\cJ' == LF in ASCII
1N/A next;
1N/A }
1N/A elsif ($src =~ s/^\x7E\x7B//) { # '~{'
1N/A $in_ascii = 0; # to GB
1N/A next;
1N/A }
1N/A else { # encounters an invalid escape, \x80 or greater
1N/A last;
1N/A }
1N/A }
1N/A else { # GB mode; the byte ranges are as in RFC 1843.
1N/A if ($src =~ s/^((?:[\x21-\x77][\x21-\x7F])+)//) {
1N/A $now = $GB->decode($1, $chk);
1N/A }
1N/A elsif ($src =~ s/^\x7E\x7D//) { # '~}'
1N/A $in_ascii = 1;
1N/A next;
1N/A }
1N/A else { # invalid
1N/A last;
1N/A }
1N/A }
1N/A
1N/A next if ! defined $now;
1N/A
1N/A $ret .= $now;
1N/A
1N/A if ($now eq $trm) {
1N/A $$rdst .= $ret;
1N/A $$rpos = $ini_pos + $pos + $ini_len - bytes::length($src);
1N/A pos($$rsrc) = $ini_pos;
1N/A return 1;
1N/A }
1N/A }
1N/A
1N/A $$rdst .= $ret;
1N/A $$rpos = $ini_pos + $pos + $ini_len - bytes::length($src);
1N/A pos($$rsrc) = $ini_pos;
1N/A return ''; # terminator not found
1N/A}
1N/A
1N/A
1N/Asub encode($$;$)
1N/A{
1N/A my ($obj,$str,$chk) = @_;
1N/A
1N/A my $GB = Encode::find_encoding('gb2312-raw');
1N/A my $ret = '';
1N/A my $in_ascii = 1; # default mode is ASCII.
1N/A
1N/A no warnings 'utf8'; # $str may be malformed UTF8 at the end of a chunk.
1N/A
1N/A while (length $str) {
1N/A if ($str =~ s/^([[:ascii:]]+)//) {
1N/A my $tmp = $1;
1N/A $tmp =~ s/~/~~/g; # escapes tildes
1N/A if (! $in_ascii) {
1N/A $ret .= "\x7E\x7D"; # '~}'
1N/A $in_ascii = 1;
1N/A }
1N/A $ret .= pack 'a*', $tmp; # remove UTF8 flag.
1N/A }
1N/A elsif ($str =~ s/(.)//) {
1N/A my $tmp = $GB->encode($1, $chk);
1N/A last if !defined $tmp;
1N/A if (length $tmp == 2) { # maybe a valid GB char (XXX)
1N/A if ($in_ascii) {
1N/A $ret .= "\x7E\x7B"; # '~{'
1N/A $in_ascii = 0;
1N/A }
1N/A $ret .= $tmp;
1N/A }
1N/A elsif (length $tmp) { # maybe FALLBACK in ASCII (XXX)
1N/A if (!$in_ascii) {
1N/A $ret .= "\x7E\x7D"; # '~}'
1N/A $in_ascii = 1;
1N/A }
1N/A $ret .= $tmp;
1N/A }
1N/A }
1N/A else { # if $str is malformed UTF8 *and* if length $str != 0.
1N/A last;
1N/A }
1N/A }
1N/A $_[1] = $str if $chk;
1N/A
1N/A # The state at the end of the chunk is discarded, even if in GB mode.
1N/A # That results in the combination of GB-OUT and GB-IN, i.e. "~}~{".
1N/A # Parhaps it is harmless, but further investigations may be required...
1N/A
1N/A if (! $in_ascii) {
1N/A $ret .= "\x7E\x7D"; # '~}'
1N/A $in_ascii = 1;
1N/A }
1N/A return $ret;
1N/A}
1N/A
1N/A1;
1N/A__END__
1N/A
1N/A=head1 NAME
1N/A
1N/AEncode::CN::HZ -- internally used by Encode::CN
1N/A
1N/A=cut