File Coverage

blib/lib/Mojo/UserAgent/Transactor.pm
Criterion Covered Total %
statement 194 194 100.0
branch 104 110 94.5
condition 59 66 89.3
subroutine 30 30 100.0
pod 9 9 100.0
total 396 409 96.8


line stmt bran cond sub pod time code
1             package Mojo::UserAgent::Transactor;
2 54     54   1001 use Mojo::Base -base;
  54         140  
  54         424  
3              
4 54     54   440 use Mojo::Asset::File;
  54         162  
  54         764  
5 54     54   347 use Mojo::Asset::Memory;
  54         167  
  54         559  
6 54     54   350 use Mojo::Content::MultiPart;
  54         166  
  54         671  
7 54     54   390 use Mojo::Content::Single;
  54         135  
  54         596  
8 54     54   537 use Mojo::File qw(path);
  54         183  
  54         3429  
9 54     54   499 use Mojo::JSON qw(encode_json);
  54         200  
  54         3091  
10 54     54   455 use Mojo::Parameters;
  54         167  
  54         451  
11 54     54   25451 use Mojo::Transaction::HTTP;
  54         217  
  54         563  
12 54     54   508 use Mojo::Transaction::WebSocket;
  54         127  
  54         349  
13 54     54   318 use Mojo::URL;
  54         176  
  54         338  
14 54     54   313 use Mojo::Util qw(encode url_escape);
  54         159  
  54         3139  
15 54     54   474 use Mojo::WebSocket qw(challenge client_handshake);
  54         583  
  54         174469  
16              
17             has compressed => sub { $ENV{MOJO_GZIP} // 1 };
18             has generators => sub { {form => \&_form, json => \&_json, multipart => \&_multipart} };
19             has name => 'Mojolicious (Perl)';
20              
21 1 50   1 1 17 sub add_generator { $_[0]->generators->{$_[1]} = $_[2] and return $_[0] }
22              
23             sub endpoint {
24 2023     2023 1 4406 my ($self, $tx) = @_;
25              
26             # Basic endpoint
27 2023         5233 my $req = $tx->req;
28 2023         5743 my $url = $req->url;
29 2023   50     6698 my $proto = $url->protocol || 'http';
30 2023         5779 my $host = $url->ihost;
31 2023 100 66     5437 my $port = $url->port // ($proto eq 'https' ? 443 : 80);
32              
33             # Proxy for normal HTTP requests
34 2023         3462 my $socks;
35 2023 100       5286 if (my $proxy = $req->proxy) { $socks = $proxy->protocol eq 'socks' }
  64         146  
36 2023 100 100     8438 return _proxy($tx, $proto, $host, $port) if $proto eq 'http' && !$req->is_handshake && !$socks;
      100        
37              
38 181         1063 return $proto, $host, $port;
39             }
40              
41 213     213 1 873 sub peer { _proxy($_[1], $_[0]->endpoint($_[1])) }
42              
43             sub promisify {
44 47     47 1 174 my ($self, $promise, $tx) = @_;
45 47         166 my $err = $tx->error;
46 47 100 100     276 return $promise->reject($err->{message}) if $err && !$err->{code};
47 43 100 100     125 return $promise->reject('WebSocket handshake failed') if $tx->req->is_handshake && !$tx->is_websocket;
48 41         205 $promise->resolve($tx);
49             }
50              
51             sub proxy_connect {
52 190     190 1 623 my ($self, $old) = @_;
53              
54             # Already a CONNECT request
55 190         839 my $req = $old->req;
56 190 100       717 return undef if uc $req->method eq 'CONNECT';
57              
58             # No proxy
59 186 100 100     626 return undef unless (my $proxy = $req->proxy) && $req->via_proxy;
60 7 100       29 return undef if $proxy->protocol eq 'socks';
61              
62             # WebSocket and/or HTTPS
63 5         17 my $url = $req->url;
64 5 100 100     18 return undef unless $req->is_handshake || $url->protocol eq 'https';
65              
66             # CONNECT request (expect a bad response)
67 3         26 my $new = $self->tx(CONNECT => $url->clone->userinfo(undef));
68 3         27 $new->req->proxy($proxy);
69 3         21 $new->res->content->auto_relax(0)->headers->connection('keep-alive');
70              
71 3         29 return $new;
72             }
73              
74             sub redirect {
75 905     905 1 2201 my ($self, $old) = @_;
76              
77             # Commonly used codes
78 905         2940 my $res = $old->res;
79 905   100     2279 my $code = $res->code // 0;
80 905 100       2037 return undef unless grep { $_ == $code } 301, 302, 303, 307, 308;
  4525         13351  
81              
82             # CONNECT requests cannot be redirected
83 54         231 my $req = $old->req;
84 54 100       179 return undef if uc $req->method eq 'CONNECT';
85              
86             # Fix location without authority and/or scheme
87 53 50       176 return undef unless my $location = $res->headers->every_header('Location')->[0];
88 53         684 $location = Mojo::URL->new($location);
89 53 100       223 $location = $location->base($req->url)->to_abs unless $location->is_abs;
90 53         244 my $proto = $location->protocol;
91 53 100 100     333 return undef if ($proto ne 'http' && $proto ne 'https') || !$location->host;
      100        
92              
93             # Clone request if necessary
94 51         187 my $new = Mojo::Transaction::HTTP->new;
95 51 100 100     364 if ($code == 307 || $code == 308) {
96 10 100       51 return undef unless my $clone = $req->clone;
97 8         34 $new->req($clone);
98             }
99             else {
100 41         140 my $method = uc $req->method;
101 41 100 100     254 $method = $code == 303 || $method eq 'POST' ? 'GET' : $method;
102 41         127 $new->req->method($method)->content->headers(my $headers = $req->headers->clone);
103 41         110 $headers->remove($_) for grep {/^content-/i} @{$headers->names};
  147         478  
  41         146  
104             }
105              
106 49 100       211 $new->res->content->auto_decompress(0) unless $self->compressed;
107 49         172 my $headers = $new->req->url($location)->headers;
108 49         269 $headers->remove($_) for qw(Authorization Cookie Host Referer);
109              
110 49         222 return $new->previous($old);
111             }
112              
113             sub tx {
114 1030     1030 1 169477 my ($self, $method, $url) = (shift, shift, shift);
115              
116             # Method and URL
117 1030         5057 my $tx = Mojo::Transaction::HTTP->new;
118 1030         3784 my $req = $tx->req->method($method);
119 1030 100       4579 ref $url ? $req->url($url) : $req->url->parse($url =~ m!^/|://! ? $url : "http://$url");
    100          
120              
121             # Headers (we identify ourselves and accept gzip compression)
122 1030         4055 my $headers = $req->headers;
123 1030 100       4620 $headers->from_hash(shift) if ref $_[0] eq 'HASH';
124 1030 100       3537 $headers->user_agent($self->name) unless $headers->user_agent;
125 1030 100       3916 if (!$self->compressed) { $tx->res->content->auto_decompress(0) }
  3 50       24  
126 1027         3030 elsif (!$headers->accept_encoding) { $headers->accept_encoding('gzip') }
127              
128             # Generator
129 1030 100       4329 if (@_ > 1) {
    100          
130 83         346 my $cb = $self->generators->{shift()};
131 83         312 $self->$cb($tx, @_);
132             }
133              
134             # Body
135 25         160 elsif (@_) { $req->body(shift) }
136              
137 1030         4874 return $tx;
138             }
139              
140             sub upgrade {
141 944     944 1 2409 my ($self, $tx) = @_;
142 944   100     2398 my $code = $tx->res->code // 0;
143 944 100 100     3136 return undef unless $tx->req->is_handshake && $code == 101;
144 63         335 my $ws = Mojo::Transaction::WebSocket->new(handshake => $tx, masked => 1);
145 63 50       288 return challenge($ws) ? $ws->established(1) : undef;
146             }
147              
148             sub websocket {
149 80     80 1 23550 my $self = shift;
150              
151             # New WebSocket transaction
152 80 100       307 my $sub = ref $_[-1] eq 'ARRAY' ? pop : [];
153 80         281 my $tx = $self->tx(GET => @_);
154 80         256 my $req = $tx->req;
155 80 100       317 $req->headers->sec_websocket_protocol(join ', ', @$sub) if @$sub;
156              
157             # Handshake protocol
158 80         253 my $url = $req->url;
159 80   50     316 my $proto = $url->protocol // '';
160 80 100       500 if ($proto eq 'ws') { $url->scheme('http') }
  7 100       24  
    100          
161 5         23 elsif ($proto eq 'wss') { $url->scheme('https') }
162 1         5 elsif ($proto eq 'ws+unix') { $url->scheme('http+unix') }
163              
164 80         365 return client_handshake $tx;
165             }
166              
167 31     31   226 sub _content { Mojo::Content::MultiPart->new(headers => $_[0], parts => $_[1]) }
168              
169             sub _form {
170 66     66   244 my ($self, $tx, $form, %options) = @_;
171 66 100       285 $options{charset} = 'UTF-8' unless exists $options{charset};
172              
173             # Check for uploads and force multipart if necessary
174 66         199 my $req = $tx->req;
175 66         234 my $headers = $req->headers;
176 66   100     249 my $multipart = ($headers->content_type // '') =~ m!multipart/form-data!i;
177 66 100       326 for my $value (map { ref $_ eq 'ARRAY' ? @$_ : $_ } values %$form) {
  104         441  
178 106 100 50     364 ++$multipart and last if ref $value eq 'HASH';
179             }
180              
181             # Multipart
182 66 100       196 if ($multipart) {
183 27         112 $req->content(_content($headers, _form_parts($options{charset}, $form)));
184 27         92 _type($headers, 'multipart/form-data');
185 27         97 return $tx;
186             }
187              
188             # Query parameters or urlencoded
189 39         134 my $method = uc $req->method;
190 39         163 my @form = map { $_ => $form->{$_} } sort keys %$form;
  63         198  
191 39 100 100     280 if ($method eq 'GET' || $method eq 'HEAD') { $req->url->query->merge(@form) }
  7         40  
192             else {
193 32         187 $req->body(Mojo::Parameters->new(@form)->charset($options{charset})->to_string);
194 32         364 _type($headers, 'application/x-www-form-urlencoded');
195             }
196              
197 39         165 return $tx;
198             }
199              
200             sub _form_parts {
201 27     27   75 my ($charset, $form) = @_;
202              
203 27         52 my @parts;
204 27         119 for my $name (sort keys %$form) {
205 41 100       157 next unless defined(my $values = $form->{$name});
206 40 100       146 $values = [$values] unless ref $values eq 'ARRAY';
207 40         87 push @parts, @{_parts($charset, $name, $values)};
  40         121  
208             }
209              
210 27         131 return \@parts;
211             }
212              
213             sub _json {
214 11     11   42 my ($self, $tx, $data) = @_;
215 11         47 _type($tx->req->body(encode_json $data)->headers, 'application/json');
216 11         29 return $tx;
217             }
218              
219             sub _multipart {
220 4     4   10 my ($self, $tx, $parts) = @_;
221 4         14 my $req = $tx->req;
222 4         10 $req->content(_content($req->headers, _parts(undef, undef, $parts)));
223 4         31 return $tx;
224             }
225              
226             sub _parts {
227 44     44   119 my ($charset, $name, $values) = @_;
228              
229 44         72 my @parts;
230 44         97 for my $value (@$values) {
231 55         205 push @parts, my $part = Mojo::Content::Single->new;
232              
233 55         103 my $filename;
234 55         190 my $headers = $part->headers;
235 55 100       226 if (ref $value eq 'HASH') {
236              
237             # File
238 30 100       143 if (my $file = delete $value->{file}) {
    50          
239 9 100       54 $file = Mojo::Asset::File->new(path => $file) unless ref $file;
240 9         35 $part->asset($file);
241 9 100 66     121 $value->{filename} //= path($file->path)->basename if $file->isa('Mojo::Asset::File');
242             }
243              
244             # Memory
245             elsif (defined(my $content = delete $value->{content})) {
246 21         98 $part->asset(Mojo::Asset::Memory->new->add_chunk($content));
247             }
248              
249             # Filename and headers
250 30         98 $filename = delete $value->{filename};
251 30         123 $headers->from_hash($value);
252 30 100       85 next unless defined $name;
253 26   66     154 $filename = url_escape $filename // $name, '"';
254 26 50       167 $filename = encode $charset, $filename if $charset;
255             }
256              
257             # Field
258             else {
259 25 100       98 $value = encode $charset, $value if $charset;
260 25         120 $part->asset(Mojo::Asset::Memory->new->add_chunk($value));
261             }
262              
263             # Content-Disposition
264 51 100 100     492 next if !defined $name || defined $headers->content_disposition;
265 48         160 $name = url_escape $name, '"';
266 48 100       235 $name = encode $charset, $name if $charset;
267 48         162 my $disposition = qq{form-data; name="$name"};
268 48 100       153 $disposition .= qq{; filename="$filename"} if defined $filename;
269 48         128 $headers->content_disposition($disposition);
270             }
271              
272 44         201 return \@parts;
273             }
274              
275             sub _proxy {
276 2055     2055   6074 my ($tx, $proto, $host, $port) = @_;
277              
278 2055         5133 my $req = $tx->req;
279 2055 100 100     5823 if ($req->via_proxy && (my $proxy = $req->proxy)) {
280 51 100 66     136 return $proxy->protocol, $proxy->ihost, $proxy->port // ($proto eq 'https' ? 443 : 80);
281             }
282              
283 2004         12108 return $proto, $host, $port;
284             }
285              
286 70 100   70   303 sub _type { $_[0]->content_type($_[1]) unless $_[0]->content_type }
287              
288             1;
289              
290             =encoding utf8
291              
292             =head1 NAME
293              
294             Mojo::UserAgent::Transactor - User agent transactor
295              
296             =head1 SYNOPSIS
297              
298             use Mojo::UserAgent::Transactor;
299              
300             # GET request with Accept header
301             my $t = Mojo::UserAgent::Transactor->new;
302             say $t->tx(GET => 'http://example.com' => {Accept => '*/*'})->req->to_string;
303              
304             # POST request with form-data
305             say $t->tx(POST => 'example.com' => form => {a => 'b'})->req->to_string;
306              
307             # PUT request with JSON data
308             say $t->tx(PUT => 'example.com' => json => {a => 'b'})->req->to_string;
309              
310             =head1 DESCRIPTION
311              
312             L is the transaction building and manipulation framework used by L.
313              
314             =head1 GENERATORS
315              
316             These content generators are available by default.
317              
318             =head2 form
319              
320             $t->tx(POST => 'http://example.com' => form => {a => 'b'});
321              
322             Generate query string, C or C content. See L for more.
323              
324             =head2 json
325              
326             $t->tx(PATCH => 'http://example.com' => json => {a => 'b'});
327              
328             Generate JSON content with L. See L for more.
329              
330             =head2 multipart
331              
332             $t->tx(PUT => 'http://example.com' => multipart => ['Hello', 'World!']);
333              
334             Generate multipart content. See L for more.
335              
336             =head1 ATTRIBUTES
337              
338             L implements the following attributes.
339              
340             =head2 compressed
341              
342             my $bool = $t->compressed;
343             $t = $t->compressed($bool);
344              
345             Try to negotiate compression for the response content and decompress it automatically, defaults to the value of the
346             C environment variable or true.
347              
348             =head2 generators
349              
350             my $generators = $t->generators;
351             $t = $t->generators({foo => sub {...}});
352              
353             Registered content generators, by default only C
, C and C are already defined.
354              
355             =head2 name
356              
357             my $name = $t->name;
358             $t = $t->name('Mojolicious');
359              
360             Value for C request header of generated transactions, defaults to C.
361              
362             =head1 METHODS
363              
364             L inherits all methods from L and implements the following new ones.
365              
366             =head2 add_generator
367              
368             $t = $t->add_generator(foo => sub {...});
369              
370             Register a content generator.
371              
372             $t->add_generator(foo => sub ($t, $tx, @args) {...});
373              
374             =head2 endpoint
375              
376             my ($proto, $host, $port) = $t->endpoint(Mojo::Transaction::HTTP->new);
377              
378             Actual endpoint for transaction.
379              
380             =head2 peer
381              
382             my ($proto, $host, $port) = $t->peer(Mojo::Transaction::HTTP->new);
383              
384             Actual peer for transaction.
385              
386             =head2 promisify
387              
388             $t->promisify(Mojo::Promise->new, Mojo::Transaction::HTTP->new);
389              
390             Resolve or reject L object with L object.
391              
392             =head2 proxy_connect
393              
394             my $tx = $t->proxy_connect(Mojo::Transaction::HTTP->new);
395              
396             Build L proxy C request for transaction if possible.
397              
398             =head2 redirect
399              
400             my $tx = $t->redirect(Mojo::Transaction::HTTP->new);
401              
402             Build L follow-up request for C<301>, C<302>, C<303>, C<307> or C<308> redirect response if
403             possible.
404              
405             =head2 tx
406              
407             my $tx = $t->tx(GET => 'example.com');
408             my $tx = $t->tx(POST => 'http://example.com');
409             my $tx = $t->tx(GET => 'http://example.com' => {Accept => '*/*'});
410             my $tx = $t->tx(PUT => 'http://example.com' => 'Content!');
411             my $tx = $t->tx(PUT => 'http://example.com' => form => {a => 'b'});
412             my $tx = $t->tx(PUT => 'http://example.com' => json => {a => 'b'});
413             my $tx = $t->tx(PUT => 'https://example.com' => multipart => ['a', 'b']);
414             my $tx = $t->tx(POST => 'example.com' => {Accept => '*/*'} => 'Content!');
415             my $tx = $t->tx(PUT => 'example.com' => {Accept => '*/*'} => form => {a => 'b'});
416             my $tx = $t->tx(PUT => 'example.com' => {Accept => '*/*'} => json => {a => 'b'});
417             my $tx = $t->tx(PUT => 'example.com' => {Accept => '*/*'} => multipart => ['a', 'b']);
418              
419             Versatile general purpose L transaction builder for requests, with support for
420             L.
421              
422             # Generate and inspect custom GET request with DNT header and content
423             say $t->tx(GET => 'example.com' => {DNT => 1} => 'Bye!')->req->to_string;
424              
425             # Stream response content to STDOUT
426             my $tx = $t->tx(GET => 'http://example.com');
427             $tx->res->content->unsubscribe('read')->on(read => sub { say $_[1] });
428              
429             # PUT request with content streamed from file
430             my $tx = $t->tx(PUT => 'http://example.com');
431             $tx->req->content->asset(Mojo::Asset::File->new(path => '/foo.txt'));
432              
433             The C content generator uses L for encoding and sets the content type to C.
434              
435             # POST request with "application/json" content
436             my $tx = $t->tx(POST => 'http://example.com' => json => {a => 'b', c => [1, 2, 3]});
437              
438             The C content generator will automatically use query parameters for C and C requests.
439              
440             # GET request with query parameters
441             my $tx = $t->tx(GET => 'http://example.com' => form => {a => 'b'});
442              
443             For all other request methods the C content type is used.
444              
445             # POST request with "application/x-www-form-urlencoded" content
446             my $tx = $t->tx(POST => 'http://example.com' => form => {a => 'b', c => 'd'});
447              
448             Parameters may be encoded with the C option.
449              
450             # PUT request with Shift_JIS encoded form values
451             my $tx = $t->tx(PUT => 'example.com' => form => {a => 'b'} => charset => 'Shift_JIS');
452              
453             An array reference can be used for multiple form values sharing the same name.
454              
455             # POST request with form values sharing the same name
456             my $tx = $t->tx(POST => 'http://example.com' => form => {a => ['b', 'c', 'd']});
457              
458             A hash reference with a C or C value can be used to switch to the C content type
459             for file uploads.
460              
461             # POST request with "multipart/form-data" content
462             my $tx = $t->tx(POST => 'http://example.com' => form => {mytext => {content => 'lala'}});
463              
464             # POST request with multiple files sharing the same name
465             my $tx = $t->tx(POST => 'http://example.com' => form => {mytext => [{content => 'first'}, {content => 'second'}]});
466              
467             The C value should contain the path to the file you want to upload or an asset object, like L
468             or L.
469              
470             # POST request with upload streamed from file
471             my $tx = $t->tx(POST => 'http://example.com' => form => {mytext => {file => '/foo.txt'}});
472              
473             # POST request with upload streamed from asset
474             my $asset = Mojo::Asset::Memory->new->add_chunk('lalala');
475             my $tx = $t->tx(POST => 'http://example.com' => form => {mytext => {file => $asset}});
476              
477             A C value will be generated automatically, but can also be set manually if necessary. All remaining values in
478             the hash reference get merged into the C content as headers.
479              
480             # POST request with form values and customized upload (filename and header)
481             my $tx = $t->tx(POST => 'http://example.com' => form => {
482             a => 'b',
483             c => 'd',
484             mytext => {
485             content => 'lalala',
486             filename => 'foo.txt',
487             'Content-Type' => 'text/plain'
488             }
489             });
490              
491             The C content type can also be enforced by setting the C header manually.
492              
493             # Force "multipart/form-data"
494             my $headers = {'Content-Type' => 'multipart/form-data'};
495             my $tx = $t->tx(POST => 'example.com' => $headers => form => {a => 'b'});
496              
497             The C content generator can be used to build custom multipart requests and does not set a content type.
498              
499             # POST request with multipart content ("foo" and "bar")
500             my $tx = $t->tx(POST => 'http://example.com' => multipart => ['foo', 'bar']);
501              
502             Similar to the C content generator you can also pass hash references with C or C values, as well
503             as headers.
504              
505             # POST request with multipart content streamed from file
506             my $tx = $t->tx(POST => 'http://example.com' => multipart => [{file => '/foo.txt'}]);
507              
508             # PUT request with multipart content streamed from asset
509             my $headers = {'Content-Type' => 'multipart/custom'};
510             my $asset = Mojo::Asset::Memory->new->add_chunk('lalala');
511             my $tx = $t->tx(PUT => 'http://example.com' => $headers => multipart => [{file => $asset}]);
512              
513             # POST request with multipart content and custom headers
514             my $tx = $t->tx(POST => 'http://example.com' => multipart => [
515             {
516             content => 'Hello',
517             'Content-Type' => 'text/plain',
518             'Content-Language' => 'en-US'
519             },
520             {
521             content => 'World!',
522             'Content-Type' => 'text/plain',
523             'Content-Language' => 'en-US'
524             }
525             ]);
526              
527             =head2 upgrade
528              
529             my $tx = $t->upgrade(Mojo::Transaction::HTTP->new);
530              
531             Build L follow-up transaction for WebSocket handshake if possible.
532              
533             =head2 websocket
534              
535             my $tx = $t->websocket('ws://example.com');
536             my $tx = $t->websocket('ws://example.com' => {DNT => 1} => ['v1.proto']);
537              
538             Versatile L transaction builder for WebSocket handshake requests.
539              
540             =head1 SEE ALSO
541              
542             L, L, L.
543              
544             =cut