File Coverage

blib/lib/WebAPI/DBIC/Resource/HAL/Role/SetWritable.pm
Criterion Covered Total %
statement 9 46 19.5
branch 0 20 0.0
condition 0 2 0.0
subroutine 3 7 42.8
pod 0 2 0.0
total 12 77 15.5


line stmt bran cond sub pod time code
1             package WebAPI::DBIC::Resource::HAL::Role::SetWritable;
2             $WebAPI::DBIC::Resource::HAL::Role::SetWritable::VERSION = '0.003002';
3              
4 2     2   22332062 use Devel::Dwarn;
  2         22884  
  2         21  
5 2     2   443 use Carp qw(confess);
  2         5  
  2         133  
6              
7 2     2   1259 use Moo::Role;
  2         52005  
  2         14  
8              
9              
10             requires '_build_content_types_accepted';
11             requires 'render_item_into_body';
12             requires 'decode_json';
13             requires 'set';
14             requires 'prefetch';
15              
16              
17             around '_build_content_types_accepted' => sub {
18             my $orig = shift;
19             my $self = shift;
20             my $types = $self->$orig();
21             unshift @$types, { 'application/hal+json' => 'from_hal_json' };
22             return $types;
23             };
24              
25              
26             sub from_hal_json {
27 0     0 0   my $self = shift;
28 0           my $item = $self->create_resources_from_hal( $self->decode_json($self->request->content) );
29 0           return $self->item($item);
30             }
31              
32              
33             sub create_resources_from_hal { # XXX unify with create_resource in SetWritable, like ItemWritable?
34 0     0 0   my ($self, $hal) = @_;
35 0           my $item;
36              
37 0           my $schema = $self->set->result_source->schema;
38             # XXX perhaps the transaction wrapper belongs higher in the stack
39             # but it has to be below the auth layer which switches schemas
40             $schema->txn_do(sub {
41              
42 0     0     $item = $self->_create_embedded_resources_from_hal($hal, $self->set->result_class);
43              
44             # resync with what's (now) in the db to pick up defaulted fields etc
45 0           $item->discard_changes();
46              
47             # called here because create_path() is too late for Web::Machine
48             # and we need it to happen inside the transaction for rollback=1 to work
49 0           $self->render_item_into_body(item => $item, prefetch => $self->prefetch)
50 0 0         if grep {defined $_->{self}} @{$self->prefetch||[]};
  0 0          
51              
52 0 0         $schema->txn_rollback if $self->param('rollback'); # XXX
53 0           });
54              
55 0           return $item;
56             }
57              
58              
59             # recurse to create resources in $hal->{_embedded}
60             # and update coresponding attributes in $hal
61             # then create $hal itself
62             sub _create_embedded_resources_from_hal {
63 0     0     my ($self, $hal, $result_class) = @_;
64              
65 0           my $links = delete $hal->{_links};
66 0           my $meta = delete $hal->{_meta};
67 0   0       my $embedded = delete $hal->{_embedded} || {};
68              
69 0           for my $rel (keys %$embedded) {
70              
71 0 0         my $rel_info = $result_class->relationship_info($rel)
72             or die "$result_class doesn't have a '$rel' relation\n";
73 0 0         die "$result_class _embedded $rel isn't a 'single' relationship\n"
74             if $rel_info->{attrs}{accessor} ne 'single';
75              
76 0           my $rel_hal = $embedded->{$rel};
77 0 0         die "_embedded $rel data is not a hash\n"
78             if ref $rel_hal ne 'HASH';
79              
80             # work out what keys to copy from the subitem we're about to create
81 0           my %fk_map;
82 0           my $cond = $rel_info->{cond};
83 0           for my $sub_field (keys %$cond) {
84 0           my $our_field = $cond->{$sub_field};
85 0 0         $our_field =~ s/^self\.//x or confess "panic $rel $our_field";
86 0 0         $sub_field =~ s/^foreign\.//x or confess "panic $rel $sub_field";
87 0           $fk_map{$our_field} = $sub_field;
88              
89 0 0         die "$result_class already contains a value for '$our_field'\n"
90             if defined $hal->{$our_field}; # null is ok
91             }
92              
93             # create this subitem (and any resources embedded in it)
94 0           my $subitem = $self->_create_embedded_resources_from_hal($rel_hal, $rel_info->{source});
95              
96             # copy the keys of the subitem up to the item we're about to create
97 0 0         warn "$result_class $rel: propagating keys: @{[ %fk_map ]}\n"
  0            
98             if $ENV{WEBAPI_DBIC_DEBUG};
99 0           while ( my ($ourfield, $subfield) = each %fk_map) {
100 0           $hal->{$ourfield} = $subitem->$subfield();
101             }
102             }
103              
104 0           return $self->set->result_source->schema->resultset($result_class)->create($hal);
105             }
106              
107             1;
108              
109             __END__
110              
111             =pod
112              
113             =encoding UTF-8
114              
115             =head1 NAME
116              
117             WebAPI::DBIC::Resource::HAL::Role::SetWritable
118              
119             =head1 VERSION
120              
121             version 0.003002
122              
123             =head1 DESCRIPTION
124              
125             Handles POST requests for resources representing set resources, e.g. to insert
126             rows into a database table.
127              
128             Supports the C<application/hal+json> and C<application/json> content types.
129              
130             =head1 NAME
131              
132             WebAPI::DBIC::Resource::HAL::Role::SetWritable - methods handling HAL requests to update set resources
133              
134             =head1 AUTHOR
135              
136             Tim Bunce <Tim.Bunce@pobox.com>
137              
138             =head1 COPYRIGHT AND LICENSE
139              
140             This software is copyright (c) 2015 by Tim Bunce.
141              
142             This is free software; you can redistribute it and/or modify it under
143             the same terms as the Perl 5 programming language system itself.
144              
145             =cut