File Coverage

blib/lib/JSON/Hyper.pm

Criterion	Covered	Total	%
statement	62	144	43.0
branch	10	70	14.2
condition	2	19	10.5
subroutine	15	23	65.2
pod	8	8	100.0
total	97	264	36.7

package JSON::Hyper;

use 5.008;
use strict;

use JSON::Hyper::Link;

use Carp;
use JSON;
use JSON::Path;
use LWP::UserAgent;
use Scalar::Util qw[blessed];
use Storable qw[dclone];
use URI;
use URI::Escape qw[uri_unescape];

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.011';
our $DEBUG     = 0;

sub json_ref
{
	return {
		description => 'A hyper schema for the JSON referencing convention',
		links       => [
			{
				href => '{id}',
				link => 'self',
			},
			{
				href => '{$ref}',
				link => 'full',
			},
			{
				href => '{$schema}',
				link => 'describedby',
			},
		],
		fragmentResolution   => 'dot-delimited',
		additionalProperties => { '$ref' => '#' },
	};
}

sub new
{
	my ($class, $schema) = @_;
	$schema ||= json_ref();
	$schema = from_json($schema) unless ref $schema;
	return bless { schema => $schema, ua => undef } => $class;
}

sub schema
{
	my ($self) = @_;
	return $self->{'schema'};
}

sub ua
{
	my $self = shift;
	$self = {} unless blessed($self);

	if (@_)
	{
		my $rv = $self->{'ua'};
		$self->{'ua'} = shift;
		croak "Set UA to something that is not an LWP::UserAgent!"
			unless blessed $self->{'ua'} && $self->{'ua'}->isa('LWP::UserAgent');
		return $rv;
	}
	unless (blessed $self->{'ua'} and $self->{'ua'}->isa('LWP::UserAgent'))
	{
		$self->{'ua'} = 'LWP::UserAgent'->new(
			agent=>sprintf('%s/%s ', __PACKAGE__, $VERSION)
		);
		$self->{'ua'}->default_header(
			'Accept'=>'application/json, application/schema+json',
		);
	}
	return $self->{'ua'};
}

sub find_links
{
	my ($self, $node, $base) = @_;

	$node = from_json($node) unless ref $node;
	return unless ref $node eq 'HASH';
	my @rv;

	foreach my $link (@{ $self->schema->{links} })
	{
		my $missing = 0;
		my $href = $link->{href};
		$href =~ s/\{(.+?)\}/if (exists $node->{$1}) { $node->{$1}; } else { $missing++; ''; }/gex;

		if (!$missing)
		{
			$href = $self->_resolve_relative_ref($href, $base) if defined $base;

			push @rv, 'JSON::Hyper::Link'->new({
				href         => $href,
				rel          => ($link->{'rel'} || $link->{'link'}),
				targetSchema => $link->{'targetSchema'},
				method       => $link->{'method'},
				enctype      => $link->{'enctype'},
				schema       => $link->{'schema'},
				properties   => $link->{'properties'},
			});
		}
	}

	return @rv;
}

sub _resolve_relative_ref
{
	my ($self, $ref, $base) = @_;

	return $ref unless $base; # keep relative unless we have a base URI

	if ($ref =~ /^([a-z][a-z0-9\+\.\-]*)\:/i)
	{
		return $ref; # already an absolute reference
	}

	# create absolute URI
	my $abs = URI->new_abs($ref, $base)->canonical->as_string;

	while ($abs =~ m!^(http://.*)(\.\./|\.)+(\.\.|\.)?$!i)
		{ $abs = $1; } # fix edge case of 'http://example.com/../../../'

	return $abs;
}

sub process_includes
{
	my ($self, $original, $base, $recurse) = @_;
	$original = from_json($original) unless ref $original;
	$self->_process_includes($original, $base, $recurse);
	return $original;
}

sub _process_includes
{
	my ($self, $object, $base, $recurse) = @_;

	my @links = $self->find_links($object, $base);
	my $full;
	foreach my $link (@links)
	{
		if (lc $link->{rel} eq 'full')
		{
			$full = $link;
			last;
		}
	}

	if (defined $full)
	{
		my ($substitute) = $self->get($full->{'href'});
		if (defined $substitute)
		{
			delete $object->{ $full->{'property'} };
			while (my($k,$v) = each %$substitute)
			{
				$object->{$k} = $v;
			}
		}
		return;
	}
	return unless $recurse;

	if (ref $object eq 'ARRAY')
	{
		foreach my $i (@$object)
		{
			$self->_process_includes($i, $base, $recurse);
		}
	}
	elsif (ref $object eq 'HASH')
	{
		foreach my $i (values %$object)
		{
			$self->_process_includes($i, $base, $recurse);
		}
	}
}

sub get
{
	my ($self, $uri) = @_;
	my ($resource, $fragment) = split /\#/, $uri, 2;
	my $object = $self->_get($resource);
	return $object unless $fragment;
	return $self->resolve_fragment($object, $fragment);
}

sub _get
{
	my ($self, $resource) = @_;

	warn "GETting $resource" if $DEBUG;

	unless ($self->{'cache'}->{$resource})
	{
		my $response = $self->ua->get($resource);
		return unless $response->is_success;
		$self->{'cache'}->{$resource} = from_json( $response->decoded_content );
		$self->{'http_cache'}->{$resource} = $resource;
	}

	my @r = ($self->{'cache'}->{$resource}, $self->{'http_cache'}->{$resource});
	return wantarray ? @r : $r[0];
}

sub resolve_fragment
{
	my ($self, $object, $fragment) = @_;
	my $style = $self->schema->{fragmentResolution} || 'slash-delimited';

	$object = from_json($object) unless ref $object;
	return $object unless $fragment;

	$fragment =~ s!^#!!;

	if ($style =~ /^(json.?)?path$/i)
	{
		my $jsonp   = JSON::Path->new(uri_unescape($fragment));
		my @matches = $jsonp->values($object);
		return @matches;
	}
	elsif (lc $style eq 'dot-delimited')
	{
		$fragment =~ s!^\.!!;
	}
	elsif (lc $style eq 'slash-delimited')
	{
		$fragment =~ s!^/!!;
	}
	else
	{
		carp "Unknown fragment resolution method: $style";
		return;
	}

	return $self->_resolve_fragment($object, $fragment);
}

sub _resolve_fragment
{
	my ($self, $object, $fragment) = @_;
	my $style = $self->schema->{fragmentResolution} || 'slash-delimited';

	my ($first, $rest);
	if (lc $style eq 'dot-delimited')
	{
		($first, $rest) = split /\./, $fragment, 2;
	}
	elsif (lc $style eq 'slash-delimited')
	{
		($first, $rest) = split /\//, $fragment, 2;
	}

	$first = uri_unescape($first);

	my $value;
	if (ref $object eq 'HASH')
	{
		$value = $object->{$first};
	}
	elsif (ref $object eq 'ARRAY' and $first =~ /^[\-\+]?[0-9]+$/)
	{
		$value = $object->[$first];
	}

	unless (defined $value)
	{
		return;
	}

	if (length $rest)
	{
		return $self->_resolve_fragment($value, $rest);
	}
	else
	{
		return ($value);
	}
}

1;

__END__