line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package WebAPI::DBIC::Resource::JSONAPI::Role::DBIC; |
2
|
|
|
|
|
|
|
$WebAPI::DBIC::Resource::JSONAPI::Role::DBIC::VERSION = '0.004001'; |
3
|
|
|
|
|
|
|
|
4
|
2
|
|
|
2
|
|
39741801
|
use Carp qw(croak confess); |
|
2
|
|
|
|
|
11
|
|
|
2
|
|
|
|
|
357
|
|
5
|
2
|
|
|
2
|
|
1111
|
use Devel::Dwarn; |
|
2
|
|
|
|
|
20171
|
|
|
2
|
|
|
|
|
20
|
|
6
|
2
|
|
|
2
|
|
1362
|
use JSON::MaybeXS qw(JSON); |
|
2
|
|
|
|
|
1519
|
|
|
2
|
|
|
|
|
102
|
|
7
|
|
|
|
|
|
|
|
8
|
2
|
|
|
2
|
|
930
|
use Moo::Role; |
|
2
|
|
|
|
|
44344
|
|
|
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
|
|
|
|
|
|
|
requires 'type_namer'; |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
sub jsonapi_type { |
21
|
0
|
|
|
0
|
0
|
|
my ($self) = @_; |
22
|
0
|
|
|
|
|
|
return $self->type_namer->type_name_for_resultset($self->set); |
23
|
|
|
|
|
|
|
} |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
sub top_link_for_relname { # XXX cacheable |
27
|
0
|
|
|
0
|
0
|
|
my ($self, $relname) = @_; |
28
|
|
|
|
|
|
|
|
29
|
0
|
|
|
|
|
|
my $link_url_templated = $self->get_url_template_for_set_relationship($self->set, $relname); |
30
|
0
|
0
|
|
|
|
|
return if not defined $link_url_templated; |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# XXX a hack to keep the template urls readable! |
33
|
0
|
|
|
|
|
|
$link_url_templated =~ s/%7B/{/g; |
34
|
0
|
|
|
|
|
|
$link_url_templated =~ s/%7D/}/g; |
35
|
|
|
|
|
|
|
|
36
|
0
|
|
|
|
|
|
my $rel_info = $self->set->result_class->relationship_info($relname); |
37
|
0
|
|
0
|
|
|
|
my $result_class = $rel_info->{class}||die "panic"; |
38
|
|
|
|
|
|
|
|
39
|
0
|
|
|
|
|
|
my $rel_jsonapi_type = $self->type_namer->type_name_for_result_class($result_class); |
40
|
|
|
|
|
|
|
|
41
|
0
|
|
|
|
|
|
my $path = $self->jsonapi_type .".". $relname; |
42
|
0
|
|
|
|
|
|
return $path => { |
43
|
|
|
|
|
|
|
href => "$link_url_templated", # XXX stringify the URL object |
44
|
|
|
|
|
|
|
type => $rel_jsonapi_type, |
45
|
|
|
|
|
|
|
}; |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
sub render_jsonapi_prefetch_rel { |
50
|
0
|
|
|
0
|
0
|
|
my ($self, $set, $relname, $sub_rel, $top_links, $compound_links, $item_edit_rel_hooks) = @_; |
51
|
|
|
|
|
|
|
|
52
|
0
|
|
|
|
|
|
my $rel_info = $set->result_class->relationship_info($relname); |
53
|
0
|
|
0
|
|
|
|
my $result_class = $rel_info->{class}||die "panic"; |
54
|
|
|
|
|
|
|
|
55
|
0
|
|
|
|
|
|
my @idcolumns = $result_class->unique_constraint_columns('primary'); # XXX wrong |
56
|
0
|
0
|
|
|
|
|
if (@idcolumns > 1) { # eg many-to-many that doesn't have a separate id |
57
|
0
|
0
|
|
|
|
|
warn "Result class $result_class has multiple keys (@idcolumns) so relations like $relname won't have links generated.\n" |
58
|
|
|
|
|
|
|
unless our $warn_once->{"$result_class $relname"}++; |
59
|
0
|
|
|
|
|
|
return; |
60
|
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
|
|
62
|
0
|
0
|
|
|
|
|
my ($top_link_key, $top_link_value) = $self->top_link_for_relname($relname) |
63
|
|
|
|
|
|
|
or return; |
64
|
0
|
|
|
|
|
|
$top_links->{$top_link_key} = $top_link_value; |
65
|
|
|
|
|
|
|
|
66
|
0
|
|
|
|
|
|
my $rel_typename = $self->type_namer->type_name_for_result_class($rel_info->{class}); |
67
|
|
|
|
|
|
|
|
68
|
0
|
0
|
|
|
|
|
die "panic: item_edit_rel_hooks for $relname already defined" |
69
|
|
|
|
|
|
|
if $item_edit_rel_hooks->{$relname}; |
70
|
|
|
|
|
|
|
$item_edit_rel_hooks->{$relname} = sub { |
71
|
0
|
|
|
0
|
|
|
my ($jsonapi_obj, $row) = @_; |
72
|
|
|
|
|
|
|
|
73
|
0
|
|
|
|
|
|
my $subitem = $row->$relname(); |
74
|
|
|
|
|
|
|
|
75
|
0
|
|
0
|
|
|
|
my $compound_links_for_rel = $compound_links->{$rel_typename} ||= {}; |
76
|
|
|
|
|
|
|
|
77
|
0
|
|
|
|
|
|
my $link_keys; |
78
|
0
|
0
|
|
|
|
|
if (not defined $subitem) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
79
|
0
|
|
|
|
|
|
$link_keys = undef; |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
elsif ($subitem->isa('DBIx::Class::ResultSet')) { # one-to-many rel |
82
|
0
|
|
|
|
|
|
$link_keys = []; |
83
|
0
|
|
|
|
|
|
while (my $subrow = $subitem->next) { |
84
|
0
|
|
|
|
|
|
my $id = $subrow->id; |
85
|
0
|
|
|
|
|
|
push @$link_keys, $id; |
86
|
0
|
|
|
|
|
|
$compound_links_for_rel->{$id} = $self->render_item_as_jsonapi_hash($subrow); # XXX typename |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
elsif ($subitem->isa('DBIx::Class::Row')) { # one-to-many rel |
90
|
0
|
|
|
|
|
|
$link_keys = $subitem->id; |
91
|
0
|
|
|
|
|
|
$compound_links_for_rel->{$subitem->id} = $self->render_item_as_jsonapi_hash($subitem); # XXX typename |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
else { |
94
|
0
|
|
|
|
|
|
die "panic: don't know how to handle $row $relname value $subitem"; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
0
|
|
|
|
|
|
$jsonapi_obj->{links}{$rel_typename} = $link_keys; |
98
|
|
|
|
|
|
|
} |
99
|
0
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
sub render_jsonapi_response { # return top-level document hashref |
103
|
0
|
|
|
0
|
0
|
|
my ($self) = @_; |
104
|
|
|
|
|
|
|
|
105
|
0
|
|
|
|
|
|
my $set = $self->set; |
106
|
|
|
|
|
|
|
|
107
|
0
|
|
|
|
|
|
my $top_links = {}; |
108
|
0
|
|
|
|
|
|
my $compound_links = {}; |
109
|
0
|
|
|
|
|
|
my $item_edit_rel_hooks = {}; |
110
|
|
|
|
|
|
|
|
111
|
0
|
0
|
|
|
|
|
for my $prefetch (@{$self->prefetch||[]}) { |
|
0
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
#warn "prefetch $prefetch"; |
113
|
0
|
0
|
|
|
|
|
next if $self->param('distinct'); |
114
|
|
|
|
|
|
|
|
115
|
0
|
|
|
|
|
|
while (my ($relname, $sub_rel) = each %{$prefetch}){ |
|
0
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
#warn "prefetch $prefetch - $relname, $sub_rel"; |
117
|
0
|
|
|
|
|
|
$self->render_jsonapi_prefetch_rel($set, $relname, $sub_rel, $top_links, $compound_links, $item_edit_rel_hooks); |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
my $set_data = $self->render_set_as_array_of_jsonapi_resource_objects($set, undef, sub { |
122
|
0
|
|
|
0
|
|
|
my ($jsonapi_obj, $row) = @_; |
123
|
0
|
|
|
|
|
|
$_->($jsonapi_obj, $row) for values %$item_edit_rel_hooks; |
124
|
0
|
|
|
|
|
|
}); |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
# construct top document to return |
127
|
0
|
0
|
|
|
|
|
my $top_set_key = ($self->param('distinct')) ? 'data' : $self->jsonapi_type; |
128
|
0
|
|
|
|
|
|
my $top_doc = { # http://jsonapi.org/format/#document-structure-top-level |
129
|
|
|
|
|
|
|
$top_set_key => $set_data, |
130
|
|
|
|
|
|
|
}; |
131
|
|
|
|
|
|
|
|
132
|
0
|
0
|
|
|
|
|
if (keys %$top_links) { |
133
|
0
|
|
|
|
|
|
$top_doc->{links} = $top_links |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
0
|
0
|
|
|
|
|
if (keys %$compound_links) { |
137
|
|
|
|
|
|
|
#Dwarn $compound_links; |
138
|
0
|
|
|
|
|
|
while ( my ($k, $v) = each %$compound_links) { |
139
|
|
|
|
|
|
|
# sort just for test stability, |
140
|
0
|
|
|
|
|
|
$top_doc->{linked}{$k} = [ @{$v}{ sort keys %$v } ]; |
|
0
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
} |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
|
144
|
0
|
|
|
|
|
|
my $total_items; |
145
|
0
|
0
|
0
|
|
|
|
if (($self->param('with')||'') =~ /count/) { # XXX |
146
|
0
|
|
|
|
|
|
$total_items = $set->pager->total_entries; |
147
|
0
|
|
|
|
|
|
$top_doc->{meta}{count} = $total_items; # XXX detail not in spec |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
0
|
|
|
|
|
|
return $top_doc; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
sub render_item_as_jsonapi_hash { |
156
|
0
|
|
|
0
|
0
|
|
my ($self, $item) = @_; |
157
|
|
|
|
|
|
|
|
158
|
0
|
|
|
|
|
|
my $data = $self->render_item_as_plain_hash($item); |
159
|
|
|
|
|
|
|
|
160
|
0
|
|
0
|
|
|
|
$data->{id} //= $item->id; |
161
|
0
|
|
|
|
|
|
$data->{type} = $self->type_namer->type_name_for_result_class($item->result_source->result_class); |
162
|
0
|
|
|
|
|
|
$data->{href} = $self->path_for_item($item); |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
#$self->_render_prefetch_jsonapi($item, $data, $_) for @{$self->prefetch||[]}; |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
# add links for relationships |
167
|
|
|
|
|
|
|
|
168
|
0
|
|
|
|
|
|
return $data; |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
sub _render_prefetch_jsonapi { |
173
|
0
|
|
|
0
|
|
|
my ($self, $item, $data, $prefetch) = @_; |
174
|
|
|
|
|
|
|
|
175
|
0
|
|
|
|
|
|
while (my ($rel, $sub_rel) = each %{$prefetch}){ |
|
0
|
|
|
|
|
|
|
176
|
0
|
0
|
|
|
|
|
next if $rel eq 'self'; |
177
|
|
|
|
|
|
|
|
178
|
0
|
|
|
|
|
|
my $subitem = $item->$rel(); |
179
|
|
|
|
|
|
|
|
180
|
0
|
0
|
|
|
|
|
if (not defined $subitem) { |
|
|
0
|
|
|
|
|
|
181
|
0
|
|
|
|
|
|
$data->{_embedded}{$rel} = undef; # show an explicit null from a prefetch |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
elsif ($subitem->isa('DBIx::Class::ResultSet')) { # one-to-many rel |
184
|
0
|
0
|
|
|
|
|
my $rel_set_resource = $self->web_machine_resource( |
185
|
|
|
|
|
|
|
set => $subitem, |
186
|
|
|
|
|
|
|
item => undef, |
187
|
|
|
|
|
|
|
prefetch => ref $sub_rel eq 'ARRAY' ? $sub_rel : [$sub_rel], |
188
|
|
|
|
|
|
|
); |
189
|
0
|
|
|
|
|
|
$data->{_embedded}{$rel} = $rel_set_resource->render_set_as_array_of_jsonapi_resource_objects($subitem, undef); |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
else { |
192
|
0
|
|
|
|
|
|
$data->{_embedded}{$rel} = $self->render_item_as_plain_hash($subitem); |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
sub render_set_as_array_of_jsonapi_resource_objects { |
198
|
0
|
|
|
0
|
0
|
|
my ($self, $set, $render_method, $edit_hook) = @_; |
199
|
0
|
|
0
|
|
|
|
$render_method ||= 'render_item_as_jsonapi_hash'; |
200
|
|
|
|
|
|
|
|
201
|
0
|
|
|
|
|
|
my @jsonapi_objs; |
202
|
0
|
|
|
|
|
|
while (my $row = $set->next) { |
203
|
0
|
|
|
|
|
|
push @jsonapi_objs, $self->$render_method($row); |
204
|
0
|
0
|
|
|
|
|
$edit_hook->($jsonapi_objs[-1], $row) if $edit_hook; |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
|
207
|
0
|
|
|
|
|
|
return \@jsonapi_objs; |
208
|
|
|
|
|
|
|
} |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
sub _jsonapi_page_links { |
214
|
0
|
|
|
0
|
|
|
my ($self, $set, $base, $page_items, $total_items) = @_; |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
# XXX we ought to allow at least the self link when not pages |
217
|
0
|
0
|
|
|
|
|
return () unless $set->is_paged; |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
# XXX we break encapsulation here, sadly, because calling |
220
|
|
|
|
|
|
|
# $set->pager->current_page triggers a "select count(*)". |
221
|
|
|
|
|
|
|
# XXX When we're using a later version of DBIx::Class we can use this: |
222
|
|
|
|
|
|
|
# https://metacpan.org/source/RIBASUSHI/DBIx-Class-0.08208/lib/DBIx/Class/ResultSet/Pager.pm |
223
|
|
|
|
|
|
|
# and do something like $rs->pager->total_entries(sub { 99999999 }) |
224
|
0
|
0
|
|
|
|
|
my $rows = $set->{attrs}{rows} or confess "panic: rows not set"; |
225
|
0
|
0
|
|
|
|
|
my $page = $set->{attrs}{page} or confess "panic: page not set"; |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
# XXX this self link this should probably be subtractive, ie include all |
228
|
|
|
|
|
|
|
# params by default except any known to cause problems |
229
|
0
|
|
|
|
|
|
my $url = $self->add_params_to_url($base, { distinct=>1, with=>1, me=>1 }, { rows => $rows }); |
230
|
0
|
|
|
|
|
|
my $linkurl = $url->as_string; |
231
|
0
|
|
|
|
|
|
$linkurl .= "&page="; # hack to optimize appending page 5 times below |
232
|
|
|
|
|
|
|
|
233
|
0
|
|
|
|
|
|
my @link_kvs; |
234
|
0
|
|
|
|
|
|
push @link_kvs, self => { |
235
|
|
|
|
|
|
|
href => $linkurl.($page), |
236
|
|
|
|
|
|
|
title => $set->result_class, |
237
|
|
|
|
|
|
|
}; |
238
|
0
|
0
|
|
|
|
|
push @link_kvs, next => { href => $linkurl.($page+1) } |
239
|
|
|
|
|
|
|
if $page_items == $rows; |
240
|
0
|
0
|
|
|
|
|
push @link_kvs, prev => { href => $linkurl.($page-1) } |
241
|
|
|
|
|
|
|
if $page > 1; |
242
|
0
|
0
|
|
|
|
|
push @link_kvs, first => { href => $linkurl.1 } |
243
|
|
|
|
|
|
|
if $page > 1; |
244
|
0
|
0
|
0
|
|
|
|
push @link_kvs, last => { href => $linkurl.$set->pager->last_page } |
245
|
|
|
|
|
|
|
if $total_items and $page != $set->pager->last_page; |
246
|
|
|
|
|
|
|
|
247
|
0
|
|
|
|
|
|
return @link_kvs; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
1; |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
__END__ |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
=pod |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
=encoding UTF-8 |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
=head1 NAME |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
WebAPI::DBIC::Resource::JSONAPI::Role::DBIC |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
=head1 VERSION |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
version 0.004001 |
266
|
|
|
|
|
|
|
|
267
|
|
|
|
|
|
|
=head1 NAME |
268
|
|
|
|
|
|
|
|
269
|
|
|
|
|
|
|
WebAPI::DBIC::Resource::JSONAPI::Role::DBIC - a role with core JSON API methods for DBIx::Class resources |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
=head1 AUTHOR |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
Tim Bunce <Tim.Bunce@pobox.com> |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
This software is copyright (c) 2015 by Tim Bunce. |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
280
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
=cut |