local-lib5/lib/perl5/JSON/PP56.pm

   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