1 package LWP::UserAgent;
4 use vars qw(@ISA $VERSION);
6 require LWP::MemberMixin;
7 @ISA = qw(LWP::MemberMixin);
11 use HTTP::Response ();
19 if ($ENV{PERL_LWP_USE_HTTP_10}) {
20 require LWP::Protocol::http10;
21 LWP::Protocol::implementor('http', 'LWP::Protocol::http10');
23 require LWP::Protocol::https10;
24 LWP::Protocol::implementor('https', 'LWP::Protocol::https10');
32 # Check for common user mistake
33 Carp::croak("Options to LWP::UserAgent should be key/value pairs, not hash reference")
34 if ref($_[1]) eq 'HASH';
36 my($class, %cnf) = @_;
38 my $agent = delete $cnf{agent};
39 my $from = delete $cnf{from};
40 my $def_headers = delete $cnf{default_headers};
41 my $timeout = delete $cnf{timeout};
42 $timeout = 3*60 unless defined $timeout;
43 my $local_address = delete $cnf{local_address};
44 my $use_eval = delete $cnf{use_eval};
45 $use_eval = 1 unless defined $use_eval;
46 my $parse_head = delete $cnf{parse_head};
47 $parse_head = 1 unless defined $parse_head;
48 my $show_progress = delete $cnf{show_progress};
49 my $max_size = delete $cnf{max_size};
50 my $max_redirect = delete $cnf{max_redirect};
51 $max_redirect = 7 unless defined $max_redirect;
52 my $env_proxy = delete $cnf{env_proxy};
54 my $cookie_jar = delete $cnf{cookie_jar};
55 my $conn_cache = delete $cnf{conn_cache};
56 my $keep_alive = delete $cnf{keep_alive};
58 Carp::croak("Can't mix conn_cache and keep_alive")
59 if $conn_cache && $keep_alive;
62 my $protocols_allowed = delete $cnf{protocols_allowed};
63 my $protocols_forbidden = delete $cnf{protocols_forbidden};
65 my $requests_redirectable = delete $cnf{requests_redirectable};
66 $requests_redirectable = ['GET', 'HEAD']
67 unless defined $requests_redirectable;
69 # Actually ""s are just as good as 0's, but for concision we'll just say:
70 Carp::croak("protocols_allowed has to be an arrayref or 0, not \"$protocols_allowed\"!")
71 if $protocols_allowed and ref($protocols_allowed) ne 'ARRAY';
72 Carp::croak("protocols_forbidden has to be an arrayref or 0, not \"$protocols_forbidden\"!")
73 if $protocols_forbidden and ref($protocols_forbidden) ne 'ARRAY';
74 Carp::croak("requests_redirectable has to be an arrayref or 0, not \"$requests_redirectable\"!")
75 if $requests_redirectable and ref($requests_redirectable) ne 'ARRAY';
79 Carp::carp("Unrecognized LWP::UserAgent options: @{[sort keys %cnf]}");
83 def_headers => $def_headers,
85 local_address => $local_address,
86 use_eval => $use_eval,
87 show_progress=> $show_progress,
88 max_size => $max_size,
89 max_redirect => $max_redirect,
92 protocols_allowed => $protocols_allowed,
93 protocols_forbidden => $protocols_forbidden,
94 requests_redirectable => $requests_redirectable,
97 $self->agent(defined($agent) ? $agent : $class->_agent)
98 if defined($agent) || !$def_headers || !$def_headers->header("User-Agent");
99 $self->from($from) if $from;
100 $self->cookie_jar($cookie_jar) if $cookie_jar;
101 $self->parse_head($parse_head);
102 $self->env_proxy if $env_proxy;
104 $self->protocols_allowed( $protocols_allowed ) if $protocols_allowed;
105 $self->protocols_forbidden($protocols_forbidden) if $protocols_forbidden;
108 $conn_cache ||= { total_capacity => $keep_alive };
110 $self->conn_cache($conn_cache) if $conn_cache;
118 my($self, $request, $arg, $size) = @_;
119 my($method, $url) = ($request->method, $request->uri);
120 my $scheme = $url->scheme;
122 local($SIG{__DIE__}); # protect against user defined die handlers
124 $self->progress("begin", $request);
126 my $response = $self->run_handlers("request_send", $request);
132 # Honor object-specific restrictions by forcing protocol objects
133 # into class LWP::Protocol::nogo.
135 if($x = $self->protocols_allowed) {
136 if (grep lc($_) eq $scheme, @$x) {
139 require LWP::Protocol::nogo;
140 $protocol = LWP::Protocol::nogo->new;
143 elsif ($x = $self->protocols_forbidden) {
144 if(grep lc($_) eq $scheme, @$x) {
145 require LWP::Protocol::nogo;
146 $protocol = LWP::Protocol::nogo->new;
149 # else fall thru and create the protocol object normally
152 # Locate protocol to use
153 my $proxy = $request->{proxy};
155 $scheme = $proxy->scheme;
159 $protocol = eval { LWP::Protocol::create($scheme, $self) };
161 $@ =~ s/ at .* line \d+.*//s; # remove file/line number
162 $response = _new_response($request, &HTTP::Status::RC_NOT_IMPLEMENTED, $@);
163 if ($scheme eq "https") {
164 $response->message($response->message . " (Crypt::SSLeay or IO::Socket::SSL not installed)");
165 $response->content_type("text/plain");
166 $response->content(<<EOT);
167 LWP will support https URLs if either Crypt::SSLeay or IO::Socket::SSL
168 is installed. More information at
169 <http://search.cpan.org/dist/libwww-perl/README.SSL>.
175 if (!$response && $self->{use_eval}) {
176 # we eval, and turn dies into responses below
178 $response = $protocol->request($request, $proxy,
179 $arg, $size, $self->{timeout});
182 $@ =~ s/ at .* line \d+.*//s; # remove file/line number
183 $response = _new_response($request,
184 &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
189 $response = $protocol->request($request, $proxy,
190 $arg, $size, $self->{timeout});
191 # XXX: Should we die unless $response->is_success ???
195 $response->request($request); # record request for reference
196 $response->header("Client-Date" => HTTP::Date::time2str(time));
198 $self->run_handlers("response_done", $response);
200 $self->progress("end", $response);
207 my($self, $request) = @_;
208 die "Method missing" unless $request->method;
209 my $url = $request->uri;
210 die "URL missing" unless $url;
211 die "URL must be absolute" unless $url->scheme;
213 $self->run_handlers("request_preprepare", $request);
215 if (my $def_headers = $self->{def_headers}) {
216 for my $h ($def_headers->header_field_names) {
217 $request->init_header($h => [$def_headers->header($h)]);
221 $self->run_handlers("request_prepare", $request);
229 my($self, $request, $arg, $size) = @_;
231 # sanity check the request passed in
232 if (defined $request) {
234 Carp::croak("You need a request object, not a " . ref($request) . " object")
235 if ref($request) eq 'ARRAY' or ref($request) eq 'HASH' or
236 !$request->can('method') or !$request->can('uri');
239 Carp::croak("You need a request object, not '$request'");
243 Carp::croak("No request object passed in");
247 $request = $self->prepare_request($request);
250 $@ =~ s/ at .* line \d+.*//s; # remove file/line number
251 return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, $@);
253 return $self->send_request($request, $arg, $size);
259 my($self, $request, $arg, $size, $previous) = @_;
261 my $response = $self->simple_request($request, $arg, $size);
262 $response->previous($previous) if $previous;
264 if ($response->redirects >= $self->{max_redirect}) {
265 $response->header("Client-Warning" =>
266 "Redirect loop detected (max_redirect = $self->{max_redirect})");
270 if (my $req = $self->run_handlers("response_redirect", $response)) {
271 return $self->request($req, $arg, $size, $response);
274 my $code = $response->code;
276 if ($code == &HTTP::Status::RC_MOVED_PERMANENTLY or
277 $code == &HTTP::Status::RC_FOUND or
278 $code == &HTTP::Status::RC_SEE_OTHER or
279 $code == &HTTP::Status::RC_TEMPORARY_REDIRECT)
281 my $referral = $request->clone;
283 # These headers should never be forwarded
284 $referral->remove_header('Host', 'Cookie');
286 if ($referral->header('Referer') &&
287 $request->uri->scheme eq 'https' &&
288 $referral->uri->scheme eq 'http')
290 # RFC 2616, section 15.1.3.
291 # https -> http redirect, suppressing Referer
292 $referral->remove_header('Referer');
295 if ($code == &HTTP::Status::RC_SEE_OTHER ||
296 $code == &HTTP::Status::RC_FOUND)
298 my $method = uc($referral->method);
299 unless ($method eq "GET" || $method eq "HEAD") {
300 $referral->method("GET");
301 $referral->content("");
302 $referral->remove_content_headers;
306 # And then we update the URL based on the Location:-header.
307 my $referral_uri = $response->header('Location');
309 # Some servers erroneously return a relative URL for redirects,
310 # so make it absolute if it not already is.
311 local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
312 my $base = $response->base;
313 $referral_uri = "" unless defined $referral_uri;
314 $referral_uri = $HTTP::URI_CLASS->new($referral_uri, $base)
317 $referral->uri($referral_uri);
319 return $response unless $self->redirect_ok($referral, $response);
320 return $self->request($referral, $arg, $size, $response);
323 elsif ($code == &HTTP::Status::RC_UNAUTHORIZED ||
324 $code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED
327 my $proxy = ($code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED);
328 my $ch_header = $proxy ? "Proxy-Authenticate" : "WWW-Authenticate";
329 my @challenge = $response->header($ch_header);
330 unless (@challenge) {
331 $response->header("Client-Warning" =>
332 "Missing Authenticate header");
336 require HTTP::Headers::Util;
337 CHALLENGE: for my $challenge (@challenge) {
338 $challenge =~ tr/,/;/; # "," is used to separate auth-params!!
339 ($challenge) = HTTP::Headers::Util::split_header_words($challenge);
340 my $scheme = shift(@$challenge);
341 shift(@$challenge); # no value
342 $challenge = { @$challenge }; # make rest into a hash
344 unless ($scheme =~ /^([a-z]+(?:-[a-z]+)*)$/) {
345 $response->header("Client-Warning" =>
346 "Bad authentication scheme '$scheme'");
349 $scheme = $1; # untainted now
350 my $class = "LWP::Authen::\u$scheme";
354 unless (%{"$class\::"}) {
356 eval "require $class";
358 if ($@ =~ /^Can\'t locate/) {
359 $response->header("Client-Warning" =>
360 "Unsupported authentication scheme '$scheme'");
363 $response->header("Client-Warning" => $@);
368 unless ($class->can("authenticate")) {
369 $response->header("Client-Warning" =>
370 "Unsupported authentication scheme '$scheme'");
373 return $class->authenticate($self, $proxy, $challenge, $response,
374 $request, $arg, $size);
383 # Now the shortcuts...
386 require HTTP::Request::Common;
387 my($self, @parameters) = @_;
388 my @suff = $self->_process_colonic_headers(\@parameters,1);
389 return $self->request( HTTP::Request::Common::GET( @parameters ), @suff );
394 require HTTP::Request::Common;
395 my($self, @parameters) = @_;
396 my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1));
397 return $self->request( HTTP::Request::Common::POST( @parameters ), @suff );
402 require HTTP::Request::Common;
403 my($self, @parameters) = @_;
404 my @suff = $self->_process_colonic_headers(\@parameters,1);
405 return $self->request( HTTP::Request::Common::HEAD( @parameters ), @suff );
409 sub _process_colonic_headers {
410 # Process :content_cb / :content_file / :read_size_hint headers.
411 my($self, $args, $start_index) = @_;
414 for(my $i = $start_index; $i < @$args; $i += 2) {
415 next unless defined $args->[$i];
417 #printf "Considering %s => %s\n", $args->[$i], $args->[$i + 1];
419 if($args->[$i] eq ':content_cb') {
420 # Some sanity-checking...
421 $arg = $args->[$i + 1];
422 Carp::croak("A :content_cb value can't be undef") unless defined $arg;
423 Carp::croak("A :content_cb value must be a coderef")
424 unless ref $arg and UNIVERSAL::isa($arg, 'CODE');
427 elsif ($args->[$i] eq ':content_file') {
428 $arg = $args->[$i + 1];
430 # Some sanity-checking...
431 Carp::croak("A :content_file value can't be undef")
433 Carp::croak("A :content_file value can't be a reference")
435 Carp::croak("A :content_file value can't be \"\"")
439 elsif ($args->[$i] eq ':read_size_hint') {
440 $size = $args->[$i + 1];
441 # Bother checking it?
447 splice @$args, $i, 2;
451 # And return a suitable suffix-list for request(REQ,...)
453 return unless defined $arg;
454 return $arg, $size if defined $size;
458 my @ANI = qw(- \ | /);
461 my($self, $status, $m) = @_;
462 return unless $self->{show_progress};
465 if ($status eq "begin") {
466 print STDERR "** ", $m->method, " ", $m->uri, " ==> ";
467 $self->{progress_start} = time;
468 $self->{progress_lastp} = "";
469 $self->{progress_ani} = 0;
471 elsif ($status eq "end") {
472 delete $self->{progress_lastp};
473 delete $self->{progress_ani};
474 print STDERR $m->status_line;
475 my $t = time - delete $self->{progress_start};
476 print STDERR " (${t}s)" if $t;
479 elsif ($status eq "tick") {
480 print STDERR "$ANI[$self->{progress_ani}++]\b";
481 $self->{progress_ani} %= @ANI;
484 my $p = sprintf "%3.0f%%", $status * 100;
485 return if $p eq $self->{progress_lastp};
486 print STDERR "$p\b\b\b\b";
487 $self->{progress_lastp} = $p;
494 # This whole allow/forbid thing is based on man 1 at's way of doing things.
496 sub is_protocol_supported
498 my($self, $scheme) = @_;
500 # assume we got a reference to an URI object
501 $scheme = $scheme->scheme;
504 Carp::croak("Illegal scheme '$scheme' passed to is_protocol_supported")
506 $scheme = lc $scheme;
510 if(ref($self) and $x = $self->protocols_allowed) {
511 return 0 unless grep lc($_) eq $scheme, @$x;
513 elsif (ref($self) and $x = $self->protocols_forbidden) {
514 return 0 if grep lc($_) eq $scheme, @$x;
517 local($SIG{__DIE__}); # protect against user defined die handlers
518 $x = LWP::Protocol::implementor($scheme);
519 return 1 if $x and $x ne 'LWP::Protocol::nogo';
524 sub protocols_allowed { shift->_elem('protocols_allowed' , @_) }
525 sub protocols_forbidden { shift->_elem('protocols_forbidden' , @_) }
526 sub requests_redirectable { shift->_elem('requests_redirectable', @_) }
531 # RFC 2616, section 10.3.2 and 10.3.3 say:
532 # If the 30[12] status code is received in response to a request other
533 # than GET or HEAD, the user agent MUST NOT automatically redirect the
534 # request unless it can be confirmed by the user, since this might
535 # change the conditions under which the request was issued.
537 # Note that this routine used to be just:
538 # return 0 if $_[1]->method eq "POST"; return 1;
540 my($self, $new_request, $response) = @_;
541 my $method = $response->request->method;
542 return 0 unless grep $_ eq $method,
543 @{ $self->requests_redirectable || [] };
545 if ($new_request->uri->scheme eq 'file') {
546 $response->header("Client-Warning" =>
547 "Can't redirect to a file:// URL!");
551 # Otherwise it's apparently okay...
559 my $netloc = lc(shift);
560 my $realm = shift || "";
561 my $old = $self->{basic_authentication}{$netloc}{$realm};
563 $self->{basic_authentication}{$netloc}{$realm} = [@_];
566 return @$old if wantarray;
567 return join(":", @$old);
571 sub get_basic_credentials
573 my($self, $realm, $uri, $proxy) = @_;
575 return $self->credentials($uri->host_port, $realm);
579 sub timeout { shift->_elem('timeout', @_); }
580 sub local_address{ shift->_elem('local_address',@_); }
581 sub max_size { shift->_elem('max_size', @_); }
582 sub max_redirect { shift->_elem('max_redirect', @_); }
583 sub show_progress{ shift->_elem('show_progress', @_); }
590 my $old = $self->set_my_handler("response_header", $flag ? sub {
591 my($response, $ua) = @_;
592 require HTML::HeadParser;
593 $parser = HTML::HeadParser->new;
594 $parser->xml_mode(1) if $response->content_is_xhtml;
595 $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
597 push(@{$response->{handlers}{response_data}}, {
599 return unless $parser;
600 unless ($parser->parse($_[3])) {
601 my $h = $parser->header;
603 for my $f ($h->header_field_names) {
604 $r->init_header($f, [$h->header($f)]);
612 m_media_type => "html",
617 return !!$self->get_my_handler("response_header");
623 my $old = $self->{cookie_jar};
626 if (ref($jar) eq "HASH") {
627 require HTTP::Cookies;
628 $jar = HTTP::Cookies->new(%$jar);
630 $self->{cookie_jar} = $jar;
631 $self->set_my_handler("request_prepare",
632 $jar ? sub { $jar->add_cookie_header($_[0]); } : undef,
634 $self->set_my_handler("response_done",
635 $jar ? sub { $jar->extract_cookies($_[0]); } : undef,
641 sub default_headers {
643 my $old = $self->{def_headers} ||= HTTP::Headers->new;
645 Carp::croak("default_headers not set to HTTP::Headers compatible object")
646 unless @_ == 1 && $_[0]->can("header_field_names");
647 $self->{def_headers} = shift;
654 return $self->default_headers->header(@_);
657 sub _agent { "libwww-perl/$LWP::VERSION" }
664 $agent .= $self->_agent if $agent =~ /\s+$/;
669 return $self->default_header("User-Agent", $agent);
671 return $self->default_header("User-Agent");
676 return $self->default_header("From", @_);
682 my $old = $self->{conn_cache};
685 if (ref($cache) eq "HASH") {
686 require LWP::ConnCache;
687 $cache = LWP::ConnCache->new(%$cache);
689 $self->{conn_cache} = $cache;
696 my($self, $phase, $cb, %spec) = @_;
697 $spec{line} ||= join(":", (caller)[1,2]);
698 my $conf = $self->{handlers}{$phase} ||= do {
699 require HTTP::Config;
702 $conf->add(%spec, callback => $cb);
706 my($self, $phase, $cb, %spec) = @_;
707 $spec{owner} = (caller(1))[3] unless exists $spec{owner};
708 $self->remove_handler($phase, %spec);
709 $spec{line} ||= join(":", (caller)[1,2]);
710 $self->add_handler($phase, $cb, %spec) if $cb;
716 my $init = pop if @_ % 2;
718 my $conf = $self->{handlers}{$phase};
721 require HTTP::Config;
722 $conf = $self->{handlers}{$phase} = HTTP::Config->new;
724 $spec{owner} = (caller(1))[3] unless exists $spec{owner};
725 my @h = $conf->find(%spec);
727 if (ref($init) eq "CODE") {
730 elsif (ref($init) eq "HASH") {
731 while (my($k, $v) = each %$init) {
735 $spec{callback} ||= sub {};
736 $spec{line} ||= join(":", (caller)[1,2]);
740 return wantarray ? @h : $h[0];
744 my($self, $phase, %spec) = @_;
746 my $conf = $self->{handlers}{$phase} || return;
747 my @h = $conf->remove(%spec);
748 delete $self->{handlers}{$phase} if $conf->empty;
752 return unless $self->{handlers};
753 return map $self->remove_handler($_), sort keys %{$self->{handlers}};
757 my($self, $phase, $o) = @_;
759 if ($o->{handlers} && $o->{handlers}{$phase}) {
760 push(@h, @{$o->{handlers}{$phase}});
762 if (my $conf = $self->{handlers}{$phase}) {
763 push(@h, $conf->matching($o));
769 my($self, $phase, $o) = @_;
770 if (defined(wantarray)) {
771 for my $h ($self->handlers($phase, $o)) {
772 my $ret = $h->{callback}->($o, $self, $h);
778 for my $h ($self->handlers($phase, $o)) {
779 $h->{callback}->($o, $self, $h);
785 sub use_eval { shift->_elem('use_eval', @_); }
788 Carp::carp("LWP::UserAgent->use_alarm(BOOL) is a no-op")
797 my $copy = bless { %$self }, ref $self; # copy most fields
799 delete $copy->{handlers};
800 delete $copy->{conn_cache};
802 # copy any plain arrays and hashes; known not to need recursive copy
803 for my $k (qw(proxy no_proxy requests_redirectable)) {
804 next unless $copy->{$k};
805 if (ref($copy->{$k}) eq "ARRAY") {
806 $copy->{$k} = [ @{$copy->{$k}} ];
808 elsif (ref($copy->{$k}) eq "HASH") {
809 $copy->{$k} = { %{$copy->{$k}} };
813 if ($self->{def_headers}) {
814 $copy->{def_headers} = $self->{def_headers}->clone;
817 # re-enable standard handlers
818 $copy->parse_head($self->parse_head);
820 # no easy way to clone the cookie jar; so let's just remove it for now
821 $copy->cookie_jar(undef);
829 my($self, $url, $file) = @_;
831 my $request = HTTP::Request->new('GET', $url);
833 # If the file exists, add a cache-related header
835 my ($mtime) = ( stat($file) )[9];
837 $request->header( 'If-Modified-Since' => HTTP::Date::time2str($mtime) );
840 my $tmpfile = "$file-$$";
842 my $response = $self->request($request, $tmpfile);
843 if ( $response->header('X-Died') ) {
844 die $response->header('X-Died');
847 # Only fetching a fresh copy of the would be considered success.
848 # If the file was not modified, "304" would returned, which
849 # is considered by HTTP::Status to be a "redirect", /not/ "success"
850 if ( $response->is_success ) {
851 my @stat = stat($tmpfile) or die "Could not stat tmpfile '$tmpfile': $!";
852 my $file_length = $stat[7];
853 my ($content_length) = $response->header('Content-length');
855 if ( defined $content_length and $file_length < $content_length ) {
857 die "Transfer truncated: " . "only $file_length out of $content_length bytes received\n";
859 elsif ( defined $content_length and $file_length > $content_length ) {
861 die "Content-length mismatch: " . "expected $content_length bytes, got $file_length\n";
863 # The file was the expected length.
865 # Replace the stale file with a fresh copy
867 # Some dosish systems fail to rename if the target exists
871 rename( $tmpfile, $file )
872 or die "Cannot rename '$tmpfile' to '$file': $!\n";
874 # make sure the file has the same last modification time
875 if ( my $lm = $response->last_modified ) {
876 utime $lm, $lm, $file;
880 # The local copy is fresh enough, so just delete the temp file
890 return if exists $req->{proxy};
891 my $proxy = $ua->{proxy}{$req->uri->scheme} || return;
892 if ($ua->{no_proxy}) {
893 if (my $host = eval { $req->uri->host }) {
894 for my $domain (@{$ua->{no_proxy}}) {
895 if ($host =~ /\Q$domain\E$/) {
901 $req->{proxy} = $HTTP::URI_CLASS->new($proxy);
909 return map $self->proxy($_, @_), @$key if ref $key;
911 Carp::croak("'$key' is not a valid URI scheme") unless $key =~ /^$URI::scheme_re\z/;
912 my $old = $self->{'proxy'}{$key};
915 if (defined($url) && length($url)) {
916 Carp::croak("Proxy must be specified as absolute URI; '$url' is not") unless $url =~ /^$URI::scheme_re:/;
917 Carp::croak("Bad http proxy specification '$url'") if $url =~ /^https?:/ && $url !~ m,^https?://\w,;
919 $self->{proxy}{$key} = $url;
920 $self->set_my_handler("request_preprepare", \&_need_proxy)
929 while(($k, $v) = each %ENV) {
930 if ($ENV{REQUEST_METHOD}) {
931 # Need to be careful when called in the CGI environment, as
932 # the HTTP_PROXY variable is under control of that other guy.
933 next if $k =~ /^HTTP_/;
934 $k = "HTTP_PROXY" if $k eq "CGI_HTTP_PROXY";
937 next unless $k =~ /^(.*)_proxy$/;
940 $self->no_proxy(split(/\s*,\s*/, $v));
943 # Ignore random _proxy variables, allow only valid schemes
944 next unless $k =~ /^$URI::scheme_re\z/;
945 # Ignore xxx_proxy variables if xxx isn't a supported protocol
946 next unless LWP::Protocol::implementor($k);
947 $self->proxy($k, $v);
956 push(@{ $self->{'no_proxy'} }, @no);
959 $self->{'no_proxy'} = [];
965 my($request, $code, $message) = @_;
966 my $response = HTTP::Response->new($code, $message);
967 $response->request($request);
968 $response->header("Client-Date" => HTTP::Date::time2str(time));
969 $response->header("Client-Warning" => "Internal response");
970 $response->header("Content-Type" => "text/plain");
971 $response->content("$code $message\n");
982 LWP::UserAgent - Web user agent class
986 require LWP::UserAgent;
988 my $ua = LWP::UserAgent->new;
992 my $response = $ua->get('http://search.cpan.org/');
994 if ($response->is_success) {
995 print $response->decoded_content; # or whatever
998 die $response->status_line;
1003 The C<LWP::UserAgent> is a class implementing a web user agent.
1004 C<LWP::UserAgent> objects can be used to dispatch web requests.
1006 In normal use the application creates an C<LWP::UserAgent> object, and
1007 then configures it with values for timeouts, proxies, name, etc. It
1008 then creates an instance of C<HTTP::Request> for the request that
1009 needs to be performed. This request is then passed to one of the
1010 request method the UserAgent, which dispatches it using the relevant
1011 protocol, and returns a C<HTTP::Response> object. There are
1012 convenience methods for sending the most common request types: get(),
1013 head() and post(). When using these methods then the creation of the
1014 request object is hidden as shown in the synopsis above.
1016 The basic approach of the library is to use HTTP style communication
1017 for all protocol schemes. This means that you will construct
1018 C<HTTP::Request> objects and receive C<HTTP::Response> objects even
1019 for non-HTTP resources like I<gopher> and I<ftp>. In order to achieve
1020 even more similarity to HTTP style communications, gopher menus and
1021 file directories are converted to HTML documents.
1023 =head1 CONSTRUCTOR METHODS
1025 The following constructor methods are available:
1029 =item $ua = LWP::UserAgent->new( %options )
1031 This method constructs a new C<LWP::UserAgent> object and returns it.
1032 Key/value pair arguments may be provided to set up the initial state.
1033 The following options correspond to attribute methods described below:
1036 ----------- --------------------
1037 agent "libwww-perl/#.###"
1041 default_headers HTTP::Headers->new
1046 protocols_allowed undef
1047 protocols_forbidden undef
1048 requests_redirectable ['GET', 'HEAD']
1051 The following additional options are also accepted: If the
1052 C<env_proxy> option is passed in with a TRUE value, then proxy
1053 settings are read from environment variables (see env_proxy() method
1054 below). If the C<keep_alive> option is passed in, then a
1055 C<LWP::ConnCache> is set up (see conn_cache() method below). The
1056 C<keep_alive> value is passed on as the C<total_capacity> for the
1061 Returns a copy of the LWP::UserAgent object.
1067 The settings of the configuration attributes modify the behaviour of the
1068 C<LWP::UserAgent> when it dispatches requests. Most of these can also
1069 be initialized by options passed to the constructor method.
1071 The following attribute methods are provided. The attribute value is
1072 left unchanged if no argument is given. The return value from each
1073 method is the old attribute value.
1079 =item $ua->agent( $product_id )
1081 Get/set the product token that is used to identify the user agent on
1082 the network. The agent value is sent as the "User-Agent" header in
1083 the requests. The default is the string returned by the _agent()
1086 If the $product_id ends with space then the _agent() string is
1089 The user agent string should be one or more simple product identifiers
1090 with an optional version number separated by the "/" character.
1093 $ua->agent('Checkbot/0.4 ' . $ua->_agent);
1094 $ua->agent('Checkbot/0.4 '); # same as above
1095 $ua->agent('Mozilla/5.0');
1096 $ua->agent(""); # don't identify
1100 Returns the default agent identifier. This is a string of the form
1101 "libwww-perl/#.###", where "#.###" is substituted with the version number
1106 =item $ua->from( $email_address )
1108 Get/set the e-mail address for the human user who controls
1109 the requesting user agent. The address should be machine-usable, as
1110 defined in RFC 822. The C<from> value is send as the "From" header in
1111 the requests. Example:
1113 $ua->from('gaas@cpan.org');
1115 The default is to not send a "From" header. See the default_headers()
1116 method for the more general interface that allow any header to be defaulted.
1118 =item $ua->cookie_jar
1120 =item $ua->cookie_jar( $cookie_jar_obj )
1122 Get/set the cookie jar object to use. The only requirement is that
1123 the cookie jar object must implement the extract_cookies($request) and
1124 add_cookie_header($response) methods. These methods will then be
1125 invoked by the user agent as requests are sent and responses are
1126 received. Normally this will be a C<HTTP::Cookies> object or some
1129 The default is to have no cookie_jar, i.e. never automatically add
1130 "Cookie" headers to the requests.
1132 Shortcut: If a reference to a plain hash is passed in as the
1133 $cookie_jar_object, then it is replaced with an instance of
1134 C<HTTP::Cookies> that is initialized based on the hash. This form also
1135 automatically loads the C<HTTP::Cookies> module. It means that:
1137 $ua->cookie_jar({ file => "$ENV{HOME}/.cookies.txt" });
1139 is really just a shortcut for:
1141 require HTTP::Cookies;
1142 $ua->cookie_jar(HTTP::Cookies->new(file => "$ENV{HOME}/.cookies.txt"));
1144 =item $ua->default_headers
1146 =item $ua->default_headers( $headers_obj )
1148 Get/set the headers object that will provide default header values for
1149 any requests sent. By default this will be an empty C<HTTP::Headers>
1152 =item $ua->default_header( $field )
1154 =item $ua->default_header( $field => $value )
1156 This is just a short-cut for $ua->default_headers->header( $field =>
1159 $ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable());
1160 $ua->default_header('Accept-Language' => "no, en");
1162 =item $ua->conn_cache
1164 =item $ua->conn_cache( $cache_obj )
1166 Get/set the C<LWP::ConnCache> object to use. See L<LWP::ConnCache>
1169 =item $ua->credentials( $netloc, $realm )
1171 =item $ua->credentials( $netloc, $realm, $uname, $pass )
1173 Get/set the user name and password to be used for a realm.
1175 The $netloc is a string of the form "<host>:<port>". The username and
1176 password will only be passed to this server. Example:
1178 $ua->credentials("www.example.com:80", "Some Realm", "foo", "secret");
1180 =item $ua->local_address
1182 =item $ua->local_address( $address )
1184 Get/set the local interface to bind to for network connections. The interface
1185 can be specified as a hostname or an IP address. This value is passed as the
1186 C<LocalAddr> argument to L<IO::Socket::INET>.
1190 =item $ua->max_size( $bytes )
1192 Get/set the size limit for response content. The default is C<undef>,
1193 which means that there is no limit. If the returned response content
1194 is only partial, because the size limit was exceeded, then a
1195 "Client-Aborted" header will be added to the response. The content
1196 might end up longer than C<max_size> as we abort once appending a
1197 chunk of data makes the length exceed the limit. The "Content-Length"
1198 header, if present, will indicate the length of the full content and
1199 will normally not be the same as C<< length($res->content) >>.
1201 =item $ua->max_redirect
1203 =item $ua->max_redirect( $n )
1205 This reads or sets the object's limit of how many times it will obey
1206 redirection responses in a given request cycle.
1208 By default, the value is 7. This means that if you call request()
1209 method and the response is a redirect elsewhere which is in turn a
1210 redirect, and so on seven times, then LWP gives up after that seventh
1213 =item $ua->parse_head
1215 =item $ua->parse_head( $boolean )
1217 Get/set a value indicating whether we should initialize response
1218 headers from the E<lt>head> section of HTML documents. The default is
1219 TRUE. Do not turn this off, unless you know what you are doing.
1221 =item $ua->protocols_allowed
1223 =item $ua->protocols_allowed( \@protocols )
1225 This reads (or sets) this user agent's list of protocols that the
1226 request methods will exclusively allow. The protocol names are case
1229 For example: C<$ua-E<gt>protocols_allowed( [ 'http', 'https'] );>
1230 means that this user agent will I<allow only> those protocols,
1231 and attempts to use this user agent to access URLs with any other
1232 schemes (like "ftp://...") will result in a 500 error.
1234 To delete the list, call: C<$ua-E<gt>protocols_allowed(undef)>
1236 By default, an object has neither a C<protocols_allowed> list, nor a
1237 C<protocols_forbidden> list.
1239 Note that having a C<protocols_allowed> list causes any
1240 C<protocols_forbidden> list to be ignored.
1242 =item $ua->protocols_forbidden
1244 =item $ua->protocols_forbidden( \@protocols )
1246 This reads (or sets) this user agent's list of protocols that the
1247 request method will I<not> allow. The protocol names are case
1250 For example: C<$ua-E<gt>protocols_forbidden( [ 'file', 'mailto'] );>
1251 means that this user agent will I<not> allow those protocols, and
1252 attempts to use this user agent to access URLs with those schemes
1253 will result in a 500 error.
1255 To delete the list, call: C<$ua-E<gt>protocols_forbidden(undef)>
1257 =item $ua->requests_redirectable
1259 =item $ua->requests_redirectable( \@requests )
1261 This reads or sets the object's list of request names that
1262 C<$ua-E<gt>redirect_ok(...)> will allow redirection for. By
1263 default, this is C<['GET', 'HEAD']>, as per RFC 2616. To
1264 change to include 'POST', consider:
1266 push @{ $ua->requests_redirectable }, 'POST';
1268 =item $ua->show_progress
1270 =item $ua->show_progress( $boolean )
1272 Get/set a value indicating whether a progress bar should be displayed
1273 on on the terminal as requests are processed. The default is FALSE.
1277 =item $ua->timeout( $secs )
1279 Get/set the timeout value in seconds. The default timeout() value is
1280 180 seconds, i.e. 3 minutes.
1282 The requests is aborted if no activity on the connection to the server
1283 is observed for C<timeout> seconds. This means that the time it takes
1284 for the complete transaction and the request() method to actually
1285 return might be longer.
1289 =head2 Proxy attributes
1291 The following methods set up when requests should be passed via a
1296 =item $ua->proxy(\@schemes, $proxy_url)
1298 =item $ua->proxy($scheme, $proxy_url)
1300 Set/retrieve proxy URL for a scheme:
1302 $ua->proxy(['http', 'ftp'], 'http://proxy.sn.no:8001/');
1303 $ua->proxy('gopher', 'http://proxy.sn.no:8001/');
1305 The first form specifies that the URL is to be used for proxying of
1306 access methods listed in the list in the first method argument,
1307 i.e. 'http' and 'ftp'.
1309 The second form shows a shorthand form for specifying
1310 proxy URL for a single access scheme.
1312 =item $ua->no_proxy( $domain, ... )
1314 Do not proxy requests to the given domains. Calling no_proxy without
1315 any domains clears the list of domains. Eg:
1317 $ua->no_proxy('localhost', 'example.com');
1319 =item $ua->env_proxy
1321 Load proxy settings from *_proxy environment variables. You might
1322 specify proxies like this (sh-syntax):
1324 gopher_proxy=http://proxy.my.place/
1325 wais_proxy=http://proxy.my.place/
1326 no_proxy="localhost,example.com"
1327 export gopher_proxy wais_proxy no_proxy
1329 csh or tcsh users should use the C<setenv> command to define these
1330 environment variables.
1332 On systems with case insensitive environment variables there exists a
1333 name clash between the CGI environment variables and the C<HTTP_PROXY>
1334 environment variable normally picked up by env_proxy(). Because of
1335 this C<HTTP_PROXY> is not honored for CGI scripts. The
1336 C<CGI_HTTP_PROXY> environment variable can be used instead.
1342 Handlers are code that injected at various phases during the
1343 processing of requests. The following methods are provided to manage
1344 the active handlers:
1348 =item $ua->add_handler( $phase => \&cb, %matchspec )
1350 Add handler to be invoked in the given processing phase. For how to
1351 specify %matchspec see L<HTTP::Config/"Matching">.
1353 The possible values $phase and the corresponding callback signatures are:
1357 =item request_preprepare => sub { my($request, $ua, $h) = @_; ... }
1359 The handler is called before the C<request_prepare> and other standard
1360 initialization of of the request. This can be used to set up headers
1361 and attributes that the C<request_prepare> handler depends on. Proxy
1362 initialization should take place here; but in general don't register
1363 handlers for this phase.
1365 =item request_prepare => sub { my($request, $ua, $h) = @_; ... }
1367 The handler is called before the request is sent and can modify the
1368 request any way it see fit. This can for instance be used to add
1369 certain headers to specific requests.
1371 The method can assign a new request object to $_[0] to replace the
1372 request that is sent fully.
1374 The return value from the callback is ignored. If an exceptions is
1375 raised it will abort the request and make the request method return a
1376 "400 Bad request" response.
1378 =item request_send => sub { my($request, $ua, $h) = @_; ... }
1380 This handler get a chance of handling requests before it's sent to the
1381 protocol handlers. It should return an HTTP::Response object if it
1382 wishes to terminate the processing; otherwise it should return nothing.
1384 The C<response_header> and C<response_data> handlers will not be
1385 invoked for this response, but the C<response_done> will be.
1387 =item response_header => sub { my($response, $ua, $h) = @_; ... }
1389 This handler is called right after the response headers have been
1390 received, but before any content data. The handler might set up
1391 handlers for data and might croak to abort the request.
1393 The handler might set the $response->{default_add_content} value to
1394 control if any received data should be added to the response object
1395 directly. This will initially be false if the $ua->request() method
1396 was called with a ':content_filename' or ':content_callbak' argument;
1399 =item response_data => sub { my($response, $ua, $h, $data) = @_; ... }
1401 This handlers is called for each chunk of data received for the
1402 response. The handler might croak to abort the request.
1404 This handler need to return a TRUE value to be called again for
1405 subsequent chunks for the same request.
1407 =item response_done => sub { my($response, $ua, $h) = @_; ... }
1409 The handler is called after the response has been fully received, but
1410 before any redirect handling is attempted. The handler can be used to
1411 extract information or modify the response.
1413 =item response_redirect => sub { my($response, $ua, $h) = @_; ... }
1415 The handler is called in $ua->request after C<response_done>. If the
1416 handler return an HTTP::Request object we'll start over with processing
1417 this request instead.
1421 =item $ua->remove_handler( undef, %matchspec )
1423 =item $ua->remove_handler( $phase, %matchspec )
1425 Remove handlers that match the given %matchspec. If $phase is not
1426 provided remove handlers from all phases.
1428 Be careful as calling this function with %matchspec that is not not
1429 specific enough can remove handlers not owned by you. It's probably
1430 better to use the set_my_handler() method instead.
1432 The removed handlers are returned.
1434 =item $ua->set_my_handler( $phase, $cb, %matchspec )
1436 Set handlers private to the executing subroutine. Works by defaulting
1437 an C<owner> field to the %matchhspec that holds the name of the called
1438 subroutine. You might pass an explicit C<owner> to override this.
1440 If $cb is passed as C<undef>, remove the handler.
1442 =item $ua->get_my_handler( $phase, %matchspec )
1444 =item $ua->get_my_handler( $phase, %matchspec, $init )
1446 Will retrieve the matching handler as hash ref.
1448 If C<$init> is passed passed as a TRUE value, create and add the
1449 handler if it's not found. If $init is a subroutine reference, then
1450 it's called with the created handler hash as argument. This sub might
1451 populate the hash with extra fields; especially the callback. If
1452 $init is a hash reference, merge the hashes.
1454 =item $ua->handlers( $phase, $request )
1456 =item $ua->handlers( $phase, $response )
1458 Returns the handlers that apply to the given request or response at
1459 the given processing phase.
1463 =head1 REQUEST METHODS
1465 The methods described in this section are used to dispatch requests
1466 via the user agent. The following request methods are provided:
1470 =item $ua->get( $url )
1472 =item $ua->get( $url , $field_name => $value, ... )
1474 This method will dispatch a C<GET> request on the given $url. Further
1475 arguments can be given to initialize the headers of the request. These
1476 are given as separate name/value pairs. The return value is a
1477 response object. See L<HTTP::Response> for a description of the
1478 interface it provides.
1480 There will still be a response object returned when LWP can't connect to the
1481 server specified in the URL or when other failures in protocol handlers occur.
1482 These internal responses use the standard HTTP status codes, so the responses
1483 can't be differentiated by testing the response status code alone. Error
1484 responses that LWP generates internally will have the "Client-Warning" header
1485 set to the value "Internal response". If you need to differentiate these
1486 internal responses from responses that a remote server actually generates, you
1487 need to test this header value.
1489 Fields names that start with ":" are special. These will not
1490 initialize headers of the request but will determine how the response
1491 content is treated. The following special field names are recognized:
1493 :content_file => $filename
1494 :content_cb => \&callback
1495 :read_size_hint => $bytes
1497 If a $filename is provided with the C<:content_file> option, then the
1498 response content will be saved here instead of in the response
1499 object. If a callback is provided with the C<:content_cb> option then
1500 this function will be called for each chunk of the response content as
1501 it is received from the server. If neither of these options are
1502 given, then the response content will accumulate in the response
1503 object itself. This might not be suitable for very large response
1504 bodies. Only one of C<:content_file> or C<:content_cb> can be
1505 specified. The content of unsuccessful responses will always
1506 accumulate in the response object itself, regardless of the
1507 C<:content_file> or C<:content_cb> options passed in.
1509 The C<:read_size_hint> option is passed to the protocol module which
1510 will try to read data from the server in chunks of this size. A
1511 smaller value for the C<:read_size_hint> will result in a higher
1512 number of callback invocations.
1514 The callback function is called with 3 arguments: a chunk of data, a
1515 reference to the response object, and a reference to the protocol
1516 object. The callback can abort the request by invoking die(). The
1517 exception message will show up as the "X-Died" header field in the
1518 response returned by the get() function.
1520 =item $ua->head( $url )
1522 =item $ua->head( $url , $field_name => $value, ... )
1524 This method will dispatch a C<HEAD> request on the given $url.
1525 Otherwise it works like the get() method described above.
1527 =item $ua->post( $url, \%form )
1529 =item $ua->post( $url, \@form )
1531 =item $ua->post( $url, \%form, $field_name => $value, ... )
1533 =item $ua->post( $url, $field_name => $value,... Content => \%form )
1535 =item $ua->post( $url, $field_name => $value,... Content => \@form )
1537 =item $ua->post( $url, $field_name => $value,... Content => $content )
1539 This method will dispatch a C<POST> request on the given $url, with
1540 %form or @form providing the key/value pairs for the fill-in form
1541 content. Additional headers and content options are the same as for
1544 This method will use the POST() function from C<HTTP::Request::Common>
1545 to build the request. See L<HTTP::Request::Common> for a details on
1546 how to pass form content and other advanced features.
1548 =item $ua->mirror( $url, $filename )
1550 This method will get the document identified by $url and store it in
1551 file called $filename. If the file already exists, then the request
1552 will contain an "If-Modified-Since" header matching the modification
1553 time of the file. If the document on the server has not changed since
1554 this time, then nothing happens. If the document has been updated, it
1555 will be downloaded again. The modification time of the file will be
1556 forced to match that of the server.
1558 The return value is the the response object.
1560 =item $ua->request( $request )
1562 =item $ua->request( $request, $content_file )
1564 =item $ua->request( $request, $content_cb )
1566 =item $ua->request( $request, $content_cb, $read_size_hint )
1568 This method will dispatch the given $request object. Normally this
1569 will be an instance of the C<HTTP::Request> class, but any object with
1570 a similar interface will do. The return value is a response object.
1571 See L<HTTP::Request> and L<HTTP::Response> for a description of the
1572 interface provided by these classes.
1574 The request() method will process redirects and authentication
1575 responses transparently. This means that it may actually send several
1576 simple requests via the simple_request() method described below.
1578 The request methods described above; get(), head(), post() and
1579 mirror(), will all dispatch the request they build via this method.
1580 They are convenience methods that simply hides the creation of the
1581 request object for you.
1583 The $content_file, $content_cb and $read_size_hint all correspond to
1584 options described with the get() method above.
1586 You are allowed to use a CODE reference as C<content> in the request
1587 object passed in. The C<content> function should return the content
1588 when called. The content can be returned in chunks. The content
1589 function will be invoked repeatedly until it return an empty string to
1590 signal that there is no more content.
1592 =item $ua->simple_request( $request )
1594 =item $ua->simple_request( $request, $content_file )
1596 =item $ua->simple_request( $request, $content_cb )
1598 =item $ua->simple_request( $request, $content_cb, $read_size_hint )
1600 This method dispatches a single request and returns the response
1601 received. Arguments are the same as for request() described above.
1603 The difference from request() is that simple_request() will not try to
1604 handle redirects or authentication responses. The request() method
1605 will in fact invoke this method for each simple request it sends.
1607 =item $ua->is_protocol_supported( $scheme )
1609 You can use this method to test whether this user agent object supports the
1610 specified C<scheme>. (The C<scheme> might be a string (like 'http' or
1611 'ftp') or it might be an URI object reference.)
1613 Whether a scheme is supported, is determined by the user agent's
1614 C<protocols_allowed> or C<protocols_forbidden> lists (if any), and by
1615 the capabilities of LWP. I.e., this will return TRUE only if LWP
1616 supports this protocol I<and> it's permitted for this particular
1621 =head2 Callback methods
1623 The following methods will be invoked as requests are processed. These
1624 methods are documented here because subclasses of C<LWP::UserAgent>
1625 might want to override their behaviour.
1629 =item $ua->prepare_request( $request )
1631 This method is invoked by simple_request(). Its task is to modify the
1632 given $request object by setting up various headers based on the
1633 attributes of the user agent. The return value should normally be the
1634 $request object passed in. If a different request object is returned
1635 it will be the one actually processed.
1637 The headers affected by the base implementation are; "User-Agent",
1638 "From", "Range" and "Cookie".
1640 =item $ua->redirect_ok( $prospective_request, $response )
1642 This method is called by request() before it tries to follow a
1643 redirection to the request in $response. This should return a TRUE
1644 value if this redirection is permissible. The $prospective_request
1645 will be the request to be sent if this method returns TRUE.
1647 The base implementation will return FALSE unless the method
1648 is in the object's C<requests_redirectable> list,
1649 FALSE if the proposed redirection is to a "file://..."
1650 URL, and TRUE otherwise.
1652 =item $ua->get_basic_credentials( $realm, $uri, $isproxy )
1654 This is called by request() to retrieve credentials for documents
1655 protected by Basic or Digest Authentication. The arguments passed in
1656 is the $realm provided by the server, the $uri requested and a boolean
1657 flag to indicate if this is authentication against a proxy server.
1659 The method should return a username and password. It should return an
1660 empty list to abort the authentication resolution attempt. Subclasses
1661 can override this method to prompt the user for the information. An
1662 example of this can be found in C<lwp-request> program distributed
1665 The base implementation simply checks a set of pre-stored member
1666 variables, set up with the credentials() method.
1668 =item $ua->progress( $status, $request_or_response )
1670 This is called frequently as the response is received regardless of
1671 how the content is processed. The method is called with $status
1672 "begin" at the start of processing the request and with $state "end"
1673 before the request method returns. In between these $status will be
1674 the fraction of the response currently received or the string "tick"
1675 if the fraction can't be calculated.
1677 When $status is "begin" the second argument is the request object,
1678 otherwise it is the response object.
1684 See L<LWP> for a complete overview of libwww-perl5. See L<lwpcook>
1685 and the scripts F<lwp-request> and F<lwp-download> for examples of
1688 See L<HTTP::Request> and L<HTTP::Response> for a description of the
1689 message objects dispatched and received. See L<HTTP::Request::Common>
1690 and L<HTML::Form> for other ways to build request objects.
1692 See L<WWW::Mechanize> and L<WWW::Search> for examples of more
1693 specialized user agents based on C<LWP::UserAgent>.
1697 Copyright 1995-2009 Gisle Aas.
1699 This library is free software; you can redistribute it and/or
1700 modify it under the same terms as Perl itself.