useragent.pm

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

# $Id: UserAgent.pm,v 2.1 2001/12/11 21:11:29 gisle Exp $

package LWP::UserAgent;
use strict;

=head1 NAME

LWP::UserAgent - A WWW UserAgent class

=head1 SYNOPSIS

 require LWP::UserAgent;
 my $ua = LWP::UserAgent->new(env_proxy => 1,
                              keep_alive => 1,
                              timeout => 30,
                             );

 $response = $ua->get('http://search.cpan.org/');

 # or:

 $request = HTTP::Request->new('GET', 'http://search.cpan.org/');
  # and then one of these:
 $response = $ua->request($request); # or
 $response = $ua->request($request, '/tmp/sss'); # or
 $response = $ua->request($request, \&callback, 4096);

 sub callback { my($data, $response, $protocol) = @_; .... }

=head1 DESCRIPTION

The C<LWP::UserAgent> is a class implementing a World-Wide Web
user agent in Perl. It brings together the HTTP::Request,
HTTP::Response and the LWP::Protocol classes that form the rest of the
core of libwww-perl library. For simple uses this class can be used
directly to dispatch WWW requests, alternatively it can be subclassed
for application-specific behaviour.

In normal use the application creates a C<LWP::UserAgent> object, and then
configures it with values for timeouts, proxies, name, etc. It then
creates an instance of C<HTTP::Request> for the request that
needs to be performed. This request is then passed to one of the UserAgent's
request() methods, which dispatches it using the relevant protocol,
and returns a C<HTTP::Response> object.

There are convenience methods for sending the most common request
types; get(), head() and post().

The basic approach of the library is to use HTTP style communication
for all protocol schemes, i.e. you even receive an C<HTTP::Response>
object for gopher or ftp requests.  In order to achieve even more
similarity to HTTP style communications, gopher menus and file
directories are converted to HTML documents.

The send_request(), simple_request() and request() methods can process
the content of the response in one of three ways: in core, into a
file, or into repeated calls to a subroutine.  You choose which one by
the kind of value passed as the second argument.

The in core variant simply stores the content in a scalar 'content'
attribute of the response object and is suitable for small HTML
replies that might need further parsing.  This variant is used if the
second argument is missing (or is undef).

The filename variant requires a scalar containing a filename as the
second argument to the request method and is suitable for large WWW
objects which need to be written directly to the file without
requiring large amounts of memory. In this case the response object
returned from the request method will have an empty content attribute.
If the request fails, then the content might not be empty, and the
file will be untouched.

The subroutine variant requires a reference to callback routine as the
second argument to the request method and it can also take an optional
chuck size as the third argument.  This variant can be used to
construct "pipe-lined" processing, where processing of received
chuncks can begin before the complete data has arrived.  The callback
function is called with 3 arguments: the data received this time, a
reference to the response object and a reference to the protocol
object.  The response object returned from the request method will
have empty content.  If the request fails, then the the callback
routine is not called, and the response->content might not be empty.

The request can be aborted by calling die() in the callback
routine.  The die message will be available as the "X-Died" special
response header field.

The library also allows you to use a subroutine reference as
content in the request object.  This subroutine should return the
content (possibly in pieces) when called.  It should return an empty
string when there is no more content.

=head1 METHODS

The following methods are available:

=over 4

=cut


use vars qw(@ISA $VERSION);

require LWP::MemberMixin;
@ISA = qw(LWP::MemberMixin);
$VERSION = sprintf("%d.%03d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/);

use HTTP::Request ();
use HTTP::Response ();
use HTTP::Date ();

use LWP ();
use LWP::Debug ();
use LWP::Protocol ();

use Carp ();

if ($ENV{PERL_LWP_USE_HTTP_10}) {
    require LWP::Protocol::http10;
    LWP::Protocol::implementor('http', 'LWP::Protocol::http10');
    eval {
        require LWP::Protocol::https10;
        LWP::Protocol::implementor('https', 'LWP::Protocol::https10');
    };
}

=item $ua = LWP::UserAgent->new( %options );

This class method constructs a new C<LWP::UserAgent> object and
returns a reference to it.

Key/value pair arguments may be provided to set up the initial state
of the user agent.  The following options correspond to attribute
methods described below:

   KEY                     DEFAULT
   -----------             --------------------
   agent                   "libwww-perl/#.##"
   from                    undef
   timeout                 180
   use_eval                1
   parse_head              1
   max_size                undef
   cookie_jar              undef
   conn_cache              undef
   protocols_allowed       undef
   protocols_forbidden     undef
   requests_redirectable   ['GET', 'HEAD']

The followings option are also accepted: If the C<env_proxy> option is
passed in an has a TRUE value, then proxy settings are read from
environment variables.  If the C<keep_alive> option is passed in, then
a C<LWP::ConnCache> is set up (see conn_cache() method below).  The
keep_alive value is a number and is passed on as the total_capacity
for the connection cache.  The C<keep_alive> option also has the
effect of loading and enabling the new experimental HTTP/1.1 protocol
module.

=cut

sub new
{
    my($class, %cnf) = @_;
    LWP::Debug::trace('()');

    my $agent = delete $cnf{agent};
    $agent = $class->_agent unless defined $agent;

    my $from  = delete $cnf{from};
    my $timeout = delete $cnf{timeout};
    $timeout = 3*60 unless defined $timeout;
    my $use_eval = delete $cnf{use_eval};
    $use_eval = 1 unless defined $use_eval;
    my $parse_head = delete $cnf{parse_head};
    $parse_head = 1 unless defined $parse_head;
    my $max_size = delete $cnf{max_size};
    my $env_proxy = delete $cnf{env_proxy};

    my $cookie_jar = delete $cnf{cookie_jar};
    my $conn_cache = delete $cnf{conn_cache};
    my $keep_alive = delete $cnf{keep_alive};
    
    Carp::croak("Can't mix conn_cache and keep_alive")
	  if $conn_cache && $keep_alive;


    my $protocols_allowed   = delete $cnf{protocols_allowed};
    my $protocols_forbidden = delete $cnf{protocols_forbidden};
    
    my $requests_redirectable = delete $cnf{requests_redirectable};
    $requests_redirectable = ['GET', 'HEAD']
      unless defined $requests_redirectable;

    # Actually ""s are just as good as 0's, but for concision we'll just say:
    Carp::croak("protocols_allowed has to be an arrayref or 0, not \"$protocols_allowed\"!")
      if $protocols_allowed and ref($protocols_allowed) ne 'ARRAY';
    Carp::croak("protocols_forbidden has to be an arrayref or 0, not \"$protocols_forbidden\"!")
      if $protocols_forbidden and ref($protocols_forbidden) ne 'ARRAY';
    Carp::croak("requests_redirectable has to be an arrayref or 0, not \"$requests_redirectable\"!")
      if $requests_redirectable and ref($requests_redirectable) ne 'ARRAY';


    if (%cnf && $^W) {
	Carp::carp("Unrecognized LWP::UserAgent options: @{[sort keys %cnf]}");
    }

    my $self = bless {
		      from        => $from,
		      timeout     => $timeout,
		      use_eval    => $use_eval,
		      parse_head  => $parse_head,
		      max_size    => $max_size,
		      proxy       => undef,
		      no_proxy    => [],
                      protocols_allowed => $protocols_allowed,
                      protocols_forbidden => $protocols_forbidden,
                      requests_redirectable => $requests_redirectable,
		     }, $class;

    $self->agent($agent) if $agent;
    $self->cookie_jar($cookie_jar) if $cookie_jar;
    $self->env_proxy if $env_proxy;

    $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;
}


# private method.  check sanity of given $request
sub _request_sanity_check {
    my($self, $request) = @_;
    # some sanity checking
    if (defined $request) {
	if (ref $request) {
	    Carp::croak("You need a request object, not a " . ref($request) . " object")
	      if ref($request) eq 'ARRAY' or ref($request) eq 'HASH' or
		 !$request->can('method') or !$request->can('uri');
	}
	else {
	    Carp::croak("You need a request object, not '$request'");
	}
    }
    else {
        Carp::croak("No request object passed in");
    }
}


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

This method dispatches a single WWW request on behalf of a user, and
returns the response received.  The request is sent off unmodified,
without passing it through C<prepare_request()>.

The C<$request> should be a reference to a C<HTTP::Request> object
with values defined for at least the method() and uri() attributes.

If C<$arg> is a scalar it is taken as a filename where the content of
the response is stored.

If C<$arg> is a reference to a subroutine, then this routine is called
as chunks of the content is received.  An optional C<$size> argument
is taken as a hint for an appropriate chunk size.

If C<$arg> is omitted, then the content is stored in the response
object itself.

=cut

sub send_request
{
    my($self, $request, $arg, $size) = @_;
    $self->_request_sanity_check($request);

    my($method, $url) = ($request->method, $request->uri);

    local($SIG{__DIE__});  # protect agains user defined die handlers

    # Check that we have a METHOD and a URL first
    return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, "Method missing")
	unless $method;
    return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, "URL missing")
	unless $url;
    return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, "URL must be absolute")
	unless $url->scheme;

    LWP::Debug::trace("$method $url");

    # Locate protocol to use
    my $scheme = '';
    my $proxy = $self->_need_proxy($url);
    if (defined $proxy) {
	$scheme = $proxy->scheme;
    } else {
	$scheme = $url->scheme;
    }

    my $protocol;

    {
      # Honor object-specific restrictions by forcing protocol objects
      #  into class LWP::Protocol::nogo.
      my $x;
      if($x       = $self->protocols_allowed) {
        if(grep $_ 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 $_ 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
    }

    unless($protocol) {
      $protocol = eval { LWP::Protocol::create($scheme, $self) };
      if ($@) {
	$@ =~ s/ at .* line \d+.*//s;  # remove file/line number
	return _new_response($request, &HTTP::Status::RC_NOT_IMPLEMENTED, $@);
      }
    }

    # Extract fields that will be used below
    my ($timeout, $cookie_jar, $use_eval, $parse_head, $max_size) =
      @{$self}{qw(timeout cookie_jar use_eval parse_head max_size)};

    my $response;
    if ($use_eval) {
	# we eval, and turn dies into responses below
	eval {
	    $response = $protocol->request($request, $proxy,
					   $arg, $size, $timeout);
	};
	if ($@) {
	    $@ =~ s/ at .* line \d+.*//s;  # remove file/line number
	    $response =
	      HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
				  $@);
	}
    } else {
	$response = $protocol->request($request, $proxy,
				       $arg, $size, $timeout);
	# XXX: Should we die unless $response->is_success ???
    }

    $response->request($request);  # record request for reference
    $cookie_jar->extract_cookies($response) if $cookie_jar;
    $response->header("Client-Date" => HTTP::Date::time2str(time));
    return $response;
}


=item $ua->prepare_request($request)

This method modifies given C<HTTP::Request> object by setting up
various headers based on the attributes of the $ua.  The headers
affected are; C<User-Agent>, C<From>, C<Range> and C<Cookie>.

The return value is the $request object passed in.

=cut

sub prepare_request
{
    my($self, $request) = @_;
    $self->_request_sanity_check($request);

    # Extract fields that will be used below
    my ($agent, $from, $cookie_jar, $max_size) =