File Coverage

blib/lib/HTTP/Request/CurlParameters.pm
Criterion Covered Total %
statement 234 406 57.6
branch 69 176 39.2
condition 25 56 44.6
subroutine 26 32 81.2
pod 5 8 62.5
total 359 678 52.9


line stmt bran cond sub pod time code
1             package HTTP::Request::CurlParameters;
2 18     18   70401 use strict;
  18         54  
  18         556  
3 18     18   119 use warnings;
  18         55  
  18         435  
4 18     18   988 use HTTP::Request;
  18         45558  
  18         359  
5 18     18   1095 use HTTP::Request::Common;
  18         4852  
  18         1014  
6 18     18   111 use URI;
  18         39  
  18         412  
7 18     18   96 use File::Spec::Unix;
  18         67  
  18         522  
8 18     18   99 use List::Util 'pairmap';
  18         32  
  18         1932  
9 18     18   7699 use PerlX::Maybe;
  18         41560  
  18         82  
10 18     18   722 use Carp 'croak';
  18         42  
  18         1219  
11              
12 18     18   9918 use Moo 2;
  18         221668  
  18         106  
13 18     18   35335 use Filter::signatures;
  18         417022  
  18         114  
14 18     18   679 use feature 'signatures';
  18         220  
  18         623  
15 18     18   109 no warnings 'experimental::signatures';
  18         118  
  18         99445  
16              
17             our $VERSION = '0.50';
18              
19             =head1 NAME
20              
21             HTTP::Request::CurlParameters - container for a Curl-like HTTP request
22              
23             =head1 SYNOPSIS
24              
25             my $ua = LWP::UserAgent->new;
26             my $params = HTTP::Request::CurlParameters->new(argv => \@ARGV);
27             my $response = $ua->request($params->as_request);
28              
29             =head1 DESCRIPTION
30              
31             Objects of this class are mostly created from L. Most
32             likely you want to use that module instead:
33              
34             my $ua = LWP::UserAgent->new;
35             my $params = HTTP::Request::FromCurl->new(command_curl => $cmd);
36             my $response = $ua->request($params->as_request);
37              
38             =head1 METHODS
39              
40             =head2 C<< ->new >>
41              
42             Options:
43              
44             =over 4
45              
46             =item *
47              
48             C
49              
50             method => 'GET'
51              
52             The HTTP method to use.
53              
54             =cut
55              
56             has method => (
57             is => 'ro',
58             default => 'GET',
59             );
60              
61             =item *
62              
63             C
64              
65             uri => 'https://example.com'
66              
67             The URI of the request.
68              
69             =cut
70              
71             has uri => (
72             is => 'ro',
73             default => 'https://example.com',
74             );
75              
76             =item *
77              
78             C
79              
80             headers => {
81             'Content-Type' => 'text/json',
82             'X-Secret' => ['value-1', 'value-2'],
83             }
84              
85             The headers of the request. Multiple headers with the same
86             name can be passed as an arrayref to the header key.
87              
88             =cut
89              
90             has headers => (
91             is => 'ro',
92             default => sub { {} },
93             );
94              
95             =item *
96              
97             C
98              
99             The cookie jar to use.
100              
101             =cut
102              
103             has cookie_jar => (
104             is => 'ro',
105             );
106              
107             =item *
108              
109             C
110              
111             Options for the constructor of the cookie jar.
112              
113             =cut
114              
115             has cookie_jar_options => (
116             is => 'ro',
117             default => sub { {} },
118             );
119              
120             =item *
121              
122             C
123              
124             credentials => 'hunter2:secret'
125              
126             The credentials to use for basic authentication.
127              
128             =cut
129              
130             has credentials => (
131             is => 'ro',
132             );
133              
134             =item *
135              
136             C
137              
138             auth => 'basic'
139              
140             The authentication method to use.
141              
142             =cut
143              
144             has auth => (
145             is => 'ro',
146             );
147              
148             =item *
149              
150             C
151              
152             post_data => ['A string','across multiple','scalars']
153              
154             The POST body to use.
155              
156             =cut
157              
158             has post_data => (
159             is => 'ro',
160             default => sub { [] },
161             );
162              
163             =item *
164              
165             C
166              
167             body => '{"greeting":"Hello"}'
168              
169             The body of the request.
170              
171             =cut
172              
173             has body => (
174             is => 'ro',
175             );
176              
177             =item *
178              
179             C
180              
181             timeout => 50
182              
183             The timeout for the request
184              
185             =cut
186              
187             has timeout => (
188             is => 'ro',
189             );
190              
191             =item *
192              
193             C
194              
195             unix_socket => '/var/run/docker/docker.sock'
196              
197             The timeout for the request
198              
199             =cut
200              
201             has unix_socket => (
202             is => 'ro',
203             );
204              
205             =item *
206              
207             C
208              
209             local_address => '192.0.2.116'
210              
211             The local network address to bind to when making the request
212              
213             =cut
214              
215             has local_address => (
216             is => 'ro',
217             );
218              
219             =item *
220              
221             C
222              
223             The HTML form parameters. These get converted into
224             a body.
225              
226             =cut
227              
228             has form_args => (
229             is => 'ro',
230             default => sub { [] },
231             );
232              
233             =item *
234              
235             C
236              
237             insecure => 1
238              
239             Disable SSL certificate verification
240              
241             =cut
242              
243             has insecure => (
244             is => 'ro',
245             );
246              
247             =item *
248              
249             C
250              
251             cert => '/path/to/certificate',
252              
253             Use the certificate file for SSL
254              
255             =cut
256              
257             has cert => (
258             is => 'ro',
259             );
260              
261             =item *
262              
263             C
264              
265             capath => '/path/to/cadir/',
266              
267             Use the certificate directory for SSL
268              
269             =cut
270              
271             has capath => (
272             is => 'ro',
273             );
274              
275             =item *
276              
277             C
278              
279             Name of the output file
280              
281             =cut
282              
283             has output => (
284             is => 'ro',
285             );
286              
287             =item *
288              
289             C
290              
291             show_error => 0
292              
293             Show error message on HTTP errors
294              
295             =cut
296              
297             has show_error => (
298             is => 'ro',
299             );
300              
301             =item *
302              
303             C
304              
305             fail => 1
306              
307             Let the Perl code C on error
308              
309             =back
310              
311             =cut
312              
313             has fail => (
314             is => 'ro',
315             );
316              
317 52     52   171 sub _build_quoted_body( $self, $body=$self->body ) {
  52         129  
  52         254  
  52         118  
318 52 100       206 if( defined $body ) {
319 8         123 $body =~ s!([\x00-\x1f'"\$\@\%\\])!sprintf '\\x%02x', ord $1!ge;
  4         232  
320 8         87 return sprintf qq{"%s"}, $body
321              
322             } else {
323             # Sluuuurp
324             my @post_data = map {
325 0 0       0 /^\@(.*)/ ? do {
326 0 0       0 open my $fh, '<', $1
327             or die "$1: $!";
328 0         0 local $/; # / for Filter::Simple
329 0         0 binmode $fh;
330             <$fh>
331 0         0 }
332             : $_
333 44         109 } @{ $self->post_data };
  44         228  
334 44         365 return join "", @post_data;
335             }
336             };
337              
338             =head2 C<< ->as_request >>
339              
340             $ua->request( $r->as_request );
341              
342             Returns an equivalent L object
343              
344             =cut
345              
346 73     73   243 sub _explode_headers( $self ) {
  73         170  
  73         146  
347             my @res =
348 387         677 map { my $h = $_;
349 387         1422 my $v = $self->headers->{$h};
350 387 100       1889 ref $v ? (map { $h => $_ } @$v)
  2         17  
351             : ($h => $v)
352 73         210 } keys %{ $self->headers };
  73         606  
353             }
354              
355             =head2 C<< $r->as_request >>
356              
357             my $r = $curl->as_request;
358              
359             Returns a L object that represents
360             the Curl options.
361              
362             =cut
363              
364 20     20 1 488468 sub as_request( $self ) {
  20         115  
  20         68  
365 20         249 HTTP::Request->new(
366             $self->method => $self->uri,
367             [ $self->_explode_headers() ],
368             $self->body(),
369             )
370             };
371              
372 0     0   0 sub _fill_snippet( $self, $snippet ) {
  0         0  
  0         0  
  0         0  
373             # Doesn't parse parameters, yet
374 0         0 $snippet =~ s!\$self->(\w+)!$self->$1!ge;
  0         0  
375 0         0 $snippet
376             }
377              
378 27     27   66 sub _init_cookie_jar_lwp( $self ) {
  27         64  
  27         53  
379 27 50       156 if( my $fn = $self->cookie_jar ) {
380 0 0       0 my $save = $self->cookie_jar_options->{'write'} ? 1 : 0;
381             return {
382 0         0 preamble => [
383             "use Path::Tiny;",
384             "use HTTP::Cookies;",
385             ],
386             code => \"HTTP::Cookies->new(\n file => path('$fn'),\n autosave => $save,\n)",
387             postamble => [
388             #"path('$fn')->spew(\$ua->cookie_jar->dump_cookies())",
389             ],
390             };
391             }
392             }
393              
394 25     25   87 sub _init_cookie_jar_tiny( $self ) {
  25         73  
  25         71  
395 25 50       2458 if( my $fn = $self->cookie_jar ) {
396 0         0 my $save = $self->cookie_jar_options->{'write'};
397             return {
398 0 0       0 preamble => [
399             "use Path::Tiny;",
400             "use HTTP::CookieJar;",
401             ],
402             code => \"HTTP::CookieJar->new->load_cookies(path('$fn')->lines),",
403             postamble => [
404             $save ?
405             ("path('$fn')->spew(\$ua->cookie_jar->dump_cookies())")
406             : (),
407             ],
408             };
409             }
410             }
411              
412 0     0   0 sub _init_cookie_jar_mojolicious( $self ) {
  0         0  
  0         0  
413 0 0       0 if( my $fn = $self->cookie_jar ) {
414 0         0 my $save = $self->cookie_jar_options->{'write'};
415             return {
416 0         0 preamble => [
417             # "use Path::Tiny;",
418             "use Mojo::UserAgent::CookieJar;",
419             ],
420             code => \"Mojo::UserAgent::CookieJar->new,",
421             postamble => [
422             #$save ?
423             # ("path('$fn')->spew(\$ua->cookie_jar->dump_cookies())")
424             # : (),
425             ],
426             };
427             }
428             }
429              
430 176     176   5776 sub _pairlist( $self, $l, $prefix = " " ) {
  176         366  
  176         420  
  176         1314  
  176         337  
431             return join ",\n",
432             pairmap { my $v = ! ref $b ? qq{'$b'}
433             : ref $b eq 'SCALAR' ? $$b
434 0         0 : ref $b eq 'ARRAY' ? '[' . join( ", ", map {qq{'$_'}} @$b ) . ']'
435 335 50   335   1355 : ref $b eq 'HASH' ? '{' . $self->_pairlist([ map { $_ => $b->{$_} } sort keys %$b ]) . '}'
  60 50       288  
    100          
    100          
436             : die "Unknown type of $b";
437 335         2355 qq{$prefix'$a' => $v}
438 176         4063 } @$l
439             }
440              
441 27     27   83 sub _build_lwp_headers( $self, $prefix = " ", %options ) {
  27         60  
  27         78  
  27         118  
  27         71  
442             # This is so we create the standard header order in our output
443 27         111 my @h = $self->_explode_headers;
444 27         276 my $h = HTTP::Headers->new( @h );
445 27         5024 $h->remove_header( @{$options{implicit_headers}} );
  27         247  
446              
447             # also skip the Host: header if it derives from $uri
448 27         548 my $val = $h->header('Host');
449 27 100 66     1663 if( $val and ($val eq $self->uri->host_port
      66        
450             or $val eq $self->uri->host )) {
451             # trivial host header
452 20         878 $h->remove_header('Host');
453             };
454              
455 27         997 $self->_pairlist([ $h->flatten ], $prefix);
456             }
457              
458 25     25   86 sub _build_tiny_headers( $self, $prefix = " ", %options ) {
  25         55  
  25         147  
  25         105  
  25         61  
459 25         176 my @h = $self->_explode_headers;
460 25         385 my $h = HTTP::Headers->new( @h );
461 25         5477 $h->remove_header( @{$options{implicit_headers}} );
  25         209  
462              
463             # HTTP::Tiny does not like overriding the Host: header :-/
464 25         829 $h->remove_header('Host');
465              
466 25         756 @h = $h->flatten;
467 25         5545 my %h;
468             my @order;
469 25         144 while( @h ) {
470 106         318 my ($k,$v) = splice(@h,0,2);
471 106 50       300 if( ! exists $h{ $k }) {
    0          
472             # Fresh value
473 106         269 $h{ $k } = $v;
474 106         331 push @order, $k;
475             } elsif( ! ref $h{$k}) {
476             # Second value
477 0         0 $h{ $k } = [$h{$k}, $v];
478             } else {
479             # Multiple values
480 0         0 push @{$h{ $k }}, $v;
  0         0  
481             }
482             };
483              
484 25         144 $self->_pairlist([ map { $_ => $h{ $_ } } @order ], $prefix);
  106         343  
485             }
486              
487 0     0   0 sub _build_mojolicious_headers( $self, $prefix = " ", %options ) {
  0         0  
  0         0  
  0         0  
  0         0  
488             # This is so we create the standard header order in our output
489 0         0 my @h = $self->_explode_headers;
490 0         0 my $h = HTTP::Headers->new( @h );
491 0         0 $h->remove_header( @{$options{implicit_headers}} );
  0         0  
492              
493             # also skip the Host: header if it derives from $uri
494 0         0 my $val = $h->header('Host');
495 0 0 0     0 if( $val and ($val eq $self->uri->host_port
      0        
496             or $val eq $self->uri->host )) {
497             # trivial host header
498 0         0 $h->remove_header('Host');
499             };
500              
501 0         0 @h = $h->flatten;
502 0         0 my %h;
503             my @order;
504 0         0 while( @h ) {
505 0         0 my ($k,$v) = splice(@h,0,2);
506 0 0       0 if( ! exists $h{ $k }) {
    0          
507             # Fresh value
508 0         0 $h{ $k } = $v;
509 0         0 push @order, $k;
510             } elsif( ! ref $h{$k}) {
511             # Second value
512 0         0 $h{ $k } = [$h{$k}, $v];
513             } else {
514             # Multiple values
515 0         0 push @{$h{ $k }}, $v;
  0         0  
516             }
517             };
518              
519 0         0 $self->_pairlist([ map { $_ => $h{ $_ } } @order ], $prefix);
  0         0  
520             }
521              
522             =head2 C<< $r->as_snippet( %options ) >>
523              
524             print $r->as_snippet( type => 'LWP' );
525              
526             Returns a code snippet that returns code to create an equivalent
527             L object and to perform the request using L.
528              
529             This is mostly intended as a convenience function for creating Perl demo
530             snippets from C examples.
531              
532             =head3 Options
533              
534             =over 4
535              
536             =item B
537              
538             Arrayref of headers that will not be output.
539              
540             Convenient values are ['Content-Length']
541              
542             =item B
543              
544             type => 'Tiny',
545              
546             Type of snippet. Valid values are C for L,
547             C for L
548             and C for L.
549              
550             =back
551              
552             =cut
553              
554 52     52 1 4357078 sub as_snippet( $self, %options ) {
  52         257  
  52         687  
  52         160  
555 52   100     390 my $type = delete $options{ type } || 'LWP';
556 52 100       387 if( 'LWP' eq $type ) {
    50          
    0          
557 27         274 $self->as_lwp_snippet( %options )
558             } elsif( 'Tiny' eq $type ) {
559 25         298 $self->as_http_tiny_snippet( %options )
560             } elsif( 'Mojolicious' eq $type ) {
561 0         0 $self->as_mojolicious_snippet( %options )
562             } else {
563 0         0 croak "Unknown type '$type'.";
564             }
565             }
566              
567 27     27 0 84 sub as_lwp_snippet( $self, %options ) {
  27         106  
  27         126  
  27         71  
568 27   50     515 $options{ prefix } ||= '';
569 27   100     381 $options{ implicit_headers } ||= [];
570              
571 27         149 my @preamble;
572             my @postamble;
573 27         0 my %ssl_options;
574 27 100       131 push @preamble, @{ $options{ preamble } } if $options{ preamble };
  25         151  
575 27 50       145 push @postamble, @{ $options{ postamble } } if $options{ postamble };
  0         0  
576 27         155 my @setup_ua = ('');
577              
578 27         354 my $request_args = join ", ",
579             '$r',
580             $self->_pairlist([
581             maybe ':content_file', $self->output
582             ], '')
583             ;
584 27         517 my $init_cookie_jar = $self->_init_cookie_jar_lwp();
585 27 50       143 if( my $p = $init_cookie_jar->{preamble}) {
586 0         0 push @preamble, @{$p}
  0         0  
587             };
588              
589 27 100       135 if( $self->insecure ) {
590 20         66 push @preamble, 'use IO::Socket::SSL;';
591 20         172 $ssl_options{ SSL_verify_mode } = \'IO::Socket::SSL::SSL_VERIFY_NONE';
592 20         122 $ssl_options{ SSL_hostname } = '';
593 20         93 $ssl_options{ verify_hostname } = '';
594             };
595              
596 27 50       136 if( $self->cert ) {
597 0         0 push @preamble, 'use IO::Socket::SSL;';
598 0         0 $ssl_options{ SSL_ca_file } = $self->cert;
599             };
600 27 50       130 if( $self->capath ) {
601 0         0 push @preamble, 'use IO::Socket::SSL;';
602 0         0 $ssl_options{ SSL_ca_path } = $self->capath;
603             };
604             my $constructor_args = join ",",
605             $self->_pairlist([
606             send_te => 0,
607             maybe local_address => $self->local_address,
608             maybe timeout => $self->timeout,
609             maybe cookie_jar => $init_cookie_jar->{code},
610 27 100       601 maybe SSL_options => keys %ssl_options ? \%ssl_options : undef,
611             ], '')
612             ;
613 27 50       320 if( defined( my $credentials = $self->credentials )) {
614 0         0 my( $user, $pass ) = split /:/, $credentials, 2;
615 0         0 my $setup_credentials = sprintf qq{\$ua->credentials("%s","%s");},
616             quotemeta $user,
617             quotemeta $pass;
618 0         0 push @setup_ua, $setup_credentials;
619             };
620 27 50       200 if( $self->show_error ) {
    50          
621 0         0 push @postamble,
622             ' die $res->message if $res->is_error;',
623             } elsif( $self->fail ) {
624 0         0 push @postamble,
625             ' exit 1 if !$res->{success};',
626             };
627              
628 27 50       125 @setup_ua = ()
629             if @setup_ua == 1;
630              
631 27         67 my $request_constructor;
632              
633 27 50 66     175 if( $self->method ne 'GET' and @{ $self->form_args }) {
  5         211  
634 0         0 push @preamble, 'use HTTP::Request::Common;';
635 0         0 $request_constructor = <
636 0         0 my \$r = HTTP::Request::Common::@{[$self->method]}(
637 0         0 '@{[$self->uri]}',
638             Content_Type => 'form-data',
639             Content => [
640 0         0 @{[$self->_pairlist($self->form_args, ' ')]}
641             ],
642 0         0 @{[$self->_build_lwp_headers(' ', %options)]}
643             );
644             SNIPPET
645             } else {
646 27         127 $request_constructor = <
647             my \$r = HTTP::Request->new(
648 27         357 '@{[$self->method]}' => '@{[$self->uri]}',
  27         297  
649             [
650 27         329 @{[$self->_build_lwp_headers(' ', %options)]}
651             ],
652 27         186 @{[$self->_build_quoted_body()]}
653             );
654             SNIPPET
655             }
656              
657 27         129 @preamble = map { "$options{prefix} $_\n" } @preamble;
  70         299  
658 27         87 @postamble = map { "$options{prefix} $_\n" } @postamble;
  0         0  
659 27         87 @setup_ua = map { "$options{prefix} $_\n" } @setup_ua;
  0         0  
660              
661 27         406 return <
662             @preamble
663             my \$ua = LWP::UserAgent->new($constructor_args);@setup_ua
664             $request_constructor
665             my \$res = \$ua->request( $request_args );
666             @postamble
667             SNIPPET
668             };
669              
670 25     25 0 110 sub as_http_tiny_snippet( $self, %options ) {
  25         99  
  25         118  
  25         56  
671 25   50     518 $options{ prefix } ||= '';
672 25   50     409 $options{ implicit_headers } ||= [];
673              
674 25         98 push @{ $options{ implicit_headers }}, 'Host'; # HTTP::Tiny dislikes that header
  25         186  
675              
676 25         126 my @preamble;
677             my @postamble;
678 25         0 my %ssl_options;
679 25 50       196 push @preamble, @{ $options{ preamble } } if $options{ preamble };
  25         148  
680 25 50       129 push @postamble, @{ $options{ postamble } } if $options{ postamble };
  0         0  
681 25         129 my @setup_ua = ('');
682              
683 25         459 my $request_args = join ", ",
684             '$r',
685             $self->_pairlist([
686             maybe ':content_file', $self->output
687             ], '')
688             ;
689 25         505 my $init_cookie_jar = $self->_init_cookie_jar_tiny();
690 25 50       124 if( my $p = $init_cookie_jar->{preamble}) {
691 0         0 push @preamble, @{$p}
  0         0  
692             };
693              
694 25         69 my @ssl;
695 25 100       175 if( $self->insecure ) {
696             } else {
697 5         41 push @ssl, verify_SSL => 1;
698             };
699 25 50       191 if( $self->cert ) {
700 0         0 push @preamble, 'use IO::Socket::SSL;';
701 0         0 $ssl_options{ SSL_ca_file } = $self->cert;
702             };
703 25 50       254 if( $self->show_error ) {
    50          
704 0         0 push @postamble,
705             ' die $res->{reason} if !$res->{success};',
706             } elsif( $self->fail ) {
707 0         0 push @postamble,
708             ' exit 1 if !$res->{success};',
709             };
710             my $constructor_args = join ",",
711             $self->_pairlist([
712             @ssl,
713             maybe timeout => $self->timeout,
714             maybe local_address => $self->local_address,
715             maybe cookie_jar => $init_cookie_jar->{code},
716 25 50       638 maybe SSL_options => keys %ssl_options ? \%ssl_options : undef,
717             ], '')
718             ;
719 25 50       437 if( defined( my $credentials = $self->credentials )) {
720 0         0 my( $user, $pass ) = split /:/, $credentials, 2;
721 0         0 my $setup_credentials = sprintf qq{\$ua->credentials("%s","%s");},
722             quotemeta $user,
723             quotemeta $pass;
724 0         0 push @setup_ua, $setup_credentials;
725             };
726              
727 25 50       191 @setup_ua = ()
728             if @setup_ua == 1;
729              
730 25         96 @preamble = map { "$options{prefix} $_\n" } @preamble;
  50         283  
731 25         103 @postamble = map { "$options{prefix} $_\n" } @postamble;
  0         0  
732 25         78 @setup_ua = map { "$options{prefix} $_\n" } @setup_ua;
  0         0  
733              
734 25         399 my @content = $self->_build_quoted_body();
735 25 100       85 if( grep {/\S/} @content ) {
  25 50       184  
736 3         44 unshift @content, 'content => ',
737 22         190 } elsif( @{ $self->form_args }) {
738 0         0 my $req = HTTP::Request::Common::POST(
739             'https://example.com',
740             Content_Type => 'form-data',
741             Content => $self->form_args,
742             );
743 0         0 @content = ('content => ', $self->_build_quoted_body( $req->content ));
744 0         0 $self->headers->{ 'Content-Type' } = join "; ", $req->headers->content_type;
745             }
746              
747 25         266 return <
748             @preamble
749             my \$ua = HTTP::Tiny->new($constructor_args);@setup_ua
750             my \$res = \$ua->request(
751 25         322 '@{[$self->method]}' => '@{[$self->uri]}',
  25         240  
752             {
753             headers => {
754 25         329 @{[$self->_build_tiny_headers(' ', %options)]}
755             },
756             @content
757             },
758             );
759             @postamble
760             SNIPPET
761             };
762              
763 0     0 0 0 sub as_mojolicious_snippet( $self, %options ) {
  0         0  
  0         0  
  0         0  
764 0   0     0 $options{ prefix } ||= '';
765 0   0     0 $options{ implicit_headers } ||= [];
766              
767 0         0 my @preamble;
768             my @postamble;
769 0         0 my %ssl_options;
770 0 0       0 push @preamble, @{ $options{ preamble } } if $options{ preamble };
  0         0  
771 0 0       0 push @postamble, @{ $options{ postamble } } if $options{ postamble };
  0         0  
772 0         0 my @setup_ua = ('');
773              
774 0         0 my $request_args = join ", ",
775             '$r',
776             $self->_pairlist([
777             maybe ':content_file', $self->output
778             ], '')
779             ;
780 0         0 my $init_cookie_jar = $self->_init_cookie_jar_mojolicious();
781 0 0       0 if( my $p = $init_cookie_jar->{preamble}) {
782 0         0 push @preamble, @{$p}
  0         0  
783             };
784              
785 0         0 my @ssl;
786 0 0       0 if( $self->insecure ) {
787 0         0 push @ssl, insecure => 1,
788             };
789 0 0       0 if( $self->cert ) {
790 0         0 push @ssl, cert => $self->cert,
791             };
792 0 0       0 if( $self->show_error ) {
    0          
793 0         0 push @postamble,
794             ' die $res->message if $res->is_error;',
795             } elsif( $self->fail ) {
796 0         0 push @postamble,
797             ' exit 1 if !$res->is_error;',
798             };
799 0         0 my $socket_options = {};
800 0 0       0 if( my $host = $self->local_address ) {
801 0         0 $socket_options->{ LocalAddr } = $host;
802             }
803             my $constructor_args = join ",",
804             $self->_pairlist([
805             @ssl,
806             keys %$socket_options ? $socket_options : (),
807             maybe request_timeout => $self->timeout,
808             maybe local_address => $self->local_address,
809             maybe cookie_jar => $init_cookie_jar->{code},
810 0 0       0 maybe SSL_options => keys %ssl_options ? \%ssl_options : undef,
    0          
811             ], '')
812             ;
813 0 0       0 if( defined( my $credentials = $self->credentials )) {
814 0         0 my( $user, $pass ) = split /:/, $credentials, 2;
815 0         0 my $setup_credentials = sprintf qq{\$ua->userinfo("%s","%s");},
816             quotemeta $user,
817             quotemeta $pass;
818 0         0 push @setup_ua, $setup_credentials;
819             };
820              
821 0 0       0 @setup_ua = ()
822             if @setup_ua == 1;
823              
824 0         0 @preamble = map { "$options{prefix} $_\n" } @preamble;
  0         0  
825 0         0 @postamble = map { "$options{prefix} $_\n" } @postamble;
  0         0  
826 0         0 @setup_ua = map { "$options{prefix} $_\n" } @setup_ua;
  0         0  
827              
828 0         0 my $content = $self->_build_quoted_body();
829 0 0       0 if( @{ $self->form_args }) {
  0         0  
830 0         0 my $req = HTTP::Request::Common::POST(
831             'https://example.com',
832             Content_Type => 'form-data',
833             Content => $self->form_args,
834             );
835 0   0     0 $content ||= $self->_build_quoted_body( $req->content );
836 0         0 $self->headers->{ 'Content-Type' } = join "; ", $req->headers->content_type;
837             }
838              
839 0         0 return <
840             @preamble
841             my \$ua = Mojo::UserAgent->new($constructor_args);@setup_ua
842             my \$tx = \$ua->build_tx(
843 0         0 '@{[$self->method]}' => '@{[$self->uri]}',
  0         0  
844             {
845 0         0 @{[$self->_build_mojolicious_headers(' ', %options)]}
846             },
847             $content
848             );
849             my \$res = \$ua->start(\$tx)->result;
850             @postamble
851             SNIPPET
852             };
853              
854             =head2 C<< $r->as_curl >>
855              
856             print $r->as_curl;
857              
858             Returns a curl command line representing the request
859              
860             This is convenient if you started out from something else or want a canonical
861             representation of a curl command line.
862              
863             =over 4
864              
865             =item B
866              
867             The curl command to be used. Default is C.
868              
869             =back
870              
871             =cut
872              
873             # These are what curl uses as defaults, not what Perl should use as default!
874             our %curl_header_defaults = (
875             'Accept' => '*/*',
876             #'Accept-Encoding' => 'deflate, gzip',
877             # For Perl, use HTTP::Message::decodable() instead of the above list
878             );
879              
880 0     0 1 0 sub as_curl($self,%options) {
  0         0  
  0         0  
  0         0  
881             $options{ curl } = 'curl'
882 0 0       0 if ! exists $options{ curl };
883             $options{ long_options } = 1
884 0 0       0 if ! exists $options{ long_options };
885              
886 0         0 my @request_commands;
887              
888 0 0       0 if( $self->method eq 'HEAD' ) {
    0          
889             push @request_commands,
890 0 0       0 $options{ long_options } ? '--head' : '-I';
891              
892             } elsif( $self->method ne 'GET' ) {
893             push @request_commands,
894 0 0       0 $options{ long_options } ? '--request' : '-X',
895             $self->method;
896             };
897              
898 0 0       0 if( scalar keys %{ $self->headers }) {
  0         0  
899 0         0 for my $h (sort keys %{$self->headers}) {
  0         0  
900 0         0 my $v = $self->headers->{$h};
901              
902 0         0 my $default;
903 0 0       0 if( exists $curl_header_defaults{ $h }) {
904 0         0 $default = $curl_header_defaults{ $h };
905             };
906              
907 0 0       0 if( ! ref $v ) {
908 0         0 $v = [$v];
909             };
910 0         0 for my $val (@$v) {
911 0 0 0     0 if( !defined $default or $val ne $default ) {
912              
913             # also skip the Host: header if it derives from $uri
914 0 0 0     0 if( $h eq 'Host' and ($val eq $self->uri->host_port
    0 0        
915             or $val eq $self->uri->host )) {
916             # trivial host header
917             } elsif( $h eq 'User-Agent' ) {
918             push @request_commands,
919 0 0       0 $options{ long_options } ? '--user-agent' : '-A',
920             $val;
921             } else {
922             push @request_commands,
923 0 0       0 $options{ long_options } ? '--header' : '-h',
924             "$h: $val";
925             };
926             };
927             };
928             };
929             };
930              
931 0 0       0 if( my $body = $self->body ) {
932             push @request_commands,
933 0 0       0 $options{ long_options } ? '--data-raw' : '--data-raw',
934             $body;
935             };
936              
937 0         0 push @request_commands, $self->uri;
938              
939             return
940             #(defined $options{ curl } ? $options{curl} : () ),
941 0         0 @request_commands;
942             }
943              
944             =head2 C<< $r->as_wget >>
945              
946             print $r->as_wget;
947              
948             Returns a curl command line representing the request
949              
950             This is convenient if you started out from something else or want a canonical
951             representation of a curl command line.
952              
953             =over 4
954              
955             =item B
956              
957             The curl command to be used. Default is C.
958              
959             =back
960              
961             =cut
962             # These are what wget uses as defaults, not what Perl should use as default!
963             our %wget_header_defaults = (
964             'Accept' => '*/*',
965             'Accept-Encoding' => 'identity',
966             'User-Agent' => 'Wget/1.21',
967             'Connection' => 'Keep-Alive',
968             );
969              
970 20     20 1 454 sub as_wget($self,%options) {
  20         123  
  20         204  
  20         57  
971             $options{ wget } = 'wget'
972 20 50       113 if ! exists $options{ wget };
973             $options{ long_options } = 1
974 20 50       191 if ! exists $options{ long_options };
975              
976 20         71 my @request_commands;
977              
978 20 100       186 if( $self->method ne 'GET' ) {
979 3 100 66     72 if( $self->method eq 'POST' and $self->body ) {
980             # This is implied by '--post-data', below
981             } else {
982 1         20 push @request_commands,
983             '--method' => $self->method;
984             };
985             };
986              
987 20 50       51 if( scalar keys %{ $self->headers }) {
  20         167  
988 20         62 my %h = %{ $self->headers };
  20         149  
989              
990             # "--no-cache" implies two headers, Cache-Control and Pragma
991             my $is_cache = exists $h{ 'Pragma' }
992             && exists $h{ 'Cache-Control' }
993             && $h{ 'Cache-Control' } =~ /^no-cache\b/
994 20   66     202 && $h{ 'Pragma' } eq 'no-cache'
995             ;
996 20 100       79 if( $is_cache ) {
997 1         3 delete $h{ 'Pragma' };
998 1         3 delete $h{ 'Cache-Control' };
999 1         3 push @request_commands, '--no-cache';
1000             };
1001              
1002 20         177 for my $name (sort keys %h) {
1003 120         953 my $v = $h{ $name };
1004              
1005 120         193 my $default;
1006 120 100       313 if( exists $wget_header_defaults{ $name }) {
1007 79         335 $default = $wget_header_defaults{ $name };
1008             };
1009              
1010 120 50       270 if( ! ref $v ) {
1011 120         266 $v = [$v];
1012             };
1013 120         288 for my $val (@$v) {
1014 120 100 100     587 if( !defined $default or $val ne $default ) {
1015             # also skip the Host: header if it derives from $uri
1016 62 100 66     463 if( $name eq 'Host' and ($val eq $self->uri->host_port
    100 100        
1017             or $val eq $self->uri->host )) {
1018             # trivial host header, ignore
1019             } elsif( $name eq 'User-Agent' ) {
1020 20         137 push @request_commands,
1021             '--user-agent',
1022             $val;
1023             } else {
1024 24         322 push @request_commands,
1025             '--header',
1026             "$name: $val";
1027             };
1028             };
1029             };
1030             };
1031             };
1032              
1033 20 100       170 if( my $body = $self->body ) {
1034 3 100       35 if( $self->method eq 'POST' ) {
1035 2         19 push @request_commands,
1036             '--post-data',
1037             $body;
1038             } else {
1039 1         12 push @request_commands,
1040             '--body-data',
1041             $body;
1042             };
1043             };
1044              
1045 20         82 push @request_commands, $self->uri;
1046              
1047             return
1048             #(defined $options{ curl } ? $options{curl} : () ),
1049 20         110 @request_commands;
1050             }
1051              
1052              
1053             =head2 C<< $r->clone >>
1054              
1055             Returns a shallow copy of the object
1056              
1057             =cut
1058              
1059 0     0 1   sub clone( $self, %options ) {
  0            
  0            
  0            
1060 0           (ref $self)->new( %$self, %options )
1061             }
1062              
1063             1;
1064              
1065             =head1 REPOSITORY
1066              
1067             The public repository of this module is
1068             L.
1069              
1070             =head1 SUPPORT
1071              
1072             The public support forum of this module is
1073             L.
1074              
1075             =head1 BUG TRACKER
1076              
1077             Please report bugs in this module via the Github bug queue at
1078             L
1079              
1080             =head1 AUTHOR
1081              
1082             Max Maischein C
1083              
1084             =head1 COPYRIGHT (c)
1085              
1086             Copyright 2018-2023 by Max Maischein C.
1087              
1088             =head1 LICENSE
1089              
1090             This module is released under the same terms as Perl itself.
1091              
1092             =cut