line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
package Encode::CN::HZ; |
2
|
|
|
|
|
|
|
3
|
6
|
|
|
6
|
813404
|
use strict; |
|
6
|
|
|
|
20
|
|
|
6
|
|
|
|
250
|
|
4
|
6
|
|
|
6
|
63
|
use warnings; |
|
6
|
|
|
|
16
|
|
|
6
|
|
|
|
191
|
|
5
|
6
|
|
|
6
|
2361
|
use utf8 (); |
|
6
|
|
|
|
60
|
|
|
6
|
|
|
|
177
|
|
6
|
|
|
|
|
|
|
7
|
6
|
|
|
6
|
36
|
use vars qw($VERSION); |
|
6
|
|
|
|
15
|
|
|
6
|
|
|
|
675
|
|
8
|
|
|
|
|
|
$VERSION = do { my @r = ( q$Revision: 2.6 $ =~ /\d+/g ); sprintf "%d." . "%02d" x $#r, @r }; |
9
|
|
|
|
|
|
|
10
|
6
|
|
|
6
|
34
|
use Encode qw(:fallbacks); |
|
6
|
|
|
|
16
|
|
|
6
|
|
|
|
1464
|
|
11
|
|
|
|
|
|
|
12
|
6
|
|
|
6
|
86
|
use base qw(Encode::Encoding); |
|
6
|
|
|
|
16
|
|
|
6
|
|
|
|
547
|
|
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
|
|
|
|
|
|
|
20
|
4
|
|
|
4
|
5846
|
sub needs_lines { 1 } |
21
|
|
|
|
|
|
|
22
|
|
|
|
|
|
sub decode ($$;$) { |
23
|
9
|
|
|
9
|
1280
|
my ( $obj, $str, $chk ) = @_; |
24
|
|
|
|
|
|
|
25
|
9
|
|
|
|
39
|
my $GB = Encode::find_encoding('gb2312-raw'); |
26
|
9
|
|
|
|
138
|
my $ret = substr($str, 0, 0); # to propagate taintedness |
27
|
9
|
|
|
|
22
|
my $in_ascii = 1; # default mode is ASCII. |
28
|
|
|
|
|
|
|
29
|
9
|
|
|
|
37
|
while ( length $str ) { |
30
|
3009
|
100
|
|
|
6113
|
if ($in_ascii) { # ASCII mode |
31
|
1507
|
100
|
|
|
10247
|
if ( $str =~ s/^([\x00-\x7D\x7F]+)// ) { # no '~' => ASCII |
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
50
|
|
|
|
|
32
|
756
|
|
|
|
3327
|
$ret .= $1; |
33
|
|
|
|
|
|
|
34
|
|
|
|
|
|
# EBCDIC should need ascii2native, but not ported. |
35
|
|
|
|
|
|
} |
36
|
|
|
|
|
|
elsif ( $str =~ s/^\x7E\x7E// ) { # escaped tilde |
37
|
0
|
|
|
|
0
|
$ret .= '~'; |
38
|
|
|
|
|
|
} |
39
|
|
|
|
|
|
elsif ( $str =~ s/^\x7E\cJ// ) { # '\cJ' == LF in ASCII |
40
|
0
|
|
|
|
0
|
1; # no-op |
41
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
elsif ( $str =~ s/^\x7E\x7B// ) { # '~{' |
43
|
751
|
|
|
|
2252
|
$in_ascii = 0; # to GB |
44
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
else { # encounters an invalid escape, \x80 or greater |
46
|
0
|
|
|
|
0
|
last; |
47
|
|
|
|
|
|
} |
48
|
|
|
|
|
|
} |
49
|
|
|
|
|
|
else { # GB mode; the byte ranges are as in RFC 1843. |
50
|
6
|
|
|
6
|
2301
|
no warnings 'uninitialized'; |
|
6
|
|
|
|
23
|
|
|
6
|
|
|
|
5410
|
|
51
|
1502
|
100
|
|
|
10001
|
if ( $str =~ s/^((?:[\x21-\x77][\x21-\x7E])+)// ) { |
|
|
50
|
|
|
|
|
52
|
751
|
|
|
|
6953
|
$ret .= $GB->decode( $1, $chk ); |
53
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
elsif ( $str =~ s/^\x7E\x7D// ) { # '~}' |
55
|
751
|
|
|
|
2189
|
$in_ascii = 1; |
56
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
else { # invalid |
58
|
0
|
|
|
|
0
|
last; |
59
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
} |
62
|
9
|
100
|
|
|
37
|
$_[1] = '' if $chk; # needs_lines guarantees no partial character |
63
|
9
|
|
|
|
468
|
return $ret; |
64
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
66
|
|
|
|
|
|
sub cat_decode { |
67
|
0
|
|
|
0
|
0
|
my ( $obj, undef, $src, $pos, $trm, $chk ) = @_; |
68
|
0
|
|
|
|
0
|
my ( $rdst, $rsrc, $rpos ) = \@_[ 1 .. 3 ]; |
69
|
|
|
|
|
|
|
70
|
0
|
|
|
|
0
|
my $GB = Encode::find_encoding('gb2312-raw'); |
71
|
0
|
|
|
|
0
|
my $ret = ''; |
72
|
0
|
|
|
|
0
|
my $in_ascii = 1; # default mode is ASCII. |
73
|
|
|
|
|
|
|
74
|
0
|
|
|
|
0
|
my $ini_pos = pos($$rsrc); |
75
|
|
|
|
|
|
|
76
|
0
|
|
|
|
0
|
substr( $src, 0, $pos ) = ''; |
77
|
|
|
|
|
|
|
78
|
0
|
|
|
|
0
|
my $ini_len = bytes::length($src); |
79
|
|
|
|
|
|
|
80
|
|
|
|
|
|
# $trm is the first of the pair '~~', then 2nd tilde is to be removed. |
81
|
|
|
|
|
|
# XXX: Is better C<$src =~ s/^\x7E// or die if ...>? |
82
|
0
|
0
|
|
|
0
|
$src =~ s/^\x7E// if $trm eq "\x7E"; |
83
|
|
|
|
|
|
|
84
|
0
|
|
|
|
0
|
while ( length $src ) { |
85
|
0
|
|
|
|
0
|
my $now; |
86
|
0
|
0
|
|
|
0
|
if ($in_ascii) { # ASCII mode |
87
|
0
|
0
|
|
|
0
|
if ( $src =~ s/^([\x00-\x7D\x7F])// ) { # no '~' => ASCII |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
88
|
0
|
|
|
|
0
|
$now = $1; |
89
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
elsif ( $src =~ s/^\x7E\x7E// ) { # escaped tilde |
91
|
0
|
|
|
|
0
|
$now = '~'; |
92
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
elsif ( $src =~ s/^\x7E\cJ// ) { # '\cJ' == LF in ASCII |
94
|
0
|
|
|
|
0
|
next; |
95
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
elsif ( $src =~ s/^\x7E\x7B// ) { # '~{' |
97
|
0
|
|
|
|
0
|
$in_ascii = 0; # to GB |
98
|
0
|
|
|
|
0
|
next; |
99
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
else { # encounters an invalid escape, \x80 or greater |
101
|
0
|
|
|
|
0
|
last; |
102
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
else { # GB mode; the byte ranges are as in RFC 1843. |
105
|
0
|
0
|
|
|
0
|
if ( $src =~ s/^((?:[\x21-\x77][\x21-\x7F])+)// ) { |
|
|
0
|
|
|
|
|
106
|
0
|
|
|
|
0
|
$now = $GB->decode( $1, $chk ); |
107
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
elsif ( $src =~ s/^\x7E\x7D// ) { # '~}' |
109
|
0
|
|
|
|
0
|
$in_ascii = 1; |
110
|
0
|
|
|
|
0
|
next; |
111
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
else { # invalid |
113
|
0
|
|
|
|
0
|
last; |
114
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
117
|
0
|
0
|
|
|
0
|
next if !defined $now; |
118
|
|
|
|
|
|
|
119
|
0
|
|
|
|
0
|
$ret .= $now; |
120
|
|
|
|
|
|
|
121
|
0
|
0
|
|
|
0
|
if ( $now eq $trm ) { |
122
|
0
|
|
|
|
0
|
$$rdst .= $ret; |
123
|
0
|
|
|
|
0
|
$$rpos = $ini_pos + $pos + $ini_len - bytes::length($src); |
124
|
0
|
|
|
|
0
|
pos($$rsrc) = $ini_pos; |
125
|
0
|
|
|
|
0
|
return 1; |
126
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
} |
128
|
|
|
|
|
|
|
129
|
0
|
|
|
|
0
|
$$rdst .= $ret; |
130
|
0
|
|
|
|
0
|
$$rpos = $ini_pos + $pos + $ini_len - bytes::length($src); |
131
|
0
|
|
|
|
0
|
pos($$rsrc) = $ini_pos; |
132
|
0
|
|
|
|
0
|
return ''; # terminator not found |
133
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
135
|
|
|
|
|
|
sub encode($$;$) { |
136
|
488
|
|
|
488
|
37941
|
my ( $obj, $str, $chk ) = @_; |
137
|
|
|
|
|
|
|
138
|
488
|
|
|
|
1626
|
my $GB = Encode::find_encoding('gb2312-raw'); |
139
|
488
|
|
|
|
7415
|
my $ret = substr($str, 0, 0); # to propagate taintedness; |
140
|
488
|
|
|
|
925
|
my $in_ascii = 1; # default mode is ASCII. |
141
|
|
|
|
|
|
|
142
|
6
|
|
|
6
|
39
|
no warnings 'utf8'; # $str may be malformed UTF8 at the end of a chunk. |
|
6
|
|
|
|
15
|
|
|
6
|
|
|
|
2584
|
|
143
|
|
|
|
|
|
|
144
|
488
|
|
|
|
1414
|
while ( length $str ) { |
145
|
31434
|
100
|
|
|
1007765
|
if ( $str =~ s/^([[:ascii:]]+)// ) { |
|
|
50
|
|
|
|
|
146
|
1480
|
|
|
|
3836
|
my $tmp = $1; |
147
|
1480
|
|
|
|
3317
|
$tmp =~ s/~/~~/g; # escapes tildes |
148
|
1480
|
100
|
|
|
3834
|
if ( !$in_ascii ) { |
149
|
994
|
|
|
|
2195
|
$ret .= "\x7E\x7D"; # '~}' |
150
|
994
|
|
|
|
2129
|
$in_ascii = 1; |
151
|
|
|
|
|
|
} |
152
|
1480
|
|
|
|
20267
|
$ret .= pack 'a*', $tmp; # remove UTF8 flag. |
153
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
elsif ( $str =~ s/(.)// ) { |
155
|
29954
|
|
|
|
73875
|
my $s = $1; |
156
|
29954
|
|
|
|
117476
|
my $tmp = $GB->encode( $s, $chk ); |
157
|
29954
|
50
|
|
|
83985
|
last if !defined $tmp; |
158
|
29954
|
50
|
|
|
71417
|
if ( length $tmp == 2 ) { # maybe a valid GB char (XXX) |
|
|
0
|
|
|
|
|
159
|
29954
|
100
|
|
|
72975
|
if ($in_ascii) { |
160
|
996
|
|
|
|
2244
|
$ret .= "\x7E\x7B"; # '~{' |
161
|
996
|
|
|
|
1934
|
$in_ascii = 0; |
162
|
|
|
|
|
|
} |
163
|
29954
|
|
|
|
492816
|
$ret .= $tmp; |
164
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
elsif ( length $tmp ) { # maybe FALLBACK in ASCII (XXX) |
166
|
0
|
0
|
|
|
0
|
if ( !$in_ascii ) { |
167
|
0
|
|
|
|
0
|
$ret .= "\x7E\x7D"; # '~}' |
168
|
0
|
|
|
|
0
|
$in_ascii = 1; |
169
|
|
|
|
|
|
} |
170
|
0
|
|
|
|
0
|
$ret .= $tmp; |
171
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
else { # if $str is malformed UTF8 *and* if length $str != 0. |
174
|
0
|
|
|
|
0
|
last; |
175
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
} |
177
|
488
|
100
|
|
|
1584
|
$_[1] = $str if $chk; |
178
|
|
|
|
|
|
|
179
|
|
|
|
|
|
# The state at the end of the chunk is discarded, even if in GB mode. |
180
|
|
|
|
|
|
# That results in the combination of GB-OUT and GB-IN, i.e. "~}~{". |
181
|
|
|
|
|
|
# Parhaps it is harmless, but further investigations may be required... |
182
|
|
|
|
|
|
|
183
|
488
|
100
|
|
|
1178
|
if ( !$in_ascii ) { |
184
|
2
|
|
|
|
6
|
$ret .= "\x7E\x7D"; # '~}' |
185
|
2
|
|
|
|
5
|
$in_ascii = 1; |
186
|
|
|
|
|
|
} |
187
|
488
|
|
|
|
1199
|
utf8::encode($ret); # https://rt.cpan.org/Ticket/Display.html?id=35120 |
188
|
488
|
|
|
|
6811
|
return $ret; |
189
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
191
|
|
|
|
|
|
1; |
192
|
|
|
|
|
|
__END__ |