view release on metacpan or  search on metacpan

lib/HTTP/Request/FromWget.pm  view on Meta::CPAN

=back

=head1 GLOBAL VARIABLES

=head2 C<< %default_headers >>

Contains the default headers added to every request

=cut

our %default_headers = (
    'Accept'     => '*/*',
    'Accept-Encoding' => 'identity',
    'User-Agent' => 'Wget/1.21',
    'Connection' => 'Keep-Alive',
);

=head2 C<< @option_spec >>

Contains the L<Getopt::Long> specification of the recognized command line
parameters.

The following C<wget> options are recognized but largely ignored:

=over 4

=item B<verbose>

=item B<quiet>

=item B<auth-no-challenge>

=item B<output-document>

=item B<debug>

If you want to keep session cookies between subsequent requests, you need to
provide a cookie jar in your user agent.

=back

=cut

our @option_spec = (
    'auth-no-challenge',     # ignored
    'bind-address=s',
    'body-data=s',
    'body-file=s',
    'buffer!',
    'cache!',
    'ca-directory=s',
    'check-certificate!',
    'certificate=s',
    'compression=s',
    'content-disposition=s',
    'cookie|b=s@',
    'cookies!',              # ignored
    'debug',                 # ignored
    'header|H=s@',
    'http-keep-alive!',
    'http-password=s',
    'http-user=s',
    'load-cookies|c=s',
    'method=s',
    'no-verbose|nv',         # ignored
    'output-document|O=s',   # ignored
    'post-data=s',
    'post-file=s',
    'progress!',             # ignored
    'quiet',                 # ignored
    'referer=s',
    'timeout|T=i',
    'user-agent|U=s',
    'verbose|v',             # ignored
);

sub new( $class, %options ) {
    my $cmd = $options{ argv };

    if( $options{ command }) {
        require Text::ParseWords;
        $cmd = [ Text::ParseWords::shellwords($options{ command }) ];

    } elsif( $options{ command_wget }) {
        require Text::ParseWords;
        $cmd = [ Text::ParseWords::shellwords($options{ command_wget }) ];

        # remove the implicit wget command:
        shift @$cmd;
    };

    my $p = Getopt::Long::Parser->new(
        config => [ 'bundling', 'no_auto_abbrev', 'no_ignore_case_always' ],
    );
    $p->getoptionsfromarray( $cmd,
        \my %wget_options,
        @option_spec,
    ) or return;

    return
        wantarray ? map { $class->_build_request( $_, \%wget_options, %options ) } @$cmd
                  :       ($class->_build_request( $cmd->[0], \%wget_options, %options ))[0]
                  ;
}

=head1 METHODS

=head2 C<< ->squash_uri( $uri ) >>

  my $uri = HTTP::Request::FromWget->squash_uri(
      URI->new( 'https://example.com/foo/bar/..' )
  );
  # https://example.com/foo/

Helper method to clean up relative path elements from the URI the same way
that wget does.

=cut

sub squash_uri( $class, $uri ) {

lib/HTTP/Request/FromWget.pm  view on Meta::CPAN

                ;
        };

        if( @form_args) {
            $method ||= 'POST';

            my $req = HTTP::Request::Common::POST(
                'https://example.com',
                Content_Type => 'form-data',
                Content => [ map { /^([^=]+)=(.*)$/ ? ($1 => $2) : () } @form_args ],
            );
            $body = $req->content;
            $request_default_headers{ 'Content-Type' } = join "; ", $req->headers->content_type;

        } elsif( defined $data ) {
            $method ||= 'POST';
            $body = $data;
            $request_default_headers{ 'Content-Type' } = 'application/x-www-form-urlencoded';

        } else {
            $method ||= 'GET';
        };

        if( defined $body ) {
            $request_default_headers{ 'Content-Length' } = length $body;
        };

        if( $options->{ 'user' } || $options->{'http-user'} ) {
            if(    $options->{anyauth}
                || $options->{ntlm}
                || $options->{negotiate}
                ) {
                # Nothing to do here, just let LWP::UserAgent do its thing
                # This means one additional request to fetch the appropriate
                # 401 response asking for credentials, but ...
            } else {
                # $options->{basic} or none at all
                my $info = delete $options->{'user'} || delete $options->{'http-user'};
                # We need to bake this into the header here?!
                push @headers, sprintf 'Authorization: Basic %s', encode_base64( $info );
            }
        };

        my %headers;
        for my $kv (
            (map { /^\s*([^:\s]+)\s*:\s*(.*)$/ ? [$1 => $2] : () } @headers),) {
                $self->_add_header( \%headers, @$kv );
        };

        if( defined $options->{ 'user-agent' }) {
            $self->_set_header( \%headers, "User-Agent", $options->{ 'user-agent' } );
        };

        if( exists $options->{ 'cache' }) {
            if(! $options->{ 'cache' } ) {
                $self->_maybe_set_header( \%headers, "Cache-Control" => 'no-cache' );
                $self->_maybe_set_header( \%headers, "Pragma" => 'no-cache' );
            };
        };

        if( exists $options->{ 'http-keep-alive' }) {
            if(! $options->{ 'http-keep-alive' } ) {
                $self->_set_header( \%headers, "Connection" => 'Close' );
            };
        };

        if( defined $options->{ referer }) {
            $self->_set_header( \%headers, "Referer" => $options->{ 'referer' } );
        };

        # We want to compare the headers case-insensitively
        my %headers_lc = map { lc $_ => 1 } keys %headers;

        for my $k (keys %request_default_headers) {
            if( ! $headers_lc{ lc $k }) {
                $self->_add_header( \%headers, $k, $request_default_headers{ $k });
            };
        };
        $self->_maybe_set_header( \%headers, 'Host' => $host );

        if( defined $options->{ 'cookie-jar' }) {
                $options->{'cookie-jar-options'}->{ 'write' } = 1;
        };

        if( defined( my $c = $options->{ cookie })) {
            if( $c =~ /=/ ) {
                $headers{ Cookie } = $options->{ 'cookie' };
            } else {
                $options->{'cookie-jar'} = $c;
                $options->{'cookie-jar-options'}->{ 'read' } = 1;
            };
        };

        if( my $c = $options->{ compression }) {
            if( $c =~ /^(gzip|auto)$/ ) {
                # my $compressions = HTTP::Message::decodable();
                $self->_set_header( \%headers, 'Accept-Encoding' => 'gzip' );
            };
        };

        push @res, HTTP::Request::CurlParameters->new({
            method => $method,
            uri    => $uri,
            headers => \%headers,
            body   => $body,
            maybe local_address => $options->{local_address},
            maybe cert => $options->{certificate},
            maybe capath => $options->{'ca-directory'},
            maybe credentials => $options->{ user },
            maybe output => $options->{ output },
            maybe timeout => $options->{ 'max-time' },
            maybe cookie_jar => $options->{'cookie-jar'},
            maybe cookie_jar_options => $options->{'cookie-jar-options'},
            maybe insecure => !$options->{'check-certificate'},
            maybe show_error => $options->{'show_error'},
            maybe fail => $options->{'fail'},
        });
    }

    return @res
};