File Coverage

blib/lib/JSON/Pointer.pm

Criterion	Covered	Total	%
statement	161	169	95.2
branch	73	100	73.0
condition	14	18	77.7
subroutine	23	24	95.8
pod	10	10	100.0
total	281	321	87.5

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.04';

sub traverse {
    my ($class, $document, $pointer, $strict) = @_;
    $strict = 1 unless defined $strict;
    $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, $strict);
            }

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

            if (is_array_numeric_index($token) && $token <= $elements_length) {
                $context->next($parent->[$token]);
                next;
            }
            elsif ($token eq "-") {
                $context->next(undef);
                next;
            }
            else {
                return _throw_or_return(ERROR_POINTER_REFERENCES_NON_EXISTENT_VALUE, $context, $strict);
            }
        }
        else {
            return _throw_or_return(ERROR_POINTER_REFERENCES_NON_EXISTENT_VALUE, $context, $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);
    };
    if (my $e = $@) {
        croak $e;
    }

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

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

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

    my $patched_document = clone($document);

    my $context = $class->traverse($patched_document, $pointer, 0);
    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, 1);
    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, 1);
    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, 1);
    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, 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 )) and !($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 )) and ($flags & B::SVp_POK);
}

1;

__END__