File Coverage

blib/lib/JSON/backportPP.pm

Criterion	Covered	Total	%
statement	823	972	84.6
branch	487	630	77.3
condition	170	275	61.8
subroutine	134	164	81.7
pod	42	82	51.2
total	1656	2123	78.0

package # This is JSON::backportPP
    JSON::PP;

# JSON-2.0

use 5.008;
use strict;

use Exporter ();
BEGIN { @JSON::backportPP::ISA = ('Exporter') }

use overload ();
use JSON::backportPP::Boolean;

use Carp ();
use Scalar::Util qw(blessed reftype refaddr);
#use Devel::Peek;

$JSON::backportPP::VERSION = '4.18';

our @EXPORT = qw(encode_json decode_json from_json to_json);

# instead of hash-access, i tried index-access for speed.
# but this method is not faster than what i expected. so it will be changed.

use constant P_ASCII                => 0;
use constant P_LATIN1               => 1;
use constant P_UTF8                 => 2;
use constant P_INDENT               => 3;
use constant P_CANONICAL            => 4;
use constant P_SPACE_BEFORE         => 5;
use constant P_SPACE_AFTER          => 6;
use constant P_ALLOW_NONREF         => 7;
use constant P_SHRINK               => 8;
use constant P_ALLOW_BLESSED        => 9;
use constant P_CONVERT_BLESSED      => 10;
use constant P_RELAXED              => 11;

use constant P_LOOSE                => 12;
use constant P_ALLOW_BIGNUM         => 13;
use constant P_ALLOW_BAREKEY        => 14;
use constant P_ALLOW_SINGLEQUOTE    => 15;
use constant P_ESCAPE_SLASH         => 16;
use constant P_AS_NONBLESSED        => 17;

use constant P_ALLOW_UNKNOWN        => 18;
use constant P_ALLOW_TAGS           => 19;

use constant USE_B => $ENV{PERL_JSON_PP_USE_B} || 0;
use constant CORE_BOOL => defined &builtin::is_bool;

my $invalid_char_re;

BEGIN {
    $invalid_char_re = "[";
    for my $i (0 .. 0x01F, 0x22, 0x5c) { # '/' is ok
        $invalid_char_re .= quotemeta chr utf8::unicode_to_native($i);
    }

    $invalid_char_re = qr/$invalid_char_re]/;
}

BEGIN {
    if (USE_B) {
        require B;
    }
}

BEGIN {
    my @xs_compati_bit_properties = qw(
            latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
            allow_blessed convert_blessed relaxed allow_unknown
            allow_tags
    );
    my @pp_bit_properties = qw(
            allow_singlequote allow_bignum loose
            allow_barekey escape_slash as_nonblessed
    );

    for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
        my $property_id = 'P_' . uc($name);

        eval qq/
            sub $name {
                my \$enable = defined \$_[1] ? \$_[1] : 1;

                if (\$enable) {
                    \$_[0]->{PROPS}->[$property_id] = 1;
                }
                else {
                    \$_[0]->{PROPS}->[$property_id] = 0;
                }

                \$_[0];
            }

            sub get_$name {
                \$_[0]->{PROPS}->[$property_id] ? 1 : '';
            }
        /;
    }

}



# Functions

my $JSON; # cache

sub encode_json ($) { # encode
    ($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
}


sub decode_json ($) { # decode
    ($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
}

# Obsoleted

sub to_json($) {
   Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
}


sub from_json($) {
   Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
}


# Methods

sub new {
    my $class = shift;
    my $self  = {
        max_depth   => 512,
        max_size    => 0,
        indent_length => 3,
    };

    $self->{PROPS}[P_ALLOW_NONREF] = 1;

    bless $self, $class;
}


sub encode {
    return $_[0]->PP_encode_json($_[1]);
}


sub decode {
    return $_[0]->PP_decode_json($_[1], 0x00000000);
}


sub decode_prefix {
    return $_[0]->PP_decode_json($_[1], 0x00000001);
}


# accessor


# pretty printing

sub pretty {
    my ($self, $v) = @_;
    my $enable = defined $v ? $v : 1;

    if ($enable) { # indent_length(3) for JSON::XS compatibility
        $self->indent(1)->space_before(1)->space_after(1);
    }
    else {
        $self->indent(0)->space_before(0)->space_after(0);
    }

    $self;
}

# etc

sub max_depth {
    my $max  = defined $_[1] ? $_[1] : 0x80000000;
    $_[0]->{max_depth} = $max;
    $_[0];
}


sub get_max_depth { $_[0]->{max_depth}; }


sub max_size {
    my $max  = defined $_[1] ? $_[1] : 0;
    $_[0]->{max_size} = $max;
    $_[0];
}


sub get_max_size { $_[0]->{max_size}; }

sub boolean_values {
    my $self = shift;
    if (@_) {
        my ($false, $true) = @_;
        $self->{false} = $false;
        $self->{true} = $true;
        if (CORE_BOOL) {
            BEGIN { CORE_BOOL and warnings->unimport(qw(experimental::builtin)) }
            if (builtin::is_bool($true) && builtin::is_bool($false) && $true && !$false) {
                $self->{core_bools} = !!1;
            }
            else {
                delete $self->{core_bools};
            }
        }
    } else {
        delete $self->{false};
        delete $self->{true};
        delete $self->{core_bools};
    }
    return $self;
}

sub core_bools {
    my $self = shift;
    my $core_bools = defined $_[0] ? $_[0] : 1;
    if ($core_bools) {
        $self->{true} = !!1;
        $self->{false} = !!0;
        $self->{core_bools} = !!1;
    }
    else {
        $self->{true} = $JSON::PP::true;
        $self->{false} = $JSON::PP::false;
        $self->{core_bools} = !!0;
    }
    return $self;
}

sub get_core_bools {
    my $self = shift;
    return !!$self->{core_bools};
}

sub unblessed_bool {
    my $self = shift;
    return $self->core_bools(@_);
}

sub get_unblessed_bool {
    my $self = shift;
    return $self->get_core_bools(@_);
}

sub get_boolean_values {
    my $self = shift;
    if (exists $self->{true} and exists $self->{false}) {
        return @$self{qw/false true/};
    }
    return;
}

sub filter_json_object {
    if (defined $_[1] and ref $_[1] eq 'CODE') {
        $_[0]->{cb_object} = $_[1];
    } else {
        delete $_[0]->{cb_object};
    }
    $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
    $_[0];
}

sub filter_json_single_key_object {
    if (@_ == 1 or @_ > 3) {
        Carp::croak("Usage: JSON::PP::filter_json_single_key_object(self, key, callback = undef)");
    }
    if (defined $_[2] and ref $_[2] eq 'CODE') {
        $_[0]->{cb_sk_object}->{$_[1]} = $_[2];
    } else {
        delete $_[0]->{cb_sk_object}->{$_[1]};
        delete $_[0]->{cb_sk_object} unless %{$_[0]->{cb_sk_object} || {}};
    }
    $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
    $_[0];
}

sub indent_length {
    if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
        Carp::carp "The acceptable range of indent_length() is 0 to 15.";
    }
    else {
        $_[0]->{indent_length} = $_[1];
    }
    $_[0];
}

sub get_indent_length {
    $_[0]->{indent_length};
}

sub sort_by {
    $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
    $_[0];
}

sub allow_bigint {
    Carp::carp("allow_bigint() is obsoleted. use allow_bignum() instead.");
    $_[0]->allow_bignum;
}

###############################

###
### Perl => JSON
###


{ # Convert

    sub PP_encode_json {
        my $self = shift;
        my $obj  = shift;

        $self->{indent_count} = 0;
        $self->{depth}        = 0;

        my $props = $self->{PROPS};

        $self->{keysort} = $self->{PROPS}[P_CANONICAL] ? sub { $a cmp $b } : undef;

        if ($self->{sort_by}) {
            $self->{keysort} = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
                             : $self->{sort_by} =~ /\D+/       ? $self->{sort_by}
                             : sub { $a cmp $b };
        }

        encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
             if(!ref $obj and !$props->[ P_ALLOW_NONREF ]);

        my $str  = $self->object_to_json($obj);

        $str .= "\n" if ( $self->{PROPS}[P_INDENT] ); # JSON::XS 2.26 compatible

        return $str;
    }


    sub object_to_json {
        my ($self, $obj) = @_;
        my $type = ref($obj);

        if($type eq 'HASH'){
            return $self->hash_to_json($obj);
        }
        elsif($type eq 'ARRAY'){
            return $self->array_to_json($obj);
        }
        elsif ($type) { # blessed object?
            if (blessed($obj)) {

                return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );

                if ( $self->{PROPS}[P_ALLOW_TAGS] and $obj->can('FREEZE') ) {
                    my $obj_class = ref $obj || $obj;
                    $obj = bless $obj, $obj_class;
                    my @results = $obj->FREEZE('JSON');
                    if ( @results and ref $results[0] ) {
                        if ( refaddr( $obj ) eq refaddr( $results[0] ) ) {
                            encode_error( sprintf(
                                "%s::FREEZE method returned same object as was passed instead of a new one",
                                ref $obj
                            ) );
                        }
                    }
                    return '("'.$obj_class.'")['.join(',', @results).']';
                }

                if ( $self->{PROPS}[P_CONVERT_BLESSED] and $obj->can('TO_JSON') ) {
                    my $result = $obj->TO_JSON();
                    if ( defined $result and ref( $result ) ) {
                        if ( refaddr( $obj ) eq refaddr( $result ) ) {
                            encode_error( sprintf(
                                "%s::TO_JSON method returned same object as was passed instead of a new one",
                                ref $obj
                            ) );
                        }
                    }

                    return $self->object_to_json( $result );
                }

                return "$obj" if ( $self->{PROPS}[P_ALLOW_BIGNUM] and _is_bignum($obj) );

                if ($self->{PROPS}[P_ALLOW_BLESSED]) {
                    return $self->blessed_to_json($obj) if ($self->{PROPS}[P_AS_NONBLESSED]); # will be removed.
                    return 'null';
                }
                encode_error( sprintf("encountered object '%s', but neither allow_blessed, convert_blessed nor allow_tags settings are enabled (or TO_JSON/FREEZE method missing)", $obj)
                );
            }
            else {
                return $self->value_to_json($obj);
            }
        }
        else{
            return $self->value_to_json($obj);
        }
    }


    sub hash_to_json {
        my ($self, $obj) = @_;
        my @res;

        encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
                                         if (++$self->{depth} > $self->{max_depth});

        my ($pre, $post) = $self->{PROPS}[P_INDENT] ? $self->_up_indent() : ('', '');
        my $del = ($self->{PROPS}[P_SPACE_BEFORE] ? ' ' : '') . ':' . ($self->{PROPS}[P_SPACE_AFTER] ? ' ' : '');

        for my $k ( $self->__sort( $obj ) ) {
            push @res, $self->string_to_json( $k )
                          .  $del
                          . ( ref $obj->{$k} ? $self->object_to_json( $obj->{$k} ) : $self->value_to_json( $obj->{$k} ) );
        }

        --$self->{depth};
        $self->_down_indent() if ($self->{PROPS}[P_INDENT]);

        return '{}' unless @res;
        return '{' . $pre . join( ",$pre", @res ) . $post . '}';
    }


    sub array_to_json {
        my ($self, $obj) = @_;
        my @res;

        encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
                                         if (++$self->{depth} > $self->{max_depth});

        my ($pre, $post) = $self->{PROPS}[P_INDENT] ? $self->_up_indent() : ('', '');

        for my $v (@$obj){
            push @res, ref($v) ? $self->object_to_json($v) : $self->value_to_json($v);
        }

        --$self->{depth};
        $self->_down_indent() if ($self->{PROPS}[P_INDENT]);

        return '[]' unless @res;
        my $space = $pre eq '' && $self->{PROPS}[P_SPACE_AFTER] ? ' ' : '';
        return '[' . $pre . join( ",$space$pre", @res ) . $post . ']';
    }

    sub _looks_like_number {
        my $value = shift;
        if (USE_B) {
            my $b_obj = B::svref_2object(\$value);
            my $flags = $b_obj->FLAGS;
            return 1 if $flags & ( B::SVp_IOK() | B::SVp_NOK() ) and !( $flags & B::SVp_POK() );
            return;
        } else {
            no warnings 'numeric';
            # if the utf8 flag is on, it almost certainly started as a string
            return if utf8::is_utf8($value);
            # detect numbers
            # string & "" -> ""
            # number & "" -> 0 (with warning)
            # nan and inf can detect as numbers, so check with * 0
            return unless length((my $dummy = "") & $value);
            return unless 0 + $value eq $value;
            return 1 if $value * 0 == 0;
            return -1; # inf/nan
        }
    }

    sub value_to_json {
        my ($self, $value) = @_;

        return 'null' if(!defined $value);

        my $type = ref($value);

        if (!$type) {
            BEGIN { CORE_BOOL and warnings->unimport('experimental::builtin') }
            if (CORE_BOOL && builtin::is_bool($value)) {
                return $value ? 'true' : 'false';
            }
            elsif (_looks_like_number($value)) {
                return $value;
            }
            return $self->string_to_json($value);
        }
        elsif( blessed($value) and  $value->isa('JSON::PP::Boolean') ){
            return $$value == 1 ? 'true' : 'false';
        }
        else {
            if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
                return $self->value_to_json("$value");
            }

            if ($type eq 'SCALAR' and defined $$value) {
                return   $$value eq '1' ? 'true'
                       : $$value eq '0' ? 'false'
                       : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
                       : encode_error("cannot encode reference to scalar");
            }

            if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
                return 'null';
            }
            else {
                if ( $type eq 'SCALAR' or $type eq 'REF' ) {
                    encode_error("cannot encode reference to scalar");
                }
                else {
                    encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
                }
            }

        }
    }


    my %esc = (
        "\n" => '\n',
        "\r" => '\r',
        "\t" => '\t',
        "\f" => '\f',
        "\b" => '\b',
        "\"" => '\"',
        "\\" => '\\\\',
        "\'" => '\\\'',
    );


    sub string_to_json {
        my ($self, $arg) = @_;

        $arg =~ s/(["\\\n\r\t\f\b])/$esc{$1}/g;
        $arg =~ s/\//\\\//g if ($self->{PROPS}[P_ESCAPE_SLASH]);

        # On ASCII platforms, matches [\x00-\x08\x0b\x0e-\x1f]
        $arg =~ s/([^\n\t\c?[:^cntrl:][:^ascii:]])/'\\u00' . unpack('H2', $1)/eg;

        if ($self->{PROPS}[P_ASCII]) {
            $arg = _encode_ascii($arg);
        }

        if ($self->{PROPS}[P_LATIN1]) {
            $arg = _encode_latin1($arg);
        }

        if ($self->{PROPS}[P_UTF8]) {
            utf8::encode($arg);
        }

        return '"' . $arg . '"';
    }


    sub blessed_to_json {
        my $reftype = reftype($_[1]) || '';
        if ($reftype eq 'HASH') {
            return $_[0]->hash_to_json($_[1]);
        }
        elsif ($reftype eq 'ARRAY') {
            return $_[0]->array_to_json($_[1]);
        }
        else {
            return 'null';
        }
    }


    sub encode_error {
        my $error  = shift;
        Carp::croak "$error";
    }


    sub __sort {
        my $self = shift;
        my $keysort = $self->{keysort};
        defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
    }


    sub _up_indent {
        my $self  = shift;
        my $space = ' ' x $self->{indent_length};

        my ($pre,$post) = ('','');

        $post = "\n" . $space x $self->{indent_count};

        $self->{indent_count}++;

        $pre = "\n" . $space x $self->{indent_count};

        return ($pre,$post);
    }


    sub _down_indent { $_[0]->{indent_count}--; }

} # Convert


sub _encode_ascii {
    join('',
        map {
            chr($_) =~ /[[:ascii:]]/ ?
                chr($_) :
            $_ <= 65535 ?
                sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
        } unpack('U*', $_[0])
    );
}


sub _encode_latin1 {
    join('',
        map {
            $_ <= 255 ?
                chr($_) :
            $_ <= 65535 ?
                sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
        } unpack('U*', $_[0])
    );
}


sub _encode_surrogates { # from perlunicode
    my $uni = $_[0] - 0x10000;
    return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
}


sub _is_bignum {
    $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
}



#
# JSON => Perl
#

my $max_intsize;

BEGIN {
    my $checkint = 1111;
    for my $d (5..64) {
        $checkint .= 1;
        my $int   = eval qq| $checkint |;
        if ($int =~ /[eE]/) {
            $max_intsize = $d - 1;
            last;
        }
    }
}

{ # PARSE

    my %escapes = ( #  by Jeremy Muhlich
        b    => "\b",
        t    => "\t",
        n    => "\n",
        f    => "\f",
        r    => "\r",
        '\\' => '\\',
        '"'  => '"',
        '/'  => '/',
    );

    sub _detect_utf_encoding {
        my $text = shift;
        my @octets = unpack('C4', $text);
        return 'unknown' unless defined $octets[3];
        return ( $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';
    }

    sub PP_decode_json {
        my ($self, $text, $want_offset) = @_;

        @$self{qw/at ch depth/} = (0, '', 0);

        if ( !defined $text or ref $text ) {
            $self->_decode_error("malformed JSON string, neither array, object, number, string or atom");
        }

        my $props = $self->{PROPS};

        if ( $self->{PROPS}[P_UTF8] ) {
            my $encoding = _detect_utf_encoding($text);
            if ($encoding ne 'UTF-8' and $encoding ne 'unknown') {
                require Encode;
                Encode::from_to($text, $encoding, 'utf-8');
            } else {
                utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
            }
        }
        else {
            utf8::encode( $text );
        }

        $self->{len}  = length $text;
        $self->{text} = $text;

        if ($self->{max_size} > 1) {
            use bytes;
            my $bytes = length $text;
            $self->_decode_error(
                sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
                    , $bytes, $self->{max_size}), 1
            ) if ($bytes > $self->{max_size});
        }

        $self->_white(); # remove head white space

        $self->_decode_error("malformed JSON string, neither array, object, number, string or atom") unless defined $self->{ch}; # Is there a first character for JSON structure?

        my $result = $self->_value();

        if ( !$props->[ P_ALLOW_NONREF ] and !ref $result ) {
                $self->_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);
        }

        Carp::croak('something wrong.') if $self->{len} < $self->{at}; # we won't arrive here.

        my $consumed = defined $self->{ch} ? $self->{at} - 1 : $self->{at}; # consumed JSON text length

        $self->_white(); # remove tail white space

        return ( $result, $consumed ) if $want_offset; # all right if decode_prefix

        $self->_decode_error("garbage after JSON object") if defined $self->{ch};

        $result;
    }


    sub _next_chr {
        my $self = shift;
        return $self->{ch} = undef if($self->{at} >= $self->{len});
        $self->{ch} = substr($self->{text}, $self->{at}++, 1);
    }


    sub _value {
        my $self = shift;
        $self->_white();
        my $ch = $self->{ch};
        return          if(!defined $ch);
        return $self->_object() if($ch eq '{');
        return $self->_array()  if($ch eq '[');
        return $self->_tag()    if($ch eq '(');
        return $self->_string() if($ch eq '"' or ($self->{PROPS}[P_ALLOW_SINGLEQUOTE] and $ch eq "'"));
        return $self->_number() if($ch =~ /[0-9]/ or $ch eq '-');
        return $self->_word();
    }

    sub _string {
        my $self = shift;
        my $utf16;
        my $is_utf8;

        my $utf8_len = 0;

        my $s = ''; # basically UTF8 flag on

        my $ch = $self->{ch};
        if($ch eq '"' or ($self->{PROPS}[P_ALLOW_SINGLEQUOTE] and $ch eq "'")){
            my $boundChar = $ch;

            OUTER: while( defined($ch = $self->_next_chr()) ){

                if($ch eq $boundChar){
                    $self->_next_chr();

                    if ($utf16) {
                        $self->_decode_error("missing low surrogate character in surrogate pair");
                    }

                    utf8::decode($s) if($is_utf8);

                    return $s;
                }
                elsif($ch eq '\\'){
                    $ch = $self->_next_chr();
                    if(exists $escapes{$ch}){
                        $s .= $escapes{$ch};
                    }
                    elsif($ch eq 'u'){ # UNICODE handling
                        my $u = '';

                        for(1..4){
                            $ch = $self->_next_chr();
                            last OUTER if($ch !~ /[0-9a-fA-F]/);
                            $u .= $ch;
                        }

                        # U+D800 - U+DBFF
                        if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
                            $utf16 = $u;
                        }
                        # U+DC00 - U+DFFF
                        elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
                            unless (defined $utf16) {
                                $self->_decode_error("missing high surrogate character in surrogate pair");
                            }
                            $is_utf8 = 1;
                            $s .= _decode_surrogates($utf16, $u) || next;
                            $utf16 = undef;
                        }
                        else {
                            if (defined $utf16) {
                                $self->_decode_error("surrogate pair expected");
                            }

                            my $hex = hex( $u );
                            if ( chr $u =~ /[[:^ascii:]]/ ) {
                                $is_utf8 = 1;
                                $s .= _decode_unicode($u) || next;
                            }
                            else {
                                $s .= chr $hex;
                            }
                        }

                    }
                    else{
                        unless ($self->{PROPS}[P_LOOSE]) {
                            $self->{at} -= 2;
                            $self->_decode_error('illegal backslash escape sequence in string');
                        }
                        $s .= $ch;
                    }
                }
                else{

                    if ( $ch =~ /[[:^ascii:]]/ ) {
                        unless( $ch = $self->_is_valid_utf8($ch, \$utf8_len) ) {
                            $self->{at} -= 1;
                            $self->_decode_error("malformed UTF-8 character in JSON string");
                        }
                        else {
                            $self->{at} += $utf8_len - 1;
                        }

                        $is_utf8 = 1;
                    }

                    if (!$self->{PROPS}[P_LOOSE]) {
                        if ($ch =~ $invalid_char_re)  { # '/' ok
                            if (!$self->{PROPS}[P_RELAXED] or $ch ne "\t") {
                                $self->{at}--;
                                $self->_decode_error(sprintf "invalid character 0x%X"
                                   . " encountered while parsing JSON string",
                                   ord $ch);
                            }
                        }
                    }

                    $s .= $ch;
                }
            }
        }

        $self->_decode_error("unexpected end of string while parsing JSON string");
    }


    sub _white {
        my $self = shift;
        my $ch = $self->{ch};
        while( defined $ch  ){
            if($ch eq '' or $ch =~ /\A[ \t\r\n]\z/){
                $ch = $self->_next_chr();
            }
            elsif($self->{PROPS}[P_RELAXED] and $ch eq '/'){
                $ch = $self->_next_chr();
                if(defined $ch and $ch eq '/'){
                    1 while(defined($ch = $self->_next_chr()) and $ch ne "\n" and $ch ne "\r");
                }
                elsif(defined $ch and $ch eq '*'){
                    $ch = $self->_next_chr();
                    while(1){
                        if(defined $ch){
                            if($ch eq '*'){
                                if(defined($ch = $self->_next_chr()) and $ch eq '/'){
                                    $ch = $self->_next_chr();
                                    last;
                                }
                            }
                            else{
                                $ch = $self->_next_chr();
                            }
                        }
                        else{
                            $self->_decode_error("Unterminated comment");
                        }
                    }
                    next;
                }
                else{
                    $self->{at}--;
                    $self->_decode_error("malformed JSON string, neither array, object, number, string or atom");
                }
            }
            else{
                if ($self->{PROPS}[P_RELAXED] and $ch eq '#') { # correctly?
                    pos($self->{text}) = $self->{at};
                    $self->{text} =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;
                    $self->{at} = pos($self->{text});
                    $ch = $self->_next_chr;
                    next;
                }

                last;
            }
        }
    }


    sub _array {
        my $self = shift;
        my $a  = $_[0] || []; # you can use this code to use another array ref object.

        $self->_decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
                                                    if (++$self->{depth} > $self->{max_depth});

        $self->_next_chr();
        $self->_white();

        my $ch = $self->{ch};
        if(defined $ch and $ch eq ']'){
            --$self->{depth};
            $self->_next_chr();
            return $a;
        }
        else {
            while(defined($ch)){
                push @$a, $self->_value();

                $self->_white();

                $ch = $self->{ch};
                if (!defined $ch) {
                    last;
                }

                if($ch eq ']'){
                    --$self->{depth};
                    $self->_next_chr();
                    return $a;
                }

                if($ch ne ','){
                    last;
                }

                $self->_next_chr();
                $self->_white();

                $ch = $self->{ch};
                if ($self->{PROPS}[P_RELAXED] and $ch eq ']') {
                    --$self->{depth};
                    $self->_next_chr();
                    return $a;
                }

            }
        }

        $self->{at}-- if defined $ch and $ch ne '';
        $self->_decode_error(", or ] expected while parsing array");
    }

    sub _tag {
        my $self = shift;
        $self->_decode_error('malformed JSON string, neither array, object, number, string or atom') unless $self->{PROPS}[P_ALLOW_TAGS];

        $self->_next_chr();
        $self->_white();

        my $tag = $self->_value();
        return unless defined $tag;
        $self->_decode_error('malformed JSON string, (tag) must be a string') if ref $tag;

        $self->_white();

        my $ch = $self->{ch};
        if (!defined $ch or $ch ne ')') {
            $self->_decode_error(') expected after tag');
        }

        $self->_next_chr();
        $self->_white();

        my $val = $self->_value();
        return unless defined $val;
        $self->_decode_error('malformed JSON string, tag value must be an array') unless ref $val eq 'ARRAY';

        if (!eval { $tag->can('THAW') }) {
             $self->_decode_error('cannot decode perl-object (package does not exist)') if $@;
             $self->_decode_error('cannot decode perl-object (package does not have a THAW method)');
        }
        $tag->THAW('JSON', @$val);
    }

    sub _object {
        my $self = shift;
        my $o = $_[0] || {}; # you can use this code to use another hash ref object.
        my $k;

        $self->_decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
                                                if (++$self->{depth} > $self->{max_depth});
        $self->_next_chr();
        $self->_white();

        my $ch = $self->{ch};
        if(defined $ch and $ch eq '}'){
            --$self->{depth};
            $self->_next_chr();
            if ($self->{F_HOOK}) {
                return $self->__json_object_hook($o);
            }
            return $o;
        }
        else {
            while (defined $ch) {
                $k = ($self->{PROPS}[P_ALLOW_BAREKEY] and $ch ne '"' and $ch ne "'") ? $self->_bareKey() : $self->_string();
                $self->_white();

                $ch = $self->{ch};
                if(!defined $ch or $ch ne ':'){
                    $self->{at}--;
                    $self->_decode_error("':' expected");
                }

                $self->_next_chr();
                $o->{$k} = $self->_value();
                $self->_white();

                $ch = $self->{ch};
                last if (!defined $ch);

                if($ch eq '}'){
                    --$self->{depth};
                    $self->_next_chr();
                    if ($self->{F_HOOK}) {
                        return $self->__json_object_hook($o);
                    }
                    return $o;
                }

                if($ch ne ','){
                    last;
                }

                $self->_next_chr();
                $self->_white();

                $ch = $self->{ch};
                if ($self->{PROPS}[P_RELAXED] and $ch eq '}') {
                    --$self->{depth};
                    $self->_next_chr();
                    if ($self->{F_HOOK}) {
                        return $self->__json_object_hook($o);
                    }
                    return $o;
                }

            }

        }

        $self->{at}-- if defined $ch and $ch ne '';
        $self->_decode_error(", or } expected while parsing object/hash");
    }


    sub _bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
        my $self = shift;
        my $key;
        my $ch = $self->{ch};
        while($ch =~ /[\$\w[:^ascii:]]/){
            $key .= $ch;
            $ch = $self->_next_chr();
        }
        return $key;
    }


    sub _word {
        my $self = shift;
        my $word =  substr($self->{text},$self->{at}-1,4);

        if($word eq 'true'){
            $self->{at} += 3;
            $self->_next_chr;
            return defined $self->{true} ? $self->{true} : $JSON::PP::true;
        }
        elsif($word eq 'null'){
            $self->{at} += 3;
            $self->_next_chr;
            return undef;
        }
        elsif($word eq 'fals'){
            $self->{at} += 3;
            if(substr($self->{text},$self->{at},1) eq 'e'){
                $self->{at}++;
                $self->_next_chr;
                return defined $self->{false} ? $self->{false} : $JSON::PP::false;
            }
        }

        $self->{at}--; # for decode_error report

        $self->_decode_error("'null' expected")  if ($word =~ /^n/);
        $self->_decode_error("'true' expected")  if ($word =~ /^t/);
        $self->_decode_error("'false' expected") if ($word =~ /^f/);
        $self->_decode_error("malformed JSON string, neither array, object, number, string or atom");
    }


    sub _number {
        my $self = shift;
        my $n    = '';
        my $v;
        my $is_dec;
        my $is_exp;

        my $ch = $self->{ch};
        if($ch eq '-'){
            $n = '-';
            $ch = $self->_next_chr;
            if (!defined $ch or $ch !~ /\d/) {
                $self->_decode_error("malformed number (no digits after initial minus)");
            }
        }

        # According to RFC4627, hex or oct digits are invalid.
        if($ch eq '0'){
            my $peek = substr($self->{text},$self->{at},1);
            if($peek =~ /^[0-9a-dfA-DF]/){ # e may be valid (exponential)
                $self->_decode_error("malformed number (leading zero must not be followed by another digit)");
            }
            $n .= $ch;
            $ch = $self->_next_chr;
        }

        while(defined $ch and $ch =~ /\d/){
            $n .= $ch;
            $ch = $self->_next_chr;
        }

        if(defined $ch and $ch eq '.'){
            $n .= '.';
            $is_dec = 1;

            $ch = $self->_next_chr;
            if (!defined $ch or $ch !~ /\d/) {
                $self->_decode_error("malformed number (no digits after decimal point)");
            }
            else {
                $n .= $ch;
            }

            while(defined($ch = $self->_next_chr) and $ch =~ /\d/){
                $n .= $ch;
            }
        }

        if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
            $n .= $ch;
            $is_exp = 1;
            $ch = $self->_next_chr;

            if(defined($ch) and ($ch eq '+' or $ch eq '-')){
                $n .= $ch;
                $ch = $self->_next_chr;
                if (!defined $ch or $ch =~ /\D/) {
                    $self->_decode_error("malformed number (no digits after exp sign)");
                }
                $n .= $ch;
            }
            elsif(defined($ch) and $ch =~ /\d/){
                $n .= $ch;
            }
            else {
                $self->_decode_error("malformed number (no digits after exp sign)");
            }

            while(defined($ch = $self->_next_chr) and $ch =~ /\d/){
                $n .= $ch;
            }

        }

        $v .= $n;

        if ($is_dec or $is_exp) {
            if ($self->{PROPS}[P_ALLOW_BIGNUM]) {
                require Math::BigFloat;
                return Math::BigFloat->new($v);
            }
        } else {
            if (length $v > $max_intsize) {
                if ($self->{PROPS}[P_ALLOW_BIGNUM]) { # from Adam Sussman
                    require Math::BigInt;
                    return Math::BigInt->new($v);
                }
                else {
                    return "$v";
                }
            }
        }

        return $is_dec ? $v/1.0 : 0+$v;
    }

    # Compute how many bytes are in the longest legal official Unicode
    # character
    my $max_unicode_length = do {
      no warnings 'utf8';
      chr 0x10FFFF;
    };
    utf8::encode($max_unicode_length);
    $max_unicode_length = length $max_unicode_length;

    sub _is_valid_utf8 {
        my ($self, $ch, $utf8_len_r) = @_;

        # Returns undef (setting $utf8_len to 0) unless the next bytes in $text
        # comprise a well-formed UTF-8 encoded character, in which case,
        # return those bytes, setting $utf8_len to their count.

        my $start_point = substr($self->{text}, $self->{at} - 1);

        # Look no further than the maximum number of bytes in a single
        # character
        my $limit = $max_unicode_length;
        $limit = length($start_point) if $limit > length($start_point);

        # Find the number of bytes comprising the first character in $text
        # (without having to know the details of its internal representation).
        # This loop will iterate just once on well-formed input.
        while ($limit > 0) {    # Until we succeed or exhaust the input
            my $copy = substr($start_point, 0, $limit);

            # decode() will return true if all bytes are valid; false
            # if any aren't.
            if (utf8::decode($copy)) {

                # Is valid: get the first character, convert back to bytes,
                # and return those bytes.
                $copy = substr($copy, 0, 1);
                utf8::encode($copy);
                $$utf8_len_r = length $copy;
                return substr($start_point, 0, $$utf8_len_r);
            }

            # If it didn't work, it could be that there is a full legal character
            # followed by a partial or malformed one.  Narrow the window and
            # try again.
            $limit--;
        }

        # Failed to find a legal UTF-8 character.
        $$utf8_len_r = 0;
        return;
    }


    sub _decode_error {
        my $self   = shift;
        my $error  = shift;
        my $no_rep = shift;
        my $str    = defined $self->{text} ? substr($self->{text}, $self->{at}) : '';
        my $mess   = '';
        my $type   = 'U*';

        for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
            my $chr_c = chr($c);
            $mess .=  $chr_c eq '\\' ? '\\\\'
                    : $chr_c =~ /[[:print:]]/ ? $chr_c
                    : $chr_c eq '\a' ? '\a'
                    : $chr_c eq '\t' ? '\t'
                    : $chr_c eq '\n' ? '\n'
                    : $chr_c eq '\r' ? '\r'
                    : $chr_c eq '\f' ? '\f'
                    : sprintf('\x{%x}', $c)
                    ;
            if ( length $mess >= 20 ) {
                $mess .= '...';
                last;
            }
        }

        unless ( length $mess ) {
            $mess = '(end of string)';
        }

        Carp::croak (
            $no_rep ? "$error" : "$error, at character offset $self->{at} (before \"$mess\")"
        );

    }


    sub __json_object_hook {
        my $self = shift;
        my $o    = $_[0];
        my @ks = keys %{$o};

        if ( $self->{cb_sk_object} and @ks == 1 and exists $self->{cb_sk_object}{ $ks[0] } and ref $self->{cb_sk_object}{ $ks[0] } ) {
            my @val = $self->{cb_sk_object}{ $ks[0] }->( $o->{$ks[0]} );
            if (@val == 0) {
                return $o;
            }
            elsif (@val == 1) {
                return $val[0];
            }
            else {
                Carp::croak("filter_json_single_key_object callbacks must not return more than one scalar");
            }
        }

        my @val = $self->{cb_object}->($o) if ($self->{cb_object});
        if (@val == 0) {
            return $o;
        }
        elsif (@val == 1) {
            return $val[0];
        }
        else {
            Carp::croak("filter_json_object callbacks must not return more than one scalar");
        }
    }

} # PARSE


sub _decode_surrogates { # from perlunicode
    my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
    my $un  = pack('U*', $uni);
    utf8::encode( $un );
    return $un;
}


sub _decode_unicode {
    my $un = pack('U', hex shift);
    utf8::encode( $un );
    return $un;
}

sub incr_parse {
    local $Carp::CarpLevel = 1;
    ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
}


sub incr_skip {
    ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
}


sub incr_reset {
    ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
}

sub incr_text : lvalue {
    $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;

    if ( $_[0]->{_incr_parser}->{incr_pos} ) {
        Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
    }
    $_[0]->{_incr_parser}->{incr_text};
}


###############################
# Utilities
#

# shamelessly copied and modified from JSON::XS code.

$JSON::PP::true  = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };

sub is_bool {
  if (blessed $_[0]) {
    return (
      $_[0]->isa("JSON::PP::Boolean")
      or $_[0]->isa("Types::Serialiser::BooleanBase")
      or $_[0]->isa("JSON::XS::Boolean")
    );
  }
  elsif (CORE_BOOL) {
    BEGIN { CORE_BOOL and warnings->unimport('experimental::builtin') }
    return builtin::is_bool($_[0]);
  }
  return !!0;
}

sub true  { $JSON::PP::true  }
sub false { $JSON::PP::false }
sub null  { undef; }

###############################

package # hide from PAUSE
  JSON::PP::IncrParser;

use strict;

use constant INCR_M_WS   => 0; # initial whitespace skipping
use constant INCR_M_STR  => 1; # inside string
use constant INCR_M_BS   => 2; # inside backslash
use constant INCR_M_JSON => 3; # outside anything, count nesting
use constant INCR_M_C0   => 4;
use constant INCR_M_C1   => 5;
use constant INCR_M_TFN  => 6;
use constant INCR_M_NUM  => 7;

$JSON::backportPP::VERSION = '1.01';

sub new {
    my ( $class ) = @_;

    bless {
        incr_nest    => 0,
        incr_text    => undef,
        incr_pos     => 0,
        incr_mode    => 0,
    }, $class;
}


sub incr_parse {
    my ( $self, $coder, $text ) = @_;

    $self->{incr_text} = '' unless ( defined $self->{incr_text} );

    if ( defined $text ) {
        $self->{incr_text} .= $text;
    }

    if ( defined wantarray ) {
        my $max_size = $coder->get_max_size;
        my $p = $self->{incr_pos};
        my @ret;
        {
            do {
                unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) {
                    $self->_incr_parse( $coder );

                    if ( $max_size and $self->{incr_pos} > $max_size ) {
                        Carp::croak("attempted decode of JSON text of $self->{incr_pos} bytes size, but max_size is set to $max_size");
                    }
                    unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) {
                        # as an optimisation, do not accumulate white space in the incr buffer
                        if ( $self->{incr_mode} == INCR_M_WS and $self->{incr_pos} ) {
                            $self->{incr_pos} = 0;
                            $self->{incr_text} = '';
                        }
                        last;
                    }
                }

                unless ( $coder->get_utf8 ) {
                    utf8::decode( $self->{incr_text} );
                }

                my ($obj, $offset) = $coder->PP_decode_json( $self->{incr_text}, 0x00000001 );
                push @ret, $obj;
                use bytes;
                $self->{incr_text} = substr( $self->{incr_text}, $offset || 0 );
                $self->{incr_pos} = 0;
                $self->{incr_nest} = 0;
                $self->{incr_mode} = 0;
                last unless wantarray;
            } while ( wantarray );
        }

        if ( wantarray ) {
            return @ret;
        }
        else { # in scalar context
            return defined $ret[0] ? $ret[0] : undef;
        }
    }
}


sub _incr_parse {
    my ($self, $coder) = @_;
    my $text = $self->{incr_text};
    my $len = length $text;
    my $p = $self->{incr_pos};

INCR_PARSE:
    while ( $len > $p ) {
        my $s = substr( $text, $p, 1 );
        last INCR_PARSE unless defined $s;
        my $mode = $self->{incr_mode};

        if ( $mode == INCR_M_WS ) {
            while ( $len > $p ) {
                $s = substr( $text, $p, 1 );
                last INCR_PARSE unless defined $s;
                if ( ord($s) > ord " " ) {
                    if ( $s eq '#' ) {
                        $self->{incr_mode} = INCR_M_C0;
                        redo INCR_PARSE;
                    } else {
                        $self->{incr_mode} = INCR_M_JSON;
                        redo INCR_PARSE;
                    }
                }
                $p++;
            }
        } elsif ( $mode == INCR_M_BS ) {
            $p++;
            $self->{incr_mode} = INCR_M_STR;
            redo INCR_PARSE;
        } elsif ( $mode == INCR_M_C0 or $mode == INCR_M_C1 ) {
            while ( $len > $p ) {
                $s = substr( $text, $p, 1 );
                last INCR_PARSE unless defined $s;
                if ( $s eq "\n" ) {
                    $self->{incr_mode} = $self->{incr_mode} == INCR_M_C0 ? INCR_M_WS : INCR_M_JSON;
                    last;
                }
                $p++;
            }
            next;
        } elsif ( $mode == INCR_M_TFN ) {
            last INCR_PARSE if $p >= $len && $self->{incr_nest};
            while ( $len > $p ) {
                $s = substr( $text, $p++, 1 );
                next if defined $s and $s =~ /[rueals]/;
                last;
            }
            $p--;
            $self->{incr_mode} = INCR_M_JSON;

            last INCR_PARSE unless $self->{incr_nest};
            redo INCR_PARSE;
        } elsif ( $mode == INCR_M_NUM ) {
            last INCR_PARSE if $p >= $len && $self->{incr_nest};
            while ( $len > $p ) {
                $s = substr( $text, $p++, 1 );
                next if defined $s and $s =~ /[0-9eE.+\-]/;
                last;
            }
            $p--;
            $self->{incr_mode} = INCR_M_JSON;

            last INCR_PARSE unless $self->{incr_nest};
            redo INCR_PARSE;
        } elsif ( $mode == INCR_M_STR ) {
            while ( $len > $p ) {
                $s = substr( $text, $p, 1 );
                last INCR_PARSE unless defined $s;
                if ( $s eq '"' ) {
                    $p++;
                    $self->{incr_mode} = INCR_M_JSON;

                    last INCR_PARSE unless $self->{incr_nest};
                    redo INCR_PARSE;
                }
                elsif ( $s eq '\\' ) {
                    $p++;
                    if ( !defined substr($text, $p, 1) ) {
                        $self->{incr_mode} = INCR_M_BS;
                        last INCR_PARSE;
                    }
                }
                $p++;
            }
        } elsif ( $mode == INCR_M_JSON ) {
            while ( $len > $p ) {
                $s = substr( $text, $p++, 1 );
                if ( $s eq "\x00" ) {
                    $p--;
                    last INCR_PARSE;
                } elsif ( $s =~ /^[\t\n\r ]$/) {
                    if ( !$self->{incr_nest} ) {
                        $p--; # do not eat the whitespace, let the next round do it
                        last INCR_PARSE;
                    }
                    next;
                } elsif ( $s eq 't' or $s eq 'f' or $s eq 'n' ) {
                    $self->{incr_mode} = INCR_M_TFN;
                    redo INCR_PARSE;
                } elsif ( $s =~ /^[0-9\-]$/ ) {
                    $self->{incr_mode} = INCR_M_NUM;
                    redo INCR_PARSE;
                } elsif ( $s eq '"' ) {
                    $self->{incr_mode} = INCR_M_STR;
                    redo INCR_PARSE;
                } elsif ( $s eq '[' or $s eq '{' ) {
                    if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
                        Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
                    }
                    next;
                } elsif ( $s eq ']' or $s eq '}' ) {
                    if ( --$self->{incr_nest} <= 0 ) {
                        last INCR_PARSE;
                    }
                } elsif ( $s eq '#' ) {
                    $self->{incr_mode} = INCR_M_C1;
                    redo INCR_PARSE;
                }
            }
        }
    }

    $self->{incr_pos} = $p;
    $self->{incr_parsing} = $p ? 1 : 0; # for backward compatibility
}


sub incr_text {
    if ( $_[0]->{incr_pos} ) {
        Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
    }
    $_[0]->{incr_text};
}


sub incr_skip {
    my $self  = shift;
    $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_pos} );
    $self->{incr_pos}     = 0;
    $self->{incr_mode}    = 0;
    $self->{incr_nest}    = 0;
}


sub incr_reset {
    my $self = shift;
    $self->{incr_text}    = undef;
    $self->{incr_pos}     = 0;
    $self->{incr_mode}    = 0;
    $self->{incr_nest}    = 0;
}

###############################


1;
__END__