File Coverage

lib/JSON.pm

Criterion	Covered	Total	%
statement	79	190	41.5
branch	15	86	17.4
condition	3	39	7.6
subroutine	16	28	57.1
pod	8	13	61.5
total	121	356	33.9

package JSON;


use strict;
use Carp ();
use base qw(Exporter);
@JSON::EXPORT = qw(from_json to_json jsonToObj objToJson encode_json decode_json);

BEGIN {
    $JSON::VERSION = '2.90';
    $JSON::DEBUG   = 0 unless (defined $JSON::DEBUG);
    $JSON::DEBUG   = $ENV{ PERL_JSON_DEBUG } if exists $ENV{ PERL_JSON_DEBUG };
}

my $Module_XS  = 'JSON::XS';
my $Module_PP  = 'JSON::PP';
my $Module_bp  = 'JSON::backportPP'; # included in JSON distribution
my $PP_Version = '2.27203';
my $XS_Version = '2.34';


# XS and PP common methods

my @PublicMethods = qw/
    ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref
    allow_blessed convert_blessed filter_json_object filter_json_single_key_object
    shrink max_depth max_size encode decode decode_prefix allow_unknown
/;

my @Properties = qw/
    ascii latin1 utf8 indent space_before space_after relaxed canonical allow_nonref
    allow_blessed convert_blessed shrink max_depth max_size allow_unknown
/;

my @XSOnlyMethods = qw/allow_tags/; # Currently nothing

my @PPOnlyMethods = qw/
    indent_length sort_by
    allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed
/; # JSON::PP specific


# used in _load_xs and _load_pp ($INSTALL_ONLY is not used currently)
my $_INSTALL_DONT_DIE  = 1; # When _load_xs fails to load XS, don't die.
my $_INSTALL_ONLY      = 2; # Don't call _set_methods()
my $_ALLOW_UNSUPPORTED = 0;
my $_UNIV_CONV_BLESSED = 0;
my $_USSING_bpPP       = 0;


# Check the environment variable to decide worker module.

unless ($JSON::Backend) {
    $JSON::DEBUG and  Carp::carp("Check used worker module...");

    my $backend = exists $ENV{PERL_JSON_BACKEND} ? $ENV{PERL_JSON_BACKEND} : 1;

    if ($backend eq '1' or $backend =~ /JSON::XS\s*,\s*JSON::PP/) {
        _load_xs($_INSTALL_DONT_DIE) or _load_pp();
    }
    elsif ($backend eq '0' or $backend eq 'JSON::PP') {
        _load_pp();
    }
    elsif ($backend eq '2' or $backend eq 'JSON::XS') {
        _load_xs();
    }
    elsif ($backend eq 'JSON::backportPP') {
        $_USSING_bpPP = 1;
        _load_pp();
    }
    else {
        Carp::croak "The value of environmental variable 'PERL_JSON_BACKEND' is invalid.";
    }
}


sub import {
    my $pkg = shift;
    my @what_to_export;
    my $no_export;

    for my $tag (@_) {
        if ($tag eq '-support_by_pp') {
            if (!$_ALLOW_UNSUPPORTED++) {
                JSON::Backend::XS
                    ->support_by_pp(@PPOnlyMethods) if ($JSON::Backend eq $Module_XS);
            }
            next;
        }
        elsif ($tag eq '-no_export') {
            $no_export++, next;
        }
        elsif ( $tag eq '-convert_blessed_universally' ) {
            eval q|
                require B;
                *UNIVERSAL::TO_JSON = sub {
                    my $b_obj = B::svref_2object( $_[0] );
                    return    $b_obj->isa('B::HV') ? { %{ $_[0] } }
                            : $b_obj->isa('B::AV') ? [ @{ $_[0] } ]
                            : undef
                            ;
                }
            | if ( !$_UNIV_CONV_BLESSED++ );
            next;
        }
        push @what_to_export, $tag;
    }

    return if ($no_export);

    __PACKAGE__->export_to_level(1, $pkg, @what_to_export);
}


# OBSOLETED

sub jsonToObj {
    my $alternative = 'from_json';
    if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) {
        shift @_; $alternative = 'decode';
    }
    Carp::carp "'jsonToObj' will be obsoleted. Please use '$alternative' instead.";
    return JSON::from_json(@_);
};

sub objToJson {
    my $alternative = 'to_json';
    if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) {
        shift @_; $alternative = 'encode';
    }
    Carp::carp "'objToJson' will be obsoleted. Please use '$alternative' instead.";
    JSON::to_json(@_);
};


# INTERFACES

sub to_json ($@) {
    if (
        ref($_[0]) eq 'JSON'
        or (@_ > 2 and $_[0] eq 'JSON')
    ) {
        Carp::croak "to_json should not be called as a method.";
    }
    my $json = JSON->new;

    if (@_ == 2 and ref $_[1] eq 'HASH') {
        my $opt  = $_[1];
        for my $method (keys %$opt) {
            $json->$method( $opt->{$method} );
        }
    }

    $json->encode($_[0]);
}


sub from_json ($@) {
    if ( ref($_[0]) eq 'JSON' or $_[0] eq 'JSON' ) {
        Carp::croak "from_json should not be called as a method.";
    }
    my $json = JSON->new;

    if (@_ == 2 and ref $_[1] eq 'HASH') {
        my $opt  = $_[1];
        for my $method (keys %$opt) {
            $json->$method( $opt->{$method} );
        }
    }

    return $json->decode( $_[0] );
}



sub true  { $JSON::true  }

sub false { $JSON::false }

sub null  { undef; }


sub require_xs_version { $XS_Version; }

sub backend {
    my $proto = shift;
    $JSON::Backend;
}

#*module = *backend;


sub is_xs {
    return $_[0]->backend eq $Module_XS;
}


sub is_pp {
    return not $_[0]->is_xs;
}


sub pureperl_only_methods { @PPOnlyMethods; }


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

    if (@_ == 1) {
        my %props;
        for $name (@Properties) {
            my $method = 'get_' . $name;
            if ($name eq 'max_size') {
                my $value = $self->$method();
                $props{$name} = $value == 1 ? 0 : $value;
                next;
            }
            $props{$name} = $self->$method();
        }
        return \%props;
    }
    elsif (@_ > 3) {
        Carp::croak('property() can take only the option within 2 arguments.');
    }
    elsif (@_ == 2) {
        if ( my $method = $self->can('get_' . $name) ) {
            if ($name eq 'max_size') {
                my $value = $self->$method();
                return $value == 1 ? 0 : $value;
            }
            $self->$method();
        }
    }
    else {
        $self->$name($value);
    }

}



# INTERNAL

sub _load_xs {
    my $opt = shift;

    $JSON::DEBUG and Carp::carp "Load $Module_XS.";

    # if called after install module, overload is disable.... why?
    JSON::Boolean::_overrride_overload($Module_XS);
    JSON::Boolean::_overrride_overload($Module_PP);

    eval qq|
        use $Module_XS $XS_Version ();
    |;

    if ($@) {
        if (defined $opt and $opt & $_INSTALL_DONT_DIE) {
            $JSON::DEBUG and Carp::carp "Can't load $Module_XS...($@)";
            return 0;
        }
        Carp::croak $@;
    }

    unless (defined $opt and $opt & $_INSTALL_ONLY) {
        _set_module( $JSON::Backend = $Module_XS );
        my $data = join("", ); # this code is from Jcode 2.xx.
        close(DATA);
        eval $data;
        JSON::Backend::XS->init;
    }

    return 1;
};


sub _load_pp {
    my $opt = shift;
    my $backend = $_USSING_bpPP ? $Module_bp : $Module_PP;

    $JSON::DEBUG and Carp::carp "Load $backend.";

    # if called after install module, overload is disable.... why?
    JSON::Boolean::_overrride_overload($Module_XS);
    JSON::Boolean::_overrride_overload($backend);

    if ( $_USSING_bpPP ) {
        eval qq| require $backend |;
    }
    else {
        eval qq| use $backend $PP_Version () |;
    }

    if ($@) {
        if ( $backend eq $Module_PP ) {
            $JSON::DEBUG and Carp::carp "Can't load $Module_PP ($@), so try to load $Module_bp";
            $_USSING_bpPP++;
            $backend = $Module_bp;
            JSON::Boolean::_overrride_overload($backend);
            local $^W; # if PP installed but invalid version, backportPP redefines methods.
            eval qq| require $Module_bp |;
        }
        Carp::croak $@ if $@;
    }

    unless (defined $opt and $opt & $_INSTALL_ONLY) {
        _set_module( $JSON::Backend = $Module_PP ); # even if backportPP, set $Backend with 'JSON::PP'
        JSON::Backend::PP->init;
    }
};


sub _set_module {
    return if defined $JSON::true;

    my $module = shift;

    local $^W;
    no strict qw(refs);

    $JSON::true  = ${"$module\::true"};
    $JSON::false = ${"$module\::false"};

    push @JSON::ISA, $module;
    if ( JSON->is_xs and JSON->backend->VERSION < 3 ) {
        eval 'package JSON::PP::Boolean';
        push @{"$module\::Boolean::ISA"}, qw(JSON::PP::Boolean);
    }

    *{"JSON::is_bool"} = \&{"$module\::is_bool"};

    for my $method ($module eq $Module_XS ? @PPOnlyMethods : @XSOnlyMethods) {
        *{"JSON::$method"} = sub {
            Carp::carp("$method is not supported in $module.");
            $_[0];
        };
    }

    return 1;
}



#
# JSON Boolean
#

package JSON::Boolean;

my %Installed;

sub _overrride_overload {
    return; # this function is currently disable.
    return if ($Installed{ $_[0] }++);

    my $boolean = $_[0] . '::Boolean';

    eval sprintf(q|
        package %s;
        use overload (
            '""' => sub { ${$_[0]} == 1 ? 'true' : 'false' },
            'eq' => sub {
                my ($obj, $op) = ref ($_[0]) ? ($_[0], $_[1]) : ($_[1], $_[0]);
                if ($op eq 'true' or $op eq 'false') {
                    return "$obj" eq 'true' ? 'true' eq $op : 'false' eq $op;
                }
                else {
                    return $obj ? 1 == $op : 0 == $op;
                }
            },
        );
    |, $boolean);

    if ($@) { Carp::croak $@; }

    if ( exists $INC{'JSON/XS.pm'} and $boolean eq 'JSON::XS::Boolean' ) {
        local $^W;
        my $true  = do { bless \(my $dummy = 1), $boolean };
        my $false = do { bless \(my $dummy = 0), $boolean };
        *JSON::XS::true  = sub () { $true };
        *JSON::XS::false = sub () { $false };
    }
    elsif ( exists $INC{'JSON/PP.pm'} and $boolean eq 'JSON::PP::Boolean' ) {
        local $^W;
        my $true  = do { bless \(my $dummy = 1), $boolean };
        my $false = do { bless \(my $dummy = 0), $boolean };
        *JSON::PP::true  = sub { $true };
        *JSON::PP::false = sub { $false };
    }

    return 1;
}


#
# Helper classes for Backend Module (PP)
#

package JSON::Backend::PP;

sub init {
    local $^W;
    no strict qw(refs); # this routine may be called after JSON::Backend::XS init was called.
    *{"JSON::decode_json"} = \&{"JSON::PP::decode_json"};
    *{"JSON::encode_json"} = \&{"JSON::PP::encode_json"};
    *{"JSON::PP::is_xs"}  = sub { 0 };
    *{"JSON::PP::is_pp"}  = sub { 1 };
    return 1;
}

#
# To save memory, the below lines are read only when XS backend is used.
#

package JSON;

1;
__DATA__