useragent.pm

稀饭伊人相册系统继承了新天堂多用户相册系统的功能

      @{$self}{qw(agent from cookie_jar max_size)};

    # Set User-Agent and From headers if they are defined
    $request->init_header('User-Agent' => $agent) if $agent;
    $request->init_header('From' => $from) if $from;
    if (defined $max_size) {
	my $last = $max_size - 1;
	$last = 0 if $last < 0;  # there is no way to actually request no content
	$request->init_header('Range' => "bytes=0-$last");
    }
    $cookie_jar->add_cookie_header($request) if $cookie_jar;

    return($request);
}


=item $ua->simple_request($request, [$arg [, $size]])

This method dispatches a single WWW request on behalf of a user, and
returns the response received.  If differs from C<send_request()> by
automatically calling the C<prepare_request()> method before the
request is sent.

The arguments are the same as for C<send_request()>.

=cut

sub simple_request
{
    my($self, $request, $arg, $size) = @_;
    $self->_request_sanity_check($request);
    my $new_request = $self->prepare_request($request);
    return($self->send_request($new_request, $arg, $size));
}


=item $ua->request($request, $arg [, $size])

Process a request, including redirects and security.  This method may
actually send several different simple requests.

The arguments are the same as for C<send_request()> and
C<simple_request()>.

=cut

sub request
{
    my($self, $request, $arg, $size, $previous) = @_;

    LWP::Debug::trace('()');

    my $response = $self->simple_request($request, $arg, $size);

    my $code = $response->code;
    $response->previous($previous) if defined $previous;

    LWP::Debug::debug('Simple response: ' .
		      (HTTP::Status::status_message($code) ||
		       "Unknown code $code"));

    if ($code == &HTTP::Status::RC_MOVED_PERMANENTLY or
	$code == &HTTP::Status::RC_MOVED_TEMPORARILY) {

	# Make a copy of the request and initialize it with the new URI
	my $referral = $request->clone;

	# And then we update the URL based on the Location:-header.
	my($referral_uri) = $response->header('Location');
	{
	    # Some servers erroneously return a relative URL for redirects,
	    # so make it absolute if it not already is.
	    local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
	    my $base = $response->base;
	    $referral_uri = $HTTP::URI_CLASS->new($referral_uri, $base)
		            ->abs($base);
	}

	$referral->url($referral_uri);
	$referral->remove_header('Host', 'Cookie');

	return $response unless $self->redirect_ok($referral);

	# Check for loop in the redirects
	my $count = 0;
	my $r = $response;
	while ($r) {
	    if (++$count > 13 ||
                $r->request->url->as_string eq $referral_uri->as_string) {
		$response->header("Client-Warning" =>
				  "Redirect loop detected");
		return $response;
	    }
	    $r = $r->previous;
	}

	return $self->request($referral, $arg, $size, $response);

    } elsif ($code == &HTTP::Status::RC_UNAUTHORIZED ||
	     $code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED
	    )
    {
	my $proxy = ($code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED);
	my $ch_header = $proxy ?  "Proxy-Authenticate" : "WWW-Authenticate";
	my @challenge = $response->header($ch_header);
	unless (@challenge) {
	    $response->header("Client-Warning" => 
			      "Missing Authenticate header");
	    return $response;
	}

	require HTTP::Headers::Util;
	CHALLENGE: for my $challenge (@challenge) {
	    $challenge =~ tr/,/;/;  # "," is used to separate auth-params!!
	    ($challenge) = HTTP::Headers::Util::split_header_words($challenge);
	    my $scheme = lc(shift(@$challenge));
	    shift(@$challenge); # no value
	    $challenge = { @$challenge };  # make rest into a hash
	    for (keys %$challenge) {       # make sure all keys are lower case
		$challenge->{lc $_} = delete $challenge->{$_};
	    }

	    unless ($scheme =~ /^([a-z]+(?:-[a-z]+)*)$/) {
		$response->header("Client-Warning" => 
				  "Bad authentication scheme '$scheme'");
		return $response;
	    }
	    $scheme = $1;  # untainted now
	    my $class = "LWP::Authen::\u$scheme";
	    $class =~ s/-/_/g;

	    no strict 'refs';
	    unless (%{"$class\::"}) {
		# try to load it
		eval "require $class";
		if ($@) {
		    if ($@ =~ /^Can\'t locate/) {
			$response->header("Client-Warning" =>
					  "Unsupported authentication scheme '$scheme'");
		    } else {
			$response->header("Client-Warning" => $@);
		    }
		    next CHALLENGE;
		}
	    }
	    return $class->authenticate($self, $proxy, $challenge, $response,
					$request, $arg, $size);
	}
	return $response;
    }
    return $response;
}

#---------------------------------------------------------------------------
# Now the shortcuts...

=item $ua->get($url, Header => Value,...);

This is a shortcut for C<$ua-E<gt>request(HTTP::Request::Common::GET(
$url, Header =E<gt> Value,... ))>.  See
L<HTTP::Request::Common|HTTP::Request::Common>.

=item $ua->post($url, \%formref, Header => Value,...);

This is a shortcut for C<$ua-E<gt>request( HTTP::Request::Common::POST(
$url, \%formref, Header =E<gt> Value,... ))>.  Note that the form
reference is optional, and can be either a hashref (C<\%formdata> or C<{
'key1' => 'val2', 'key2' => 'val2', ...
}>) or an arrayref (C<\@formdata> or
C<['key1' => 'val2', 'key2' => 'val2', ...]>).  See
L<HTTP::Request::Common|HTTP::Request::Common>.

=item $ua->head($url, Header => Value,...);

This is a shortcut for C<$ua-E<gt>request( HTTP::Request::Common::HEAD(
$url, Header =E<gt> Value,... ))>.  See
L<HTTP::Request::Common|HTTP::Request::Common>.

=item $ua->put($url, Header => Value,...);

This is a shortcut for C<$ua-E<gt>request( HTTP::Request::Common::PUT(
$url, Header =E<gt> Value,... ))>.  See
L<HTTP::Request::Common|HTTP::Request::Common>.

=cut

sub get {
  require HTTP::Request::Common;
  return shift->request( HTTP::Request::Common::GET( @_ ) );
}

sub post {
  require HTTP::Request::Common;
  return shift->request( HTTP::Request::Common::POST( @_ ) );
}

sub head {
  require HTTP::Request::Common;
  return shift->request( HTTP::Request::Common::HEAD( @_ ) );
}

sub put {
  require HTTP::Request::Common;
  return shift->request( HTTP::Request::Common::PUT( @_ ) );
}


#---------------------------------------------------------------------------
# This whole allow/forbid thing is based on man 1 at's way of doing things.

=item $ua->protocols_allowed( );  # to read

=item $ua->protocols_allowed( \@protocols ); # to set

This reads (or sets) this user-agent's list of procotols that
C<$ua-E<gt>request> and C<$ua-E<gt>simple_request> will exclusively
allow.

For example: C<$ua-E<gt>protocols_allowed( [ 'http', 'https'] );>
means that this user agent will I<allow only> those protocols,
and attempts to use this user-agent to access URLs with any other
schemes (like "ftp://...") will result in a 500 error.

To delete the list, call: 
C<$ua-E<gt>protocols_allowed(undef)>

By default, an object has neither a protocols_allowed list, nor
a protocols_forbidden list.

Note that having a protocols_allowed
list causes any protocols_forbidden list to be ignored.

=item $ua->protocols_forbidden( );  # to read

=item $ua->protocols_forbidden( \@protocols ); # to set

This reads (or sets) this user-agent's list of procotols that
C<$ua-E<gt>request> and C<$ua-E<gt>simple_request> will I<not> allow.

For example: C<$ua-E<gt>protocols_forbidden( [ 'file', 'mailto'] );>
means that this user-agent will I<not> allow those protocols, and
attempts to use this user-agent to access URLs with those schemes
will result in a 500 error.

To delete the list, call: 
C<$ua-E<gt>protocols_forbidden(undef)>

=item $ua->is_protocol_supported($scheme)

You can use this method to test whether this user-agent object supports the
specified C<scheme>.  (The C<scheme> might be a string (like 'http' or
'ftp') or it might be an URI object reference.)

Whether a scheme is supported, is determined by $ua's protocols_allowed or
protocols_forbidden lists (if any), and by the capabilities
of LWP.  I.e., this will return TRUE only if LWP supports this protocol
I<and> it's permitted for this particular object.

=cut

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 $_ eq $scheme, @$x;
    } elsif (ref($self) and $x = $self->protocols_forbidden) {
      return 0 if grep $_ eq $scheme, @$x;
    }

    local($SIG{__DIE__});  # protect agains user defined die handlers
    $x = LWP::Protocol::implementor($scheme);
    return 1 if $x and $x ne 'LWP::Protocol::nogo';
    return 0;
}

#---------------------------------------------------------------------------

=item $ua->requests_redirectable( );  # to read

=item $ua->requests_redirectable( \@requests );  # to set

This reads or sets the object's list of request names that 
C<$ua-E<gt>redirect_ok(...)> will allow redirection for.  By
default, this is C<['GET', 'HEAD']>, as per RFC 2068.  To
change to include 'POST', consider:

   push @{ $ua->requests_redirectable }, 'POST';

=cut

sub protocols_allowed      { shift->_elem('protocols_allowed'    , @_) }
sub protocols_forbidden    { shift->_elem('protocols_forbidden'  , @_) }
sub requests_redirectable  { shift->_elem('requests_redirectable', @_) }

#---------------------------------------------------------------------------

=item $ua->redirect_ok($prospective_request)

This method is called by request() before it tries to follow a
redirection to the request in $prospective_request.  This
should return a true value if this redirection is
permissible.

The default implementation will return FALSE unless the method
is in the object's C<requests_redirectable> list,
FALSE if the proposed redirection is to a "file://..."
URL, and TRUE otherwise.

Subclasses might want to override this.

(This method's behavior in previous versions was simply to return
TRUE for anything except POST requests).

=cut

sub redirect_ok
{
    # RFC 2068, 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, $request) = @_;
    my $method = $request->method;
    return 0 unless grep $_ eq $method,
      @{ $self->requests_redirectable || [] };
    
    if($request->url->scheme eq 'file') {
      LWP::Debug::trace("Can't redirect to a file:// URL!");
      return 0;
    }
    
    # Otherwise it's apparently okay...
    return 1;
}


=item $ua->credentials($netloc, $realm, $uname, $pass)

Set the user name and password to be used for a realm.  It is often more
useful to specialize the get_basic_credentials() method instead.

=cut

sub credentials
{
    my($self, $netloc, $realm, $uid, $pass) = @_;
    @{ $self->{'basic_authentication'}{$netloc}{$realm} } = ($uid, $pass);
}


=item $ua->get_basic_credentials($realm, $uri, [$proxy])

This is called by request() to retrieve credentials for a Realm
protected by Basic Authentication or Digest Authentication.

Should return username and password in a list.  Return undef to abort
the authentication resolution atempts.

This implementation simply checks a set of pre-stored member
variables. Subclasses can override this method to e.g. ask the user
for a username/password.  An example of this can be found in
C<lwp-request> program distributed with this library.

=cut

sub get_basic_credentials
{
    my($self, $realm, $uri, $proxy) = @_;
    return if $proxy;