File Coverage

blib/lib/WebAPI/DBIC/Resource/HAL/Role/DBIC.pm
Criterion Covered Total %
statement 12 66 18.1
branch 0 34 0.0
condition 0 7 0.0
subroutine 4 9 44.4
pod 0 3 0.0
total 16 119 13.4


line stmt bran cond sub pod time code
1             package WebAPI::DBIC::Resource::HAL::Role::DBIC;
2             $WebAPI::DBIC::Resource::HAL::Role::DBIC::VERSION = '0.003002';
3              
4 2     2   23414079 use Carp qw(croak confess);
  2         57  
  2         371  
5 2     2   975 use Devel::Dwarn;
  2         20042  
  2         17  
6 2     2   1136 use JSON::MaybeXS qw(JSON);
  2         1638  
  2         109  
7              
8 2     2   931 use Moo::Role;
  2         50405  
  2         11  
9              
10              
11             requires 'get_url_for_item_relationship';
12             requires 'render_item_as_plain_hash';
13             requires 'path_for_item';
14             requires 'add_params_to_url';
15             requires 'prefetch';
16              
17              
18             sub render_item_as_hal_hash {
19 0     0 0   my ($self, $item) = @_;
20              
21 0           my $data = $self->render_item_as_plain_hash($item);
22              
23 0           my $itemurl = $self->path_for_item($item);
24 0           $data->{_links}{self} = {
25             href => $self->add_params_to_url($itemurl, {}, {})->as_string,
26             };
27              
28 0 0         $self->_render_prefetch($item, $data, $_) for @{$self->prefetch||[]};
  0            
29              
30 0           my $curie = (0) ? "r" : ""; # XXX we don't use CURIE syntax yet
31              
32             # add links for relationships
33 0           for my $relname ($item->result_class->relationships) {
34              
35 0 0         my $url = $self->get_url_for_item_relationship($item, $relname)
36             or next;
37              
38 0 0         $data->{_links}{ ($curie?"$curie:":"") . $relname} = { href => $url->as_string };
39             }
40 0 0         if ($curie) {
41 0           $data->{_links}{curies} = [{
42             name => $curie,
43             href => "http://docs.acme.com/relations/{rel}", # XXX
44             templated => JSON->true,
45             }];
46             }
47              
48 0           return $data;
49             }
50              
51              
52             sub _render_prefetch {
53 0     0     my ($self, $item, $data, $prefetch) = @_;
54              
55 0           while (my ($rel, $sub_rel) = each %{$prefetch}){
  0            
56 0 0         next if $rel eq 'self';
57              
58 0           my $subitem = $item->$rel();
59              
60             # XXX perhaps render_item_as_hal_hash but requires cloned WM, eg without prefetch
61             # If we ever do render_item_as_hal_hash then we need to ensure that "a link
62             # inside an embedded resource implicitly relates to that embedded
63             # resource and not the parent."
64             # See http://blog.stateless.co/post/13296666138/json-linking-with-hal
65 0 0         if (not defined $subitem) {
    0          
66 0           $data->{_embedded}{$rel} = undef; # show an explicit null from a prefetch
67             }
68             elsif ($subitem->isa('DBIx::Class::ResultSet')) { # one-to-many rel
69 0 0         my $rel_set_resource = $self->web_machine_resource(
70             set => $subitem,
71             prefetch => ref $sub_rel eq 'ARRAY' ? $sub_rel : [$sub_rel],
72             );
73 0           $data->{_embedded}{$rel} = $rel_set_resource->render_set_as_list_of_hal($subitem);
74             }
75             else {
76 0           $data->{_embedded}{$rel} = $self->render_item_as_plain_hash($subitem);
77             }
78             }
79             }
80              
81              
82             sub render_set_as_list_of_hal {
83 0     0 0   my ($self, $set, $render_method) = @_;
84 0   0       $render_method ||= 'render_item_as_hal_hash';
85              
86 0           my $set_data = [ map { $self->$render_method($_) } $set->all ];
  0            
87              
88 0           return $set_data;
89             }
90              
91              
92             sub render_set_as_hal {
93 0     0 0   my ($self, $set) = @_;
94              
95             # some params, like distinct, mean we're not returning full resource representations(?)
96             # so render the contents of the _embedded set as plain JSON
97 0 0         my $render_method = ($self->param('distinct'))
98             ? 'render_item_as_plain_hash'
99             : 'render_item_as_hal_hash';
100 0           my $set_data = $self->render_set_as_list_of_hal($set, $render_method);
101              
102 0           my $data = {};
103              
104 0           my $total_items;
105 0 0 0       if (($self->param('with')||'') =~ /count/) { # XXX
106 0           $total_items = $set->pager->total_entries;
107 0           $data->{_meta}{count} = $total_items;
108             }
109              
110 0           my ($prefix, $rel) = $self->uri_for(result_class => $set->result_class);
111 0           $data->{_embedded} = {
112             $rel => $set_data,
113             };
114 0           $data->{_links} = {
115             $self->_hal_page_links($set, "$prefix/$rel", scalar @$set_data, $total_items),
116             };
117              
118 0           return $data;
119             }
120              
121              
122             sub _hal_page_links {
123 0     0     my ($self, $set, $base, $page_items, $total_items) = @_;
124              
125             # XXX we ought to allow at least the self link when not pages
126 0 0         return () unless $set->is_paged;
127              
128             # XXX we break encapsulation here, sadly, because calling
129             # $set->pager->current_page triggers a "select count(*)".
130             # XXX When we're using a later version of DBIx::Class we can use this:
131             # https://metacpan.org/source/RIBASUSHI/DBIx-Class-0.08208/lib/DBIx/Class/ResultSet/Pager.pm
132             # and do something like $rs->pager->total_entries(sub { 99999999 })
133 0 0         my $rows = $set->{attrs}{rows} or confess "panic: rows not set";
134 0 0         my $page = $set->{attrs}{page} or confess "panic: page not set";
135              
136             # XXX this self link this should probably be subtractive, ie include all
137             # params by default except any known to cause problems
138 0           my $url = $self->add_params_to_url($base, { distinct=>1, with=>1, me=>1 }, { rows => $rows });
139 0           my $linkurl = $url->as_string;
140 0           $linkurl .= "&page="; # hack to optimize appending page 5 times below
141              
142 0           my @link_kvs;
143 0           push @link_kvs, self => {
144             href => $linkurl.($page),
145             title => $set->result_class,
146             };
147 0 0         push @link_kvs, next => { href => $linkurl.($page+1) }
148             if $page_items == $rows;
149 0 0         push @link_kvs, prev => { href => $linkurl.($page-1) }
150             if $page > 1;
151 0 0         push @link_kvs, first => { href => $linkurl.1 }
152             if $page > 1;
153 0 0 0       push @link_kvs, last => { href => $linkurl.$set->pager->last_page }
154             if $total_items and $page != $set->pager->last_page;
155              
156 0           return @link_kvs;
157             }
158              
159              
160             1;
161              
162             __END__
163              
164             =pod
165              
166             =encoding UTF-8
167              
168             =head1 NAME
169              
170             WebAPI::DBIC::Resource::HAL::Role::DBIC
171              
172             =head1 VERSION
173              
174             version 0.003002
175              
176             =head1 NAME
177              
178             WebAPI::DBIC::Resource::HAL::Role::DBIC - a role with core HAL methods for DBIx::Class resources
179              
180             =head1 AUTHOR
181              
182             Tim Bunce <Tim.Bunce@pobox.com>
183              
184             =head1 COPYRIGHT AND LICENSE
185              
186             This software is copyright (c) 2015 by Tim Bunce.
187              
188             This is free software; you can redistribute it and/or modify it under
189             the same terms as the Perl 5 programming language system itself.
190              
191             =cut