File Coverage

blib/lib/HTTP/Request/CurlParameters.pm
Criterion Covered Total %
statement 231 406 56.9
branch 68 178 38.2
condition 23 62 37.1
subroutine 26 32 81.2
pod 5 8 62.5
total 353 686 51.4


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