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