view release on metacpan or  search on metacpan

lib/LWP/Protocol/http.pm  view on Meta::CPAN

package LWP::Protocol::http;

use strict;

our $VERSION = '6.83';

require HTTP::Response;
require HTTP::Status;
require Net::HTTP;
use parent qw(LWP::Protocol);

our @EXTRA_SOCK_OPTS;
my $CRLF = "\015\012";

sub _new_socket
{
    my($self, $host, $port, $timeout) = @_;

    # IPv6 literal IP address should be [bracketed] to remove
    # ambiguity between ip address and port number.
    if ( ($host =~ /:/) && ($host !~ /^\[/) ) {
      $host = "[$host]";
    }

    local($^W) = 0;  # IO::Socket::INET can be noisy
    my $sock = $self->socket_class->new(PeerAddr => $host,
					PeerPort => $port,
					LocalAddr => $self->{ua}{local_address},
					Proto    => 'tcp',
					Timeout  => $timeout,
					KeepAlive => !!$self->{ua}{conn_cache},
					SendTE    => $self->{ua}{send_te},
					$self->_extra_sock_opts($host, $port),
				       );

    unless ($sock) {
	# IO::Socket::INET leaves additional error messages in $@
	my $status = "Can't connect to $host:$port";
	if ($@ =~ /\bconnect: (.*)/ ||
	    $@ =~ /\b(Bad hostname)\b/ ||
	    $@ =~ /\b(nodename nor servname provided, or not known)\b/ ||
	    $@ =~ /\b(certificate verify failed)\b/ ||
	    $@ =~ /\b(Crypt-SSLeay can't verify hostnames)\b/
	) {
	    $status .= " ($1)";
	} elsif ($@) {
	    $status .= " ($@)";
	}
	die "$status\n\n$@";
    }

    $sock->blocking(0);

    $sock;
}

sub socket_type
{
    return "http";
}

sub socket_class
{
    my $self = shift;
    (ref($self) || $self) . "::Socket";
}

sub _extra_sock_opts  # to be overridden by subclass
{
    return @EXTRA_SOCK_OPTS;
}

sub _check_sock
{
    #my($self, $req, $sock) = @_;
}

sub _get_sock_info
{
    my($self, $res, $sock) = @_;
    if (defined(my $peerhost = $sock->peerhost)) {
        $res->header("Client-Peer" => "$peerhost:" . $sock->peerport);
    }
}

sub _fixup_header
{
    my($self, $h, $url, $proxy) = @_;

    # Extract 'Host' header
    my $hhost = $url->authority;
    if ($hhost =~ s/^([^\@]*)\@//) {  # get rid of potential "user:pass@"
	# add authorization header if we need them.  HTTP URLs do
	# not really support specification of user and password, but
	# we allow it.
	if (defined($1) && not $h->header('Authorization')) {
	    require URI::Escape;
	    $h->authorization_basic(map URI::Escape::uri_unescape($_),
				    split(":", $1, 2));
	}
    }