Commit | Line | Data |
3fea05b9 |
1 | package JSON::PP56; |
2 | |
3 | use 5.006; |
4 | use strict; |
5 | |
6 | my @properties; |
7 | |
8 | $JSON::PP56::VERSION = '1.08'; |
9 | |
10 | BEGIN { |
11 | |
12 | sub utf8::is_utf8 { |
13 | my $len = length $_[0]; # char length |
14 | { |
15 | use bytes; # byte length; |
16 | return $len != length $_[0]; # if !=, UTF8-flagged on. |
17 | } |
18 | } |
19 | |
20 | |
21 | sub utf8::upgrade { |
22 | ; # noop; |
23 | } |
24 | |
25 | |
26 | sub utf8::downgrade ($;$) { |
27 | return 1 unless ( utf8::is_utf8( $_[0] ) ); |
28 | |
29 | if ( _is_valid_utf8( $_[0] ) ) { |
30 | my $downgrade; |
31 | for my $c ( unpack( "U*", $_[0] ) ) { |
32 | if ( $c < 256 ) { |
33 | $downgrade .= pack("C", $c); |
34 | } |
35 | else { |
36 | $downgrade .= pack("U", $c); |
37 | } |
38 | } |
39 | $_[0] = $downgrade; |
40 | return 1; |
41 | } |
42 | else { |
43 | Carp::croak("Wide character in subroutine entry") unless ( $_[1] ); |
44 | 0; |
45 | } |
46 | } |
47 | |
48 | |
49 | sub utf8::encode ($) { # UTF8 flag off |
50 | if ( utf8::is_utf8( $_[0] ) ) { |
51 | $_[0] = pack( "C*", unpack( "C*", $_[0] ) ); |
52 | } |
53 | else { |
54 | $_[0] = pack( "U*", unpack( "C*", $_[0] ) ); |
55 | $_[0] = pack( "C*", unpack( "C*", $_[0] ) ); |
56 | } |
57 | } |
58 | |
59 | |
60 | sub utf8::decode ($) { # UTF8 flag on |
61 | if ( _is_valid_utf8( $_[0] ) ) { |
62 | utf8::downgrade( $_[0] ); |
63 | $_[0] = pack( "U*", unpack( "U*", $_[0] ) ); |
64 | } |
65 | } |
66 | |
67 | |
68 | *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; |
69 | *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; |
70 | *JSON::PP::JSON_PP_decode_surrogates = \&JSON::PP::_decode_surrogates; |
71 | *JSON::PP::JSON_PP_decode_unicode = \&JSON::PP::_decode_unicode; |
72 | |
73 | unless ( defined &B::SVp_NOK ) { # missing in B module. |
74 | eval q{ sub B::SVp_NOK () { 0x02000000; } }; |
75 | } |
76 | |
77 | } |
78 | |
79 | |
80 | |
81 | sub _encode_ascii { |
82 | join('', |
83 | map { |
84 | $_ <= 127 ? |
85 | chr($_) : |
86 | $_ <= 65535 ? |
87 | sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_)); |
88 | } _unpack_emu($_[0]) |
89 | ); |
90 | } |
91 | |
92 | |
93 | sub _encode_latin1 { |
94 | join('', |
95 | map { |
96 | $_ <= 255 ? |
97 | chr($_) : |
98 | $_ <= 65535 ? |
99 | sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_)); |
100 | } _unpack_emu($_[0]) |
101 | ); |
102 | } |
103 | |
104 | |
105 | sub _unpack_emu { # for Perl 5.6 unpack warnings |
106 | return !utf8::is_utf8($_[0]) ? unpack('C*', $_[0]) |
107 | : _is_valid_utf8($_[0]) ? unpack('U*', $_[0]) |
108 | : unpack('C*', $_[0]); |
109 | } |
110 | |
111 | |
112 | sub _is_valid_utf8 { |
113 | my $str = $_[0]; |
114 | my $is_utf8; |
115 | |
116 | while ($str =~ /(?: |
117 | ( |
118 | [\x00-\x7F] |
119 | |[\xC2-\xDF][\x80-\xBF] |
120 | |[\xE0][\xA0-\xBF][\x80-\xBF] |
121 | |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] |
122 | |[\xED][\x80-\x9F][\x80-\xBF] |
123 | |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] |
124 | |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] |
125 | |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] |
126 | |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] |
127 | ) |
128 | | (.) |
129 | )/xg) |
130 | { |
131 | if (defined $1) { |
132 | $is_utf8 = 1 if (!defined $is_utf8); |
133 | } |
134 | else { |
135 | $is_utf8 = 0 if (!defined $is_utf8); |
136 | if ($is_utf8) { # eventually, not utf8 |
137 | return; |
138 | } |
139 | } |
140 | } |
141 | |
142 | return $is_utf8; |
143 | } |
144 | |
145 | |
146 | sub JSON::PP::incr_parse { |
147 | local $Carp::CarpLevel = 1; |
148 | ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ ); |
149 | } |
150 | |
151 | |
152 | sub JSON::PP::incr_text : lvalue { |
153 | $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; |
154 | |
155 | if ( $_[0]->{_incr_parser}->{incr_parsing} ) { |
156 | Carp::croak("incr_text can not be called when the incremental parser already started parsing"); |
157 | } |
158 | $_[0]->{_incr_parser}->{incr_text}; |
159 | } |
160 | |
161 | |
162 | sub JSON::PP::incr_skip { |
163 | ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip; |
164 | } |
165 | |
166 | |
167 | sub JSON::PP::incr_reset { |
168 | ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset; |
169 | } |
170 | |
171 | |
172 | 1; |
173 | __END__ |
174 | |
175 | =pod |
176 | |
177 | =head1 NAME |
178 | |
179 | JSON::PP56 - Helper module in using JSON::PP in Perl 5.6 |
180 | |
181 | =head1 DESCRIPTION |
182 | |
183 | JSON::PP calls internally. |
184 | |
185 | =head1 AUTHOR |
186 | |
187 | Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt> |
188 | |
189 | |
190 | =head1 COPYRIGHT AND LICENSE |
191 | |
192 | Copyright 2007-2009 by Makamaka Hannyaharamitu |
193 | |
194 | This library is free software; you can redistribute it and/or modify |
195 | it under the same terms as Perl itself. |
196 | |
197 | =cut |
198 | |