summaryrefslogtreecommitdiffstats
path: root/qooxdoo/source/perl/JSON/PP.pm
diff options
context:
space:
mode:
Diffstat (limited to 'qooxdoo/source/perl/JSON/PP.pm')
-rwxr-xr-xqooxdoo/source/perl/JSON/PP.pm1355
1 files changed, 1355 insertions, 0 deletions
diff --git a/qooxdoo/source/perl/JSON/PP.pm b/qooxdoo/source/perl/JSON/PP.pm
new file mode 100755
index 0000000..dc2d39a
--- /dev/null
+++ b/qooxdoo/source/perl/JSON/PP.pm
@@ -0,0 +1,1355 @@
+package JSON::PP;
+
+# JSON-2.0
+
+use 5.005;
+use strict;
+use base qw(Exporter);
+use overload;
+
+use Carp ();
+use B ();
+#use Devel::Peek;
+
+$JSON::PP::VERSION = '0.96';
+
+@JSON::PP::EXPORT = qw(from_json to_json jsonToObj objToJson);
+
+*jsonToObj = *from_json;
+*objToJson = *to_json;
+
+
+
+BEGIN {
+ my @properties = qw(
+ utf8 allow_nonref indent space_before space_after canonical max_depth shrink
+ allow_tied self_encode singlequote allow_bigint disable_UTF8 strict
+ allow_barekey escape_slash literal_value
+ );
+
+ # Perl version check, ascii() is enable?
+ # Helper module may set @JSON::PP::_properties.
+ if ($] >= 5.008) {
+ require Encode;
+ push @properties, 'ascii', 'latin1';
+
+ *utf8::is_utf8 = *Encode::is_utf8 if ($] == 5.008);
+
+ *JSON_encode_ascii = *_encode_ascii;
+ *JSON_encode_latin1 = *_encode_latin1;
+ *JSON_decode_unicode = *_decode_unicode;
+ }
+ else {
+ my $helper = $] >= 5.006 ? 'JSON::PP56' : 'JSON::PP5005';
+ eval qq| require $helper |;
+ if ($@) { Carp::croak $@; }
+ push @properties, @JSON::PP::_properties;
+ }
+
+ for my $name (@properties) {
+ eval qq|
+ sub $name {
+ \$_[0]->{$name} = defined \$_[1] ? \$_[1] : 1;
+ \$_[0];
+ }
+ |;
+ }
+
+}
+
+
+
+# Functions
+
+my %encode_allow_method
+ = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 allow_tied self_encode escape_slash/;
+my %decode_allow_method
+ = map {($_ => 1)} qw/utf8 allow_nonref disable_UTF8 strict singlequote allow_bigint
+ allow_barekey literal_value/;
+
+
+sub to_json { # encode
+ my ($obj, $opt) = @_;
+
+ if ($opt) {
+ my $json = JSON::PP->new->utf8;
+
+ for my $method (keys %$opt) {
+ Carp::croak("non acceptble option")
+ unless (exists $encode_allow_method{$method});
+ $json->$method($opt->{$method});
+ }
+
+ return $json->encode($obj);
+ }
+ else {
+ return __PACKAGE__->new->utf8->encode($obj);
+ }
+
+}
+
+
+sub from_json { # decode
+ my ($obj, $opt) = @_;
+
+ if ($opt) {
+ my $json = JSON::PP->new->utf8;
+
+ for my $method (keys %$opt) {
+ Carp::croak("non acceptble option")
+ unless (exists $decode_allow_method{$method});
+ $json->$method($opt->{$method});
+ }
+
+ return $json->decode($obj);
+ }
+ else {
+ __PACKAGE__->new->utf8->decode(shift);
+ }
+}
+
+
+# Methods
+
+sub new {
+ my $class = shift;
+ my $self = {
+ max_depth => 32,
+ unmap => 1,
+ indent => 0,
+ fallback => sub { encode_error('Invalid value. JSON can only reference.') },
+ };
+
+ bless $self, $class;
+}
+
+
+sub encode {
+ return $_[0]->encode_json($_[1]);
+}
+
+
+sub decode {
+ return $_[0]->decode_json($_[1], 0x00000000);
+}
+
+
+sub decode_prefix {
+ return $_[0]->decode_json($_[1], 0x00000001);
+}
+
+
+# accessor
+
+sub property {
+ my ($self, $name, $value) = @_;
+
+ if (@_ == 1) {
+ Carp::croak('property() requires 1 or 2 arguments.');
+ }
+ elsif (@_ == 2) {
+ $self->{$name};
+ }
+ else {
+ $self->$name($value);
+ }
+}
+
+
+# pretty printing
+
+sub pretty {
+ my ($self, $v) = @_;
+ $self->{pretty} = defined $v ? $v : 1;
+
+ if ($v) { # JSON::XS compati
+ $self->indent(3);
+ $self->space_before(1);
+ $self->space_after(1);
+ }
+ else {
+ $self->indent(0);
+ $self->space_before(0);
+ $self->space_after(0);
+ }
+
+ $self;
+}
+
+###############################
+
+sub JSON::true () { JSON::Literal::true->new; }
+
+sub JSON::false () { JSON::Literal::false->new; }
+
+sub JSON::null () { JSON::Literal::null->new; }
+
+###############################
+
+###
+### Perl => JSON
+###
+
+{ # Convert
+
+ my $depth;
+ my $max_depth;
+ my $keysort;
+ my $indent;
+ my $indent_count;
+ my $ascii;
+ my $utf8;
+ my $self_encode;
+ my $disable_UTF8;
+ my $escape_slash;
+
+ my $latin1;
+
+
+ sub encode_json {
+ my $self = shift;
+ my $obj = shift;
+
+ $indent_count = 0;
+ $depth = 0;
+
+ ($indent, $ascii, $utf8, $self_encode, $max_depth, $disable_UTF8, $escape_slash, $latin1)
+ = @{$self}{qw/indent ascii utf8 self_encode max_depth disable_UTF8 escape_slash latin1/};
+
+ $keysort = !$self->{canonical} ? undef
+ : ref($self->{canonical}) eq 'CODE' ? $self->{canonical}
+ : $self->{canonical} =~ /\D+/ ? $self->{canonical}
+ : sub { $a cmp $b };
+
+ my $str = $self->toJson($obj);
+
+ if (!defined $str and $self->{allow_nonref}){
+ $str = $self->valueToJson($obj);
+ }
+
+ encode_error("non ref") unless(defined $str);
+
+ return $str;
+ }
+
+
+ sub toJson {
+ my ($self, $obj) = @_;
+ my $type = ref($obj);
+
+ if($type eq 'HASH'){
+ return $self->hashToJson($obj);
+ }
+ elsif($type eq 'ARRAY'){
+ return $self->arrayToJson($obj);
+ }
+ elsif ($type) { # blessed object?
+ if (blessed($obj)) {
+ if ($self->{self_encode} and $obj->can('toJson')) {
+ return $self->selfToJson($obj);
+ }
+ elsif (!$obj->isa('JSON::Literal')) { # handling in valueToJson
+ ($type) = B::svref_2object($obj) =~ /(.+)=/;
+ return $type eq 'B::AV' ? $self->arrayToJson($obj)
+ : $type eq 'B::HV' ? $self->hashToJson($obj)
+ : undef;
+ }
+ }
+ else {
+ return $self->valueToJson($obj);
+ }
+ }
+ else{
+ return;
+ }
+ }
+
+
+ sub hashToJson {
+ my ($self, $obj) = @_;
+ my ($k,$v);
+ my %res;
+
+ encode_error("data structure too deep (hit recursion limit)")
+ if (++$depth > $max_depth);
+
+ $self->_tie_object($obj, \%res) if ($self->{allow_tied});
+
+ my ($pre, $post) = $indent ? $self->_upIndent() : ('', '');
+ my $del = ($self->{space_before} ? ' ' : '') . ':' . ($self->{space_after} ? ' ' : '');
+
+ for my $k (keys %$obj) {
+ my $v = $obj->{$k};
+ $res{$k} = $self->toJson($v) || $self->valueToJson($v);
+ }
+
+ $self->_downIndent() if ($indent);
+
+ return '{' . $pre
+ . join(",$pre", map { utf8::decode($_) if ($] < 5.008);
+ _stringfy($self, $_)
+ . $del . $res{$_} } _sort($self, \%res))
+ . $post
+ . '}';
+ }
+
+
+ sub arrayToJson {
+ my ($self, $obj) = @_;
+ my @res;
+
+ encode_error("data structure too deep (hit recursion limit)")
+ if (++$depth > $max_depth);
+
+ $self->_tie_object($obj, \@res) if ($self->{allow_tied});
+
+ my ($pre, $post) = $indent ? $self->_upIndent() : ('', '');
+
+ for my $v (@$obj){
+ push @res, $self->toJson($v) || $self->valueToJson($v);
+ }
+
+ $self->_downIndent() if ($indent);
+
+ return '[' . $pre . join(",$pre" ,@res) . $post . ']';
+ }
+
+
+ sub valueToJson {
+ my ($self, $value) = @_;
+
+ return 'null' if(!defined $value);
+
+ my $b_obj = B::svref_2object(\$value); # for round trip problem
+ # SvTYPE is IV or NV?
+ return $value # as is
+ if ($b_obj->FLAGS & B::SVf_IOK or $b_obj->FLAGS & B::SVf_NOK);
+
+ my $type = ref($value);
+
+ if(!$type){
+ return _stringfy($self, $value);
+ }
+ elsif( blessed($value) and $value->isa('JSON::Literal') ){
+ return $value->{str};
+ }
+ elsif ($type) {
+ if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
+ return $self->valueToJson("$value");
+ }
+
+ if ($type eq 'SCALAR' and defined $$value) {
+ return $$value eq '1' ? 'true'
+ : $$value eq '0' ? 'false' : encode_error("cannot encode reference.");
+ }
+
+ if ($type eq 'CODE') {
+ encode_error("JSON can only reference.");
+ }
+ else {
+ encode_error("cannot encode reference.");
+ }
+
+ }
+ else {
+ return $self->{fallback}->($value)
+ if ($self->{fallback} and ref($self->{fallback}) eq 'CODE');
+ return 'null';
+ }
+
+ }
+
+
+ my %esc = (
+ "\n" => '\n',
+ "\r" => '\r',
+ "\t" => '\t',
+ "\f" => '\f',
+ "\b" => '\b',
+ "\"" => '\"',
+ "\\" => '\\\\',
+ "\'" => '\\\'',
+ );
+
+
+ sub _stringfy {
+ my ($self, $arg) = @_;
+
+ $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/eg;
+ $arg =~ s/\//\\\//g if ($escape_slash);
+ $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
+
+ if ($ascii) {
+ $arg = JSON_encode_ascii($arg);
+ }
+
+ if ($latin1) {
+ $arg = JSON_encode_latin1($arg);
+ }
+
+ if ($utf8 or $disable_UTF8) {
+ utf8::encode($arg);
+ }
+
+ return '"' . $arg . '"';
+ }
+
+
+ sub selfToJson {
+ my ($self, $obj) = @_;
+ return $obj->toJson($self);
+ }
+
+
+ sub encode_error {
+ my $error = shift;
+ Carp::croak "$error";
+ }
+
+
+ sub _sort {
+ my ($self, $res) = @_;
+ defined $keysort ? (sort $keysort (keys %$res)) : keys %$res;
+ }
+
+
+ sub _tie_object {
+ my ($self, $obj, $res) = @_;
+ my $class;
+ # by ddascalescu+perl [at] gmail.com
+ if (ref($obj) eq 'ARRAY' and $class = tied @$obj) {
+ $class =~ s/=.*//;
+ tie @$res, $class;
+ }
+ elsif (ref($obj) eq 'HASH' and $class = tied %$obj) {
+ $class =~ s/=.*//;
+ tie %$res, $class;
+ }
+ }
+
+
+ sub _upIndent {
+ my $self = shift;
+ my $space = ' ' x $indent;
+
+ my ($pre,$post) = ('','');
+
+ $post = "\n" . $space x $indent_count;
+
+ $indent_count++;
+
+ $pre = "\n" . $space x $indent_count;
+
+ return ($pre,$post);
+ }
+
+
+ sub _downIndent { $_[0]->{indent_count}--; }
+
+} # Convert
+
+
+
+sub _encode_ascii {
+ join('',
+ map {
+ $_ <= 127 ?
+ chr($_) :
+ $_ <= 65535 ?
+ sprintf('\u%04x', $_) :
+ join("", map { '\u' . $_ }
+ unpack("H4H4", Encode::encode('UTF-16BE', pack("U", $_))));
+ } unpack('U*', $_[0])
+ );
+}
+
+
+sub _encode_latin1 {
+ join('',
+ map {
+ $_ <= 255 ?
+ chr($_) :
+ $_ <= 65535 ?
+ sprintf('\u%04x', $_) :
+ join("", map { '\u' . $_ }
+ unpack("H4H4", Encode::encode('UTF-16BE', pack("U", $_))));
+ } unpack('U*', $_[0])
+ );
+}
+
+
+
+#
+# JSON => Perl
+#
+
+# from Adam Sussman
+use Config;
+my $max_intsize = length(((1 << (8 * $Config{intsize} - 2))-1)*2 + 1) - 1;
+#my $max_intsize = length(2 ** ($Config{intsize} * 8)) - 1;
+
+
+{ # PARSE
+
+ my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org>
+ b => "\x8",
+ t => "\x9",
+ n => "\xA",
+ f => "\xC",
+ r => "\xD",
+ '\\' => '\\',
+ );
+
+ my $text; # json data
+ my $at; # offset
+ my $ch; # 1chracter
+ my $len; # text length (changed according to UTF8 or NON UTF8)
+
+ my $is_utf8;
+ my $depth;
+ my $encoding;
+
+ my $literal_value; # unmmaping
+ my $utf8; #
+ my $max_depth; # max nest nubmer of objects and arrays
+ my $allow_bigint; # using Math::BigInt
+ my $disable_UTF8; # don't flag UTF8 on
+ my $singlequote; # loosely quoting
+ my $strict; #
+ my $allow_barekey; # bareKey
+
+ # $opt flag
+ # 0x00000001 .... decode_prefix
+
+ sub decode_json {
+ my ($self, $opt); # $opt is an effective flag during this decode_json.
+
+ ($self, $text, $opt) = @_;
+
+ ($at, $ch, $depth) = (0, '', 0);
+
+ if (!defined $text or ref $text) {
+ decode_error("malformed text data.");
+ }
+
+ $is_utf8 = 1 if (utf8::is_utf8($text));
+
+ $len = length $text;
+
+ ($utf8, $literal_value, $max_depth, $allow_bigint, $disable_UTF8, $strict, $singlequote, $allow_barekey)
+ = @{$self}{qw/utf8 literal_value max_depth allow_bigint disable_UTF8 strict singlequote allow_barekey/};
+
+ unless ($self->{allow_nonref}) {
+ white();
+ unless (defined $ch and ($ch eq '{' or $ch eq '[')) {
+ decode_error('JSON text must be an object or array'
+ . ' (but found number, string, true, false or null,'
+ . ' use allow_nonref to allow this)', 1);
+ }
+ }
+
+ # Currently no effective
+ my @octets = unpack('C4', $text);
+ $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8'
+ : (!$octets[0] and $octets[1]) ? 'UTF-16BE'
+ : (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
+ : ( $octets[2] ) ? 'UTF-16LE'
+ : (!$octets[2] ) ? 'UTF-32LE'
+ : 'unknown';
+
+ my $result = value();
+
+ if ($len > $at) {
+ my $consumed = $at - 1;
+ white();
+ if ($ch) {
+ decode_error("garbage after JSON object") unless ($opt & 0x00000001);
+ return ($result, $consumed);
+ }
+ }
+
+ $result;
+ }
+
+
+ sub next_chr {
+ return $ch = undef if($at >= $len);
+ $ch = substr($text, $at++, 1);
+ }
+
+
+ sub value {
+ white();
+ return if(!defined $ch);
+ return object() if($ch eq '{');
+ return array() if($ch eq '[');
+ return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
+ return number() if($ch eq '-');
+ return $ch =~ /\d/ ? number() : word();
+ }
+
+
+ sub string {
+ my ($i,$s,$t,$u);
+ my @utf16;
+
+ $s = ''; # basically UTF8 flag on
+
+ if($ch eq '"' or ($singlequote and $ch eq "'")){
+ my $boundChar = $ch if ($singlequote);
+
+ OUTER: while( defined(next_chr()) ){
+
+ if((!$singlequote and $ch eq '"') or ($singlequote and $ch eq $boundChar)){
+ next_chr();
+
+ if (@utf16) {
+ decode_error("missing low surrogate character in surrogate pair");
+ }
+
+ if($disable_UTF8) {
+ utf8::encode($s) if (utf8::is_utf8($s));
+ }
+ else {
+ utf8::decode($s);
+ }
+
+ return $s;
+ }
+ elsif($ch eq '\\'){
+ next_chr();
+ if(exists $escapes{$ch}){
+ $s .= $escapes{$ch};
+ }
+ elsif($ch eq 'u'){ # UNICODE handling
+ my $u = '';
+
+ for(1..4){
+ $ch = next_chr();
+ last OUTER if($ch !~ /[0-9a-fA-F]/);
+ $u .= $ch;
+ }
+
+ $s .= JSON_decode_unicode($u, \@utf16) || next;
+
+ }
+ else{
+ $s .= $ch;
+ }
+ }
+ else{
+ if ($utf8 and $is_utf8) {
+ if( hex(unpack('H*', $ch)) > 255 ) {
+ decode_error("malformed UTF-8 character in JSON string");
+ }
+ }
+ elsif ($strict) {
+ if ($ch =~ /[\x00-\x1f\x22\x2f\x5c]/) {
+ decode_error('invalid character');
+ }
+ }
+
+ $s .= $ch;
+ }
+ }
+ }
+
+ decode_error("Bad string (unexpected end)");
+ }
+
+
+ sub white {
+ while( defined $ch ){
+ if($ch le ' '){
+ next_chr();
+ }
+ elsif($ch eq '/'){
+ next_chr();
+ if($ch eq '/'){
+ 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
+ }
+ elsif($ch eq '*'){
+ next_chr();
+ while(1){
+ if(defined $ch){
+ if($ch eq '*'){
+ if(defined(next_chr()) and $ch eq '/'){
+ next_chr();
+ last;
+ }
+ }
+ else{
+ next_chr();
+ }
+ }
+ else{
+ decode_error("Unterminated comment");
+ }
+ }
+ next;
+ }
+ else{
+ decode_error("Syntax decode_error (whitespace)");
+ }
+ }
+ else{
+ last;
+ }
+ }
+ }
+
+
+ sub object {
+ my $o = {};
+ my $k;
+
+ if($ch eq '{'){
+ decode_error('json structure too deep (hit recursion limit)', )
+ if (++$depth > $max_depth);
+ next_chr();
+ white();
+ if(defined $ch and $ch eq '}'){
+ next_chr();
+ return $o;
+ }
+ while(defined $ch){
+ $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
+ white();
+
+ if(!defined $ch or $ch ne ':'){
+ decode_error("Bad object ; ':' expected");
+ }
+
+ next_chr();
+ $o->{$k} = value();
+ white();
+
+ last if (!defined $ch);
+
+ if($ch eq '}'){
+ next_chr();
+ return $o;
+ }
+ elsif($ch ne ','){
+ last;
+ }
+ next_chr();
+ white();
+ }
+
+ decode_error("Bad object ; ,or } expected while parsing object/hash");
+ }
+ }
+
+
+ sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
+ my $key;
+ while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
+ $key .= $ch;
+ next_chr();
+ }
+ return $key;
+ }
+
+
+ sub word {
+ my $word = substr($text,$at-1,4);
+
+ if($word eq 'true'){
+ $at += 3;
+ next_chr;
+ return $literal_value ? JSON::true : 1;
+ }
+ elsif($word eq 'null'){
+ $at += 3;
+ next_chr;
+ return $literal_value ? JSON::null : undef;
+ }
+ elsif($word eq 'fals'){
+ $at += 3;
+ if(substr($text,$at,1) eq 'e'){
+ $at++;
+ next_chr;
+ return $literal_value ? JSON::false : 0;
+ }
+ }
+
+ $at--; # for decode_error report
+
+ decode_error("Syntax decode_error (word) 'null' expected") if ($word =~ /^n/);
+ decode_error("Syntax decode_error (word) 'true' expected") if ($word =~ /^t/);
+ decode_error("Syntax decode_error (word) 'false' expected") if ($word =~ /^f/);
+ decode_error("Syntax decode_error (word)" .
+ " malformed json string, neither array, object, number, string or atom");
+ }
+
+
+ sub number {
+ my $n = '';
+ my $v;
+
+ # According to RFC4627, hex or oct digts are invalid.
+ if($ch eq '0'){
+ my $peek = substr($text,$at,1);
+ my $hex = $peek =~ /[xX]/; # 0 or 1
+
+ if($hex){
+ ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
+ }
+ else{ # oct
+ ($n) = ( substr($text, $at) =~ /^([0-7]+)/);
+ }
+
+ if(defined $n and length($n)){
+ if (!$hex and length($n) == 1) {
+ decode_error("malformed number (leading zero must not be followed by another digit)");
+ }
+ $at += length($n) + $hex;
+ next_chr;
+ return $hex ? hex($n) : oct($n);
+ }
+ }
+
+ if($ch eq '-'){
+ $n = '-';
+ next_chr;
+ if (!defined $ch or $ch !~ /\d/) {
+ decode_error("malformed number (no digits after initial minus)");
+ }
+ }
+
+ while(defined $ch and $ch =~ /\d/){
+ $n .= $ch;
+ next_chr;
+ }
+
+ if(defined $ch and $ch eq '.'){
+ $n .= '.';
+
+ next_chr;
+ if (!defined $ch or $ch !~ /\d/) {
+ decode_error("malformed number (no digits after decimal point)");
+ }
+ else {
+ $n .= $ch;
+ }
+
+ while(defined(next_chr) and $ch =~ /\d/){
+ $n .= $ch;
+ }
+ }
+
+ if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
+ $n .= $ch;
+ next_chr;
+
+ if(defined($ch) and ($ch eq '+' or $ch eq '-' or $ch =~ /\d/)){
+ $n .= $ch;
+ }
+ else {
+ decode_error("malformed number (no digits after exp sign)");
+ }
+
+ while(defined(next_chr) and $ch =~ /\d/){
+ $n .= $ch;
+ }
+
+ }
+
+ $v .= $n;
+
+ if ($allow_bigint) { # from Adam Sussman
+ require Math::BigInt;
+ return Math::BigInt->new($v) if ($v !~ /[.eE]/ and length $v > $max_intsize);
+ }
+
+ return 0+$v;
+ }
+
+
+ sub array {
+ my $a = [];
+
+ if ($ch eq '[') {
+ decode_error('json structure too deep (hit recursion limit)', 1)
+ if (++$depth > $max_depth);
+ next_chr();
+ white();
+ if(defined $ch and $ch eq ']'){
+ next_chr();
+ return $a;
+ }
+
+ while(defined($ch)){
+ push @$a, value();
+ white();
+
+ if (!defined $ch) {
+ last;
+ }
+
+ if($ch eq ']'){
+ next_chr();
+ return $a;
+ }
+ elsif($ch ne ','){
+ last;
+ }
+ next_chr();
+ white();
+ }
+ }
+
+ decode_error(", or ] expected while parsing array");
+ }
+
+
+ sub decode_error {
+ my $error = shift;
+ my $no_rep = shift;
+ my $str = defined $text ? substr($text, $at) : '';
+
+ unless (length $str) { $str = '(end of string)'; }
+
+ if ($no_rep) {
+ Carp::croak "$error";
+ }
+ else {
+ Carp::croak "$error, at character offset $at ($str)";
+ }
+ }
+
+} # PARSE
+
+
+sub _decode_unicode {
+ my $u = $_[0];
+ my $utf16 = $_[1];
+
+ # U+10000 - U+10FFFF
+
+ # U+D800 - U+DBFF
+ if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
+ push @$utf16, $u;
+ }
+ # U+DC00 - U+DFFF
+ elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
+ unless (scalar(@$utf16)) {
+ decode_error("missing high surrogate character in surrogate pair");
+ }
+ my $str = pack('H4H4', @$utf16, $u);
+ @$utf16 = ();
+ return Encode::decode('UTF-16BE', $str); # UTF-8 flag on
+ }
+ else {
+ if (scalar(@$utf16)) {
+ decode_error("surrogate pair expected");
+ }
+
+ return chr(hex($u));
+ }
+
+ return;
+}
+
+
+###############################
+# Utilities
+#
+
+BEGIN {
+ eval 'require Scalar::Util';
+ unless($@){
+ *JSON::PP::blessed = \&Scalar::Util::blessed;
+ }
+ else{ # This code is from Sclar::Util.
+ # warn $@;
+ eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
+ *JSON::PP::blessed = sub {
+ local($@, $SIG{__DIE__}, $SIG{__WARN__});
+ ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
+ };
+ }
+}
+
+
+###############################
+
+package JSON::Literal;
+use overload (
+ '""' => sub { $_[0]->{str} },
+ 'bool' => sub { $_[0]->{value} },
+ 'eq' => sub { $_[0]->{str} eq $_[1] },
+ 'ne' => sub { $_[0]->{str} ne $_[1] },
+);
+
+
+package JSON::Literal::true;
+use base qw(JSON::Literal);
+
+use overload (
+ '==' => sub { 1 == $_[1] },
+ '!=' => sub { 1 != $_[1] },
+);
+
+sub new { bless { str => 'true', value => 1 }; }
+
+
+package JSON::Literal::false;
+use base qw(JSON::Literal);
+
+use overload (
+ '==' => sub { 0 == $_[1] },
+ '!=' => sub { 0 != $_[1] },
+);
+
+sub new { bless { str => 'false', value => 0 }; }
+
+package JSON::Literal::null;
+use base qw(JSON::Literal);
+
+use overload (
+ '==' => sub { -1 == $_[1] },
+ '!=' => sub { -1 != $_[1] },
+);
+
+sub new { bless { str => 'null', value => undef }; }
+
+###############################
+
+
+1;
+__END__
+=pod
+
+=head1 NAME
+
+JSON::PP - An experimental JSON::XS compatible Pure Perl module.
+
+=head1 SYNOPSIS
+
+ use JSON::PP;
+
+ $obj = from_json($json_text);
+ $json_text = to_json($obj);
+
+ # or
+
+ $obj = jsonToObj($json_text);
+ $json_text = objToJson($obj);
+
+ $json = new JSON;
+ $json_text = $json->ascii->pretty($obj);
+
+ # you can set options to functions.
+
+ $json_text = to_json($obj, {ascii => 1, intend => 2});
+ $obj = from_json($json_text, {utf8 => 0});
+
+
+=head1 DESCRIPTION
+
+This module is L<JSON::XS> compatible Pure Perl module.
+( Perl better than 5.008 is recommended)
+
+Module variables ($JSON::*) were abolished.
+
+JSON::PP will be renamed JSON (JSON-2.0).
+
+Many things including error handling are learned from L<JSON::XS>.
+For t/02_error.t compatible, error messages was copied partially from JSON::XS.
+
+
+=head2 FEATURES
+
+=over
+
+=item * perhaps correct unicode handling
+
+This module knows how to handle Unicode (perhaps),
+but not yet documents how and when it does so.
+
+In Perl5.6x, Unicode handling requires L<Unicode::String> module.
+
+Perl 5.005_xx, Unicode handling is disable currenlty.
+
+
+=item * round-trip integrity
+
+This module solved the problem pointed out by JSON::XS
+using L<B> module.
+
+=item * strict checking of JSON correctness
+
+I want to bring close to XS.
+How do you want to carry out?
+
+you can set C<strict> decoding method.
+
+=item * slow
+
+Compared to other JSON modules, this module does not compare
+favourably in terms of speed. Very slowly!
+
+=item * simple to use
+
+This module became very simple.
+Since its interface were anyway made the same as JSON::XS.
+
+
+=item * reasonably versatile output formats
+
+See to L<JSON::XS>.
+
+=back
+
+=head1 FUNCTIONS
+
+=over
+
+=item to_json
+
+See to JSON::XS.
+C<objToJson> is an alias.
+
+=item from_json
+
+See to JSON::XS.
+C<jsonToObj> is an alias.
+
+
+=item JSON::true
+
+Returns JSON true value which is blessed object.
+It C<isa> JSON::Literal object.
+
+=item JSON::false
+
+Returns JSON false value which is blessed object.
+It C<isa> JSON::Literal object.
+
+
+=item JSON::null
+
+Returns JSON null value which is blessed object.
+It C<isa> JSON::Literal object.
+
+
+=back
+
+
+=head1 METHODS
+
+=over
+
+=item new
+
+Returns JSON::PP object.
+
+=item ascii
+
+See to JSON::XS.
+
+In Perl 5.6, this method requires L<Unicode::String>.
+If you don't have Unicode::String,
+the method is always set to false and warns.
+
+In Perl 5.005, this option is currently disable.
+
+
+=item latin1
+
+See to JSON::XS.
+
+In Perl 5.6, this method requires L<Unicode::String>.
+If you don't have Unicode::String,
+the method is always set to false and warns.
+
+In Perl 5.005, this option is currently disable.
+
+
+=item utf8
+
+See to JSON::XS.
+
+Currently this module always handles UTF-16 as UTF-16BE.
+
+=item pretty
+
+See to JSON::XS.
+
+=item indent
+
+See to JSON::XS.
+Strictly, this module does not carry out equivalent to XS.
+
+ $json->indent(4);
+
+is not the same as this:
+
+ $json->indent();
+
+
+=item space_before
+
+See to JSON::XS.
+
+=item space_after
+
+See JSON::XS.
+
+=item canonical
+
+See to JSON::XS.
+Strictly, this module does not carry out equivalent to XS.
+This method can take a subref for sorting (see to L<JSON>).
+
+
+=item allow_nonref
+
+See to JSON::XS.
+
+=item shrink
+
+Not yet implemented.
+
+=item max_depth
+
+See to JSON::XS.
+Strictly, this module does not carry out equivalent to XS.
+By default, not 512 (JSON::XS) but 32.
+
+=item encode
+
+See to JSON::XS.
+
+=item decode
+
+See to JSON::XS.
+In Perl 5.6, if you don't have Unicode::String,
+the method can't handle UTF-16(BE) char and returns as is.
+
+
+=item property
+
+Accessor.
+
+ $json->property(utf8 => 1); # $json->utf8(1);
+
+ $value = $json->property('utf8'); # returns 1.
+
+
+=item self_encode
+
+See L<JSON/BLESSED OBJECT>'s I<self convert> function.
+
+
+=item disable_UTF8
+
+If this option is set, UTF8 flag in strings generated
+by C<encode>/C<decode> is off.
+
+
+=item allow_tied
+
+Enable.
+
+This option will be obsoleted.
+
+
+=item singlequote
+
+Allows to decode single quoted strings.
+
+Unlike L<JSON> module, this module does not encode
+Perl string into single quoted string any longer.
+
+
+=item allow_barekey
+
+Allows to decode bare key of member.
+
+
+=item allow_bigint
+
+When json text has any integer in decoding more than Perl can't handle,
+If this option is on, they are converted into L<Math::BigInt> objects.
+
+
+=item strict
+
+For JSON format, unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid and
+JSON::XS decodes just like that. While this module can deocde thoese.
+But if this option is set, the module strictly decodes.
+
+
+=item escape_slash
+
+By default, JSON::PP encodes strings without escaping slash (U+002F).
+Setting the option to escape slash.
+
+
+=item literal_value
+
+
+
+=back
+
+
+=head1 MAPPING
+
+
+
+=head1 COMPARISON
+
+Using a benchmark program in the JSON::XS (v1.11) distribution.
+
+ module | encode | decode |
+ -----------|------------|------------|
+ JSON::PP | 11092.260 | 4482.033 |
+ -----------+------------+------------+
+ JSON::XS | 341513.380 | 226138.509 |
+ -----------+------------+------------+
+
+In case t/12_binary.t (JSON::XS distribution).
+(shrink of JSON::PP has no effect.)
+
+JSON::PP takes 147 (sec).
+
+JSON::XS takes 4.
+
+
+=head1 TODO
+
+=over
+
+=item Document!
+
+It is troublesome.
+
+=item clean up
+
+Under the cleaning.
+
+=back
+
+
+=head1 SEE ALSO
+
+L<JSON>, L<JSON::XS>
+
+RFC4627
+
+=head1 AUTHOR
+
+Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
+
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007 by Makamaka Hannyaharamitu
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
generated by cgit v1.2.3-24-g4f1b (git 2.32.0) at 2024-07-19 11:41:57 +0200