File Coverage

blib/lib/Net/PMP/CollectionDoc.pm
Criterion Covered Total %
statement 27 150 18.0
branch 0 56 0.0
condition 0 43 0.0
subroutine 9 28 32.1
pod 17 17 100.0
total 53 294 18.0


line stmt bran cond sub pod time code
1             package Net::PMP::CollectionDoc;
2 3     3   18 use Moose;
  3         8  
  3         18  
3 3     3   17183 use Carp;
  3         7  
  3         207  
4 3     3   16 use Data::Dump qw( dump );
  3         6  
  3         116  
5 3     3   1015 use Net::PMP::TypeConstraints;
  3         12  
  3         120  
6 3     3   1197 use Net::PMP::CollectionDoc::Links;
  3         8  
  3         95  
7 3     3   1128 use Net::PMP::CollectionDoc::Items;
  3         7  
  3         95  
8 3     3   1030 use UUID::Tiny ':std';
  3         41062  
  3         495  
9 3     3   22 use JSON;
  3         7  
  3         21  
10 3     3   258 use Try::Tiny;
  3         5  
  3         3682  
11              
12             our $VERSION = '0.006';
13              
14             # the 'required' flag on these attributes should match
15             # the core CollectionDoc schema:
16             # https://api.pmp.io/schemas/core
17              
18             has 'href' => (
19             is => 'rw',
20             isa => 'Net::PMP::Type::Href',
21             required => 0,
22             coerce => 1,
23             );
24             has 'links' => ( is => 'ro', isa => 'HashRef', required => 0, );
25             has 'attributes' => ( is => 'ro', isa => 'HashRef', required => 0, );
26             has 'version' =>
27             ( is => 'ro', isa => 'Str', required => 1, default => sub {'1.0'}, );
28             has 'items' => ( is => 'ro', isa => 'ArrayRef', required => 0, );
29              
30             =head1 NAME
31              
32             Net::PMP::CollectionDoc - Collection.doc+JSON object for Net::PMP::Client
33              
34             =head1 SYNOPSIS
35              
36             my $doc = $pmp_client->get_doc();
37             printf("API version: %s\n", $doc->version);
38             my $query_links = $doc->get_links('query');
39              
40             =head1 DESCRIPTION
41              
42             Net::PMP::CollectionDoc represents the PMP API media type L<https://github.com/publicmediaplatform/pmpdocs/wiki/Collection.doc-JSON-Media-Type>.
43              
44             =head1 METHODS
45              
46             =head2 href
47              
48             The unique identifier. See L<http://cdoc.io/spec.html#guid-vs-href>.
49              
50             =head2 items
51              
52             Returns arrayref of child items. These are returned as a convenience from the server
53             and are not a native part of the CollectionDoc.
54              
55             =head2 get_links( I<type> )
56              
57             Returns Net::PMP::CollectionDoc::Links object for I<type>, which may be one of (for example):
58              
59             =over
60              
61             =item creator
62              
63             =item edit
64              
65             =item navigation
66              
67             =item query
68              
69             =item permission
70              
71             =back
72              
73             =head2 links
74              
75             Returns hashref of link data.
76              
77             =head2 attributes
78              
79             Returns hashref of attribute data.
80              
81             =head2 version
82              
83             Returns API version string.
84              
85             =cut
86              
87             sub get_links {
88 0     0 1   my $self = shift;
89 0 0         my $type = shift or croak "type required";
90 0 0         my $links = $self->links->{$type} or croak "No such type $type";
91 0           return Net::PMP::CollectionDoc::Links->new(
92             type => $type,
93             links => $links
94             );
95             }
96              
97             =head2 get_items
98              
99             Returns L<Net::PMP::CollectionDoc::Items> object, unlike the B<items>
100             accessor method, which returns the raw arrayref.
101              
102             =cut
103              
104             sub get_items {
105 0     0 1   my $self = shift;
106 0 0         if ( !$self->items ) {
107 0           croak "No items defined for CollectionDoc";
108             }
109 0           my $navlinks = $self->get_links('navigation');
110 0           my $navself = $navlinks->rels('self')->[0];
111 0           my $total = $navself->totalitems;
112 0           return Net::PMP::CollectionDoc::Items->new(
113             items => $self->items,
114             navlinks => $navlinks,
115             total => $total,
116             );
117             }
118              
119             =head2 has_items
120              
121             Returns total number of items this CollectionDoc refers to.
122             B<NOTE> this is not the current result set, but the server-side total.
123             I.e., paging is ignored.
124              
125             =cut
126              
127             sub has_items {
128 0     0 1   my $self = shift;
129 0 0         if ( !$self->items ) {
130 0           return 0;
131             }
132 0           my $navlinks = $self->get_links('navigation');
133 0           my $navself = $navlinks->rels('self')->[0];
134 0           return $navself->totalitems;
135             }
136              
137             =head2 query(I<urn>)
138              
139             Returns L<Net::PMP::CollectionDoc::Link> object matching I<urn>,
140             or undef if no match is found.
141              
142             =cut
143              
144             sub query {
145 0     0 1   my $self = shift;
146 0 0         my $urn = shift or croak "URN required";
147 0           my $query_links = $self->get_links('query');
148 0           my $rels = $query_links->rels($urn);
149 0 0         if (@$rels) {
150 0           return $rels->[0]; # first link found
151             }
152 0           return undef;
153             }
154              
155             =head2 get_title
156              
157             Returns C<title> attribute value.
158              
159             =cut
160              
161             sub get_title {
162 0     0 1   my $self = shift;
163 0           return $self->attributes->{title};
164             }
165              
166             =head2 get_profile
167              
168             Returns first C<profile> link C<href> value.
169              
170             =cut
171              
172             sub get_profile {
173 0     0 1   my $self = shift;
174 0           return $self->links->{profile}->[0]->{href};
175             }
176              
177             =head2 get_uri
178              
179             Returns the C<href> string from the C<navigation> link
180             representing this CollectionDoc.
181              
182             =cut
183              
184             sub get_uri {
185 0     0 1   my $self = shift;
186 0 0         if ( $self->href ) { return $self->href }
  0            
187 0 0 0       if ( $self->links and $self->links->{navigation} ) {
188 0           my $nav = $self->get_links('navigation');
189 0           my $nav_self = $nav->rels('self')->[0];
190 0 0         if ($nav_self) {
191 0           return $nav_self->href;
192             }
193             else {
194 0           return $self->links->{navigation}->[0]->{href};
195             }
196             }
197              
198 0           return $self->get_self_uri();
199             }
200              
201             =head2 get_publish_uri([I<edit_link>])
202              
203             Returns the C<href> string from the C<edit> link
204             representing this CollectionDoc.
205              
206             I<edit_link> may be passed explicitly, which is
207             usually necessary for saving a doc the first time.
208              
209             =cut
210              
211             sub get_publish_uri {
212 0     0 1   my $self = shift;
213 0           my $edit_link = shift;
214 0 0 0       if ( $self->links
215             and $self->links->{edit} )
216             {
217 0           $edit_link
218             = $self->get_links('edit')
219             ->rels('urn:collectiondoc:form:documentsave')->[0];
220             }
221 0 0         if ($edit_link) {
222 0   0       my $guid = $self->get_guid() || $self->create_guid();
223 0           my $uri = $edit_link->as_uri( { guid => $guid } );
224 0           return $uri;
225             }
226 0           croak "No edit link defined in Doc and none passed to get_publish_uri()";
227             }
228              
229             =head2 get_self_uri
230              
231             Returns canonical URI for Doc per 'self' link.
232              
233             =cut
234              
235             sub get_self_uri {
236 0     0 1   my $self = shift;
237 0 0 0       if ( $self->links and exists $self->links->{self} ) {
238 0           return $self->links->{self}->[0]->{href};
239             }
240 0           return '';
241             }
242              
243             =head2 set_uri(I<uri>)
244              
245             Sets the C<href> string for the C<navigation> link
246             representing this CollectionDoc.
247              
248             =cut
249              
250             sub set_uri {
251 0     0 1   my $self = shift;
252 0 0         my $uri = shift or croak "uri required";
253 0 0 0       if ( $self->links and $self->links->{self} ) {
    0 0        
254 0           $self->links->{self}->[0]->{href} = $uri;
255             }
256             elsif ( $self->links and $self->links->{navigation} ) {
257 0           for my $link ( @{ $self->links->{navigation} } ) {
  0            
258 0 0         if ( $link->{rel} eq 'urn:collectiondoc:navigation:self' ) {
259 0           $link->{href} = $uri;
260             }
261             }
262             }
263             else {
264 0           $self->{links}->{self}->[0]->{href} = $uri;
265             }
266             }
267              
268             =head2 get_guid
269              
270             Returns the C<guid> attribute.
271              
272             =cut
273              
274             sub get_guid {
275 0     0 1   my $self = shift;
276 0 0 0       if ( $self->attributes and $self->attributes->{guid} ) {
277 0           return $self->attributes->{guid};
278             }
279 0           return undef;
280             }
281              
282             =head2 create_guid([I<use_remote>])
283              
284             Returns a v4-compliant UUID per PMP spec.
285              
286             NOTE the I<use_remote> flag is currently ignored.
287              
288             =cut
289              
290             sub create_guid {
291 0     0 1   my $self = shift;
292 0   0       my $use_remote = shift || 0;
293 0 0         if ($use_remote) {
294              
295             # TODO use PMP API to create a GUID
296             }
297             else {
298 0           return lc( create_uuid_as_string(UUID_V4) );
299             }
300             }
301              
302             =head2 set_guid([<Iguid>])
303              
304             Sets the guid attribute to I<guid>. If I<guid> is omitted,
305             the return value of create_guid() is used.
306              
307             =cut
308              
309             sub set_guid {
310 0     0 1   my $self = shift;
311 0   0       my $guid = shift || $self->create_guid();
312 0           $self->attributes->{guid} = $guid;
313 0           return $guid;
314             }
315              
316             =head2 as_hash
317              
318             Returns the CollectionDoc as a hashref. as_json() calls this method
319             internally.
320              
321             =cut
322              
323             sub as_hash {
324 0     0 1   my $self = shift;
325 0           my %hash;
326 0           for my $m (qw( version attributes href )) {
327 0 0         next if !defined $self->$m;
328 0           $hash{$m} = $self->$m;
329             }
330              
331             # must be defined but can be blank and server will set it
332 0   0       $hash{href} ||= "";
333              
334             # items are Docs
335             # but top-level "items" are just convenience.
336             # only those in links are authoritative
337 0 0 0       if ( $self->links and $self->links->{item} and @{ $self->links->{item} } )
  0   0        
338             {
339 0           $hash{links}->{item} = [];
340 0           for my $item ( @{ $self->links->{item} } ) {
  0            
341 0 0         if ( blessed $item) {
342 0           push @{ $hash{links}->{item} }, $item->as_link_hash;
  0            
343             }
344             else {
345 0           push @{ $hash{links}->{item} }, $item;
  0            
346             }
347             }
348             }
349              
350             # flesh out links with anything required for save
351 0           $hash{links}->{profile} = $self->links->{profile};
352 0 0 0       if ( $self->get_uri and !$self->get_self_uri ) {
353 0           $hash{links}->{self} = [ { href => $self->get_uri } ];
354 0   0       $hash{href} ||= $self->get_uri;
355             }
356              
357             # blacklist read-only links that come from the server
358             # in order to make round-trips safe
359 0           my %ro_links = map { $_ => 1 } qw( query edit auth navigation creator );
  0            
360 0           for my $link ( keys %{ $self->links } ) {
  0            
361 0 0         next if exists $hash{links}->{$link};
362 0 0         next if exists $ro_links{$link};
363 0           $hash{links}->{$link} = $self->links->{$link};
364             }
365              
366 0           return \%hash;
367             }
368              
369             =head2 as_link_hash
370              
371             Returns minimal hashref describing CollectionDoc, suitable
372             for B<links> B<item> attribute. This method is called internally
373             by as_hash(); it automatically recurses for any descendent items.
374              
375             =cut
376              
377             sub as_link_hash {
378 0     0 1   my $self = shift;
379 0           my %hash = ( href => $self->get_uri() );
380 0 0 0       if ( $self->links and $self->links->{item} ) {
381 0           for my $iitem ( @{ $self->links->{item} } ) {
  0            
382 0 0         if ( blessed $iitem) {
383 0           push @{ $hash{links}->{item} }, $iitem->as_link_hash();
  0            
384             }
385             else {
386 0           push @{ $hash{links}->{item} }, $iitem;
  0            
387             }
388             }
389             }
390 0           return \%hash;
391             }
392              
393             =head2 as_json
394              
395             Returns the CollectionDoc as a JSON-encoded string suitable for saving.
396              
397             =cut
398              
399             sub as_json {
400 0     0 1   my $self = shift;
401             my $json = try {
402 0     0     encode_json( $self->as_hash );
403             }
404             catch {
405 0     0     confess $_; # re-throw with full stack trace.
406 0           return ''; # we can't get here can we?
407 0           };
408 0           return $json;
409             }
410              
411             =head2 add_item( I<child> )
412              
413             Shortcut for:
414              
415             push @{ $doc->links->{item} }, $child->as_link_hash;
416              
417             =cut
418              
419             sub add_item {
420 0     0 1   my $self = shift;
421 0 0         my $child = shift or croak "child required";
422 0 0         if ( !$child->isa('Net::PMP::CollectionDoc') ) {
423 0           croak "child must be a Net::PMP::CollectionDoc object";
424             }
425 0           push @{ $self->{links}->{item} }, $child->as_link_hash;
  0            
426             }
427              
428             1;
429              
430             __END__
431              
432             =head1 AUTHOR
433              
434             Peter Karman, C<< <karman at cpan.org> >>
435              
436             =head1 BUGS
437              
438             Please report any bugs or feature requests to C<bug-net-pmp at rt.cpan.org>, or through
439             the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Net-PMP>. I will be notified, and then you'll
440             automatically be notified of progress on your bug as I make changes.
441              
442              
443             =head1 SUPPORT
444              
445             You can find documentation for this module with the perldoc command.
446              
447             perldoc Net::PMP::CollectionDoc
448              
449              
450             You can also look for information at:
451              
452             =over 4
453              
454             =item * RT: CPAN's request tracker (report bugs here)
455              
456             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Net-PMP>
457              
458             =item * AnnoCPAN: Annotated CPAN documentation
459              
460             L<http://annocpan.org/dist/Net-PMP>
461              
462             =item * CPAN Ratings
463              
464             L<http://cpanratings.perl.org/d/Net-PMP>
465              
466             =item * Search CPAN
467              
468             L<http://search.cpan.org/dist/Net-PMP/>
469              
470             =back
471              
472              
473             =head1 ACKNOWLEDGEMENTS
474              
475             American Public Media and the Public Media Platform sponsored the development of this module.
476              
477             =head1 LICENSE AND COPYRIGHT
478              
479             Copyright 2013 American Public Media Group
480              
481             See the LICENSE file that accompanies this module.
482              
483             =cut