home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / perl5 / JSON / PP56.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-02  |  4.3 KB  |  199 lines
  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.  
  199.