Commit | Line | Data |
3fea05b9 |
1 | package JSON::PP5005; |
2 | |
3 | use 5.005; |
4 | use strict; |
5 | |
6 | my @properties; |
7 | |
8 | $JSON::PP5005::VERSION = '1.09'; |
9 | |
10 | BEGIN { |
11 | |
12 | sub utf8::is_utf8 { |
13 | 0; # It is considered that UTF8 flag off for Perl 5.005. |
14 | } |
15 | |
16 | sub utf8::upgrade { |
17 | } |
18 | |
19 | sub utf8::downgrade { |
20 | 1; # must always return true. |
21 | } |
22 | |
23 | sub utf8::encode { |
24 | } |
25 | |
26 | sub utf8::decode { |
27 | } |
28 | |
29 | *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; |
30 | *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; |
31 | *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates; |
32 | *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode; |
33 | |
34 | # missing in B module. |
35 | sub B::SVf_IOK () { 0x00010000; } |
36 | sub B::SVf_NOK () { 0x00020000; } |
37 | sub B::SVf_POK () { 0x00040000; } |
38 | sub B::SVp_IOK () { 0x01000000; } |
39 | sub B::SVp_NOK () { 0x02000000; } |
40 | |
41 | $INC{'bytes.pm'} = 1; # dummy |
42 | } |
43 | |
44 | |
45 | |
46 | sub _encode_ascii { |
47 | join('', map { $_ <= 127 ? chr($_) : sprintf('\u%04x', $_) } unpack('C*', $_[0]) ); |
48 | } |
49 | |
50 | |
51 | sub _encode_latin1 { |
52 | join('', map { chr($_) } unpack('C*', $_[0]) ); |
53 | } |
54 | |
55 | |
56 | sub _decode_surrogates { # from http://homepage1.nifty.com/nomenclator/unicode/ucs_utf.htm |
57 | my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); # from perlunicode |
58 | my $bit = unpack('B32', pack('N', $uni)); |
59 | |
60 | if ( $bit =~ /^00000000000(...)(......)(......)(......)$/ ) { |
61 | my ($w, $x, $y, $z) = ($1, $2, $3, $4); |
62 | return pack('B*', sprintf('11110%s10%s10%s10%s', $w, $x, $y, $z)); |
63 | } |
64 | else { |
65 | Carp::croak("Invalid surrogate pair"); |
66 | } |
67 | } |
68 | |
69 | |
70 | sub _decode_unicode { |
71 | my ($u) = @_; |
72 | my ($utf8bit); |
73 | |
74 | if ( $u =~ /^00([89a-f][0-9a-f])$/i ) { # 0x80-0xff |
75 | return pack( 'H2', $1 ); |
76 | } |
77 | |
78 | my $bit = unpack("B*", pack("H*", $u)); |
79 | |
80 | if ( $bit =~ /^00000(.....)(......)$/ ) { |
81 | $utf8bit = sprintf('110%s10%s', $1, $2); |
82 | } |
83 | elsif ( $bit =~ /^(....)(......)(......)$/ ) { |
84 | $utf8bit = sprintf('1110%s10%s10%s', $1, $2, $3); |
85 | } |
86 | else { |
87 | Carp::croak("Invalid escaped unicode"); |
88 | } |
89 | |
90 | return pack('B*', $utf8bit); |
91 | } |
92 | |
93 | |
94 | sub JSON::PP::incr_parse { |
95 | local $Carp::CarpLevel = 1; |
96 | ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ ); |
97 | } |
98 | |
99 | |
100 | sub JSON::PP::incr_text { |
101 | $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; |
102 | |
103 | if ( $_[0]->{_incr_parser}->{incr_parsing} ) { |
104 | Carp::croak("incr_text can not be called when the incremental parser already started parsing"); |
105 | } |
106 | |
107 | $_[0]->{_incr_parser}->{incr_text} = $_[1] if ( @_ > 1 ); |
108 | $_[0]->{_incr_parser}->{incr_text}; |
109 | } |
110 | |
111 | |
112 | sub JSON::PP::incr_skip { |
113 | ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip; |
114 | } |
115 | |
116 | |
117 | sub JSON::PP::incr_reset { |
118 | ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset; |
119 | } |
120 | |
121 | |
122 | 1; |
123 | __END__ |
124 | |
125 | =pod |
126 | |
127 | =head1 NAME |
128 | |
129 | JSON::PP5005 - Helper module in using JSON::PP in Perl 5.005 |
130 | |
131 | =head1 DESCRIPTION |
132 | |
133 | JSON::PP calls internally. |
134 | |
135 | =head1 AUTHOR |
136 | |
137 | Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt> |
138 | |
139 | |
140 | =head1 COPYRIGHT AND LICENSE |
141 | |
142 | Copyright 2007-2009 by Makamaka Hannyaharamitu |
143 | |
144 | This library is free software; you can redistribute it and/or modify |
145 | it under the same terms as Perl itself. |
146 | |
147 | =cut |
148 | |