File Coverage

blib/lib/XML/Loy/XRD.pm
Criterion Covered Total %
statement 168 172 97.6
branch 70 90 77.7
condition 13 16 81.2
subroutine 27 27 100.0
pod 9 9 100.0
total 287 314 91.4


line stmt bran cond sub pod time code
1             package XML::Loy::XRD;
2 3     3   3174 use strict;
  3         8  
  3         95  
3 3     3   18 use warnings;
  3         5  
  3         100  
4              
5 3     3   970 use Mojo::JSON qw/encode_json decode_json/;
  3         37664  
  3         219  
6 3     3   20 use Mojo::Util 'quote';
  3         6  
  3         148  
7 3     3   22 use Carp qw/carp/;
  3         5  
  3         167  
8 3     3   1522 use XML::Loy::Date::RFC3339;
  3         9  
  3         257  
9              
10             use XML::Loy with => (
11             mime => 'application/xrd+xml',
12             namespace => 'http://docs.oasis-open.org/ns/xri/xrd-1.0',
13             prefix => 'xrd',
14             on_init => sub {
15             shift->namespace(
16 530     530   1173 xsi => 'http://www.w3.org/2001/XMLSchema-instance'
17             );
18             }
19 3     3   582 );
  3         8  
  3         34  
20              
21             our @CARP_NOT;
22              
23             # Constructor
24             sub new {
25 527     527 1 66884 my $class = shift;
26              
27 527         630 my $xrd;
28              
29             # Empty
30 527 100       961 unless ($_[0]) {
    100          
31 516         1022 unshift(@_, 'XRD');
32 516         1118 $xrd = $class->SUPER::new(@_);
33             }
34              
35             # JRD
36 0         0 elsif ($_[0] =~ /^\s*\{/) {
37 2         8 $xrd = $class->SUPER::new('XRD');
38 2         15 $xrd->_to_xml($_[0]);
39             }
40              
41             # Whatever
42             else {
43 9         35 $xrd = $class->SUPER::new(@_);
44             };
45              
46 527         1293 return $xrd;
47             };
48              
49              
50             # Set subject
51             sub subject {
52 9 50   9 1 2995 my $self = $_[0]->type eq 'root' ?
53             shift : shift->root;
54              
55             # Return subject
56 9 100       141 unless ($_[0]) {
57              
58             # Subject found
59 3 50       13 my $sub = $self->at('Subject') or return;
60 3         83 return $sub->text;
61             };
62              
63 6         39 my $new_node = $self->set(Subject => @_);
64              
65             # Set subject (only once)
66 6 50       16 if (my $np = $self->at('*:root > *')) {
67              
68             # Put in correct order - maybe not effective
69 6         151 my $clone = $self->at('Subject');
70              
71 6         112 $self->at('Subject')->remove;
72              
73             # return $np->prepend($clone);
74 6         128 return $np->prepend($clone->to_string);
75             };
76              
77             # Set subject
78 0         0 return $new_node;
79             };
80              
81              
82             # Add alias
83             sub alias {
84 11 50   11 1 1887 my $self = $_[0]->type eq 'root' ?
85             shift : shift->root;
86              
87             # Return subject
88 11 100       149 unless ($_[0]) {
89              
90             # Subject found
91 3 50       22 my $sub = $self->find('Alias') or return;
92 3         97 return @{ $sub->map('text') };
  3         18  
93             };
94              
95             # Add new alias
96 8         31 $self->add(Alias => $_) foreach @_;
97              
98 8         52 return 1;
99             };
100              
101              
102             # Add Property
103             sub property {
104 32     32 1 14408 my $self = shift;
105              
106 32 100       74 return unless $_[0];
107              
108 31         54 my $type = shift;
109              
110             # Returns the first match
111 31 100       119 return $self->at( qq{Property[type="$type"]} ) unless scalar @_ >= 1;
112              
113             # Get possible attributes
114 11 100 66     50 my %hash = ($_[0] && ref $_[0] && ref $_[0] eq 'HASH') ? %{ shift(@_) } : ();
  1         4  
115              
116             # Set type
117 11         25 $hash{type} = $type;
118              
119             # Set xsi:nil unless there is content
120 11 100       28 $hash{'xsi:nil'} = 'true' unless $_[0];
121              
122             # Return element
123 11         39 return $self->add(Property => \%hash => @_ );
124             };
125              
126              
127             # Add Link
128             sub link {
129 36     36 1 16461 my $self = shift;
130              
131             # No rel given
132 36 50       81 return unless $_[0];
133              
134 36         60 my $rel = shift;
135              
136             # Get link
137 36 100       70 unless ($_[0]) {
138 24         89 return $self->at( qq{Link[rel="$rel"]} );
139             };
140              
141 12         14 my %hash;
142              
143             # Accept hash reference
144 12 100 66     50 if (ref $_[0] && ref $_[0] eq 'HASH') {
145 8         11 %hash = %{ $_[0] };
  8         35  
146             }
147              
148             # Accept string
149             else {
150 4         11 $hash{href} = shift;
151             };
152              
153             # Set relation
154 12         25 $hash{rel} = $rel;
155              
156             # Return link object
157 12         39 return $self->add(Link => \%hash);
158             };
159              
160              
161             # Set or get expiration date
162             sub expires {
163 10     10 1 6698 my $self = shift;
164              
165             # Return subject
166 10 100       28 unless ($_[0]) {
167              
168             # Subject found
169 6         17 my $exp = $self->at('Expires');
170              
171             # Return
172 6 50       114 return unless $exp;
173              
174             # Return RFC3339 object
175 6         40 return XML::Loy::Date::RFC3339->new($exp->text);
176             };
177              
178             # New RFC3339 object
179 4         21 my $new_time = XML::Loy::Date::RFC3339->new($_[0])->to_string(0);
180              
181             # RFC3339 obect undefined
182 4 50       17 return unless $new_time;
183              
184 4         16 my $new_node = $self->set(Expires => $new_time);
185              
186             # Set subject (only once)
187 4 50       14 if (my $np = $self->at('Link, Alias, Property')) {
188              
189             # Put in correct order - maybe not effective
190 4         97 my $clone = $self->at('Expires');
191 4         79 $self->at('Expires')->remove;
192 4         93 return $np->prepend($clone->to_string);
193             };
194              
195             # Return new node
196 0         0 return $new_node;
197             };
198              
199              
200             # Check for expiration
201             sub expired {
202 2 50   2 1 592 my $self = $_[0]->type eq 'root' ?
203             shift : shift->root;
204              
205             # No expiration date given
206 2 50       30 my $exp = $self->expires or return;
207              
208             # Document is expired
209 2 100       13 return 1 if $exp->epoch < time;
210              
211             # Document is still current
212 1         10 return;
213             };
214              
215              
216             # Filter link relations
217             sub filter_rel {
218 4     4 1 1960 my $self = shift;
219 4         12 my $xrd = $self->new( $self->to_string );
220              
221             # No xrd
222 4 50       13 return unless $xrd;
223              
224 4         22 my @rel;
225              
226             # Push valid relations
227 4 100       10 if (@_ == 1) {
228              
229             # Based on array reference
230 2 100 66     25 if (ref $_[0] && ref $_[0] eq 'ARRAY') {
231 1         4 @rel = @{ shift() };
  1         4  
232             }
233              
234             # Based on string
235             else {
236 1         7 @rel = split /\s+/, shift;
237             }
238             }
239              
240             # As array
241             else {
242 2         5 @rel = @_;
243             };
244              
245             # Create unwanted link relation query
246             my $rel = scalar @rel ? 'Link:' . join(':', map {
247 4 100       11 'not([rel=' . quote($_) . '])'
  6         37  
248             } @rel) : 'Link';
249              
250             # Remove unwanted link relations
251 4         33 $xrd->find($rel)->map('remove');
252 4         139 return $xrd;
253             };
254              
255              
256             # Convert to xml
257             sub _to_xml {
258 2     2   6 my $xrd = shift;
259              
260             # Parse json document
261 2         3 my $jrd;
262              
263             # There may be a parsing error
264 2 50       4 eval {
265 2         10 $jrd = decode_json $_[0];
266             } or carp $@;
267              
268             # Itterate over all XRD elements
269 2         1441 foreach my $key (keys %$jrd) {
270 9         29 $key = lc $key;
271              
272             # Properties
273 9 100 100     50 if ($key eq 'properties') {
    100          
    100          
    50          
    0          
274 2         10 _to_xml_properties($xrd, $jrd->{$key});
275             }
276              
277             # Links
278             elsif ($key eq 'links') {
279 2         9 _to_xml_links($xrd, $jrd->{$key});
280             }
281              
282             # Subject or Expires
283             elsif ($key eq 'subject' || $key eq 'expires') {
284 3         23 $xrd->set(ucfirst($key), $jrd->{$key});
285             }
286              
287             # Aliases
288             elsif ($key eq 'aliases') {
289 2         3 $xrd->alias($_) foreach (@{$jrd->{$key}});
  2         13  
290             }
291              
292             # Titles
293             elsif ($key eq 'titles') {
294 0         0 _to_xml_titles($xrd, $jrd->{$key});
295             };
296             };
297             };
298              
299              
300             # Convert From JSON to XML
301             sub _to_xml_titles {
302 2     2   6 my ($node, $hash) = @_;
303 2         5 foreach (keys %$hash) {
304              
305             # Default
306 3 100       10 if ($_ eq 'default') {
307 2         7 $node->add(Title => $hash->{$_});
308             }
309              
310             # Language
311             else {
312 1         6 $node->add(Title => { 'xml:lang' => $_ } => $hash->{$_});
313             };
314             };
315             };
316              
317              
318             # Convert from JSON to XML
319             sub _to_xml_links {
320 2     2   7 my ($node, $array) = @_;
321              
322             # All link objects
323 2         5 foreach (@$array) {
324              
325             # titles and properties
326 4         36 my $titles = delete $_->{titles};
327 4         7 my $properties = delete $_->{properties};
328              
329             # Add new link object
330 4         15 my $link = $node->link(delete $_->{rel}, $_);
331              
332             # Add titles and properties
333 4 100       19 _to_xml_titles($link, $titles) if $titles;
334 4 100       20 _to_xml_properties($link, $properties) if $properties;
335             };
336             };
337              
338              
339             # Convert from JSON to XML
340             sub _to_xml_properties {
341 3     3   7 my ($node, $hash) = @_;
342              
343 3         17 $node->property($_ => $hash->{$_}) foreach keys %$hash;
344             };
345              
346              
347             # Render JRD
348             sub to_json {
349 4     4 1 1815 my $self = shift;
350              
351 4 50       45 my $root = $self->type eq 'root' ?
352             $self : $self->root;
353              
354 4         57 my %object;
355              
356             # Serialize Subject and Expires
357 4         10 foreach (qw/Subject Expires/) {
358 8         147 my $obj = $root->at($_);
359 8 100       825 $object{lc($_)} = $obj->text if $obj;
360             };
361              
362             # Serialize aliases
363 4         77 my @aliases;
364             $root->children('Alias')->each(
365             sub {
366 6     6   179 push(@aliases, shift->text );
367 4         28 });
368 4 100       142 $object{'aliases'} = \@aliases if @aliases;
369              
370             # Serialize titles
371 4         16 my $titles = _to_json_titles($root);
372 4 50       18 $object{'titles'} = $titles if keys %$titles;
373              
374             # Serialize properties
375 4         9 my $properties = _to_json_properties($root);
376 4 50       22 $object{'properties'} = $properties if keys %$properties;
377              
378             # Serialize links
379 4         7 my @links;
380             $root->children('Link')->each(
381             sub {
382 8     8   113 my $link = shift;
383 8         26 my $link_att = $link->attr;
384              
385 8         116 my %link_prop;
386 8         25 foreach (qw/rel template href type/) {
387 32 100       57 if (exists $link_att->{$_}) {
388 17         36 $link_prop{$_} = $link_att->{$_};
389             };
390             };
391              
392             # Serialize link titles
393 8         18 my $link_titles = _to_json_titles($link);
394 8 100       37 $link_prop{'titles'} = $link_titles if keys %$link_titles;
395              
396             # Serialize link properties
397 8         15 my $link_properties = _to_json_properties($link);
398 8 100       33 $link_prop{'properties'} = $link_properties
399             if keys %$link_properties;
400              
401 8         38 push(@links, \%link_prop);
402 4         14 });
403 4 50       46 $object{'links'} = \@links if @links;
404 4         21 return encode_json(\%object);
405             };
406              
407              
408             # Serialize node titles
409             sub _to_json_titles {
410 12     12   17 my $node = shift;
411 12         14 my %titles;
412             $node->children('Title')->each(
413             sub {
414 7     7   81 my $val = $_->text;
415 7   100     195 my $lang = $_->attr->{'xml:lang'} || 'default';
416 7         126 $titles{$lang} = $val;
417 12         29 });
418 12         213 return \%titles;
419             };
420              
421              
422             # Serialize node properties
423             sub _to_json_properties {
424 12     12   17 my $node = shift;
425 12         21 my %property = ();
426             $node->children('Property')->each(
427             sub {
428 10     10   138 my $p = shift;
429 10   100     21 my $val = $p->text || undef;
430 10         290 my $type = $p->attr->{'type'};
431              
432 10         165 $property{$type} = $val;
433 12         23 });
434 12         159 return \%property;
435             };
436              
437              
438             1;
439              
440              
441             __END__