File Coverage

blib/lib/JSV/Reference.pm
Criterion Covered Total %
statement 73 79 92.4
branch 22 30 73.3
condition 21 30 70.0
subroutine 15 16 93.7
pod 0 6 0.0
total 131 161 81.3


line stmt bran cond sub pod time code
1             package JSV::Reference;
2              
3 45     45   24720 use strict;
  45         67  
  45         1051  
4 45     45   193 use warnings;
  45         75  
  45         943  
5              
6 45     45   194 use Carp;
  45         67  
  45         2430  
7 45     45   819 use Clone qw(clone);
  45         2939  
  45         1569  
8 45     45   36416 use Data::Walk;
  45         56415  
  45         2389  
9 45     45   34996 use JSON::Pointer;
  45         426740  
  45         1597  
10 45     45   322 use Scalar::Util qw(weaken);
  45         85  
  45         3535  
11 45     45   81292 use URI;
  45         114556  
  45         1564  
12 45     45   61437 use URI::Split qw(uri_split uri_join);
  45         23198  
  45         35243  
13              
14             my %memo;
15              
16             sub new {
17 60     60 0 139 my $class = shift;
18 60 50       244 my $args = ref $_[0] ? $_[0] : { @_ };
19              
20 60         339 %$args = (
21             registered_schema_map => {},
22             max_recursion => 10,
23             %$args,
24             );
25              
26 60         1419 bless $args => $class;
27             }
28              
29             sub resolve {
30 79     79 0 16098 my ($self, $ref, $opts) = @_;
31 79 50       240 die 'ref value should be hash' unless ref $ref eq 'HASH';
32 79 50       205 die '$ref not found' unless exists $ref->{'$ref'};
33 79         366 my $ref_uri = URI->new($ref->{'$ref'});
34              
35 79 100 66     619742 if ( ! $ref_uri->scheme && $opts->{base_uri} ) {
36 4         127 $ref_uri = $ref_uri->abs($opts->{base_uri});
37             }
38            
39 79 50 100     2699 die '$ref format invalid' unless $ref_uri->scheme || $ref_uri->fragment || $ref_uri->as_string eq "#";
      66        
40              
41 79         1404 my $ref_obj = $self->get_schema($ref_uri, $opts);
42              
43 77 100 33     327 if ( ref $ref_obj eq 'HASH' && exists $ref_obj->{'$ref'} ) {
44 5         21 $self->resolve($ref_obj, $opts);
45             }
46              
47 77         344 %$ref = %$ref_obj;
48              
49             ### TODO: Does this weaken have means?
50 77         224 weaken($ref_obj);
51              
52 77         233 $ref->{id} = $ref_uri->as_string;
53             }
54              
55             sub get_schema {
56 79     79 0 135 my ($self, $uri, $opts) = @_;
57              
58 79         200 my ($normalized_uri, $fragment) = $self->normalize_uri($uri);
59 79   66     313 my $schema = $self->{registered_schema_map}{$normalized_uri} || $opts->{root};
60 79 100       203 unless (ref $schema eq 'HASH') {
61 1         6 die sprintf("cannot resolve reference: uri = %s", $uri);
62             }
63              
64 78 50 66     239 if (exists $schema->{'$ref'} && $schema->{'$ref'} eq $normalized_uri) {
65 0         0 die sprintf("cannot resolve reference: uri = %s", $uri);
66             }
67              
68 78 100       179 if ( $fragment ) {
69 69         180 eval {
70 69         299 $schema = JSON::Pointer->get($schema, $fragment, 1);
71             };
72 69 100       10200 if (my $e = $@ ) {
    50          
73 1         14 die sprintf("cannot resolve reference fragment: uri = %s, msg = %s", $uri, $e);
74             }
75             elsif (!$schema) {
76 0         0 die sprintf("cannot resolve reference fragment: uri = %s, msg = %s", $uri);
77             }
78             }
79              
80 77 50       196 unless (ref $schema eq 'HASH') {
81 0         0 die sprintf("cannot resolve reference: uri = %s", $uri);
82             }
83              
84 77         170 return $schema;
85             }
86              
87             sub register_schema {
88 9     9 0 181 my ($self, $uri, $schema) = @_;
89 9         144 my $normalized_uri = $self->normalize_uri($uri);
90 9         790 my $cloned_schema = clone($schema);
91              
92             ### recursive reference resolution
93             walkdepth(+{
94             wanted => sub {
95 410 50 100 410   25454 if (
      66        
      66        
      66        
96             defined $Data::Walk::type &&
97             $Data::Walk::type eq "HASH" &&
98             exists $_->{'$ref'} &&
99             !ref $_->{'$ref'} &&
100             keys %$_ == 1
101             ) {
102 28         116 my $ref_uri = URI->new($_->{'$ref'});
103 28 100       22480 return if $ref_uri->scheme;
104 27         538 $_->{'$ref'} = $ref_uri->abs($normalized_uri)->as_string;
105             }
106             },
107 9         139 }, $cloned_schema);
108              
109 9         438 $self->{registered_schema_map}{$normalized_uri} = $cloned_schema;
110             }
111              
112             sub unregister_schema {
113 0     0 0 0 my ($self, $uri) = @_;
114 0         0 my $normalized_uri = $self->normalize_uri($uri);
115 0         0 delete $self->{registered_schema_map}{$normalized_uri};
116             }
117              
118             sub normalize_uri {
119 88     88 0 158 my ($self, $uri) = @_;
120 88         121 my %parts;
121              
122 88         289 @parts{qw/scheme authority path query fragment/} = uri_split($uri);
123 88         1425 my $fragment = $parts{fragment};
124 88         188 $parts{fragment} = undef;
125              
126 88         294 my $normalized_uri = uri_join(@parts{qw/scheme authority path query fragment/});
127              
128 88 100       1914 return wantarray ? ($normalized_uri, $fragment) : $normalized_uri;
129             }
130              
131             1;
132              
133             __END__