useragent.pm

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

    my $host_port = $uri->host_port;
    if (exists $self->{'basic_authentication'}{$host_port}{$realm}) {
	return @{ $self->{'basic_authentication'}{$host_port}{$realm} };
    }

    return (undef, undef);
}


=item $ua->agent([$product_id])

Get/set the product token that is used to identify the user agent on
the network.  The agent value is sent as the "User-Agent" header in
the requests.  The default is the string returned by the _agent()
method (see below).

If the $product_id ends with space then the C<_agent> string is
appended to it.

The user agent string should be one or more simple product identifiers
with an optional version number separated by the "/" character.
Examples are:

  $ua->agent('Checkbot/0.4 ' . $ua->_agent);
  $ua->agent('Checkbot/0.4 ');    # same as above
  $ua->agent('Mozilla/5.0');
  $ua->agent("");                 # don't identify

=item $ua->_agent

Returns the default agent identifier.  This is a string of the form
"libwww-perl/#.##", where "#.##" is substitued with the version numer
of this library.

=cut

sub agent {
    my $self = shift;
    my $old = $self->{agent};
    if (@_) {
	my $agent = shift;
	$agent .= $self->_agent if $agent && $agent =~ /\s+$/;
	$self->{agent} = $agent;
    }
    $old;
}

sub _agent     { "libwww-perl/$LWP::VERSION" }


=item $ua->from([$email_address])

Get/set the Internet e-mail address for the human user who controls
the requesting user agent.  The address should be machine-usable, as
defined in RFC 822.  The from value is send as the "From" header in
the requests.  Example:

  $ua->from('[e-mail]');

The default is to not send a "From" header.

=item $ua->timeout([$secs])

Get/set the timeout value in seconds. The default timeout() value is
180 seconds, i.e. 3 minutes.

=item $ua->cookie_jar([$cookie_jar_obj])

Get/set the cookie jar object to use.  The only requirement is that
the cookie jar object must implement the extract_cookies($request) and
add_cookie_header($response) methods.  These methods will then be
invoked by the user agent as requests are sent and responses are
received.  Normally this will be a C<HTTP::Cookies> object or some
subclass.

The default is to have no cookie_jar, i.e. never automatically add
"Cookie" headers to the requests.

Shortcut: If a reference to a plain hash is passed in as the
$cookie_jar_object, then it is replaced with an instance of
C<HTTP::Cookies> that is initalized based on the hash.  This form also
automatically loads the C<HTTP::Cookies> module.  It means that:

  $ua->cookie_jar({ file => "$ENV{HOME}/.cookies.txt" });

is really just a shortcut for:

  require HTTP::Cookies;
  $ua->cookie_jar(HTTP::Cookies->new(file => "$ENV{HOME}/.cookies.txt"));

=item $ua->conn_cache([$cache_obj])

Get/set the I<LWP::ConnCache> object to use.

=item $ua->parse_head([$boolean])

Get/set a value indicating wether we should initialize response
headers from the E<lt>head> section of HTML documents. The default is
TRUE.  Do not turn this off, unless you know what you are doing.

=item $ua->max_size([$bytes])

Get/set the size limit for response content.  The default is C<undef>,
which means that there is no limit.  If the returned response content
is only partial, because the size limit was exceeded, then a
"Client-Aborted" header will be added to the response.

=cut

sub timeout    { shift->_elem('timeout',   @_); }
sub from       { shift->_elem('from',      @_); }
sub parse_head { shift->_elem('parse_head',@_); }
sub max_size   { shift->_elem('max_size',  @_); }

sub cookie_jar {
    my $self = shift;
    my $old = $self->{cookie_jar};
    if (@_) {
	my $jar = shift;
	if (ref($jar) eq "HASH") {
	    require HTTP::Cookies;
	    $jar = HTTP::Cookies->new(%$jar);
	}
	$self->{cookie_jar} = $jar;
    }
    $old;
}

sub conn_cache {
    my $self = shift;
    my $old = $self->{conn_cache};
    if (@_) {
	my $cache = shift;
	if (ref($cache) eq "HASH") {
	    require LWP::ConnCache;
	    $cache = LWP::ConnCache->new(%$cache);
	}
	$self->{conn_cache} = $cache;
    }
    $old;
}

# depreciated
sub use_eval   { shift->_elem('use_eval',  @_); }
sub use_alarm
{
    Carp::carp("LWP::UserAgent->use_alarm(BOOL) is a no-op")
	if @_ > 1 && $^W;
    "";
}


=item $ua->clone;

Returns a copy of the LWP::UserAgent object

=cut


sub clone
{
    my $self = shift;
    my $copy = bless { %$self }, ref $self;  # copy most fields

    # elements that are references must be handled in a special way
    $copy->{'proxy'} = { %{$self->{'proxy'}} };
    $copy->{'no_proxy'} = [ @{$self->{'no_proxy'}} ];  # copy array

    # remove reference to objects for now
    delete $copy->{cookie_jar};
    delete $copy->{conn_cache};

    $copy;
}




=item $ua->mirror($url, $file)

Get and store a document identified by a URL, using If-Modified-Since,
and checking of the Content-Length.  Returns a reference to the
response object.

=cut

sub mirror
{
    my($self, $url, $file) = @_;

    LWP::Debug::trace('()');
    my $request = HTTP::Request->new('GET', $url);

    if (-e $file) {
	my($mtime) = (stat($file))[9];
	if($mtime) {
	    $request->header('If-Modified-Since' =>
			     HTTP::Date::time2str($mtime));
	}
    }
    my $tmpfile = "$file-$$";

    my $response = $self->request($request, $tmpfile);
    if ($response->is_success) {

	my $file_length = (stat($tmpfile))[7];
	my($content_length) = $response->header('Content-length');

	if (defined $content_length and $file_length < $content_length) {
	    unlink($tmpfile);
	    die "Transfer truncated: " .
		"only $file_length out of $content_length bytes received\n";
	} elsif (defined $content_length and $file_length > $content_length) {
	    unlink($tmpfile);
	    die "Content-length mismatch: " .
		"expected $content_length bytes, got $file_length\n";
	} else {
	    # OK
	    if (-e $file) {
		# Some dosish systems fail to rename if the target exists
		chmod 0777, $file;
		unlink $file;
	    }
	    rename($tmpfile, $file) or
		die "Cannot rename '$tmpfile' to '$file': $!\n";

	    if (my $lm = $response->last_modified) {
		# make sure the file has the same last modification time
		utime $lm, $lm, $file;
	    }
	}
    } else {
	unlink($tmpfile);
    }
    return $response;
}

=item $ua->proxy(...)

Set/retrieve proxy URL for a scheme:

 $ua->proxy(['http', 'ftp'], 'http://proxy.sn.no:8001/');
 $ua->proxy('gopher', 'http://proxy.sn.no:8001/');

The first form specifies that the URL is to be used for proxying of
access methods listed in the list in the first method argument,
i.e. 'http' and 'ftp'.

The second form shows a shorthand form for specifying
proxy URL for a single access scheme.

=cut

sub proxy
{
    my $self = shift;
    my $key  = shift;

    LWP::Debug::trace("$key @_");

    return map $self->proxy($_, @_), @$key if ref $key;

    my $old = $self->{'proxy'}{$key};
    $self->{'proxy'}{$key} = shift if @_;
    return $old;
}

=item $ua->env_proxy()

Load proxy settings from *_proxy environment variables.  You might
specify proxies like this (sh-syntax):

  gopher_proxy=http://proxy.my.place/
  wais_proxy=http://proxy.my.place/
  no_proxy="localhost,my.domain"
  export gopher_proxy wais_proxy no_proxy

Csh or tcsh users should use the C<setenv> command to define these
environment variables.

On systems with case-insensitive environment variables there exists a
name clash between the CGI environment variables and the C<HTTP_PROXY>
environment variable normally picked up by env_proxy().  Because of
this C<HTTP_PROXY> is not honored for CGI scripts.  The
C<CGI_HTTP_PROXY> environment variable can be used instead.

=cut

sub env_proxy {
    my ($self) = @_;
    my($k,$v);
    while(($k, $v) = each %ENV) {
	if ($ENV{REQUEST_METHOD}) {
	    # Need to be careful when called in the CGI environment, as
	    # the HTTP_PROXY variable is under control of that other guy.
	    next if $k =~ /^HTTP_/;
	    $k = "HTTP_PROXY" if $k eq "CGI_HTTP_PROXY";
	}
	$k = lc($k);
	next unless $k =~ /^(.*)_proxy$/;
	$k = $1;
	if ($k eq 'no') {
	    $self->no_proxy(split(/\s*,\s*/, $v));
	}
	else {
	    $self->proxy($k, $v);
	}
    }
}

=item $ua->no_proxy($domain,...)

Do not proxy requests to the given domains.  Calling no_proxy without
any domains clears the list of domains. Eg:

 $ua->no_proxy('localhost', 'no', ...);

=cut

sub no_proxy {
    my($self, @no) = @_;
    if (@no) {
	push(@{ $self->{'no_proxy'} }, @no);
    }
    else {
	$self->{'no_proxy'} = [];
    }
}


# Private method which returns the URL of the Proxy configured for this
# URL, or undefined if none is configured.
sub _need_proxy
{
    my($self, $url) = @_;
    $url = $HTTP::URI_CLASS->new($url) unless ref $url;

    my $scheme = $url->scheme || return;
    if (my $proxy = $self->{'proxy'}{$scheme}) {
	if (@{ $self->{'no_proxy'} }) {
	    if (my $host = eval { $url->host }) {
		for my $domain (@{ $self->{'no_proxy'} }) {
		    if ($host =~ /\Q$domain\E$/) {
			LWP::Debug::trace("no_proxy configured");
			return;
		    }
		}
	    }
	}
	LWP::Debug::debug("Proxied to $proxy");
	return $HTTP::URI_CLASS->new($proxy);
    }
    LWP::Debug::debug('Not proxied');
    undef;
}

sub _new_response {
    my($request, $code, $message) = @_;
    my $response = HTTP::Response->new($code, $message);
    $response->request($request);
    $response->header("Client-Date" => HTTP::Date::time2str(time));
    return $response;
}

1;

=back

=head1 SEE ALSO

See L<LWP> for a complete overview of libwww-perl5.  See F<lwp-request> and
F<lwp-mirror> for examples of usage.

=head1 COPYRIGHT

Copyright 1995-2001 Gisle Aas.

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut