File Coverage

blib/lib/JSON/Path/Evaluator.pm

Criterion	Covered	Total	%
statement	361	408	88.4
branch	167	216	77.3
condition	32	58	55.1
subroutine	37	39	94.8
pod	3	3	100.0
total	600	724	82.8

package JSON::Path::Evaluator;
$JSON::Path::Evaluator::VERSION = '1.0.6';
use strict;
use warnings;

# ABSTRACT: A module that recursively evaluates JSONPath expressions with native support for Javascript-style filters

use Carp;
use Carp::Assert qw(assert);
use JSON::MaybeXS;
use JSON::Path::Constants qw(:operators :symbols);
use JSON::Path::Tokenizer qw(tokenize);
use List::Util qw/pairs uniq/;
use Readonly;
use Safe;
use Scalar::Util qw/looks_like_number blessed refaddr/;
use Storable qw/dclone/;
use Try::Tiny;

# VERSION
use Exporter::Shiny qw/evaluate_jsonpath/;
our $AUTHORITY = 'cpan:POPEFELIX';

Readonly my $OPERATOR_IS_TRUE         => 'IS_TRUE';
Readonly my $OPERATOR_TYPE_PATH       => 1;
Readonly my $OPERATOR_TYPE_COMPARISON => 2;
Readonly my %OPERATORS                => (
    $TOKEN_ROOT                => $OPERATOR_TYPE_PATH,          # $
    $TOKEN_CURRENT             => $OPERATOR_TYPE_PATH,          # @
    $TOKEN_CHILD               => $OPERATOR_TYPE_PATH,          # . OR []
    $TOKEN_RECURSIVE           => $OPERATOR_TYPE_PATH,          # ..
    $TOKEN_ALL                 => $OPERATOR_TYPE_PATH,          # *
    $TOKEN_FILTER_OPEN         => $OPERATOR_TYPE_PATH,          # ?(
    $TOKEN_SCRIPT_OPEN         => $OPERATOR_TYPE_PATH,          # (
    $TOKEN_FILTER_SCRIPT_CLOSE => $OPERATOR_TYPE_PATH,          # )
    $TOKEN_SUBSCRIPT_OPEN      => $OPERATOR_TYPE_PATH,          # [
    $TOKEN_SUBSCRIPT_CLOSE     => $OPERATOR_TYPE_PATH,          # ]
    $TOKEN_UNION               => $OPERATOR_TYPE_PATH,          # ,
    $TOKEN_ARRAY_SLICE         => $OPERATOR_TYPE_PATH,          # [ start:end:step ]
    $TOKEN_SINGLE_EQUAL        => $OPERATOR_TYPE_COMPARISON,    # =
    $TOKEN_DOUBLE_EQUAL        => $OPERATOR_TYPE_COMPARISON,    # ==
    $TOKEN_TRIPLE_EQUAL        => $OPERATOR_TYPE_COMPARISON,    # ===
    $TOKEN_GREATER_THAN        => $OPERATOR_TYPE_COMPARISON,    # >
    $TOKEN_LESS_THAN           => $OPERATOR_TYPE_COMPARISON,    # <
    $TOKEN_NOT_EQUAL           => $OPERATOR_TYPE_COMPARISON,    # !=
    $TOKEN_GREATER_EQUAL       => $OPERATOR_TYPE_COMPARISON,    # >=
    $TOKEN_LESS_EQUAL          => $OPERATOR_TYPE_COMPARISON,    # <=
    $TOKEN_REGEX               => $OPERATOR_TYPE_COMPARISON,    # =~
);

Readonly my $ASSERT_ENABLE => $ENV{ASSERT_ENABLE};


sub new {
    my $class = shift;
    my %args  = ref $_[0] eq 'HASH' ? %{ $_[0] } : @_;
    my $self  = {};
    for my $key (qw/root expression/) {
        croak qq{Missing required argument '$key' in constructor} unless $args{$key};
        $self->{$key} = $args{$key};
    }
    $self->{want_ref}         = $args{want_ref}         || 0;
    $self->{_calling_context} = $args{_calling_context} || 0;

    my $script_engine =
        $args{script_engine} ? $args{script_engine} : $self->{expression} =~ /\$_/ ? 'perl' : undef;
    $self->{script_engine} = $script_engine || 'PseudoJS';
    bless $self, $class;
    return $self;
}


sub evaluate_jsonpath {
    my ( $json_object, $expression, %args ) = @_;
    if ( !ref $json_object ) {
        try {
            $json_object = decode_json($json_object);
        }
        catch {
            croak qq{Unable to decode $json_object as JSON: $_};
        }
    }

    my $want_ref  = delete $args{want_ref}  || 0;
    my $want_path = delete $args{want_path} || 0;

    my $self = __PACKAGE__->new(
        root             => $json_object,
        expression       => $expression,
        _calling_context => wantarray ? 'ARRAY' : 'SCALAR',
        %args
    );
    return $self->evaluate( $expression, want_ref => $want_ref, want_path => $want_path );
}


sub evaluate {
    my ( $self, $expression, %args ) = @_;

    my $json_object = $self->{root};

    my $token_stream = [ tokenize($expression) ];
#use Data::Dumper qw/Dumper/;
#print Dumper $token_stream;
    shift @{$token_stream} if $token_stream->[0] eq $TOKEN_ROOT;
    shift @{$token_stream} if $token_stream->[0] eq $TOKEN_CHILD;

    if ( $args{want_path} ) {
        my %reftable = $self->_reftable_walker($json_object);
        my @refs = $self->_evaluate( $json_object, dclone $token_stream, 1 );

        my @paths;
        for my $ref (@refs) {
            my $refaddr = ref ${$ref} ? refaddr ${$ref} : refaddr $ref;
            push @paths, $reftable{$refaddr};
        }
        return @paths;
    }

    my @ret = $self->_evaluate( $json_object, $token_stream, $args{want_ref} );
    return @ret;
}

sub _reftable_walker {
    my ( $self, $json_object, $base_path ) = @_;

    $base_path   //= '$';
    $json_object //= $self->root;

    my @entries = ( refaddr $json_object => $base_path );

    if ( _arraylike($json_object) ) {
        for ( 0 .. $#{$json_object} ) {
            my $path = sprintf q{%s['%d']}, $base_path, $_;
            if ( ref $json_object->[$_] ) {
                push @entries, $self->_reftable_walker( $json_object->[$_], $path );
            }
            else {
                push @entries, refaddr \( $json_object->[$_] ) => $path;
            }
        }
    }
    elsif ( _hashlike($json_object) ) {
        for my $index ( keys %{$json_object} ) {
            my $path = sprintf q{%s['%s']}, $base_path, $index;
            if ( ref $json_object->{$index} ) {
                push @entries, $self->_reftable_walker( $json_object->{$index}, $path );
            }
            else {
                push @entries, refaddr \( $json_object->{$index} ) => $path;
            }
        }
    }
    return @entries;
}

sub _evaluate {    # This assumes that the token stream is syntactically valid
    my ( $self, $obj, $token_stream, $want_ref ) = @_;

    return unless ref $obj;

    $token_stream //= [];

    while ( defined( my $token = shift @{$token_stream} ) ) {
        next if $token eq $TOKEN_CURRENT;
        next if $token eq $TOKEN_CHILD;

        if ( $token eq $TOKEN_FILTER_OPEN ) {
            my $filter_expression = shift @{$token_stream};

            my $closing_token = shift @{$token_stream};
            assert( $closing_token eq $TOKEN_FILTER_SCRIPT_CLOSE, q{Closing token seen} ) if $ASSERT_ENABLE;

            # Find all indices matching the filter expression. This modifies $token_stream
            my @matching_indices = $self->_process_filter( $obj, $filter_expression );

            if ( !@{$token_stream} ) {
                my @got = map { _get( $obj, $_ ) } @matching_indices;
                return $want_ref ? @got : map { ${$_} } @got;
            }
            else {
                return map { $self->_evaluate( _get( $obj, $_ ), dclone($token_stream), $want_ref ) } @matching_indices;
            }
        }
        elsif ( $token eq $TOKEN_RECURSIVE )
        {    # Sweet Jesus, Pooh, that's not honey! You're eating Sweet Jesus, Pooh, that's not honey! You're eating...
            my $index = shift @{$token_stream};
            my @matched;
            if ( $index eq $TOKEN_FILTER_OPEN ) {
                my $filter_expression = shift @{$token_stream};

                my $closing_token = shift @{$token_stream};
                assert( $closing_token eq $TOKEN_FILTER_SCRIPT_CLOSE, q{Closing token seen} ) if $ASSERT_ENABLE;

                return $self->_filter_recursive( $obj, $filter_expression, $want_ref );
            }

            @matched = _match_recursive( $obj, $index, $want_ref );
            if ( !@{$token_stream} ) {
                return @matched;
            }
            return map { $self->_evaluate( $_, dclone($token_stream), $want_ref ) } @matched;
        }
        else {
            my $index;
            if ( $token eq $TOKEN_SUBSCRIPT_OPEN ) {
                $index = shift @{$token_stream};
                my $closing_token = shift @{$token_stream};
                assert $closing_token eq $TOKEN_SUBSCRIPT_CLOSE if $ASSERT_ENABLE;
            }
            else {
                $index = $token;
            }

            assert( !$OPERATORS{$index}, qq{"$index" is not an operator} ) if $index ne $TOKEN_ALL;
            assert( !ref $index,         q{Index is a scalar} )            if $ASSERT_ENABLE;

            my (@got) = _get( $obj, $index, create_key => $want_ref );    # This always returns a ref
            if ( !@{$token_stream} ) {
                return $want_ref ? @got : map { ${$_} } @got;
            }
            else {
                return map { $self->_evaluate( ${$_}, dclone($token_stream), $want_ref ) } @got;
            }
        }
    }
}

sub _process_filter {
    my ( $self, $obj, $filter_expression ) = @_;

    my @matching_indices;
    if ( $self->{script_engine} eq 'PseudoJS' ) {
        @matching_indices = $self->_process_pseudo_js( $obj, $filter_expression );
    }
    elsif ( $self->{script_engine} eq 'perl' ) {
        @matching_indices = $self->_process_perl( $obj, $filter_expression );
    }
    else {
        croak qq{Unsupported script engine "$self->{script_engine}"};
    }
    return @matching_indices;
}

# This _always_ has to return a ref so that when it's called from evaluate( ... , want_ref => 1)
# So that we can return a ref into the object (e.g. for use as an lvalue), even when the path points
# to a scalar (which will of course be copied).
#
# I.E.: for { foo => 'bar' }, we always want \( foo->{bar} ) so that
# JSON::Path->new('$.foo')->value($obj) = 'baz' works  like it oughtta.
sub _get {
    my ( $object, $index, %args ) = @_;

    assert( _hashlike($object) || _arraylike($object), 'Object is a hashref or an arrayref' ) if $ASSERT_ENABLE;

    my $create_key = $args{create_key};

    # When want_ref is passed to _evaluate(), it will return a reference to whatever was matched.
    # If what was matched is itself a ref (e.g. an arrayref), _evaluate() will return a ref of
    # type 'REF'.
    if ( ref $object eq 'REF' ) {
        $object = ${$object};
    }

    if ( $index eq $TOKEN_ALL ) {
        if ( _hashlike($object) ) {
            return map { \($_) } values %{$object};
        }
        else {
            return map { \($_) } @{$object};
        }
    }
    else {
        my @indices;
        if ( $index =~ /$TOKEN_ARRAY_SLICE/ ) {
            my $length = _hashlike($object) ? scalar values %{$object} : scalar @{$object};
            @indices = _slice( $index, $length );
        }
        elsif ( $index =~ /$TOKEN_UNION/ ) {
            @indices = split /$TOKEN_UNION/, $index;
        }
        else {
            @indices = ($index);
        }

        if ( _hashlike($object) ) {
            if ($create_key) {
                return map { \( $object->{$_} ) } @indices;
            }
            else {
                my @ret;
                for my $index (@indices) {
                    push @ret, \( $object->{$index} ) if exists $object->{$index};
                }
                return @ret;
            }
        }
        else {
            my @numeric_indices = grep { looks_like_number($_) } @indices;
            if ($create_key) {
                return map { \( $object->[$_] ) } @numeric_indices;
            }
            else {
                my @ret;
                for my $index (@numeric_indices) {
                    push @ret, \( $object->[$index] ) if exists $object->[$index];
                }
                return @ret;
            }
        }
    }
}

sub _indices {
    my $object = shift;
    return
          _hashlike($object)  ? keys %{$object}
        : _arraylike($object) ? ( 0 .. $#{$object} )
        : ();
}

sub _hashlike {
    my $object = shift;
    return ( ref $object eq 'HASH' || ( blessed $object && $object->can('typeof') && $object->typeof eq 'HASH' ) );
}

sub _arraylike {
    my $object = shift;
    return ( ref $object eq 'ARRAY' || ( blessed $object && $object->can('typeof') && $object->typeof eq 'ARRAY' ) );
}

sub _get_token {
    my $token_stream = shift;
    my $token        = shift @{$token_stream};
    return unless defined $token;

    if ( $token eq $TOKEN_SUBSCRIPT_OPEN ) {
        my @substream;
        my $close_seen;
        while ( defined( my $token = shift @{$token_stream} ) ) {
            if ( $token eq $TOKEN_SUBSCRIPT_CLOSE ) {
                $close_seen = 1;
                last;
            }
            push @substream, $token;
        }

        assert($close_seen) if $ASSERT_ENABLE;

        if ( grep { $_ eq $TOKEN_ARRAY_SLICE } @substream ) {

            # There are five valid cases:
            #
            # n:m   -> n:m:1
            # n:m:s -> n:m:s
            # :m    -> 0:m:1
            # ::s   -> 0:-1:s
            # n:    -> n:-1:1
            if ( $substream[0] eq $TOKEN_ARRAY_SLICE ) {
                unshift @substream, undef;
            }

            no warnings qw/uninitialized/;
            if ( $substream[2] eq $TOKEN_ARRAY_SLICE ) {
                @substream = ( @substream[ ( 0, 1 ) ], undef, @substream[ ( 2 .. $#substream ) ] );
            }
            use warnings qw/uninitialized/;

            my ( $start, $end, $step );
            $start = $substream[0] // 0;
            $end   = $substream[2] // -1;
            $step  = $substream[4] // 1;
            return { slice => [ $start, $end, $step ] };
        }
        elsif ( grep { $_ eq $TOKEN_UNION } @substream ) {
            my @union = grep { $_ ne $TOKEN_UNION } @substream;
            return { union => \@union };
        }

        return $substream[0];
    }
    return $token;
}

# See http://wiki.ecmascript.org/doku.php?id=proposals:slice_syntax
#
# in particular, for the slice [n:m], m is *one greater* than the last index to slice.
# This means that the slice [3:5] will return indices 3 and 4, but *not* 5.
sub _slice {
    my ( $index, $length ) = @_;

    my ( $start, $end, $step ) = split /$TOKEN_ARRAY_SLICE/, $index, 3;

    if ( !defined($start) || $start eq '' ) {
        $start = 0;
    }
    if ( !defined($end) || $end eq '' ) {
        $end = -1;
    }
    if ( !defined($step) || $step eq '' ) {
        $step = 1;
    }

    $start = ( $length - 1 ) if $start == -1;
    $end   = $length         if $end == -1;

    my @indices;
    if ( $step < 0 ) {
        @indices = grep { %_ % -$step == 0 } reverse( $start .. ( $end - 1 ) );
    }
    else {
        @indices = grep { $_ % $step == 0 } ( $start .. ( $end - 1 ) );
    }
    return @indices;
}

sub _match_recursive {
    my ( $obj, $index, $want_ref ) = @_;

    my @match;

    # Fix for RT #122529.
    #
    # Consider the expression "$..foo..bar", evaluated with respect to the JSON "{"foo":{"bar":"baz"}}".
    #
    # The first term to be evaluated in the expression is "$..foo". If want_ref is passed to evaluate(),
    # this will return a REF reference. In that case we must first dereference it to get the object that
    # we will evaluate "..bar" with respect to.
    if ( ref $obj eq 'REF' ) {
        $obj = ${$obj};
    }

    if ( _arraylike($obj) ) {
        if ( looks_like_number($index) && exists $obj->[$index] ) {
            push @match, $want_ref ? \( $obj->[$index] ) : $obj->[$index];
        }
        for ( 0 .. $#{$obj} ) {
            next unless ref $obj->[$_];
            push @match, _match_recursive( $obj->[$_], $index, $want_ref );
        }
    }
    elsif ( _hashlike($obj) ) {
        if ( exists $obj->{$index} ) {
            push @match, $want_ref ? \( $obj->{$index} ) : $obj->{$index};
        }
        for my $val ( values %{$obj} ) {
            next unless ref $val;
            push @match, _match_recursive( $val, $index, $want_ref );
        }
    }
    return @match;
}

sub _filter_recursive {
    my ( $self, $obj, $expression, $want_ref ) = @_;

    my @ret;

    # Evaluate the filter expression for the current object
    my @matching_indices = $self->_process_filter( $obj, $expression );
    for my $index (@matching_indices) {
        my ($got) = _get( $obj, $index );
        push @ret, $want_ref ? $got : ${$got};
    }

    # Evaluate the filter expression for any subordinate objects
    for my $index ( _indices($obj) ) {
        my ($got) = _get( $obj, $index );
        $got = ${$got};    # _get will always return a reference. We want the value, so dereference it
        next unless ref $got;
        push @ret, $self->_filter_recursive( $got, $expression, $want_ref );
    }

    return @ret;
}

sub _process_pseudo_js {
    my ( $self, $object, $expressions ) = @_;

    my @expressions_or = split /\Q||\E/, $expressions;
    my @matching_or;

    foreach my $expression (@expressions_or) {
        my @expressions_and = split /\Q&&\E/, $expression;
        my %matching_and;

        foreach my $expression (@expressions_and) {

            my ( $lhs, $operator, $rhs ) = _parse_psuedojs_expression($expression);
            $lhs =~ s/^\s+|\s+$//g;

            my (@token_stream) = tokenize($lhs);

            if ( _hashlike($object) ) {
                while (my ($k, $v) = each(%$object)) {
                  my @got = $self->_evaluate( $v, [@token_stream] );
                  foreach my $got (@got) {
                      $matching_and{$k}++ if _compare( $operator, $got, $rhs );
                  }
                }
            }
            elsif ( _arraylike($object) ) {
                my $idx = 0;
                for my $value ( @{$object} ) {
                    my ($got) = $self->_evaluate( $value, [@token_stream] );
                    $matching_and{$idx}++ if _compare( $operator, $got, $rhs );
                    $idx++;
                }
            }
        }
        while (my ($idx, $val) = each(%matching_and)) {
            push @matching_or, $idx if ($val == @expressions_and);
        }
    }

    return sort(uniq(@matching_or));
}

sub _parse_psuedojs_expression {
    my $expression = shift;
    my @parts;

    my ( $lhs, $operator, $rhs );

    # The operator could be '=', '!=', '==', '===', '<=', '>=' or '=~'
    if ( $expression =~ /$EQUAL_SIGN/ ) {
        my $position = index( $expression, '=' );
        if ( substr( $expression, $position + 1, 1 ) eq $EQUAL_SIGN ) {    # could be '==' or '==='
            if ( substr( $expression, $position + 2, 1 ) eq $EQUAL_SIGN ) {    # ===
                $operator = $TOKEN_TRIPLE_EQUAL;
            }
            else {
                $operator = $TOKEN_DOUBLE_EQUAL;
            }
        }
        elsif ( substr( $expression, $position + 1, 1 ) eq $TILDE_SIGN ) {
            $operator = $TOKEN_REGEX;
        }
        else {
            my $preceding_char = substr( $expression, $position - 1, 1 );
            if ( $preceding_char eq $GREATER_THAN_SIGN ) {
                $operator = $TOKEN_GREATER_EQUAL;
            }
            elsif ( $preceding_char eq $LESS_THAN_SIGN ) {
                $operator = $TOKEN_LESS_EQUAL;
            }
            elsif ( $preceding_char eq $EXCLAMATION_MARK ) {
                $operator = $TOKEN_NOT_EQUAL;
            }
            else {
                $operator = $TOKEN_SINGLE_EQUAL;
            }
        }
        ( $lhs, $rhs ) = split /$operator/, $expression, 2;
    }
    else {
        for ( grep { $OPERATORS{$_} eq $OPERATOR_TYPE_COMPARISON } keys %OPERATORS ) {
            next if /$EQUAL_SIGN/;
            if ( $expression =~ /$_/ ) {
                ( $lhs, $rhs ) = split /$_/, $expression, 2;
                $operator = $_;
                last;
            }
        }
    }

    # FIXME: RHS is assumed to be a single value. This isn't necessarily a safe assumption.
    if ($operator) {
        $rhs = _normalize( $rhs || '' );
        $lhs = _normalize($lhs);
    }
    else {
        $operator = $OPERATOR_IS_TRUE;
        $lhs      = $expression;
    }
    return ( $lhs, $operator, $rhs );
}

sub _normalize {
    my $string = shift;

    # NB: Stripping spaces *before* stripping quotes allows the caller to quote spaces in an index.
    # So an index of 'foo ' will be correctly normalized as 'foo', but '"foo "' will normalize to 'foo '.
    $string =~ s/\s+$//;                # trim trailing spaces
    $string =~ s/^\s+//;                # trim leading spaces
    $string =~ s/^['"](.+)['"]$/$1/;    # Strip quotes from index
    return $string;
}

sub _process_perl {
    my ( $self, $object, $code ) = @_;

    my $cpt = Safe->new;
    $cpt->permit_only( ':base_core', qw/padsv padav padhv padany rv2gv/ );
    ${ $cpt->varglob('root') } = dclone( $self->{root} );

    my @matching;
    if ( _hashlike($object) ) {
        for my $index ( keys %{$object} ) {
            local $_ = $object->{$index};
            my $ret = $cpt->reval($code);
            croak qq{Error in filter: $@} if $@;
            push @matching, $index if $ret;
        }
    }
    else {
        for my $index ( 0 .. $#{$object} ) {
            local $_ = $object->[$index];
            my $ret = $cpt->reval($code);
            croak qq{Error in filter: $@} if $@;
            push @matching, $index if $ret;
        }
    }
    return @matching;
}

sub _compare {
    my ( $operator, $lhs, $rhs ) = @_;

    no warnings qw/uninitialized/;
    if ( $operator eq $OPERATOR_IS_TRUE ) {
        return $lhs ? 1 : 0;
    }

    my $use_numeric = looks_like_number($lhs) && looks_like_number($rhs);

    if ( $operator eq '=' || $operator eq '==' || $operator eq '===' ) {
        return $use_numeric ? ( $lhs == $rhs ) : $lhs eq $rhs;
    }
    if ( $operator eq '<' ) {
        return $use_numeric ? ( $lhs < $rhs ) : $lhs lt $rhs;
    }
    if ( $operator eq '>' ) {
        return $use_numeric ? ( $lhs > $rhs ) : $lhs gt $rhs;
    }
    if ( $operator eq '<=' ) {
        return $use_numeric ? ( $lhs <= $rhs ) : $lhs le $rhs;
    }
    if ( $operator eq '>=' ) {
        return $use_numeric ? ( $lhs >= $rhs ) : $lhs ge $rhs;
    }
    if ( $operator eq '!=' || $operator eq '!==' ) {
        return $use_numeric ? ( $lhs != $rhs ) : $lhs ne $rhs;
    }

    if ( $operator eq '=~' ) {
        if ( $rhs =~ m@^/(.*)/([msian]*)$@ ) {
            my $regex     = $1;
            my $modifiers = $2;
            return $lhs =~ qr/(?$modifiers)$regex/;
        }
        else {
            warn("Regexp need to be sorrounded by //. Allowed modifiers: msian");
            return 1;
        }
    }
    use warnings qw/uninitialized/;
}

1;

__END__