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

   1 package JSON::PP5005;
   2
   3 use 5.005;
   4 use strict;
   5
   6 my @properties;
   7
   8 $JSON::PP5005::VERSION = '1.09';
   9
  10 BEGIN {
  11
  12     sub utf8::is_utf8 {
  13         0; # It is considered that UTF8 flag off for Perl 5.005.
  14     }
  15
  16     sub utf8::upgrade {
  17     }
  18
  19     sub utf8::downgrade {
  20         1; # must always return true.
  21     }
  22
  23     sub utf8::encode  {
  24     }
  25
  26     sub utf8::decode {
  27     }
  28
  29     *JSON::PP::JSON_PP_encode_ascii      = \&_encode_ascii;
  30     *JSON::PP::JSON_PP_encode_latin1     = \&_encode_latin1;
  31     *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
  32     *JSON::PP::JSON_PP_decode_unicode    = \&_decode_unicode;
  33
  34     # missing in B module.
  35     sub B::SVf_IOK () { 0x00010000; }
  36     sub B::SVf_NOK () { 0x00020000; }
  37     sub B::SVf_POK () { 0x00040000; }
  38     sub B::SVp_IOK () { 0x01000000; }
  39     sub B::SVp_NOK () { 0x02000000; }
  40
  41     $INC{'bytes.pm'} = 1; # dummy
  42 }
  43
  44
  45
  46 sub _encode_ascii {
  47     join('', map { $_ <= 127 ? chr($_) : sprintf('\u%04x', $_) } unpack('C*', $_[0]) );
  48 }
  49
  50
  51 sub _encode_latin1 {
  52     join('', map { chr($_) } unpack('C*', $_[0]) );
  53 }
  54
  55
  56 sub _decode_surrogates { # from http://homepage1.nifty.com/nomenclator/unicode/ucs_utf.htm
  57     my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); # from perlunicode
  58     my $bit = unpack('B32', pack('N', $uni));
  59
  60     if ( $bit =~ /^00000000000(...)(......)(......)(......)$/ ) {
  61         my ($w, $x, $y, $z) = ($1, $2, $3, $4);
  62         return pack('B*', sprintf('11110%s10%s10%s10%s', $w, $x, $y, $z));
  63     }
  64     else {
  65         Carp::croak("Invalid surrogate pair");
  66     }
  67 }
  68
  69
  70 sub _decode_unicode {
  71     my ($u) = @_;
  72     my ($utf8bit);
  73
  74     if ( $u =~ /^00([89a-f][0-9a-f])$/i ) { # 0x80-0xff
  75          return pack( 'H2', $1 );
  76     }
  77
  78     my $bit = unpack("B*", pack("H*", $u));
  79
  80     if ( $bit =~ /^00000(.....)(......)$/ ) {
  81         $utf8bit = sprintf('110%s10%s', $1, $2);
  82     }
  83     elsif ( $bit =~ /^(....)(......)(......)$/ ) {
  84         $utf8bit = sprintf('1110%s10%s10%s', $1, $2, $3);
  85     }
  86     else {
  87         Carp::croak("Invalid escaped unicode");
  88     }
  89
  90     return pack('B*', $utf8bit);
  91 }
  92
  93
  94 sub JSON::PP::incr_parse {
  95     local $Carp::CarpLevel = 1;
  96     ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
  97 }
  98
  99
 100 sub JSON::PP::incr_text {
 101     $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
 102
 103     if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
 104         Carp::croak("incr_text can not be called when the incremental parser already started parsing");
 105     }
 106
 107     $_[0]->{_incr_parser}->{incr_text} = $_[1] if ( @_ > 1 );
 108     $_[0]->{_incr_parser}->{incr_text};
 109 }
 110
 111
 112 sub JSON::PP::incr_skip {
 113     ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
 114 }
 115
 116
 117 sub JSON::PP::incr_reset {
 118     ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
 119 }
 120
 121
 122 1;
 123 __END__
 124
 125 =pod
 126
 127 =head1 NAME
 128
 129 JSON::PP5005 - Helper module in using JSON::PP in Perl 5.005
 130
 131 =head1 DESCRIPTION
 132
 133 JSON::PP calls internally.
 134
 135 =head1 AUTHOR
 136
 137 Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
 138
 139
 140 =head1 COPYRIGHT AND LICENSE
 141
 142 Copyright 2007-2009 by Makamaka Hannyaharamitu
 143
 144 This library is free software; you can redistribute it and/or modify
 145 it under the same terms as Perl itself.
 146
 147 =cut
 148