$self->protocols_allowed( $protocols_allowed ) if $protocols_allowed;
$self->protocols_forbidden($protocols_forbidden) if $protocols_forbidden;
if ($keep_alive) {
$conn_cache ||= { total_capacity => $keep_alive };
}
$self->conn_cache($conn_cache) if $conn_cache;
return $self;
}
sub send_request
{
my($self, $request, $arg, $size) = @_;
my($method, $url) = ($request->method, $request->uri);
my $scheme = $url->scheme;
local($SIG{__DIE__}); # protect against user defined die handlers
LWP::Debug::trace("$method $url");
$self->progress("begin", $request);
my $response = $self->run_handlers("request_send", $request);
unless ($response) {
my $protocol;
{
# Honor object-specific restrictions by forcing protocol objects
# into class LWP::Protocol::nogo.
my $x;
if($x = $self->protocols_allowed) {
if (grep lc($_) eq $scheme, @$x) {
LWP::Debug::trace("$scheme URLs are among $self\'s allowed protocols (@$x)");
}
else {
LWP::Debug::trace("$scheme URLs aren't among $self\'s allowed protocols (@$x)");
require LWP::Protocol::nogo;
$protocol = LWP::Protocol::nogo->new;
}
}
elsif ($x = $self->protocols_forbidden) {
if(grep lc($_) eq $scheme, @$x) {
LWP::Debug::trace("$scheme URLs are among $self\'s forbidden protocols (@$x)");
require LWP::Protocol::nogo;
$protocol = LWP::Protocol::nogo->new;
}
else {
LWP::Debug::trace("$scheme URLs aren't among $self\'s forbidden protocols (@$x)");
}
}
# else fall thru and create the protocol object normally
}
# Locate protocol to use
my $proxy = $request->{proxy};
if ($proxy) {
$scheme = $proxy->scheme;
}
unless ($protocol) {
$protocol = eval { LWP::Protocol::create($scheme, $self) };
if ($@) {
$@ =~ s/ at .* line \d+.*//s; # remove file/line number
$response = _new_response($request, &HTTP::Status::RC_NOT_IMPLEMENTED, $@);
if ($scheme eq "https") {
$response->message($response->message . " (Crypt::SSLeay not installed)");
$response->content_type("text/plain");
$response->content(<<EOT);
LWP will support https URLs if the Crypt::SSLeay module is installed.
More information at <http://www.linpro.no/lwp/libwww-perl/README.SSL>.
EOT
}
}
}
if (!$response && $self->{use_eval}) {
# we eval, and turn dies into responses below
eval {
$response = $protocol->request($request, $proxy,
$arg, $size, $self->{timeout});
};
if ($@) {
$@ =~ s/ at .* line \d+.*//s; # remove file/line number
$response = _new_response($request,
&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
$@);
}
}
elsif (!$response) {
$response = $protocol->request($request, $proxy,
$arg, $size, $self->{timeout});
# XXX: Should we die unless $response->is_success ???
}
}
$response->request($request); # record request for reference
=2= |