File Coverage

blib/lib/JSON/Any.pm

Criterion	Covered	Total	%
statement	158	218	72.4
branch	50	76	65.7
condition	11	15	73.3
subroutine	22	22	100.0
pod	7	7	100.0
total	248	338	73.3

package JSON::Any; # git description: v1.39-25-gd13a0fd

use warnings;
use strict;

our $VERSION = '1.40';

use Carp qw(croak carp);

# ABSTRACT: (DEPRECATED) Wrapper Class for the various JSON classes
# KEYWORDS: json serialization serialisation wrapper abstraction

our $UTF8;

my ( %conf, $handler, $encoder, $decoder );
use constant HANDLER => 0;
use constant ENCODER => 1;
use constant DECODER => 2;
use constant UTF8    => 3;

BEGIN {
    %conf = (
        json_1 => {
            encoder       => 'objToJson',
            decoder       => 'jsonToObj',
            get_true      => sub { return JSON::True(); },
            get_false     => sub { return JSON::False(); },
            create_object => sub {
                require JSON;
                my ( $self, $conf ) = @_;
                my @params = qw(
                  autoconv
                  skipinvalid
                  execcoderef
                  pretty
                  indent
                  delimiter
                  keysort
                  convblessed
                  selfconvert
                  singlequote
                  quoteapos
                  unmapping
                  barekey
                );
                my $obj =
                  $handler->new( utf8 => $conf->{utf8} );    ## constructor only

                for my $mutator (@params) {
                    next unless exists $conf->{$mutator};
                    $obj = $obj->$mutator( $conf->{$mutator} );
                }

                $self->[ENCODER] = 'objToJson';
                $self->[DECODER] = 'jsonToObj';
                $self->[HANDLER] = $obj;
            },
        },
        json_pp => {
            encoder       => 'encode_json',
            decoder       => 'decode_json',
            get_true      => sub { return JSON::PP::true(); },
            get_false     => sub { return JSON::PP::false(); },
            create_object => sub {
                my ( $self, $conf ) = @_;
                my @params = qw(
                  ascii
                  latin1
                  utf8
                  pretty
                  indent
                  space_before
                  space_after
                  relaxed
                  canonical
                  allow_nonref
                  allow_blessed
                  convert_blessed
                  filter_json_object
                  shrink
                  max_depth
                  max_size
                  loose
                  allow_bignum
                  allow_barekey
                  allow_singlequote
                  escape_slash
                  indent_length
                  sort_by
                );
                local $conf->{utf8} = !$conf->{utf8};    # it means the opposite
                my $obj = $handler->new;

                for my $mutator (@params) {
                    next unless exists $conf->{$mutator};
                    $obj = $obj->$mutator( $conf->{$mutator} );
                }

                $self->[ENCODER] = 'encode';
                $self->[DECODER] = 'decode';
                $self->[HANDLER] = $obj;
            },
        },
        json_dwiw => {
            encoder       => 'to_json',
            decoder       => 'from_json',
            get_true      => sub { return JSON::DWIW->true; },
            get_false     => sub { return JSON::DWIW->false; },
            create_object => sub {
                my ( $self, $conf ) = @_;
                my @params = qw(bare_keys);
                croak "JSON::DWIW does not support utf8" if $conf->{utf8};
                $self->[ENCODER] = 'to_json';
                $self->[DECODER] = 'from_json';
                $self->[HANDLER] =
                  $handler->new( { map +($_ => $conf->{$_}), @params } );
            },
        },
        json_xs_1 => {
            encoder       => 'to_json',
            decoder       => 'from_json',
            get_true      => sub { return \1; },
            get_false     => sub { return \0; },
            create_object => sub {
                my ( $self, $conf ) = @_;

                my @params = qw(
                  ascii
                  utf8
                  pretty
                  indent
                  space_before
                  space_after
                  canonical
                  allow_nonref
                  shrink
                  max_depth
                );

                my $obj = $handler->new;
                for my $mutator (@params) {
                    next unless exists $conf->{$mutator};
                    $obj = $obj->$mutator( $conf->{$mutator} );
                }
                $self->[ENCODER] = 'encode';
                $self->[DECODER] = 'decode';
                $self->[HANDLER] = $obj;
            },
        },
        json_xs_2 => {
            encoder       => 'encode_json',
            decoder       => 'decode_json',
            get_true      => sub { return JSON::XS::true(); },
            get_false     => sub { return JSON::XS::false(); },
            create_object => sub {
                my ( $self, $conf ) = @_;

                my @params = qw(
                  ascii
                  latin1
                  utf8
                  pretty
                  indent
                  space_before
                  space_after
                  relaxed
                  canonical
                  allow_nonref
                  allow_blessed
                  convert_blessed
                  filter_json_object
                  shrink
                  max_depth
                  max_size
                );

                local $conf->{utf8} = !$conf->{utf8};    # it means the opposite

                my $obj = $handler->new;
                for my $mutator (@params) {
                    next unless exists $conf->{$mutator};
                    $obj = $obj->$mutator( $conf->{$mutator} );
                }
                $self->[ENCODER] = 'encode';
                $self->[DECODER] = 'decode';
                $self->[HANDLER] = $obj;
            },
        },
        json_syck => {
            encoder  => 'Dump',
            decoder  => 'Load',
            get_true => sub {
                croak "JSON::Syck does not support special boolean values";
            },
            get_false => sub {
                croak "JSON::Syck does not support special boolean values";
            },
            create_object => sub {
                my ( $self, $conf ) = @_;
                croak "JSON::Syck does not support utf8" if $conf->{utf8};
                $self->[ENCODER] = sub { Dump(@_) };
                $self->[DECODER] = sub { Load(@_) };
                $self->[HANDLER] = 'JSON::Syck';
              }
        },
    );

    # JSON.pm v2 has the same API as JSON::PP
    $conf{json_2} = { %{ $conf{json_pp} } };
    $conf{json_2}{get_true}  = sub { return JSON::true(); };
    $conf{json_2}{get_false} = sub { return JSON::false(); };
    {
      my $create = $conf{json_2}{create_object};
      $conf{json_2}{create_object} = sub {
        JSON->import( '-support_by_pp', '-no_export' );
        goto &$create;
      };
    }

    # JSON.pm v3 and v4 are the same as v2
    $conf{json_3} = { %{ $conf{json_2} } };
    $conf{json_4} = { %{ $conf{json_3} } };

    # Cpanel::JSON::XS is a fork of JSON::XS (currently)
    $conf{cpanel_json_xs} = { %{ $conf{json_xs_2} } };
    $conf{cpanel_json_xs}{get_true}  = sub { return Cpanel::JSON::XS::true(); };
    $conf{cpanel_json_xs}{get_false} = sub { return Cpanel::JSON::XS::false(); };

    # JSON::XS 3 is almost the same as JSON::XS 2
    $conf{json_xs_3} = { %{ $conf{json_xs_2} } };
    $conf{json_xs_3}{get_true}  = sub { return Types::Serialiser::true(); };
    $conf{json_xs_3}{get_false} = sub { return Types::Serialiser::false(); };

    # JSON::XS v4 is the same as v3
    $conf{json_xs_4} = { %{ $conf{json_xs_3} } };
}

sub _make_key {
    my $handler = shift;
    ( my $key = lc($handler) ) =~ s/::/_/g;
    if ( 'json_xs' eq $key || 'json' eq $key ) {
        no strict 'refs';
        $key .= "_" . ( split /\./, ${"$handler\::VERSION"} )[0];
    }
    return $key;
}

my @default    = qw(CPANEL XS PP JSON DWIW);
my @deprecated = qw(Syck);

sub _module_name {
    my ($testmod) = @_;
    return 'Cpanel::JSON::XS' if $testmod eq 'CPANEL';
    return 'JSON'             if $testmod eq 'JSON';
    return "JSON::$testmod";
}

sub _try_loading {
    my @order = @_;
    ( $handler, $encoder, $decoder ) = ();
    foreach my $mod (@order) {
        my $testmod = _module_name($mod);
        if (eval "require $testmod; 1") {
            $handler = $testmod;
            my $key = _make_key($handler);
            next unless exists $conf{$key};
            $encoder = $conf{$key}->{encoder};
            $decoder = $conf{$key}->{decoder};
            last;
        }
    }
    return ( $handler, $encoder, $decoder );
}

sub import {
    my $class = shift;
    my @order = @_;

    ( $handler, $encoder, $decoder ) = ();

    @order = split /\s/, $ENV{JSON_ANY_ORDER}
      if !@order and $ENV{JSON_ANY_ORDER};

    if (@order) {
        ( $handler, $encoder, $decoder ) = _try_loading(@order);
        if ( $handler && grep "JSON::$_" eq $handler, @deprecated ) {
            my @upgrade_to = grep { my $mod = $_; !grep { $mod eq $_ } @deprecated } @order;
            @upgrade_to = @default if not @upgrade_to;
            carp "Found deprecated package $handler. Please upgrade to ",
                _module_name_list(@upgrade_to);
        }
    }
    else {
        ( $handler, $encoder, $decoder ) = _try_loading(@default);
        unless ($handler) {
            ( $handler, $encoder, $decoder ) = _try_loading(@deprecated);
            if ($handler) {
                carp "Found deprecated package $handler. Please upgrade to ",
                  _module_name_list(@default);
            }
        }
    }

    unless ($handler) {
        croak "Couldn't find a JSON package. Need ", _module_name_list(@order ? @order : @default);
    }
    croak "Couldn't find a working decoder method (but found handler $handler ", $handler->VERSION, ")." unless $decoder;
    croak "Couldn't find a working encoder method (but found handler $handler ", $handler->VERSION, ")." unless $encoder;
}

sub _module_name_list {
    my @list = map _module_name($_), @_;
    my $last = pop @list;
    return (@list
        ? (join(', ' => @list), " or $last")
        : $last
    );
}

#pod =head1 SYNOPSIS
#pod
#pod     use JSON::Any;
#pod     my $j = JSON::Any->new;
#pod     my $json = $j->objToJson({foo=>'bar', baz=>'quux'});
#pod     my $obj = $j->jsonToObj($json);
#pod
#pod =head1 DEPRECATION NOTICE
#pod
#pod The original need for L has been solved (quite some time ago
#pod actually). If you're producing new code it is recommended to use L which
#pod will optionally use L for speed purposes.
#pod
#pod JSON::Any will continue to be maintained for compatibility with existing code
#pod (as well as for rare cases where you want L as a backend),
#pod but for new code you should strongly consider using L instead.
#pod
#pod For more information about the various options and which are preferred, see
#pod L.
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module tries to provide a coherent API to bring together the various JSON
#pod modules currently on CPAN. This module will allow you to code to any JSON API
#pod and have it work regardless of which JSON module is actually installed.
#pod
#pod     use JSON::Any;
#pod
#pod     my $j = JSON::Any->new;
#pod
#pod     $json = $j->objToJson({foo=>'bar', baz=>'quux'});
#pod     $obj = $j->jsonToObj($json);
#pod
#pod or
#pod
#pod     $json = $j->encode({foo=>'bar', baz=>'quux'});
#pod     $obj = $j->decode($json);
#pod
#pod or
#pod
#pod     $json = $j->Dump({foo=>'bar', baz=>'quux'});
#pod     $obj = $j->Load($json);
#pod
#pod or
#pod
#pod     $json = $j->to_json({foo=>'bar', baz=>'quux'});
#pod     $obj = $j->from_json($json);
#pod
#pod or without creating an object:
#pod
#pod     $json = JSON::Any->objToJson({foo=>'bar', baz=>'quux'});
#pod     $obj = JSON::Any->jsonToObj($json);
#pod
#pod On load, JSON::Any will find a valid JSON module in your @INC by looking
#pod for them in this order:
#pod
#pod     Cpanel::JSON::XS
#pod     JSON::XS
#pod     JSON::PP
#pod     JSON
#pod     JSON::DWIW
#pod
#pod And loading the first one it finds.
#pod
#pod You may change the order by specifying it on the C line:
#pod
#pod     use JSON::Any qw(DWIW XS CPANEL JSON PP);
#pod
#pod Specifying an order that is missing modules will prevent those module from
#pod being used:
#pod
#pod     use JSON::Any qw(CPANEL PP); # same as JSON::MaybeXS
#pod
#pod This will check in that order, and will never attempt to load L,
#pod L, or L. This can also be set via the C<$ENV{JSON_ANY_ORDER}>
#pod environment variable.
#pod
#pod L has been deprecated by its author, but in the attempt to still
#pod stay relevant as a "Compatibility Layer" JSON::Any still supports it. This support
#pod however has been made optional starting with JSON::Any 1.19. In deference to a
#pod bug request starting with L 1.20, L and other deprecated modules
#pod will still be installed, but only as a last resort and will now include a
#pod warning.
#pod
#pod     use JSON::Any qw(Syck XS JSON);
#pod
#pod or
#pod
#pod     $ENV{JSON_ANY_ORDER} = 'Syck XS JSON';
#pod
#pod At install time, JSON::Any will attempt to install L as a reasonable
#pod fallback if you do not appear have B backends installed on your system.
#pod
#pod WARNING: If you call JSON::Any with an empty list
#pod
#pod     use JSON::Any ();
#pod
#pod It will skip the JSON package detection routines and will die loudly that it
#pod couldn't find a package.
#pod
#pod =head1 WARNING
#pod
#pod L 3.0 or higher has a conflict with any version of L less than 2.90
#pod when you use L's C<-support_by_pp> option, which JSON::Any enables by
#pod default.
#pod
#pod This situation should only come up with JSON::Any if you have L 2.61 or
#pod lower B L 3.0 or higher installed, and you use L
#pod via C<< use JSON::Any qw(JSON); >> or the C environment variable.
#pod
#pod If you run into an issue where you're getting recursive inheritance errors in a
#pod L package, please try upgrading L to 2.90 or higher.
#pod
#pod =head1 METHODS
#pod
#pod =head2 C
#pod
#pod =for stopwords recognised unicode
#pod
#pod Will take any of the parameters for the underlying system and pass them
#pod through. However these values don't map between JSON modules, so, from a
#pod portability standpoint this is really only helpful for those parameters that
#pod happen to have the same name.
#pod
#pod The one parameter that is universally supported (to the extent that is
#pod supported by the underlying JSON modules) is C. When this parameter is
#pod enabled all resulting JSON will be marked as unicode, and all unicode strings
#pod in the input data structure will be preserved as such.
#pod
#pod Also note that the C parameter is recognised by all the modules
#pod that throw exceptions when a blessed reference is given them meaning that
#pod setting it to true works for all modules. Of course, that means that you
#pod cannot set it to false intentionally in order to always get such exceptions.
#pod
#pod The actual output will vary, for example L will encode and decode
#pod unicode chars (the resulting JSON is not unicode) whereas L will emit
#pod unicode JSON.
#pod
#pod =cut

sub new {
    my $class = shift;
    my $self  = bless [], $class;
    my $key   = _make_key($handler);
    if ( my $creator = $conf{$key}->{create_object} ) {
        my @config;
        # undocumented! and yet, people are using this...
        if ( $ENV{JSON_ANY_CONFIG} ) {
            push @config, map split(/=/, $_), split(/,\s*/, $ENV{JSON_ANY_CONFIG});
        }
        push @config, @_;
        $creator->( $self, my $conf = {@config} );
        $self->[UTF8] = $conf->{utf8};
    }
    return $self;
}

#pod =head2 C
#pod
#pod Takes no arguments, returns a string indicating which JSON Module is in use.
#pod
#pod =cut

sub handlerType {
    my $class = shift;
    $handler;
}

#pod =head2 C
#pod
#pod Takes no arguments, if called on an object returns the internal JSON::*
#pod object in use.  Otherwise returns the JSON::* package we are using for
#pod class methods.
#pod
#pod =cut

sub handler {
    my $self = shift;
    if ( ref $self ) {
        return $self->[HANDLER];
    }
    return $handler;
}

#pod =head2 C
#pod
#pod Takes no arguments, returns the special value that the internal JSON
#pod object uses to map to a JSON C boolean.
#pod
#pod =cut

sub true {
    my $key = _make_key($handler);
    return $conf{$key}->{get_true}->();
}

#pod =head2 C
#pod
#pod Takes no arguments, returns the special value that the internal JSON
#pod object uses to map to a JSON C boolean.
#pod
#pod =cut

sub false {
    my $key = _make_key($handler);
    return $conf{$key}->{get_false}->();
}

#pod =head2 C
#pod
#pod Takes a single argument, a hashref to be converted into JSON.
#pod It returns the JSON text in a scalar.
#pod
#pod =cut

sub objToJson {
    my $self = shift;
    my $obj  = shift;
    croak 'must provide object to convert' unless defined $obj;

    my $json;

    if ( ref $self ) {
        my $method;
        unless ( ref $self->[ENCODER] ) {
            croak "No $handler Object created!"
              unless exists $self->[HANDLER];
            $method = $self->[HANDLER]->can( $self->[ENCODER] );
            croak "$handler can't execute $self->[ENCODER]" unless $method;
        }
        else {
            $method = $self->[ENCODER];
        }
        $json = $self->[HANDLER]->$method($obj);
    }
    else {
        $json = $handler->can($encoder)->($obj);
    }

    utf8::decode($json)
      if ( ref $self ? $self->[UTF8] : $UTF8 )
      and !utf8::is_utf8($json)
      and utf8::valid($json);
    return $json;
}

#pod =head2 C
#pod
#pod =head2 C
#pod
#pod =head2 C
#pod
#pod Aliases for C, can be used interchangeably, regardless of the
#pod underlying JSON module.
#pod =cut

*to_json = \&objToJson;
*Dump    = \&objToJson;
*encode  = \&objToJson;

#pod =head2 C
#pod
#pod Takes a single argument, a string of JSON text to be converted
#pod back into a hashref.
#pod
#pod =cut

sub jsonToObj {
    my $self = shift;
    my $obj  = shift;
    croak 'must provide json to convert' unless defined $obj;

    # some handlers can't parse single booleans (I'm looking at you DWIW)
    if ( $obj =~ /^(true|false)$/ ) {
        return $self->$1;
    }

    if ( ref $self ) {
        my $method;
        unless ( ref $self->[DECODER] ) {
            croak "No $handler Object created!"
              unless exists $self->[HANDLER];
            $method = $self->[HANDLER]->can( $self->[DECODER] );
            croak "$handler can't execute $self->[DECODER]" unless $method;
        }
        else {
            $method = $self->[DECODER];
        }
        return $self->[HANDLER]->$method($obj);
    }
    $handler->can($decoder)->($obj);
}

#pod =head2 C
#pod
#pod =head2 C
#pod
#pod =head2 C
#pod
#pod Aliases for C, can be used interchangeably, regardless of the
#pod underlying JSON module.
#pod
#pod =cut

*from_json = \&jsonToObj;
*Load      = \&jsonToObj;
*decode    = \&jsonToObj;

{
    no strict 'refs';
    delete @{__PACKAGE__.'::'}{qw(croak carp)};
}

1;

__END__