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_surrogates($_)); 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_surrogates($_)); 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-2009 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
This page was automatically generated by LXR 0.3.1. • OpenWrt