File Coverage

blib/lib/Paws/Net/RestXmlCaller.pm
Criterion Covered Total %
statement 141 155 90.9
branch 53 62 85.4
condition 14 15 93.3
subroutine 13 14 92.8
pod 0 2 0.0
total 221 248 89.1


line stmt bran cond sub pod time code
1             package Paws::Net::RestXmlCaller;
2 8     8   4912 use Moose::Role;
  8         17  
  8         54  
3 8     8   35839 use HTTP::Request::Common;
  8         13747  
  8         525  
4 8     8   49 use POSIX qw(strftime);
  8         15  
  8         64  
5 8     8   521 use URI::Template;
  8         17  
  8         173  
6 8     8   36 use URI::Escape;
  8         11  
  8         354  
7 8     8   48 use Moose::Util;
  8         14  
  8         62  
8              
9             sub array_flatten_string {
10 9     9 0 12 my $self = shift;
11 9 50       21 return ($self->flattened_arrays)?'%s.%d':'%s.member.%d';
12             }
13              
14             # converts the objects that represent the call into parameters that the API can understand
15             sub _to_querycaller_params {
16 13     13   39 my ($self, $params) = @_;
17              
18              
19 13         22 my %p;
20 13         48 foreach my $att (grep { $_ !~ m/^_/ } $params->meta->get_attribute_list) {
  71         543  
21            
22             # e.g. S3 metadata objects, which are passed in the header
23 71 100       417 next if $params->meta->get_attribute($att)->does('Paws::API::Attribute::Trait::ParamInHeaders');
24              
25 70 100       18209 my $key = $params->meta->get_attribute($att)->does('Paws::API::Attribute::Trait::ParamInQuery')?$params->meta->get_attribute($att)->query_name:$att;
26 70 100       14531 if (defined $params->$att) {
27 28         88 my $att_type = $params->meta->get_attribute($att)->type_constraint;
28              
29 28 100       1572 if ($self->_is_internal_type($att_type)) {
    100          
30 21         1035 $p{ $key } = $params->{$att};
31             } elsif ($att_type =~ m/^ArrayRef\[(.*)\]/) {
32 3 100       506 if ($self->_is_internal_type("$1")){
33 1         3 my $i = 1;
34 1         2 foreach my $value (@{ $params->$att }){
  1         22  
35 3         7 $p{ sprintf($self->array_flatten_string, $key, $i) } = $value;
36 3         7 $i++
37             }
38             } else {
39 2         4 my $i = 1;
40 2         3 foreach my $value (@{ $params->$att }){
  2         50  
41 2         9 my %complex_value = $self->_to_querycaller_params($value);
42 2         7 map { $p{ sprintf($self->array_flatten_string . ".%s", $key, $i, $_) } = $complex_value{$_} } keys %complex_value;
  6         13  
43 2         8 $i++
44             }
45             }
46             } else {
47 4         959 my %complex_value = $self->_to_querycaller_params($params->$att);
48 4         10 map { $p{ "$key.$_" } = $complex_value{$_} } keys %complex_value;
  18         58  
49             }
50             }
51             }
52 13         246 return %p;
53             }
54              
55             sub _call_uri {
56 7     7   22 my ($self, $call) = @_;
57 7         29 my $uri_template = $call->meta->name->_api_uri; # in auto-lib/<service>/<method>.pm
58              
59 7         60 my @uri_attribs = $uri_template =~ /{(.+?)}/g;
60 7         17 my $vars = {};
61              
62 7         14 my %uri_attrib_is_greedy;
63 7         26 foreach my $attrib ( @uri_attribs ) {
64 7         43 my ($att_name, $greedy) = $attrib =~ /(\w+)(\+?)/;
65 7         26 $uri_attrib_is_greedy{$att_name} = $greedy;
66             }
67              
68 7         30 foreach my $attribute ($call->meta->get_all_attributes)
69             {
70 49 100       11955 if ($attribute->does('Paws::API::Attribute::Trait::ParamInURI')) {
71 7         1703 my $att_name = $attribute->name;
72 7 100       28 if ($uri_attrib_is_greedy{$att_name}) {
73 1         26 $vars->{ $attribute->uri_name } = uri_escape_utf8($call->$att_name, q[^A-Za-z0-9\-\._~/]);
74 1         20 $uri_template =~ s{$att_name\+}{\+$att_name}g;
75             } else {
76 6         184 $vars->{ $attribute->uri_name } = $call->$att_name;
77             }
78             }
79             }
80              
81 7         1315 my $t = URI::Template->new( $uri_template );
82 7         835 my $uri = $t->process($vars);
83 7         1637 return $uri;
84             }
85              
86             sub _to_header_params {
87 7     7   20 my ($self, $request, $call) = @_;
88 7         26 foreach my $attribute ($call->meta->get_all_attributes) {
89 49 100       7725 if ($attribute->does('Paws::API::Attribute::Trait::AutoInHeader')) {
90 1 50       266 if ( $attribute->auto eq 'MD5' ) {
91 1         10 require MIME::Base64;
92 1         6 require Digest::MD5;
93 1         2 my $value;
94 1 50       4 if ( $attribute->has_value($call) ) {
95 0         0 $value = $attribute->get_value($call);
96             }
97             else {
98 1         54 $value = MIME::Base64::encode_base64( Digest::MD5::md5( $request->content ) );
99 1         6 chomp $value;
100             }
101 1         38 $request->headers->header( $attribute->header_name => $value );
102             }
103 1         70 next;
104             }
105 48 100       14030 next unless $attribute->has_value($call);
106 17 50       466 if ($attribute->does('Paws::API::Attribute::Trait::ParamInHeader')) {
    100          
107 0         0 my $value = $attribute->get_value($call);
108 0         0 $request->headers->header( $attribute->header_name => $value );
109             }
110             elsif ($attribute->does('Paws::API::Attribute::Trait::ParamInHeaders')) {
111 1         473 my $map = $attribute->get_value($call)->Map;
112 1         27 my $prefix = $attribute->header_prefix;
113 1         3 for my $header (keys %{$map}) {
  1         4  
114 2         93 my $header_name = $prefix . $header;
115 2         49 $request->headers->header( $header_name => $map->{$header} );
116             }
117             }
118             }
119             }
120              
121             # URI escaping adapted from URI::Escape
122             #c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
123             # perl 5.6 ready UTF-8 encoding adapted from JSON::PP
124             our %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
125             our $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
126              
127             sub _uri_escape {
128 0     0   0 my ($self, $str) = @_;
129 0         0 utf8::encode($str);
130 0         0 $str =~ s/($unsafe_char)/$escapes{$1}/ge;
  0         0  
131 0         0 $str =~ s/ /+/go;
132 0         0 return $str;
133             }
134              
135             sub _to_xml {
136 6     6   216 my ($self, $value) = @_;
137              
138 6         8 my $xml = '';
139 6         20 foreach my $attribute ($value->meta->get_all_attributes) {
140 22         1088 my $att_name = $attribute->name;
141 22 100       53 next if (not $attribute->has_value($value));
142 12 100       667 if (Moose::Util::find_meta($attribute->type_constraint->name)) {
    100          
    100          
143 2 50       106 if ($attribute->does('NameInRequest')) {
144 0         0 my $location = $attribute->request_name;
145 0         0 $xml .= sprintf '<%s>%s</%s>', $location, $self->_to_xml($attribute->get_value($value)), $location;
146             } else {
147 2         141 $xml .= sprintf '<%s>%s</%s>', $att_name, $self->_to_xml($attribute->get_value($value)), $att_name;
148             }
149             } elsif ($attribute->type_constraint eq 'ArrayRef[Str|Undef]') {
150 1         118 my $location = $attribute->request_name;
151 1         4 $xml .= "<${att_name}>" . ( join '', map { sprintf '<%s>%s</%s>', $location, $_, $location } @{ $attribute->get_value($value) } ) . "</${att_name}>";
  3         115  
  1         10  
152             } elsif ($attribute->type_constraint =~ m/^ArrayRef\[(.*?\:\:.*)\]/) { #assume it's an array of Paws API objects
153 2 50       385 my $location = $attribute->does('NameInRequest') ? $attribute->request_name : $att_name;
154 2         5 $xml .= ( join '', map { sprintf '<%s>%s</%s>', $location, $self->_to_xml($_), $location } @{ $attribute->get_value($value) } );
  2         277  
  2         8  
155             } else {
156 7 50       1144 if ($attribute->does('NameInRequest')) {
157 0         0 my $location = $attribute->request_name;
158 0         0 $xml .= sprintf '<%s>%s</%s>', $location, $attribute->get_value($value), $location;
159             } else {
160 7         567 $xml .= sprintf '<%s>%s</%s>', $att_name, $attribute->get_value($value), $att_name;
161             }
162             }
163             }
164 6         406 return $xml;
165             }
166              
167             sub _to_xml_body {
168 7     7   20 my ($self, $call) = @_;
169              
170 7         17 my $xml = '';
171 7         24 foreach my $attribute ($call->meta->get_all_attributes) {
172 49 100 66     9068 if ($attribute->has_value($call) and
      100        
      100        
      100        
      100        
173             not $attribute->does('Paws::API::Attribute::Trait::ParamInHeader') and
174             not $attribute->does('Paws::API::Attribute::Trait::ParamInQuery') and
175             not $attribute->does('Paws::API::Attribute::Trait::ParamInURI') and
176             not $attribute->does('Paws::API::Attribute::Trait::ParamInBody') and
177             not $attribute->type_constraint eq 'Paws::S3::Metadata'
178             ) {
179 2         699 my $attribute_value = $attribute->get_value($call);
180 2 50       230 if ( ref $attribute_value ) {
181 2 50       7 my $location = $attribute->does('NameInRequest') ? $attribute->request_name : $attribute->name;
182 2         136 $xml .= sprintf '<%s>%s</%s>', $location, $self->_to_xml($attribute_value), $location;
183             }
184             else {
185 0         0 $xml .= $attribute_value;
186             }
187             }
188             }
189              
190 7 100       3652 return undef if (not $xml);
191 2         7 return $xml;
192             }
193              
194             sub prepare_request_for_call {
195 7     7 0 80 my ($self, $call) = @_;
196              
197 7         14 my $request;
198 7 100       57 if ($self->isa('Paws::S3')){
199 4         1111 require Paws::Net::S3APIRequest;
200 4         41 $request = Paws::Net::S3APIRequest->new();
201             } else {
202 3         25 $request = Paws::Net::APIRequest->new();
203             }
204              
205 7         5288 my $uri = $self->_call_uri($call); #in RestXmlCaller
206              
207 7         53 my $qparams = { $uri->query_form };
208 7         258 foreach my $attribute ($call->meta->get_all_attributes) {
209 49         9342 my $att_name = $attribute->name;
210 49 100       120 if ($attribute->does('Paws::API::Attribute::Trait::ParamInQuery')) {
211 14 100       3204 $qparams->{ $attribute->query_name } = $call->$att_name if (defined $call->$att_name);
212             }
213             }
214 7         1304 $uri->query_form(%$qparams);
215              
216 7         432 $request->uri($uri->as_string);
217              
218 7         182 my $url = $self->_api_endpoint . $uri; #in Paws::API::EndPointResolver
219              
220             #TODO: I'm not sure if any of the REST style APIs want things as query parameters
221 7         67 $request->parameters({ $self->_to_querycaller_params($call) });
222              
223 7         171 $request->url($url);
224 7         203 $request->method($call->_api_method);
225              
226 7 100       38 if (my $xml_body = $self->_to_xml_body($call)){
227 2         54 $request->content($xml_body);
228             }
229              
230 7         36 $self->_to_header_params($request, $call);
231              
232 7 100       1906 if ($call->can('_stream_param')) {
233 1         30 my $param_name = $call->_stream_param;
234 1         23 $request->content($call->$param_name);
235 1         23 $request->headers->header( 'content-length' => $request->content_length );
236             #$request->headers->header( 'content-type' => $self->content_type );
237             }
238              
239 7         95 $self->sign($request);
240              
241 7         138 return $request;
242             }
243             1;