print STDERR " (${t}s)" if $t;
print STDERR "\n";
}
elsif ($status eq "tick") {
print STDERR "$ANI[$self->{progress_ani}++]\b";
$self->{progress_ani} %= @ANI;
}
else {
my $p = sprintf "%3.0f%%", $status * 100;
return if $p eq $self->{progress_lastp};
print STDERR "$p\b\b\b\b";
$self->{progress_lastp} = $p;
}
STDERR->flush;
}
#
# This whole allow/forbid thing is based on man 1 at's way of doing things.
#
sub is_protocol_supported
{
my($self, $scheme) = @_;
if (ref $scheme) {
# assume we got a reference to an URI object
$scheme = $scheme->scheme;
}
else {
Carp::croak("Illegal scheme '$scheme' passed to is_protocol_supported")
if $scheme =~ /\W/;
$scheme = lc $scheme;
}
my $x;
if(ref($self) and $x = $self->protocols_allowed) {
return 0 unless grep lc($_) eq $scheme, @$x;
}
elsif (ref($self) and $x = $self->protocols_forbidden) {
return 0 if grep lc($_) eq $scheme, @$x;
}
local($SIG{__DIE__}); # protect against user defined die handlers
$x = LWP::Protocol::implementor($scheme);
return 1 if $x and $x ne 'LWP::Protocol::nogo';
return 0;
}
sub protocols_allowed { shift->_elem('protocols_allowed' , @_) }
sub protocols_forbidden { shift->_elem('protocols_forbidden' , @_) }
sub requests_redirectable { shift->_elem('requests_redirectable', @_) }
sub redirect_ok
{
# RFC 2616, section 10.3.2 and 10.3.3 say:
# If the 30[12] status code is received in response to a request other
# than GET or HEAD, the user agent MUST NOT automatically redirect the
# request unless it can be confirmed by the user, since this might
# change the conditions under which the request was issued.
# Note that this routine used to be just:
# return 0 if $_[1]->method eq "POST"; return 1;
my($self, $new_request, $response) = @_;
my $method = $response->request->method;
return 0 unless grep $_ eq $method,
@{ $self->requests_redirectable || [] };
if ($new_request->url->scheme eq 'file') {
$response->header("Client-Warning" =>
"Can't redirect to a file:// URL!");
return 0;
}
# Otherwise it's apparently okay...
return 1;
}
sub credentials
{
my $self = shift;
my $netloc = lc(shift);
my $realm = shift || "";
my $old = $self->{basic_authentication}{$netloc}{$realm};
if (@_) {
$self->{basic_authentication}{$netloc}{$realm} = [@_];
}
return unless $old;
return @$old if wantarray;
return join(":", @$old);
}
sub get_basic_credentials
{
my($self, $realm, $uri, $proxy) = @_;
return if $proxy;
return $self->credentials($uri->host_port, $realm);
=6= |