File Coverage

blib/lib/WebAPI/DBIC/Resource/HAL/Role/ItemWritable.pm
Criterion Covered Total %
statement 9 38 23.6
branch 0 14 0.0
condition 0 2 0.0
subroutine 3 5 60.0
pod 0 1 0.0
total 12 60 20.0


line stmt bran cond sub pod time code
1             package WebAPI::DBIC::Resource::HAL::Role::ItemWritable;
2             $WebAPI::DBIC::Resource::HAL::Role::ItemWritable::VERSION = '0.003002';
3              
4 2     2   22749966 use Carp qw(croak confess);
  2         27  
  2         436  
5 2     2   1236 use Devel::Dwarn;
  2         21233  
  2         12  
6              
7 2     2   1371 use Moo::Role;
  2         43062  
  2         9  
8              
9              
10             requires 'decode_json';
11             requires 'request';
12              
13             requires '_pre_update_resource_method';
14              
15              
16             around '_build_content_types_accepted' => sub {
17             my $orig = shift;
18             my $self = shift;
19             my $types = $self->$orig();
20             unshift @$types, { 'application/hal+json' => 'from_hal_json' };
21             return $types;
22             };
23              
24              
25             sub from_hal_json {
26 0     0 0   my $self = shift;
27 0           $self->_pre_update_resource_method( "_do_update_embedded_resources_hal" );
28 0           my $data = $self->decode_json( $self->request->content );
29 0           $self->update_resource($data, is_put_replace => 0);
30 0           return;
31             }
32              
33              
34             sub _do_update_embedded_resources_hal {
35 0     0     my ($self, $item, $hal, $result_class) = @_;
36              
37 0           my $links = delete $hal->{_links};
38 0           my $meta = delete $hal->{_meta};
39 0   0       my $embedded = delete $hal->{_embedded} || {};
40              
41 0           for my $rel (keys %$embedded) {
42              
43 0 0         my $rel_info = $result_class->relationship_info($rel)
44             or die "$result_class doesn't have a '$rel' relation\n";
45 0 0         die "$result_class _embedded $rel isn't a 'single' relationship\n"
46             if $rel_info->{attrs}{accessor} ne 'single';
47              
48 0           my $rel_hal = $embedded->{$rel};
49 0 0         die "_embedded $rel data is not a hash\n"
50             if ref $rel_hal ne 'HASH';
51              
52             # work out what keys to copy from the subitem we're about to update
53             # XXX this isn't required unless updating key fields - optimize
54 0           my %fk_map;
55 0           my $cond = $rel_info->{cond};
56 0           for my $sub_field (keys %$cond) {
57 0           my $our_field = $cond->{$sub_field};
58 0 0         $our_field =~ s/^self\.//x or confess "panic $rel $our_field";
59 0 0         $sub_field =~ s/^foreign\.//x or confess "panic $rel $sub_field";
60 0           $fk_map{$our_field} = $sub_field;
61              
62 0 0         die "$result_class already contains a value for '$our_field'\n"
63             if defined $hal->{$our_field}; # null is ok
64             }
65              
66             # update this subitem (and any resources embedded in it)
67 0           my $subitem = $item->$rel();
68 0           $subitem = $self->_do_update_resource($subitem, $rel_hal, $rel_info->{source});
69              
70             # copy the keys of the subitem up to the item we're about to update
71 0 0         warn "$result_class $rel: propagating keys: @{[ %fk_map ]}\n"
  0            
72             if $ENV{WEBAPI_DBIC_DEBUG};
73 0           while ( my ($ourfield, $subfield) = each %fk_map) {
74 0           $hal->{$ourfield} = $subitem->$subfield();
75             }
76              
77             # XXX perhaps save $subitem to optimise prefetch handling?
78             }
79              
80 0           return;
81             }
82              
83              
84             1;
85              
86             __END__
87              
88             =pod
89              
90             =encoding UTF-8
91              
92             =head1 NAME
93              
94             WebAPI::DBIC::Resource::HAL::Role::ItemWritable
95              
96             =head1 VERSION
97              
98             version 0.003002
99              
100             =head1 NAME
101              
102             WebAPI::DBIC::Resource::HAL::Role::ItemWritable - methods handling HAL requests to update item resources
103              
104             =head1 AUTHOR
105              
106             Tim Bunce <Tim.Bunce@pobox.com>
107              
108             =head1 COPYRIGHT AND LICENSE
109              
110             This software is copyright (c) 2015 by Tim Bunce.
111              
112             This is free software; you can redistribute it and/or modify it under
113             the same terms as the Perl 5 programming language system itself.
114              
115             =cut