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.03';
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__
=head1 NAME
JSON::Pointer - A Perl implementation of JSON Pointer (RFC6901)
=head1 VERSION
This document describes JSON::Pointer version 0.03.
=head1 SYNOPSIS
use JSON::Pointer;
my $obj = {
foo => 1,
bar => [ { qux => "hello" }, 3 ],
baz => { boo => [ 1, 3, 5, 7 ] }
};
JSON::Pointer->get($obj, "/foo"); ### $obj->{foo}
JSON::Pointer->get($obj, "/bar/0"); ### $obj->{bar}[0]
JSON::Pointer->get($obj, "/bar/0/qux"); ### $obj->{bar}[0]{qux}
JSON::Pointer->get($obj, "/bar/1"); ### $obj->{bar}[1]
JSON::Pointer->get($obj, "/baz/boo/2"); ### $obj->{baz}{boo}[2]
=head1 DESCRIPTION
This library is implemented JSON Pointer (L<http://tools.ietf.org/html/rfc6901>) and
some useful operator from JSON Patch (L<http://tools.ietf.org/html/rfc6902>).
JSON Pointer is available to identify a specified value in JSON document, and it is simillar to XPath.
Please read the both of specifications for details.
=head1 METHODS
=head2 get($document :HashRef/ArrayRef/Scalar, $pointer :Str, $strict :Int) :Scalar
=over
=item $document :HashRef/ArrayRef/Scalar
Target perl data structure that is able to be presented by JSON format.
=item $pointer :Str
JSON Pointer string to identify specified value in the document.
=item $strict :Int
Strict mode. When this value equals true value, this method may throw exception on error.
When this value equals false value, this method return undef value on error.
=back
Get specified value identified by I<$pointer> from I<$document>.
For example,
use JSON::Pointer;
print JSON::Pointer->get({ foo => 1, bar => { "qux" => "hello" } }, "/bar/qux"); ### hello
=head2 contains($document :HashRef/ArrayRef/Scalar, $pointer :Str) :Int
=over
=item $document :HashRef/ArrayRef/Scalar
Target perl data structure that is able to present by JSON format.
=item $pointer :Str
JSON Pointer string to identify specified value in the document.
=back
Return which the target location identified by I<$pointer> exists or not in the I<$document>.
use JSON::Pointer;
my $document = { foo => 1 };
if (JSON::Pointer->contains($document, "/foo")) {
print "/foo exists";
}
=head2 add($document :HashRef/ArrayRef/Scalar, $pointer :Str, $value :HashRef/ArrayRef/Scalar) :HashRef/ArrayRef/Scalar
=over
=item $document :HashRef/ArrayRef/Scalar
Target perl data structure that is able to be presented by JSON format.
=item $pointer :Str
JSON Pointer string to identify specified value in the document.
=item $value :HashRef/ArrayRef/Scalar
The perl data structure that is able to be presented by JSON format.
=back
Add specified I<$value> on target location identified by I<$pointer> in the I<$document>.
For example,
use JSON::Pointer;
my $document = +{ foo => 1, };
my $value = +{ qux => "hello" };
my $patched_document = JSON::Pointer->add($document, "/bar", $value);
print $patched_document->{bar}{qux}; ### hello
=head2 remove($document, $pointer) :Array/Scalar
=over
=item $document :HashRef/ArrayRef/Scalar
Target perl data structure that is able to be presented by JSON format.
=item $pointer :Str
JSON Pointer string to identify specified value in the document.
=back
Remove target location identified by I<$pointer> in the I<$document>.
use JSON::Pointer;
my $document = { foo => 1 };
my $patched_document = JSON::Pointer->remove($document, "/foo");
unless (exists $patched_document->{foo}) {
print "removed /foo";
}
This method is contextial return value. When the return value of I<wantarray> equals true,
return I<$patched_document> and I<$removed_value>, or not return I<$patched_document> only.
=head2 replace($document :HashRef/ArrayRef/Scalar, $pointer :Str, $value :HashRef/ArrayRef/Scalar) :Array/HashRef/ArrayRef/Scalar
=over
=item $document :HashRef/ArrayRef/Scalar
Target perl data structure that is able to be presented by JSON format.
=item $pointer :Str
JSON Pointer string to identify specified value in the document.
=item $value :HashRef/ArrayRef/Scalar
The perl data structure that is able to be presented by JSON format.
=back
Replace the value of target location specified by I<$pointer> to the I<$value> in the I<$document>.
use JSON::Pointer;
my $document = { foo => 1 };
my $patched_document = JSON::Pointer->replace($document, "/foo", 2);
print $patched_document->{foo}; ## 2
This method is contextial return value. When the return value of I<wantarray> equals true,
return I<$patched_document> and I<$replaced_value>, or not return I<$patched_document> only.
=head2 set($document :HashRef/ArrayRef/Scalar, $pointer :Str, $value :HashRef/ArrayRef/Scalar) :Array/HashRef/ArrayRef/Scalar
This method is alias of replace method.
=head2 copy($document :HashRef/ArrayRef/Scalar, $from_pointer :Str, $to_pointer :Str) :HashRef/ArrayRef/Scalar
=over
=item $document :HashRef/ArrayRef/Scalar
Target perl data structure that is able to be presented by JSON format.
=item $from_pointer :Str
JSON Pointer string to identify specified value in the document.
=item $to_pointer :Str
JSON Pointer string to identify specified value in the document.
=back
Copy the value identified by I<$from_pointer> to target location identified by I<$to_pointer>.
For example,
use JSON::Pointer;
my $document = +{ foo => [ { qux => "hello" } ], bar => [ 1 ] };
my $patched_document = JSON::Pointer->copy($document, "/foo/0/qux", "/bar/-");
print $patched_document->{bar}[1]; ## hello
Note that "-" notation means next of last element in the array.
In this example, "-" means 1.
=head2 move($document :HashRef/ArrayRef/Scalar, $from_pointer :Str, $to_pointer :Str) :HashRef/ArrayRef/Scalar
=over
=item $document :HashRef/ArrayRef/Scalar
Target perl data structure that is able to be presented by JSON format.
=item $from_pointer :Str
JSON Pointer string to identify specified value in the document.
=item $to_pointer :Str
JSON Pointer string to identify specified value in the document.
=back
Move the value identified by I<$from_pointer> to target location identified by I<$to_pointer>.
For example,
use JSON;
use JSON::Pointer;
my $document = +{ foo => [ { qux => "hello" } ], bar => [ 1 ] };
my $patched_document = JSON::Pointer->move($document, "/foo/0/qux", "/bar/-");
print encode_json($patched_document); ## {"bar":[1,"hello"],"foo":[{}]}
=head2 test($document :HashRef/ArrayRef/Scalar, $pointer :Str, $value :HashRef/ArrayRef/Scalar) :Int
=over
=item $document :HashRef/ArrayRef/Scalar
Target perl data structure that is able to be presented by JSON format.
=item $pointer :Str
JSON Pointer string to identify specified value in the document.
=item $value :HashRef/ArrayRef/Scalar
The perl data structure that is able to be presented by JSON format.
=back
Return which the value identified by I<$pointer> equals I<$value> or not in the I<$document>.
This method distinguish type of each values.
use JSON::Pointer;
my $document = { foo => 1 };
print JSON::Pointer->test($document, "/foo", 1); ### 1
print JSON::Pointer->test($document, "/foo", "1"); ### 0
=head2 traverse($document, $pointer, $strict) : JSON::Pointer::Context
This method is used as internal implementation only.
=head1 DEPENDENCIES
Perl 5.8.1 or later.
=head1 BUGS
All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
=head1 SEE ALSO
=over
=item L<perl>
=item L<Mojo::JSON::Pointer>
Many codes in this module is inspired by the module.
=item L<http://tools.ietf.org/html/rfc6901>
=item L<http://tools.ietf.org/html/rfc6902>
=back
=head1 AUTHOR
Toru Yamaguchi E<lt>zigorou at cpan.orgE<gt>
=head1 LICENSE AND COPYRIGHT
Copyright (c) 2013, Toru Yamaguchi. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut