Blame lib/Encode/CN/HZ.pm

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