File Coverage

blib/lib/JSON/Pointer.pm

Criterion	Covered	Total	%
statement	183	192	95.3
branch	87	112	77.6
condition	20	26	76.9
subroutine	24	25	96.0
pod	11	11	100.0
total	325	366	88.8

package JSON::Pointer;

use 5.008_001;
use strict;
use warnings;

use B;
use Carp qw(croak);
use Clone qw(clone);
use JSON qw(encode_json decode_json);
use JSON::Pointer::Context;
use JSON::Pointer::Exception qw(:all);
use JSON::Pointer::Syntax qw(is_array_numeric_index);
use URI::Escape qw(uri_unescape);

our $VERSION = '0.07';

sub traverse {
    my ($class, $document, $pointer, $opts) = @_;
    $opts = +{
        strict => 1,
        inclusive => 0,
        %{ $opts || +{} }
    };
    $pointer = uri_unescape($pointer);

    my @tokens  = JSON::Pointer::Syntax->tokenize($pointer);
    my $context = JSON::Pointer::Context->new(+{
        pointer => $pointer,
        tokens  => \@tokens,
        target  => $document,
        parent  => $document,
    });

    foreach my $token (@tokens) {
        $context->begin($token);

        my $parent = $context->parent;
        my $type   = ref $parent;

        if ($type eq "HASH") {
            unless (exists $parent->{$token}) {
                return _throw_or_return(ERROR_POINTER_REFERENCES_NON_EXISTENT_VALUE, $context, $opts->{strict});
            }

            $context->next($parent->{$token});
            next;
        }
        elsif ($type eq "ARRAY") {
            if ($token eq '-') {
                $token = $#{$parent} + 1;
            }

            my $max_index = $#{$parent};
            $max_index++ if $opts->{inclusive};

            if (is_array_numeric_index($token) && $token <= $max_index) {
                $context->next($parent->[$token]);
                next;
            }
            else {
                return _throw_or_return(ERROR_POINTER_REFERENCES_NON_EXISTENT_VALUE, $context, $opts->{strict});
            }
        }
        else {
            return _throw_or_return(ERROR_POINTER_REFERENCES_NON_EXISTENT_VALUE, $context, $opts->{strict});
        }
    }

    $context->result(1);
    return $context;
}

sub get {
    my ($class, $document, $pointer, $strict) = @_;
    $strict = 0 unless defined $strict;

    my $context;
    eval {
        $context = $class->traverse($document, $pointer, +{ strict => $strict });
    };
    if (my $e = $@) {
        croak $e;
    }

    return $context->result ? $context->target : undef;
}

sub get_relative {
    my ($class, $document, $current_pointer, $relative_pointer, $strict) = @_;
    $strict = 0 unless defined $strict;

    my @current_tokens = JSON::Pointer::Syntax->tokenize($current_pointer);

    my $context = JSON::Pointer::Context->new(+{
        pointer => $current_pointer,
        tokens  => \@current_tokens,
        target  => $document,
        parent  => $document,
    });

    my ($steps, $relative_pointer_suffix, $use_index) =
        ($relative_pointer =~ m{^(0|[1-9]?[0-9]+)([^#]*)(#?)$});
    $relative_pointer_suffix ||= "";

    unless (defined $steps) {
        return _throw_or_return(ERROR_INVALID_POINTER_SYNTAX, $context, +{ strict => $strict });
    }

    for (my $i = 0; $i < $steps; $i++) {
        if (@current_tokens == 0) {
            return _throw_or_return(ERROR_POINTER_REFERENCES_NON_EXISTENT_VALUE, $context, +{ strict => $strict });
        }
        pop(@current_tokens);
    }

    if ($use_index) {
        my @relative_tokens = JSON::Pointer::Syntax->tokenize($relative_pointer_suffix);
        return (@relative_tokens > 0) ? $relative_tokens[-1] : $current_tokens[-1];
    }

    my $absolute_pointer = JSON::Pointer::Syntax->as_pointer(@current_tokens) . $relative_pointer_suffix;

    eval {
        $context = $class->traverse($document, $absolute_pointer, +{ strict => $strict });
    };
    if (my $e = $@) {
        croak $e;
    }

    return $context->result ? $context->target : undef;
}

sub contains {
    my ($class, $document, $pointer) = @_;
    my $context = $class->traverse($document, $pointer, +{ strict => 0 });
    return $context->result;
}

sub add {
    my ($class, $document, $pointer, $value) = @_;

    my $patched_document = clone($document);

    my $context = $class->traverse($patched_document, $pointer, +{ strict => 0, inclusive => 1 });
    my $parent  = $context->parent;
    my $type    = ref $parent;

    if ($type eq "HASH") {
        if (!$context->result && @{$context->processed_tokens} < @{$context->tokens} - 1) {
            ### Parent isn't object
            JSON::Pointer::Exception->throw(
                code    => ERROR_POINTER_REFERENCES_NON_EXISTENT_VALUE,
                context => $context,
            );
        }

        if (defined $context->last_token) {
            $parent->{$context->last_token} = $value;
        }
        else {
            ### pointer is empty string (whole document)
            $patched_document = $value;
        }

        return $patched_document;
    }
    elsif ($type eq "ARRAY") {
        unless ($context->result) {
            JSON::Pointer::Exception->throw(
                code    => ERROR_POINTER_REFERENCES_NON_EXISTENT_VALUE,
                context => $context,
            );
        }

        if (defined $context->last_token) {
            my $parent_array_length = $#{$parent} + 1;
            my $target_index        = ($context->last_token eq "-") ?
                $parent_array_length : $context->last_token;

            splice(@$parent, $target_index, 0, $value);
        }
        else {
            $patched_document = $value;
        }

        return $patched_document;
    }
    else {
        unless ($context->result) {
            JSON::Pointer::Exception->throw(
                code    => ERROR_POINTER_REFERENCES_NON_EXISTENT_VALUE,
                context => $context,
            );
        }

        return $value;
    }
}

sub remove {
    my ($class, $document, $pointer) = @_;

    my $patched_document = clone($document);

    my $context = $class->traverse($patched_document, $pointer);
    my $parent  = $context->parent;
    my $type    = ref $parent;

    if ($type eq "HASH") {
        my $target_member = $context->last_token;
        if (defined $target_member) {
            my $removed = delete $parent->{$target_member};
            return wantarray ? ($patched_document, $removed) : $patched_document;
        }
        else {
            ### pointer is empty string (whole document)
            return wantarray ? (undef, $patched_document) : undef;
        }
    }
    elsif ($type eq "ARRAY") {
        my $target_index = $context->last_token;
        if (defined $target_index) {
            my $parent_array_length = $#{$parent} + 1;
            $target_index = $parent_array_length if ($target_index eq "-");
            my $removed = splice(@$parent, $target_index, 1);
            return wantarray ? ($patched_document, $removed) : $patched_document;
        }
        else {
            ### pointer is empty string (whole document)
            return wantarray ? (undef, $patched_document) : undef;
        }
    }
    else {
        unless ($context->result) {
            JSON::Pointer::Exception->throw(
                code    => ERROR_POINTER_REFERENCES_NON_EXISTENT_VALUE,
                context => $context,
            );
        }

        return wantarray ? (undef, $patched_document) : undef;
    }
}

sub replace {
    my ($class, $document, $pointer, $value) = @_;

    my $patched_document = clone($document);
    my $context = $class->traverse($patched_document, $pointer);
    my $parent  = $context->parent;
    my $type    = ref $parent;

    if ($type eq "HASH") {
        my $target_member = $context->last_token;
        if (defined $target_member) {
            my $replaced = $parent->{$context->last_token};
            $parent->{$context->last_token} = $value;
            return wantarray ? ($patched_document, $replaced) : $patched_document;
        }
        else {
            ### pointer is empty string (whole document)
            return wantarray ? ($value, $patched_document) : $value;
        }
    }
    else {
        my $target_index = $context->last_token;
        if (defined $target_index) {
            my $parent_array_length = $#{$parent} + 1;
            $target_index = $parent_array_length if ($target_index eq "-");
            my $replaced = $parent->[$target_index];
            $parent->[$target_index] = $value;
            return wantarray ? ($patched_document, $replaced) : $patched_document;
        }
        else {
            ### pointer is empty string (whole document)
            return wantarray ? ($value, $patched_document) : $value;
        }
    }
}

sub set {
    shift->replace(@_);
}

sub copy {
    my ($class, $document, $from_pointer, $to_pointer) = @_;
    my $context = $class->traverse($document, $from_pointer);
    return $class->add($document, $to_pointer, $context->target);
}

sub move {
    my ($class, $document, $from_pointer, $to_pointer) = @_;
    my ($patched_document, $removed) = $class->remove($document, $from_pointer);
    $class->add($patched_document, $to_pointer, $removed);
}

sub test {
    my ($class, $document, $pointer, $value) = @_;

    my $context = $class->traverse($document, $pointer, +{ strict => 0 });

    return 0 unless $context->result;

    my $target      = $context->target;
    my $target_type = ref $target;

    if ($target_type eq "HASH" || $target_type eq "ARRAY") {
        return encode_json($target) eq encode_json($value) ? 1 : 0;
    }
    elsif (defined $target) {
        if (JSON::is_bool($target)) {
            return JSON::is_bool($value) && $target == $value ? 1 : 0;
        }
        elsif (_is_iv_or_nv($target) && _is_iv_or_nv($value)) {
            return $target == $value ? 1 : 0;
        }
        elsif (_is_pv($target) && _is_pv($value)) {
            return $target eq $value ? 1 : 0;
        }
        else {
            return 0;
        }
    }
    else {
        ### null
        return !defined $value ? 1 : 0;
    }
}

sub _throw_or_return {
    my ($code, $context, $strict) = @_;

    if ($strict) {
        JSON::Pointer::Exception->throw(
            code    => $code,
            context => $context,
        );
    }
    else {
        $context->last_error($code);
        return $context;
    }
}

sub _is_iv_or_nv {
    my $value = shift;
    my $flags = B::svref_2object(\$value)->FLAGS;
    return ( ($flags & ( B::SVp_IOK | B::SVp_NOK )) && !($flags & B::SVp_POK) );
}

sub _is_pv {
    my $value = shift;
    my $flags = B::svref_2object(\$value)->FLAGS;
    return ( !($flags & ( B::SVp_IOK | B::SVp_NOK )) && ($flags & B::SVp_POK) );
}

1;

__END__