data/lib/JSON/backportPP/Compat5006.pm

   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