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   69501 use strict;
  18         50  
  18         562  
3 18     18   111 use warnings;
  18         46  
  18         489  
4 18     18   1002 use HTTP::Request;
  18         43850  
  18         356  
5 18     18   1105 use HTTP::Request::Common;
  18         4592  
  18         1273  
6 18     18   114 use URI;
  18         41  
  18         331  
7 18     18   110 use File::Spec::Unix;
  18         50  
  18         570  
8 18     18   104 use List::Util 'pairmap';
  18         39  
  18         2003  
9 18     18   8235 use PerlX::Maybe;
  18         42650  
  18         86  
10 18     18   764 use Carp 'croak';
  18         45  
  18         1219  
11              
12 18     18   9871 use Moo 2;
  18         221690  
  18         115  
13 18     18   35765 use Filter::signatures;
  18         414936  
  18         121  
14 18     18   735 use feature 'signatures';
  18         188  
  18         642  
15 18     18   106 no warnings 'experimental::signatures';
  18         124  
  18         99004  
16              
17             our $VERSION = '0.51';
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   150 sub _build_quoted_body( $self, $body=$self->body ) {
  52         119  
  52         221  
  52         112  
318 52 100       232 if( defined $body ) {
319 8         90 $body =~ s!([\x00-\x1f'"\$\@\%\\])!sprintf '\\x%02x', ord $1!ge;
  4         203  
320 8         88 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         105 } @{ $self->post_data };
  44         216  
334 44         349 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   178 sub _explode_headers( $self ) {
  73         168  
  73         150  
347             my @res =
348 387         705 map { my $h = $_;
349 387         1147 my $v = $self->headers->{$h};
350 387 100       1825 ref $v ? (map { $h => $_ } @$v)
  2         14  
351             : ($h => $v)
352 73         172 } keys %{ $self->headers };
  73         602  
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 459390 sub as_request( $self ) {
  20         81  
  20         63  
365 20         224 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   64 sub _init_cookie_jar_lwp( $self ) {
  27         59  
  27         58  
379 27 50       167 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   74 sub _init_cookie_jar_tiny( $self ) {
  25         64  
  25         88  
395 25 50       242 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   5419 sub _pairlist( $self, $l, $prefix = " " ) {
  176         361  
  176         374  
  176         579  
  176         334  
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   1206 : ref $b eq 'HASH' ? '{' . $self->_pairlist([ map { $_ => $b->{$_} } sort keys %$b ]) . '}'
  60 50       277  
    100          
    100          
436             : die "Unknown type of $b";
437 335         2046 qq{$prefix'$a' => $v}
438 176         3615 } @$l
439             }
440              
441 27     27   89 sub _build_lwp_headers( $self, $prefix = " ", %options ) {
  27         70  
  27         59  
  27         102  
  27         69  
442             # This is so we create the standard header order in our output
443 27         127 my @h = $self->_explode_headers;
444 27         275 my $h = HTTP::Headers->new( @h );
445 27         5130 $h->remove_header( @{$options{implicit_headers}} );
  27         270  
446              
447             # also skip the Host: header if it derives from $uri
448 27         551 my $val = $h->header('Host');
449 27 100 66     1600 if( $val and ($val eq $self->uri->host_port
      66        
450             or $val eq $self->uri->host )) {
451             # trivial host header
452 20         1020 $h->remove_header('Host');
453             };
454              
455 27         884 $self->_pairlist([ $h->flatten ], $prefix);
456             }
457              
458 25     25   87 sub _build_tiny_headers( $self, $prefix = " ", %options ) {
  25         59  
  25         156  
  25         117  
  25         47  
459 25         143 my @h = $self->_explode_headers;
460 25         349 my $h = HTTP::Headers->new( @h );
461 25         4644 $h->remove_header( @{$options{implicit_headers}} );
  25         175  
462              
463             # HTTP::Tiny does not like overriding the Host: header :-/
464 25         631 $h->remove_header('Host');
465              
466 25         603 @h = $h->flatten;
467 25         4676 my %h;
468             my @order;
469 25         96 while( @h ) {
470 106         257 my ($k,$v) = splice(@h,0,2);
471 106 50       242 if( ! exists $h{ $k }) {
    0          
472             # Fresh value
473 106         259 $h{ $k } = $v;
474 106         276 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         87 $self->_pairlist([ map { $_ => $h{ $_ } } @order ], $prefix);
  106         286  
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 4329206 sub as_snippet( $self, %options ) {
  52         237  
  52         638  
  52         163  
555 52   100     422 my $type = delete $options{ type } || 'LWP';
556 52 100       368 if( 'LWP' eq $type ) {
    50          
    0          
557 27         232 $self->as_lwp_snippet( %options )
558             } elsif( 'Tiny' eq $type ) {
559 25         230 $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 75 sub as_lwp_snippet( $self, %options ) {
  27         71  
  27         133  
  27         59  
568 27   50     515 $options{ prefix } ||= '';
569 27   100     391 $options{ implicit_headers } ||= [];
570              
571 27         151 my @preamble;
572             my @postamble;
573 27         0 my %ssl_options;
574 27 100       144 push @preamble, @{ $options{ preamble } } if $options{ preamble };
  25         139  
575 27 50       130 push @postamble, @{ $options{ postamble } } if $options{ postamble };
  0         0  
576 27         176 my @setup_ua = ('');
577              
578 27         376 my $request_args = join ", ",
579             '$r',
580             $self->_pairlist([
581             maybe ':content_file', $self->output
582             ], '')
583             ;
584 27         455 my $init_cookie_jar = $self->_init_cookie_jar_lwp();
585 27 50       135 if( my $p = $init_cookie_jar->{preamble}) {
586 0         0 push @preamble, @{$p}
  0         0  
587             };
588              
589 27 100       142 if( $self->insecure ) {
590 20         65 push @preamble, 'use IO::Socket::SSL;';
591 20         184 $ssl_options{ SSL_verify_mode } = \'IO::Socket::SSL::SSL_VERIFY_NONE';
592 20         104 $ssl_options{ SSL_hostname } = '';
593 20         78 $ssl_options{ verify_hostname } = '';
594             };
595              
596 27 50       156 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       152 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       584 maybe SSL_options => keys %ssl_options ? \%ssl_options : undef,
611             ], '')
612             ;
613 27 50       297 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       294 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       132 @setup_ua = ()
629             if @setup_ua == 1;
630              
631 27         57 my $request_constructor;
632              
633 27 50 66     187 if( $self->method ne 'GET' and @{ $self->form_args }) {
  5         216  
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         108 $request_constructor = <
647             my \$r = HTTP::Request->new(
648 27         323 '@{[$self->method]}' => '@{[$self->uri]}',
  27         306  
649             [
650 27         310 @{[$self->_build_lwp_headers(' ', %options)]}
651             ],
652 27         191 @{[$self->_build_quoted_body()]}
653             );
654             SNIPPET
655             }
656              
657 27         151 @preamble = map { "$options{prefix} $_\n" } @preamble;
  70         304  
658 27         96 @postamble = map { "$options{prefix} $_\n" } @postamble;
  0         0  
659 27         68 @setup_ua = map { "$options{prefix} $_\n" } @setup_ua;
  0         0  
660              
661 27         372 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 107 sub as_http_tiny_snippet( $self, %options ) {
  25         111  
  25         95  
  25         66  
671 25   50     521 $options{ prefix } ||= '';
672 25   50     354 $options{ implicit_headers } ||= [];
673              
674 25         73 push @{ $options{ implicit_headers }}, 'Host'; # HTTP::Tiny dislikes that header
  25         188  
675              
676 25         164 my @preamble;
677             my @postamble;
678 25         0 my %ssl_options;
679 25 50       166 push @preamble, @{ $options{ preamble } } if $options{ preamble };
  25         112  
680 25 50       111 push @postamble, @{ $options{ postamble } } if $options{ postamble };
  0         0  
681 25         215 my @setup_ua = ('');
682              
683 25         578 my $request_args = join ", ",
684             '$r',
685             $self->_pairlist([
686             maybe ':content_file', $self->output
687             ], '')
688             ;
689 25         487 my $init_cookie_jar = $self->_init_cookie_jar_tiny();
690 25 50       165 if( my $p = $init_cookie_jar->{preamble}) {
691 0         0 push @preamble, @{$p}
  0         0  
692             };
693              
694 25         64 my @ssl;
695 25 100       184 if( $self->insecure ) {
696             } else {
697 5         48 push @ssl, verify_SSL => 1;
698             };
699 25 50       208 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       287 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       554 maybe SSL_options => keys %ssl_options ? \%ssl_options : undef,
717             ], '')
718             ;
719 25 50       321 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       139 @setup_ua = ()
728             if @setup_ua == 1;
729              
730 25         84 @preamble = map { "$options{prefix} $_\n" } @preamble;
  50         232  
731 25         102 @postamble = map { "$options{prefix} $_\n" } @postamble;
  0         0  
732 25         70 @setup_ua = map { "$options{prefix} $_\n" } @setup_ua;
  0         0  
733              
734 25         197 my @content = $self->_build_quoted_body();
735 25 100       82 if( grep {/\S/} @content ) {
  25 50       171  
736 3         43 unshift @content, 'content => ',
737 22         179 } 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         209 return <
748             @preamble
749             my \$ua = HTTP::Tiny->new($constructor_args);@setup_ua
750             my \$res = \$ua->request(
751 25         223 '@{[$self->method]}' => '@{[$self->uri]}',
  25         239  
752             {
753             headers => {
754 25         349 @{[$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              
963             # These are what wget uses as defaults, not what Perl should use as default!
964             our %wget_header_defaults = (
965             'Accept' => '*/*',
966             'Accept-Encoding' => 'identity',
967             'User-Agent' => 'Wget/1.21',
968             'Connection' => 'Keep-Alive',
969             );
970              
971 20     20 1 409 sub as_wget($self,%options) {
  20         59  
  20         198  
  20         52  
972             $options{ wget } = 'wget'
973 20 50       88 if ! exists $options{ wget };
974             $options{ long_options } = 1
975 20 50       133 if ! exists $options{ long_options };
976              
977 20         55 my @request_commands;
978              
979 20 100       173 if( $self->method ne 'GET' ) {
980 3 100 66     68 if( $self->method eq 'POST' and $self->body ) {
981             # This is implied by '--post-data', below
982             } else {
983 1         18 push @request_commands,
984             '--method' => $self->method;
985             };
986             };
987              
988 20 50       117 if( scalar keys %{ $self->headers }) {
  20         163  
989 20         41 my %h = %{ $self->headers };
  20         145  
990              
991             # "--no-cache" implies two headers, Cache-Control and Pragma
992             my $is_cache = exists $h{ 'Pragma' }
993             && exists $h{ 'Cache-Control' }
994             && $h{ 'Cache-Control' } =~ /^no-cache\b/
995 20   66     171 && $h{ 'Pragma' } eq 'no-cache'
996             ;
997 20 100       88 if( $is_cache ) {
998 1         3 delete $h{ 'Pragma' };
999 1         2 delete $h{ 'Cache-Control' };
1000 1         3 push @request_commands, '--no-cache';
1001             };
1002              
1003 20         215 for my $name (sort keys %h) {
1004 120         855 my $v = $h{ $name };
1005              
1006 120         188 my $default;
1007 120 100       271 if( exists $wget_header_defaults{ $name }) {
1008 79         258 $default = $wget_header_defaults{ $name };
1009             };
1010              
1011 120 50       279 if( ! ref $v ) {
1012 120         291 $v = [$v];
1013             };
1014 120         245 for my $val (@$v) {
1015 120 100 100     636 if( !defined $default or $val ne $default ) {
1016             # also skip the Host: header if it derives from $uri
1017 62 100 66     354 if( $name eq 'Host' and ($val eq $self->uri->host_port
    100 100        
1018             or $val eq $self->uri->host )) {
1019             # trivial host header, ignore
1020             } elsif( $name eq 'User-Agent' ) {
1021 20         138 push @request_commands,
1022             '--user-agent',
1023             $val;
1024             } else {
1025 24         311 push @request_commands,
1026             '--header',
1027             "$name: $val";
1028             };
1029             };
1030             };
1031             };
1032             };
1033              
1034 20 100       136 if( my $body = $self->body ) {
1035 3 100       38 if( $self->method eq 'POST' ) {
1036 2         8 push @request_commands,
1037             '--post-data',
1038             $body;
1039             } else {
1040 1         5 push @request_commands,
1041             '--body-data',
1042             $body;
1043             };
1044             };
1045              
1046 20         83 push @request_commands, $self->uri;
1047              
1048             return
1049             #(defined $options{ curl } ? $options{curl} : () ),
1050 20         107 @request_commands;
1051             }
1052              
1053              
1054             =head2 C<< $r->clone >>
1055              
1056             Returns a shallow copy of the object
1057              
1058             =cut
1059              
1060 0     0 1   sub clone( $self, %options ) {
  0            
  0            
  0            
1061 0           (ref $self)->new( %$self, %options )
1062             }
1063              
1064             1;
1065              
1066             =head1 REPOSITORY
1067              
1068             The public repository of this module is
1069             L.
1070              
1071             =head1 SUPPORT
1072              
1073             The public support forum of this module is
1074             L.
1075              
1076             =head1 BUG TRACKER
1077              
1078             Please report bugs in this module via the Github bug queue at
1079             L
1080              
1081             =head1 AUTHOR
1082              
1083             Max Maischein C
1084              
1085             =head1 COPYRIGHT (c)
1086              
1087             Copyright 2018-2023 by Max Maischein C.
1088              
1089             =head1 LICENSE
1090              
1091             This module is released under the same terms as Perl itself.
1092              
1093             =cut