← Index
NYTProf Performance Profile   « block view • line view • sub view »
For 05.Domain_and_Item.t
  Run on Tue May 4 17:21:41 2010
Reported on Tue May 4 17:23:05 2010

File /usr/local/lib/perl5/site_perl/5.10.1/LWP/UserAgent.pm
Statements Executed 4860
Statement Execution Time 15.8ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1117.84ms9.41msLWP::UserAgent::::BEGIN@10LWP::UserAgent::BEGIN@10
41113.12ms15.5sLWP::UserAgent::::send_requestLWP::UserAgent::send_request
1112.59ms3.06msLWP::UserAgent::::BEGIN@12LWP::UserAgent::BEGIN@12
41111.78ms15.5sLWP::UserAgent::::requestLWP::UserAgent::request
246621.77ms19.6msLWP::UserAgent::::run_handlersLWP::UserAgent::run_handlers
1111.63ms1.72msLWP::UserAgent::::add_handlerLWP::UserAgent::add_handler
41111.61ms6.36msLWP::UserAgent::::prepare_requestLWP::UserAgent::prepare_request
303321.49ms18.1msLWP::UserAgent::::handlersLWP::UserAgent::handlers
1111.24ms4.04msLWP::UserAgent::::BEGIN@11LWP::UserAgent::BEGIN@11
111994µs1.05msLWP::UserAgent::::BEGIN@15LWP::UserAgent::BEGIN@15
4111876µs15.5sLWP::UserAgent::::simple_requestLWP::UserAgent::simple_request
111851µs939µsLWP::UserAgent::::conn_cacheLWP::UserAgent::conn_cache
13932502µs502µsLWP::UserAgent::::progressLWP::UserAgent::progress
4111258µs485µsLWP::UserAgent::::protocols_allowedLWP::UserAgent::protocols_allowed
4111183µs269µsLWP::UserAgent::::protocols_forbiddenLWP::UserAgent::protocols_forbidden
111116µs116µsLWP::UserAgent::::BEGIN@14LWP::UserAgent::BEGIN@14
11163µs2.88msLWP::UserAgent::::newLWP::UserAgent::new
11132µs1.76msLWP::UserAgent::::set_my_handlerLWP::UserAgent::set_my_handler
11116µs20µsLWP::UserAgent::::BEGIN@3LWP::UserAgent::BEGIN@3
11116µs96µsLWP::UserAgent::::agentLWP::UserAgent::agent
11115µs1.78msLWP::UserAgent::::parse_headLWP::UserAgent::parse_head
11113µs79µsLWP::UserAgent::::default_headerLWP::UserAgent::default_header
11112µs22µsLWP::UserAgent::::default_headersLWP::UserAgent::default_headers
1118µs8µsLWP::UserAgent::::remove_handlerLWP::UserAgent::remove_handler
1117µs19µsLWP::UserAgent::::BEGIN@353LWP::UserAgent::BEGIN@353
1117µs49µsLWP::UserAgent::::BEGIN@4LWP::UserAgent::BEGIN@4
1114µs4µsLWP::UserAgent::::BEGIN@17LWP::UserAgent::BEGIN@17
1114µs4µsLWP::UserAgent::::_agentLWP::UserAgent::_agent
1121µs1µsLWP::UserAgent::::CORE:matchLWP::UserAgent::CORE:match (opcode)
0000s0sLWP::UserAgent::::__ANON__[:608]LWP::UserAgent::__ANON__[:608]
0000s0sLWP::UserAgent::::__ANON__[:611]LWP::UserAgent::__ANON__[:611]
0000s0sLWP::UserAgent::::__ANON__[:632]LWP::UserAgent::__ANON__[:632]
0000s0sLWP::UserAgent::::__ANON__[:635]LWP::UserAgent::__ANON__[:635]
0000s0sLWP::UserAgent::::__ANON__[:735]LWP::UserAgent::__ANON__[:735]
0000s0sLWP::UserAgent::::_need_proxyLWP::UserAgent::_need_proxy
0000s0sLWP::UserAgent::::_new_responseLWP::UserAgent::_new_response
0000s0sLWP::UserAgent::::_process_colonic_headersLWP::UserAgent::_process_colonic_headers
0000s0sLWP::UserAgent::::cloneLWP::UserAgent::clone
0000s0sLWP::UserAgent::::cookie_jarLWP::UserAgent::cookie_jar
0000s0sLWP::UserAgent::::credentialsLWP::UserAgent::credentials
0000s0sLWP::UserAgent::::env_proxyLWP::UserAgent::env_proxy
0000s0sLWP::UserAgent::::fromLWP::UserAgent::from
0000s0sLWP::UserAgent::::getLWP::UserAgent::get
0000s0sLWP::UserAgent::::get_basic_credentialsLWP::UserAgent::get_basic_credentials
0000s0sLWP::UserAgent::::get_my_handlerLWP::UserAgent::get_my_handler
0000s0sLWP::UserAgent::::headLWP::UserAgent::head
0000s0sLWP::UserAgent::::is_protocol_supportedLWP::UserAgent::is_protocol_supported
0000s0sLWP::UserAgent::::local_addressLWP::UserAgent::local_address
0000s0sLWP::UserAgent::::max_redirectLWP::UserAgent::max_redirect
0000s0sLWP::UserAgent::::max_sizeLWP::UserAgent::max_size
0000s0sLWP::UserAgent::::mirrorLWP::UserAgent::mirror
0000s0sLWP::UserAgent::::no_proxyLWP::UserAgent::no_proxy
0000s0sLWP::UserAgent::::postLWP::UserAgent::post
0000s0sLWP::UserAgent::::proxyLWP::UserAgent::proxy
0000s0sLWP::UserAgent::::redirect_okLWP::UserAgent::redirect_ok
0000s0sLWP::UserAgent::::requests_redirectableLWP::UserAgent::requests_redirectable
0000s0sLWP::UserAgent::::show_progressLWP::UserAgent::show_progress
0000s0sLWP::UserAgent::::timeoutLWP::UserAgent::timeout
0000s0sLWP::UserAgent::::use_alarmLWP::UserAgent::use_alarm
0000s0sLWP::UserAgent::::use_evalLWP::UserAgent::use_eval
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package LWP::UserAgent;
2
3325µs223µs
# spent 20µs (16+3) within LWP::UserAgent::BEGIN@3 which was called # once (16µs+3µs) by SimpleDB::Client::BEGIN@54 at line 3
use strict;
# spent 20µs making 1 call to LWP::UserAgent::BEGIN@3 # spent 3µs making 1 call to strict::import
4342µs292µs
# spent 49µs (7+42) within LWP::UserAgent::BEGIN@4 which was called # once (7µs+42µs) by SimpleDB::Client::BEGIN@54 at line 4
use vars qw(@ISA $VERSION);
# spent 49µs making 1 call to LWP::UserAgent::BEGIN@4 # spent 42µs making 1 call to vars::import
5
61700nsrequire LWP::MemberMixin;
718µs@ISA = qw(LWP::MemberMixin);
81500ns$VERSION = "5.834";
9
103164µs19.41ms
# spent 9.41ms (7.84+1.58) within LWP::UserAgent::BEGIN@10 which was called # once (7.84ms+1.58ms) by SimpleDB::Client::BEGIN@54 at line 10
use HTTP::Request ();
# spent 9.41ms making 1 call to LWP::UserAgent::BEGIN@10
113141µs14.04ms
# spent 4.04ms (1.24+2.79) within LWP::UserAgent::BEGIN@11 which was called # once (1.24ms+2.79ms) by SimpleDB::Client::BEGIN@54 at line 11
use HTTP::Response ();
# spent 4.04ms making 1 call to LWP::UserAgent::BEGIN@11
123176µs13.06ms
# spent 3.06ms (2.59+472µs) within LWP::UserAgent::BEGIN@12 which was called # once (2.59ms+472µs) by SimpleDB::Client::BEGIN@54 at line 12
use HTTP::Date ();
# spent 3.06ms making 1 call to LWP::UserAgent::BEGIN@12
13
143116µs1116µs
# spent 116µs within LWP::UserAgent::BEGIN@14 which was called # once (116µs+0s) by SimpleDB::Client::BEGIN@54 at line 14
use LWP ();
# spent 116µs making 1 call to LWP::UserAgent::BEGIN@14
153109µs11.05ms
# spent 1.05ms (994µs+59µs) within LWP::UserAgent::BEGIN@15 which was called # once (994µs+59µs) by SimpleDB::Client::BEGIN@54 at line 15
use LWP::Protocol ();
# spent 1.05ms making 1 call to LWP::UserAgent::BEGIN@15
16
1731.15ms14µs
# spent 4µs within LWP::UserAgent::BEGIN@17 which was called # once (4µs+0s) by SimpleDB::Client::BEGIN@54 at line 17
use Carp ();
# spent 4µs making 1 call to LWP::UserAgent::BEGIN@17
18
1911µsif ($ENV{PERL_LWP_USE_HTTP_10}) {
20 require LWP::Protocol::http10;
21 LWP::Protocol::implementor('http', 'LWP::Protocol::http10');
22 eval {
23 require LWP::Protocol::https10;
24 LWP::Protocol::implementor('https', 'LWP::Protocol::https10');
25 };
26}
27
28
29
30sub new
31
# spent 2.88ms (63µs+2.81) within LWP::UserAgent::new which was called # once (63µs+2.81ms) by SimpleDB::Client::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/SimpleDB/Client.pm:138] at line 138 of SimpleDB/Client.pm
{
32 # Check for common user mistake
331800ns Carp::croak("Options to LWP::UserAgent should be key/value pairs, not hash reference")
34 if ref($_[1]) eq 'HASH';
35
3613µs my($class, %cnf) = @_;
37
3811µs my $agent = delete $cnf{agent};
391800ns my $from = delete $cnf{from};
401600ns my $def_headers = delete $cnf{default_headers};
411800ns my $timeout = delete $cnf{timeout};
421200ns $timeout = 3*60 unless defined $timeout;
431800ns my $local_address = delete $cnf{local_address};
441300ns my $use_eval = delete $cnf{use_eval};
451300ns $use_eval = 1 unless defined $use_eval;
461300ns my $parse_head = delete $cnf{parse_head};
471200ns $parse_head = 1 unless defined $parse_head;
481400ns my $show_progress = delete $cnf{show_progress};
491400ns my $max_size = delete $cnf{max_size};
501300ns my $max_redirect = delete $cnf{max_redirect};
511500ns $max_redirect = 7 unless defined $max_redirect;
521400ns my $env_proxy = delete $cnf{env_proxy};
53
541200ns my $cookie_jar = delete $cnf{cookie_jar};
551200ns my $conn_cache = delete $cnf{conn_cache};
561700ns my $keep_alive = delete $cnf{keep_alive};
57
581100ns Carp::croak("Can't mix conn_cache and keep_alive")
59 if $conn_cache && $keep_alive;
60
61
621400ns my $protocols_allowed = delete $cnf{protocols_allowed};
631400ns my $protocols_forbidden = delete $cnf{protocols_forbidden};
64
651500ns my $requests_redirectable = delete $cnf{requests_redirectable};
6612µs $requests_redirectable = ['GET', 'HEAD']
67 unless defined $requests_redirectable;
68
69 # Actually ""s are just as good as 0's, but for concision we'll just say:
701300ns Carp::croak("protocols_allowed has to be an arrayref or 0, not \"$protocols_allowed\"!")
71 if $protocols_allowed and ref($protocols_allowed) ne 'ARRAY';
721300ns Carp::croak("protocols_forbidden has to be an arrayref or 0, not \"$protocols_forbidden\"!")
73 if $protocols_forbidden and ref($protocols_forbidden) ne 'ARRAY';
7411µs Carp::croak("requests_redirectable has to be an arrayref or 0, not \"$requests_redirectable\"!")
75 if $requests_redirectable and ref($requests_redirectable) ne 'ARRAY';
76
77
781500ns if (%cnf && $^W) {
79 Carp::carp("Unrecognized LWP::UserAgent options: @{[sort keys %cnf]}");
80 }
81
82118µs my $self = bless {
83 def_headers => $def_headers,
84 timeout => $timeout,
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,
90 proxy => {},
91 no_proxy => [],
92 protocols_allowed => $protocols_allowed,
93 protocols_forbidden => $protocols_forbidden,
94 requests_redirectable => $requests_redirectable,
95 }, $class;
96
9716µs299µs $self->agent(defined($agent) ? $agent : $class->_agent)
# spent 96µs making 1 call to LWP::UserAgent::agent # spent 4µs making 1 call to LWP::UserAgent::_agent
98 if defined($agent) || !$def_headers || !$def_headers->header("User-Agent");
991500ns $self->from($from) if $from;
1001300ns $self->cookie_jar($cookie_jar) if $cookie_jar;
10113µs11.78ms $self->parse_head($parse_head);
# spent 1.78ms making 1 call to LWP::UserAgent::parse_head
1021500ns $self->env_proxy if $env_proxy;
103
1041300ns $self->protocols_allowed( $protocols_allowed ) if $protocols_allowed;
1051100ns $self->protocols_forbidden($protocols_forbidden) if $protocols_forbidden;
106
10711µs if ($keep_alive) {
108 $conn_cache ||= { total_capacity => $keep_alive };
109 }
11012µs1939µs $self->conn_cache($conn_cache) if $conn_cache;
# spent 939µs making 1 call to LWP::UserAgent::conn_cache
111
11214µs return $self;
113}
114
115
116sub send_request
117
# spent 15.5s (3.12ms+15.5) within LWP::UserAgent::send_request which was called 41 times, avg 378ms/call: # 41 times (3.12ms+15.5s) by LWP::UserAgent::simple_request at line 253, avg 378ms/call
{
1184154µs my($self, $request, $arg, $size) = @_;
11941143µs82297µs my($method, $url) = ($request->method, $request->uri);
# spent 218µs making 41 calls to HTTP::Request::method, avg 5µs/call # spent 79µs making 41 calls to HTTP::Request::uri, avg 2µs/call
1204166µs41453µs my $scheme = $url->scheme;
# spent 453µs making 41 calls to URI::scheme, avg 11µs/call
121
12241129µs local($SIG{__DIE__}); # protect against user defined die handlers
123
12441107µs41138µs $self->progress("begin", $request);
# spent 138µs making 41 calls to LWP::UserAgent::progress, avg 3µs/call
125
1264175µs41341µs my $response = $self->run_handlers("request_send", $request);
# spent 341µs making 41 calls to LWP::UserAgent::run_handlers, avg 8µs/call
127
1284127µs unless ($response) {
129418µs my $protocol;
130
131 {
132 # Honor object-specific restrictions by forcing protocol objects
133 # into class LWP::Protocol::nogo.
1348239µs my $x;
13541275µs82754µs if($x = $self->protocols_allowed) {
# spent 485µs making 41 calls to LWP::UserAgent::protocols_allowed, avg 12µs/call # spent 269µs making 41 calls to LWP::UserAgent::protocols_forbidden, avg 7µs/call
136 if (grep lc($_) eq $scheme, @$x) {
137 }
138 else {
139 require LWP::Protocol::nogo;
140 $protocol = LWP::Protocol::nogo->new;
141 }
142 }
143 elsif ($x = $self->protocols_forbidden) {
144 if(grep lc($_) eq $scheme, @$x) {
145 require LWP::Protocol::nogo;
146 $protocol = LWP::Protocol::nogo->new;
147 }
148 }
149 # else fall thru and create the protocol object normally
150 }
151
152 # Locate protocol to use
1534132µs my $proxy = $request->{proxy};
1544117µs if ($proxy) {
155 $scheme = $proxy->scheme;
156 }
157
1584120µs unless ($protocol) {
15982136µs4117.0ms $protocol = eval { LWP::Protocol::create($scheme, $self) };
# spent 17.0ms making 41 calls to LWP::Protocol::create, avg 414µs/call
1604114µs if ($@) {
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);
167LWP will support https URLs if either Crypt::SSLeay or IO::Socket::SSL
168is installed. More information at
169<http://search.cpan.org/dist/libwww-perl/README.SSL>.
170EOT
171 }
172 }
173 }
174
17541139µs if (!$response && $self->{use_eval}) {
176 # we eval, and turn dies into responses below
1774121µs eval {
17841185µs4115.5s $response = $protocol->request($request, $proxy,
# spent 15.5s making 41 calls to LWP::Protocol::http::request, avg 378ms/call
179 $arg, $size, $self->{timeout});
180 };
1814117µs if ($@) {
182 $@ =~ s/ at .* line \d+.*//s; # remove file/line number
183 $response = _new_response($request,
184 &HTTP::Status::RC_INTERNAL_SERVER_ERROR,
185 $@);
186 }
187 }
188 elsif (!$response) {
189 $response = $protocol->request($request, $proxy,
190 $arg, $size, $self->{timeout});
191 # XXX: Should we die unless $response->is_success ???
192 }
193 }
194
19541114µs41335µs $response->request($request); # record request for reference
# spent 335µs making 41 calls to HTTP::Response::request, avg 8µs/call
19641254µs822.08ms $response->header("Client-Date" => HTTP::Date::time2str(time));
# spent 1.36ms making 41 calls to HTTP::Message::__ANON__[HTTP/Message.pm:622], avg 33µs/call # spent 722µs making 41 calls to HTTP::Date::time2str, avg 18µs/call
197
19841104µs41406µs $self->run_handlers("response_done", $response);
# spent 406µs making 41 calls to LWP::UserAgent::run_handlers, avg 10µs/call
199
2004190µs4193µs $self->progress("end", $response);
# spent 93µs making 41 calls to LWP::UserAgent::progress, avg 2µs/call
20141374µs return $response;
202}
203
204
205sub prepare_request
206
# spent 6.36ms (1.61+4.76) within LWP::UserAgent::prepare_request which was called 41 times, avg 155µs/call: # 41 times (1.61ms+4.76ms) by LWP::UserAgent::simple_request at line 247, avg 155µs/call
{
2074146µs my($self, $request) = @_;
2084169µs41231µs die "Method missing" unless $request->method;
# spent 231µs making 41 calls to HTTP::Request::method, avg 6µs/call
2094159µs4179µs my $url = $request->uri;
# spent 79µs making 41 calls to HTTP::Request::uri, avg 2µs/call
21041152µs41124µs die "URL missing" unless $url;
# spent 124µs making 41 calls to URI::__ANON__[URI.pm:24], avg 3µs/call
21141128µs41673µs die "URL must be absolute" unless $url->scheme;
# spent 673µs making 41 calls to URI::scheme, avg 16µs/call
212
21341114µs41470µs $self->run_handlers("request_preprepare", $request);
# spent 470µs making 41 calls to LWP::UserAgent::run_handlers, avg 11µs/call
214
21541219µs41651µs if (my $def_headers = $self->{def_headers}) {
# spent 651µs making 41 calls to HTTP::Headers::header_field_names, avg 16µs/call
216 for my $h ($def_headers->header_field_names) {
21741257µs822.19ms $request->init_header($h => [$def_headers->header($h)]);
# spent 1.16ms making 40 calls to HTTP::Message::__ANON__[HTTP/Message.pm:622], avg 29µs/call # spent 1.01ms making 41 calls to HTTP::Headers::header, avg 25µs/call # spent 14µs making 1 call to HTTP::Message::AUTOLOAD
218 }
219 }
220
2214172µs41312µs $self->run_handlers("request_prepare", $request);
# spent 312µs making 41 calls to LWP::UserAgent::run_handlers, avg 8µs/call
222
22341124µs return $request;
224}
225
226
227sub simple_request
228
# spent 15.5s (876µs+15.5) within LWP::UserAgent::simple_request which was called 41 times, avg 378ms/call: # 41 times (876µs+15.5s) by LWP::UserAgent::request at line 261, avg 378ms/call
{
2294154µs my($self, $request, $arg, $size) = @_;
230
231 # sanity check the request passed in
23241355µs8278µs if (defined $request) {
# spent 78µs making 82 calls to UNIVERSAL::can, avg 948ns/call
233 if (ref $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');
237 }
238 else {
239 Carp::croak("You need a request object, not '$request'");
240 }
241 }
242 else {
243 Carp::croak("No request object passed in");
244 }
245
2464136µs eval {
24741167µs416.36ms $request = $self->prepare_request($request);
# spent 6.36ms making 41 calls to LWP::UserAgent::prepare_request, avg 155µs/call
248 };
2494116µs if ($@) {
250 $@ =~ s/ at .* line \d+.*//s; # remove file/line number
251 return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, $@);
252 }
25341255µs4115.5s return $self->send_request($request, $arg, $size);
# spent 15.5s making 41 calls to LWP::UserAgent::send_request, avg 378ms/call
254}
255
256
257sub request
258
# spent 15.5s (1.78ms+15.5) within LWP::UserAgent::request which was called 41 times, avg 378ms/call: # 41 times (1.78ms+15.5s) by SimpleDB::Client::send_request at line 214 of SimpleDB/Client.pm, avg 378ms/call
{
2594152µs my($self, $request, $arg, $size, $previous) = @_;
260
26141148µs4115.5s my $response = $self->simple_request($request, $arg, $size);
# spent 15.5s making 41 calls to LWP::UserAgent::simple_request, avg 378ms/call
2624117µs $response->previous($previous) if $previous;
263
26441188µs41788µs if ($response->redirects >= $self->{max_redirect}) {
# spent 788µs making 41 calls to HTTP::Response::redirects, avg 19µs/call
265 $response->header("Client-Warning" =>
266 "Redirect loop detected (max_redirect = $self->{max_redirect})");
267 return $response;
268 }
269
27041102µs41440µs if (my $req = $self->run_handlers("response_redirect", $response)) {
# spent 440µs making 41 calls to LWP::UserAgent::run_handlers, avg 11µs/call
271 return $self->request($req, $arg, $size, $response);
272 }
273
2744188µs41258µs my $code = $response->code;
# spent 258µs making 41 calls to HTTP::Response::code, avg 6µs/call
275
276411.25ms246406µs if ($code == &HTTP::Status::RC_MOVED_PERMANENTLY or
# spent 101µs making 41 calls to HTTP::Status::HTTP_MOVED_PERMANENTLY, avg 2µs/call # spent 68µs making 41 calls to HTTP::Status::HTTP_PROXY_AUTHENTICATION_REQUIRED, avg 2µs/call # spent 61µs making 41 calls to HTTP::Status::HTTP_FOUND, avg 1µs/call # spent 61µs making 41 calls to HTTP::Status::HTTP_TEMPORARY_REDIRECT, avg 1µs/call # spent 59µs making 41 calls to HTTP::Status::HTTP_UNAUTHORIZED, avg 1µs/call # spent 55µs making 41 calls to HTTP::Status::HTTP_SEE_OTHER, avg 1µs/call
277 $code == &HTTP::Status::RC_FOUND or
278 $code == &HTTP::Status::RC_SEE_OTHER or
279 $code == &HTTP::Status::RC_TEMPORARY_REDIRECT)
280 {
281 my $referral = $request->clone;
282
283 # These headers should never be forwarded
284 $referral->remove_header('Host', 'Cookie');
285
286 if ($referral->header('Referer') &&
287 $request->uri->scheme eq 'https' &&
288 $referral->uri->scheme eq 'http')
289 {
290 # RFC 2616, section 15.1.3.
291 # https -> http redirect, suppressing Referer
292 $referral->remove_header('Referer');
293 }
294
295 if ($code == &HTTP::Status::RC_SEE_OTHER ||
296 $code == &HTTP::Status::RC_FOUND)
297 {
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;
303 }
304 }
305
306 # And then we update the URL based on the Location:-header.
307 my $referral_uri = $response->header('Location');
308 {
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)
315 ->abs($base);
316 }
317 $referral->uri($referral_uri);
318
319 return $response unless $self->redirect_ok($referral, $response);
320 return $self->request($referral, $arg, $size, $response);
321
322 }
323 elsif ($code == &HTTP::Status::RC_UNAUTHORIZED ||
324 $code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED
325 )
326 {
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");
333 return $response;
334 }
335
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
343
344 unless ($scheme =~ /^([a-z]+(?:-[a-z]+)*)$/) {
345 $response->header("Client-Warning" =>
346 "Bad authentication scheme '$scheme'");
347 return $response;
348 }
349 $scheme = $1; # untainted now
350 my $class = "LWP::Authen::\u$scheme";
351 $class =~ s/-/_/g;
352
35332.65ms230µs
# spent 19µs (7+12) within LWP::UserAgent::BEGIN@353 which was called # once (7µs+12µs) by SimpleDB::Client::BEGIN@54 at line 353
no strict 'refs';
# spent 19µs making 1 call to LWP::UserAgent::BEGIN@353 # spent 12µs making 1 call to strict::unimport
354 unless (%{"$class\::"}) {
355 # try to load it
356 eval "require $class";
357 if ($@) {
358 if ($@ =~ /^Can\'t locate/) {
359 $response->header("Client-Warning" =>
360 "Unsupported authentication scheme '$scheme'");
361 }
362 else {
363 $response->header("Client-Warning" => $@);
364 }
365 next CHALLENGE;
366 }
367 }
368 unless ($class->can("authenticate")) {
369 $response->header("Client-Warning" =>
370 "Unsupported authentication scheme '$scheme'");
371 next CHALLENGE;
372 }
373 return $class->authenticate($self, $proxy, $challenge, $response,
374 $request, $arg, $size);
375 }
376 return $response;
377 }
37841172µs return $response;
379}
380
381
382#
383# Now the shortcuts...
384#
385sub get {
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 );
390}
391
392
393sub post {
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 );
398}
399
400
401sub head {
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 );
406}
407
408
409sub _process_colonic_headers {
410 # Process :content_cb / :content_file / :read_size_hint headers.
411 my($self, $args, $start_index) = @_;
412
413 my($arg, $size);
414 for(my $i = $start_index; $i < @$args; $i += 2) {
415 next unless defined $args->[$i];
416
417 #printf "Considering %s => %s\n", $args->[$i], $args->[$i + 1];
418
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');
425
426 }
427 elsif ($args->[$i] eq ':content_file') {
428 $arg = $args->[$i + 1];
429
430 # Some sanity-checking...
431 Carp::croak("A :content_file value can't be undef")
432 unless defined $arg;
433 Carp::croak("A :content_file value can't be a reference")
434 if ref $arg;
435 Carp::croak("A :content_file value can't be \"\"")
436 unless length $arg;
437
438 }
439 elsif ($args->[$i] eq ':read_size_hint') {
440 $size = $args->[$i + 1];
441 # Bother checking it?
442
443 }
444 else {
445 next;
446 }
447 splice @$args, $i, 2;
448 $i -= 2;
449 }
450
451 # And return a suitable suffix-list for request(REQ,...)
452
453 return unless defined $arg;
454 return $arg, $size if defined $size;
455 return $arg;
456}
457
45811µsmy @ANI = qw(- \ | /);
459
460
# spent 502µs within LWP::UserAgent::progress which was called 139 times, avg 4µs/call: # 57 times (270µs+0s) by LWP::Protocol::collect at line 157 of LWP/Protocol.pm, avg 5µs/call # 41 times (138µs+0s) by LWP::UserAgent::send_request at line 124, avg 3µs/call # 41 times (93µs+0s) by LWP::UserAgent::send_request at line 200, avg 2µs/call
sub progress {
461139145µs my($self, $status, $m) = @_;
462139502µs return unless $self->{show_progress};
463
464 local($,, $\);
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;
470 }
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;
477 print STDERR "\n";
478 }
479 elsif ($status eq "tick") {
480 print STDERR "$ANI[$self->{progress_ani}++]\b";
481 $self->{progress_ani} %= @ANI;
482 }
483 else {
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;
488 }
489 STDERR->flush;
490}
491
492
493#
494# This whole allow/forbid thing is based on man 1 at's way of doing things.
495#
496sub is_protocol_supported
497{
498 my($self, $scheme) = @_;
499 if (ref $scheme) {
500 # assume we got a reference to an URI object
501 $scheme = $scheme->scheme;
502 }
503 else {
504 Carp::croak("Illegal scheme '$scheme' passed to is_protocol_supported")
505 if $scheme =~ /\W/;
506 $scheme = lc $scheme;
507 }
508
509 my $x;
510 if(ref($self) and $x = $self->protocols_allowed) {
511 return 0 unless grep lc($_) eq $scheme, @$x;
512 }
513 elsif (ref($self) and $x = $self->protocols_forbidden) {
514 return 0 if grep lc($_) eq $scheme, @$x;
515 }
516
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';
520 return 0;
521}
522
523
52441229µs41226µs
# spent 485µs (258+227) within LWP::UserAgent::protocols_allowed which was called 41 times, avg 12µs/call: # 41 times (258µs+227µs) by LWP::UserAgent::send_request at line 135, avg 12µs/call
sub protocols_allowed { shift->_elem('protocols_allowed' , @_) }
# spent 226µs making 41 calls to LWP::MemberMixin::_elem, avg 6µs/call
52541148µs4187µs
# spent 269µs (183+87) within LWP::UserAgent::protocols_forbidden which was called 41 times, avg 7µs/call: # 41 times (183µs+87µs) by LWP::UserAgent::send_request at line 135, avg 7µs/call
sub protocols_forbidden { shift->_elem('protocols_forbidden' , @_) }
# spent 87µs making 41 calls to LWP::MemberMixin::_elem, avg 2µs/call
526sub requests_redirectable { shift->_elem('requests_redirectable', @_) }
527
528
529sub redirect_ok
530{
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.
536
537 # Note that this routine used to be just:
538 # return 0 if $_[1]->method eq "POST"; return 1;
539
540 my($self, $new_request, $response) = @_;
541 my $method = $response->request->method;
542 return 0 unless grep $_ eq $method,
543 @{ $self->requests_redirectable || [] };
544
545 if ($new_request->uri->scheme eq 'file') {
546 $response->header("Client-Warning" =>
547 "Can't redirect to a file:// URL!");
548 return 0;
549 }
550
551 # Otherwise it's apparently okay...
552 return 1;
553}
554
555
556sub credentials
557{
558 my $self = shift;
559 my $netloc = lc(shift);
560 my $realm = shift || "";
561 my $old = $self->{basic_authentication}{$netloc}{$realm};
562 if (@_) {
563 $self->{basic_authentication}{$netloc}{$realm} = [@_];
564 }
565 return unless $old;
566 return @$old if wantarray;
567 return join(":", @$old);
568}
569
570
571sub get_basic_credentials
572{
573 my($self, $realm, $uri, $proxy) = @_;
574 return if $proxy;
575 return $self->credentials($uri->host_port, $realm);
576}
577
578
579sub timeout { shift->_elem('timeout', @_); }
580sub local_address{ shift->_elem('local_address',@_); }
581sub max_size { shift->_elem('max_size', @_); }
582sub max_redirect { shift->_elem('max_redirect', @_); }
583sub show_progress{ shift->_elem('show_progress', @_); }
584
585
# spent 1.78ms (15µs+1.76) within LWP::UserAgent::parse_head which was called # once (15µs+1.76ms) by LWP::UserAgent::new at line 101
sub parse_head {
5861700ns my $self = shift;
5871600ns if (@_) {
5881600ns my $flag = shift;
5891400ns my $parser;
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;
596
597 push(@{$response->{handlers}{response_data}}, {
598 callback => sub {
599 return unless $parser;
600 unless ($parser->parse($_[3])) {
601 my $h = $parser->header;
602 my $r = $_[0];
603 for my $f ($h->header_field_names) {
604 $r->init_header($f, [$h->header($f)]);
605 }
606 undef($parser);
607 }
608 },
609 });
610
611 } : undef,
61219µs11.76ms m_media_type => "html",
# spent 1.76ms making 1 call to LWP::UserAgent::set_my_handler
613 );
61413µs return !!$old;
615 }
616 else {
617 return !!$self->get_my_handler("response_header");
618 }
619}
620
621sub cookie_jar {
622 my $self = shift;
623 my $old = $self->{cookie_jar};
624 if (@_) {
625 my $jar = shift;
626 if (ref($jar) eq "HASH") {
627 require HTTP::Cookies;
628 $jar = HTTP::Cookies->new(%$jar);
629 }
630 $self->{cookie_jar} = $jar;
631 $self->set_my_handler("request_prepare",
632 $jar ? sub { $jar->add_cookie_header($_[0]); } : undef,
633 );
634 $self->set_my_handler("response_done",
635 $jar ? sub { $jar->extract_cookies($_[0]); } : undef,
636 );
637 }
638 $old;
639}
640
641
# spent 22µs (12+10) within LWP::UserAgent::default_headers which was called # once (12µs+10µs) by LWP::UserAgent::default_header at line 654
sub default_headers {
6421400ns my $self = shift;
64317µs110µs my $old = $self->{def_headers} ||= HTTP::Headers->new;
# spent 10µs making 1 call to HTTP::Headers::new
6441300ns if (@_) {
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;
648 }
64913µs return $old;
650}
651
652
# spent 79µs (13+66) within LWP::UserAgent::default_header which was called # once (13µs+66µs) by LWP::UserAgent::agent at line 669
sub default_header {
6531500ns my $self = shift;
65419µs266µs return $self->default_headers->header(@_);
# spent 44µs making 1 call to HTTP::Headers::header # spent 22µs making 1 call to LWP::UserAgent::default_headers
655}
656
65716µs
# spent 4µs within LWP::UserAgent::_agent which was called # once (4µs+0s) by LWP::UserAgent::new at line 97
sub _agent { "libwww-perl/$LWP::VERSION" }
658
659
# spent 96µs (16+80) within LWP::UserAgent::agent which was called # once (16µs+80µs) by LWP::UserAgent::new at line 97
sub agent {
6601600ns my $self = shift;
6611600ns if (@_) {
6621600ns my $agent = shift;
6631800ns if ($agent) {
66417µs11µs $agent .= $self->_agent if $agent =~ /\s+$/;
# spent 1µs making 1 call to LWP::UserAgent::CORE:match
665 }
666 else {
667 undef($agent)
668 }
66915µs179µs return $self->default_header("User-Agent", $agent);
# spent 79µs making 1 call to LWP::UserAgent::default_header
670 }
671 return $self->default_header("User-Agent");
672}
673
674sub from { # legacy
675 my $self = shift;
676 return $self->default_header("From", @_);
677}
678
679
680
# spent 939µs (851+88) within LWP::UserAgent::conn_cache which was called # once (851µs+88µs) by LWP::UserAgent::new at line 110
sub conn_cache {
6811700ns my $self = shift;
6821800ns my $old = $self->{conn_cache};
6831700ns if (@_) {
6841400ns my $cache = shift;
6851900ns if (ref($cache) eq "HASH") {
6861100µs require LWP::ConnCache;
68715µs134µs $cache = LWP::ConnCache->new(%$cache);
# spent 34µs making 1 call to LWP::ConnCache::new
688 }
68911µs $self->{conn_cache} = $cache;
690 }
69113µs $old;
692}
693
694
695
# spent 1.72ms (1.63+94µs) within LWP::UserAgent::add_handler which was called # once (1.63ms+94µs) by LWP::UserAgent::set_my_handler at line 710
sub add_handler {
69612µs my($self, $phase, $cb, %spec) = @_;
6971700ns $spec{line} ||= join(":", (caller)[1,2]);
69811µs my $conf = $self->{handlers}{$phase} ||= do {
6991134µs require HTTP::Config;
70014µs19µs HTTP::Config->new;
# spent 9µs making 1 call to HTTP::Config::new
701 };
70217µs15µs $conf->add(%spec, callback => $cb);
# spent 5µs making 1 call to HTTP::Config::add
703}
704
705
# spent 1.76ms (32µs+1.73) within LWP::UserAgent::set_my_handler which was called # once (32µs+1.73ms) by LWP::UserAgent::parse_head at line 612
sub set_my_handler {
70613µs my($self, $phase, $cb, %spec) = @_;
707111µs $spec{owner} = (caller(1))[3] unless exists $spec{owner};
70815µs18µs $self->remove_handler($phase, %spec);
# spent 8µs making 1 call to LWP::UserAgent::remove_handler
70914µs $spec{line} ||= join(":", (caller)[1,2]);
71017µs11.72ms $self->add_handler($phase, $cb, %spec) if $cb;
# spent 1.72ms making 1 call to LWP::UserAgent::add_handler
711}
712
713sub get_my_handler {
714 my $self = shift;
715 my $phase = shift;
716 my $init = pop if @_ % 2;
717 my %spec = @_;
718 my $conf = $self->{handlers}{$phase};
719 unless ($conf) {
720 return unless $init;
721 require HTTP::Config;
722 $conf = $self->{handlers}{$phase} = HTTP::Config->new;
723 }
724 $spec{owner} = (caller(1))[3] unless exists $spec{owner};
725 my @h = $conf->find(%spec);
726 if (!@h && $init) {
727 if (ref($init) eq "CODE") {
728 $init->(\%spec);
729 }
730 elsif (ref($init) eq "HASH") {
731 while (my($k, $v) = each %$init) {
732 $spec{$k} = $v;
733 }
734 }
735 $spec{callback} ||= sub {};
736 $spec{line} ||= join(":", (caller)[1,2]);
737 $conf->add(\%spec);
738 return \%spec;
739 }
740 return wantarray ? @h : $h[0];
741}
742
743
# spent 8µs within LWP::UserAgent::remove_handler which was called # once (8µs+0s) by LWP::UserAgent::set_my_handler at line 708
sub remove_handler {
74412µs my($self, $phase, %spec) = @_;
7451500ns if ($phase) {
74616µs my $conf = $self->{handlers}{$phase} || return;
747 my @h = $conf->remove(%spec);
748 delete $self->{handlers}{$phase} if $conf->empty;
749 return @h;
750 }
751
752 return unless $self->{handlers};
753 return map $self->remove_handler($_), sort keys %{$self->{handlers}};
754}
755
756
# spent 18.1ms (1.49+16.6) within LWP::UserAgent::handlers which was called 303 times, avg 60µs/call: # 164 times (929µs+16.6ms) by LWP::UserAgent::run_handlers at line 778, avg 107µs/call # 82 times (213µs+0s) by LWP::UserAgent::run_handlers at line 771, avg 3µs/call # 57 times (350µs+0s) by LWP::Protocol::collect at line 149 of LWP/Protocol.pm, avg 6µs/call
sub handlers {
757303180µs my($self, $phase, $o) = @_;
75830352µs my @h;
759303224µs if ($o->{handlers} && $o->{handlers}{$phase}) {
760 push(@h, @{$o->{handlers}{$phase}});
761 }
762303399µs4116.6ms if (my $conf = $self->{handlers}{$phase}) {
# spent 16.6ms making 41 calls to HTTP::Config::matching, avg 406µs/call
763 push(@h, $conf->matching($o));
764 }
765303797µs return @h;
766}
767
768
# spent 19.6ms (1.77+17.8) within LWP::UserAgent::run_handlers which was called 246 times, avg 80µs/call: # 41 times (431µs+17.2ms) by LWP::Protocol::collect at line 132 of LWP/Protocol.pm, avg 429µs/call # 41 times (298µs+172µs) by LWP::UserAgent::prepare_request at line 213, avg 11µs/call # 41 times (322µs+117µs) by LWP::UserAgent::request at line 270, avg 11µs/call # 41 times (275µs+132µs) by LWP::UserAgent::send_request at line 198, avg 10µs/call # 41 times (245µs+96µs) by LWP::UserAgent::send_request at line 126, avg 8µs/call # 41 times (203µs+109µs) by LWP::UserAgent::prepare_request at line 221, avg 8µs/call
sub run_handlers {
769246190µs my($self, $phase, $o) = @_;
77024689µs if (defined(wantarray)) {
77182218µs82213µs for my $h ($self->handlers($phase, $o)) {
# spent 213µs making 82 calls to LWP::UserAgent::handlers, avg 3µs/call
772 my $ret = $h->{callback}->($o, $self, $h);
773 return $ret if $ret;
774 }
77582205µs return undef;
776 }
777
778164858µs16417.6ms for my $h ($self->handlers($phase, $o)) {
# spent 17.6ms making 164 calls to LWP::UserAgent::handlers, avg 107µs/call
779 $h->{callback}->($o, $self, $h);
780 }
781}
782
783
784# depreciated
785sub use_eval { shift->_elem('use_eval', @_); }
786sub use_alarm
787{
788 Carp::carp("LWP::UserAgent->use_alarm(BOOL) is a no-op")
789 if @_ > 1 && $^W;
790 "";
791}
792
793
794sub clone
795{
796 my $self = shift;
797 my $copy = bless { %$self }, ref $self; # copy most fields
798
799 delete $copy->{handlers};
800 delete $copy->{conn_cache};
801
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}} ];
807 }
808 elsif (ref($copy->{$k}) eq "HASH") {
809 $copy->{$k} = { %{$copy->{$k}} };
810 }
811 }
812
813 if ($self->{def_headers}) {
814 $copy->{def_headers} = $self->{def_headers}->clone;
815 }
816
817 # re-enable standard handlers
818 $copy->parse_head($self->parse_head);
819
820 # no easy way to clone the cookie jar; so let's just remove it for now
821 $copy->cookie_jar(undef);
822
823 $copy;
824}
825
826
827sub mirror
828{
829 my($self, $url, $file) = @_;
830
831 my $request = HTTP::Request->new('GET', $url);
832
833 # If the file exists, add a cache-related header
834 if ( -e $file ) {
835 my ($mtime) = ( stat($file) )[9];
836 if ($mtime) {
837 $request->header( 'If-Modified-Since' => HTTP::Date::time2str($mtime) );
838 }
839 }
840 my $tmpfile = "$file-$$";
841
842 my $response = $self->request($request, $tmpfile);
843 if ( $response->header('X-Died') ) {
844 die $response->header('X-Died');
845 }
846
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');
854
855 if ( defined $content_length and $file_length < $content_length ) {
856 unlink($tmpfile);
857 die "Transfer truncated: " . "only $file_length out of $content_length bytes received\n";
858 }
859 elsif ( defined $content_length and $file_length > $content_length ) {
860 unlink($tmpfile);
861 die "Content-length mismatch: " . "expected $content_length bytes, got $file_length\n";
862 }
863 # The file was the expected length.
864 else {
865 # Replace the stale file with a fresh copy
866 if ( -e $file ) {
867 # Some dosish systems fail to rename if the target exists
868 chmod 0777, $file;
869 unlink $file;
870 }
871 rename( $tmpfile, $file )
872 or die "Cannot rename '$tmpfile' to '$file': $!\n";
873
874 # make sure the file has the same last modification time
875 if ( my $lm = $response->last_modified ) {
876 utime $lm, $lm, $file;
877 }
878 }
879 }
880 # The local copy is fresh enough, so just delete the temp file
881 else {
882 unlink($tmpfile);
883 }
884 return $response;
885}
886
887
888sub _need_proxy {
889 my($req, $ua) = @_;
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$/) {
896 return;
897 }
898 }
899 }
900 }
901 $req->{proxy} = $HTTP::URI_CLASS->new($proxy);
902}
903
904
905sub proxy
906{
907 my $self = shift;
908 my $key = shift;
909 return map $self->proxy($_, @_), @$key if ref $key;
910
911 Carp::croak("'$key' is not a valid URI scheme") unless $key =~ /^$URI::scheme_re\z/;
912 my $old = $self->{'proxy'}{$key};
913 if (@_) {
914 my $url = shift;
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,;
918 }
919 $self->{proxy}{$key} = $url;
920 $self->set_my_handler("request_preprepare", \&_need_proxy)
921 }
922 return $old;
923}
924
925
926sub env_proxy {
927 my ($self) = @_;
928 my($k,$v);
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";
935 }
936 $k = lc($k);
937 next unless $k =~ /^(.*)_proxy$/;
938 $k = $1;
939 if ($k eq 'no') {
940 $self->no_proxy(split(/\s*,\s*/, $v));
941 }
942 else {
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);
948 }
949 }
950}
951
952
953sub no_proxy {
954 my($self, @no) = @_;
955 if (@no) {
956 push(@{ $self->{'no_proxy'} }, @no);
957 }
958 else {
959 $self->{'no_proxy'} = [];
960 }
961}
962
963
964sub _new_response {
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");
972 return $response;
973}
974
975
976112µs1;
977
978__END__
979
980=head1 NAME
981
982LWP::UserAgent - Web user agent class
983
984=head1 SYNOPSIS
985
986 require LWP::UserAgent;
987
988 my $ua = LWP::UserAgent->new;
989 $ua->timeout(10);
990 $ua->env_proxy;
991
992 my $response = $ua->get('http://search.cpan.org/');
993
994 if ($response->is_success) {
995 print $response->decoded_content; # or whatever
996 }
997 else {
998 die $response->status_line;
999 }
1000
1001=head1 DESCRIPTION
1002
1003The C<LWP::UserAgent> is a class implementing a web user agent.
1004C<LWP::UserAgent> objects can be used to dispatch web requests.
1005
1006In normal use the application creates an C<LWP::UserAgent> object, and
1007then configures it with values for timeouts, proxies, name, etc. It
1008then creates an instance of C<HTTP::Request> for the request that
1009needs to be performed. This request is then passed to one of the
1010request method the UserAgent, which dispatches it using the relevant
1011protocol, and returns a C<HTTP::Response> object. There are
1012convenience methods for sending the most common request types: get(),
1013head() and post(). When using these methods then the creation of the
1014request object is hidden as shown in the synopsis above.
1015
1016The basic approach of the library is to use HTTP style communication
1017for all protocol schemes. This means that you will construct
1018C<HTTP::Request> objects and receive C<HTTP::Response> objects even
1019for non-HTTP resources like I<gopher> and I<ftp>. In order to achieve
1020even more similarity to HTTP style communications, gopher menus and
1021file directories are converted to HTML documents.
1022
1023=head1 CONSTRUCTOR METHODS
1024
1025The following constructor methods are available:
1026
1027=over 4
1028
1029=item $ua = LWP::UserAgent->new( %options )
1030
1031This method constructs a new C<LWP::UserAgent> object and returns it.
1032Key/value pair arguments may be provided to set up the initial state.
1033The following options correspond to attribute methods described below:
1034
1035 KEY DEFAULT
1036 ----------- --------------------
1037 agent "libwww-perl/#.###"
1038 from undef
1039 conn_cache undef
1040 cookie_jar undef
1041 default_headers HTTP::Headers->new
1042 local_address undef
1043 max_size undef
1044 max_redirect 7
1045 parse_head 1
1046 protocols_allowed undef
1047 protocols_forbidden undef
1048 requests_redirectable ['GET', 'HEAD']
1049 timeout 180
1050
1051The following additional options are also accepted: If the
1052C<env_proxy> option is passed in with a TRUE value, then proxy
1053settings are read from environment variables (see env_proxy() method
1054below). If the C<keep_alive> option is passed in, then a
1055C<LWP::ConnCache> is set up (see conn_cache() method below). The
1056C<keep_alive> value is passed on as the C<total_capacity> for the
1057connection cache.
1058
1059=item $ua->clone
1060
1061Returns a copy of the LWP::UserAgent object.
1062
1063=back
1064
1065=head1 ATTRIBUTES
1066
1067The settings of the configuration attributes modify the behaviour of the
1068C<LWP::UserAgent> when it dispatches requests. Most of these can also
1069be initialized by options passed to the constructor method.
1070
1071The following attribute methods are provided. The attribute value is
1072left unchanged if no argument is given. The return value from each
1073method is the old attribute value.
1074
1075=over
1076
1077=item $ua->agent
1078
1079=item $ua->agent( $product_id )
1080
1081Get/set the product token that is used to identify the user agent on
1082the network. The agent value is sent as the "User-Agent" header in
1083the requests. The default is the string returned by the _agent()
1084method (see below).
1085
1086If the $product_id ends with space then the _agent() string is
1087appended to it.
1088
1089The user agent string should be one or more simple product identifiers
1090with an optional version number separated by the "/" character.
1091Examples are:
1092
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
1097
1098=item $ua->_agent
1099
1100Returns the default agent identifier. This is a string of the form
1101"libwww-perl/#.###", where "#.###" is substituted with the version number
1102of this library.
1103
1104=item $ua->from
1105
1106=item $ua->from( $email_address )
1107
1108Get/set the e-mail address for the human user who controls
1109the requesting user agent. The address should be machine-usable, as
1110defined in RFC 822. The C<from> value is send as the "From" header in
1111the requests. Example:
1112
1113 $ua->from('gaas@cpan.org');
1114
1115The default is to not send a "From" header. See the default_headers()
1116method for the more general interface that allow any header to be defaulted.
1117
1118=item $ua->cookie_jar
1119
1120=item $ua->cookie_jar( $cookie_jar_obj )
1121
1122Get/set the cookie jar object to use. The only requirement is that
1123the cookie jar object must implement the extract_cookies($request) and
1124add_cookie_header($response) methods. These methods will then be
1125invoked by the user agent as requests are sent and responses are
1126received. Normally this will be a C<HTTP::Cookies> object or some
1127subclass.
1128
1129The default is to have no cookie_jar, i.e. never automatically add
1130"Cookie" headers to the requests.
1131
1132Shortcut: If a reference to a plain hash is passed in as the
1133$cookie_jar_object, then it is replaced with an instance of
1134C<HTTP::Cookies> that is initialized based on the hash. This form also
1135automatically loads the C<HTTP::Cookies> module. It means that:
1136
1137 $ua->cookie_jar({ file => "$ENV{HOME}/.cookies.txt" });
1138
1139is really just a shortcut for:
1140
1141 require HTTP::Cookies;
1142 $ua->cookie_jar(HTTP::Cookies->new(file => "$ENV{HOME}/.cookies.txt"));
1143
1144=item $ua->default_headers
1145
1146=item $ua->default_headers( $headers_obj )
1147
1148Get/set the headers object that will provide default header values for
1149any requests sent. By default this will be an empty C<HTTP::Headers>
1150object.
1151
1152=item $ua->default_header( $field )
1153
1154=item $ua->default_header( $field => $value )
1155
1156This is just a short-cut for $ua->default_headers->header( $field =>
1157$value ). Example:
1158
1159 $ua->default_header('Accept-Encoding' => scalar HTTP::Message::decodable());
1160 $ua->default_header('Accept-Language' => "no, en");
1161
1162=item $ua->conn_cache
1163
1164=item $ua->conn_cache( $cache_obj )
1165
1166Get/set the C<LWP::ConnCache> object to use. See L<LWP::ConnCache>
1167for details.
1168
1169=item $ua->credentials( $netloc, $realm )
1170
1171=item $ua->credentials( $netloc, $realm, $uname, $pass )
1172
1173Get/set the user name and password to be used for a realm.
1174
1175The $netloc is a string of the form "<host>:<port>". The username and
1176password will only be passed to this server. Example:
1177
1178 $ua->credentials("www.example.com:80", "Some Realm", "foo", "secret");
1179
1180=item $ua->local_address
1181
1182=item $ua->local_address( $address )
1183
1184Get/set the local interface to bind to for network connections. The interface
1185can be specified as a hostname or an IP address. This value is passed as the
1186C<LocalAddr> argument to L<IO::Socket::INET>.
1187
1188=item $ua->max_size
1189
1190=item $ua->max_size( $bytes )
1191
1192Get/set the size limit for response content. The default is C<undef>,
1193which means that there is no limit. If the returned response content
1194is only partial, because the size limit was exceeded, then a
1195"Client-Aborted" header will be added to the response. The content
1196might end up longer than C<max_size> as we abort once appending a
1197chunk of data makes the length exceed the limit. The "Content-Length"
1198header, if present, will indicate the length of the full content and
1199will normally not be the same as C<< length($res->content) >>.
1200
1201=item $ua->max_redirect
1202
1203=item $ua->max_redirect( $n )
1204
1205This reads or sets the object's limit of how many times it will obey
1206redirection responses in a given request cycle.
1207
1208By default, the value is 7. This means that if you call request()
1209method and the response is a redirect elsewhere which is in turn a
1210redirect, and so on seven times, then LWP gives up after that seventh
1211request.
1212
1213=item $ua->parse_head
1214
1215=item $ua->parse_head( $boolean )
1216
1217Get/set a value indicating whether we should initialize response
1218headers from the E<lt>head> section of HTML documents. The default is
1219TRUE. Do not turn this off, unless you know what you are doing.
1220
1221=item $ua->protocols_allowed
1222
1223=item $ua->protocols_allowed( \@protocols )
1224
1225This reads (or sets) this user agent's list of protocols that the
1226request methods will exclusively allow. The protocol names are case
1227insensitive.
1228
1229For example: C<$ua-E<gt>protocols_allowed( [ 'http', 'https'] );>
1230means that this user agent will I<allow only> those protocols,
1231and attempts to use this user agent to access URLs with any other
1232schemes (like "ftp://...") will result in a 500 error.
1233
1234To delete the list, call: C<$ua-E<gt>protocols_allowed(undef)>
1235
1236By default, an object has neither a C<protocols_allowed> list, nor a
1237C<protocols_forbidden> list.
1238
1239Note that having a C<protocols_allowed> list causes any
1240C<protocols_forbidden> list to be ignored.
1241
1242=item $ua->protocols_forbidden
1243
1244=item $ua->protocols_forbidden( \@protocols )
1245
1246This reads (or sets) this user agent's list of protocols that the
1247request method will I<not> allow. The protocol names are case
1248insensitive.
1249
1250For example: C<$ua-E<gt>protocols_forbidden( [ 'file', 'mailto'] );>
1251means that this user agent will I<not> allow those protocols, and
1252attempts to use this user agent to access URLs with those schemes
1253will result in a 500 error.
1254
1255To delete the list, call: C<$ua-E<gt>protocols_forbidden(undef)>
1256
1257=item $ua->requests_redirectable
1258
1259=item $ua->requests_redirectable( \@requests )
1260
1261This reads or sets the object's list of request names that
1262C<$ua-E<gt>redirect_ok(...)> will allow redirection for. By
1263default, this is C<['GET', 'HEAD']>, as per RFC 2616. To
1264change to include 'POST', consider:
1265
1266 push @{ $ua->requests_redirectable }, 'POST';
1267
1268=item $ua->show_progress
1269
1270=item $ua->show_progress( $boolean )
1271
1272Get/set a value indicating whether a progress bar should be displayed
1273on on the terminal as requests are processed. The default is FALSE.
1274
1275=item $ua->timeout
1276
1277=item $ua->timeout( $secs )
1278
1279Get/set the timeout value in seconds. The default timeout() value is
1280180 seconds, i.e. 3 minutes.
1281
1282The requests is aborted if no activity on the connection to the server
1283is observed for C<timeout> seconds. This means that the time it takes
1284for the complete transaction and the request() method to actually
1285return might be longer.
1286
1287=back
1288
1289=head2 Proxy attributes
1290
1291The following methods set up when requests should be passed via a
1292proxy server.
1293
1294=over
1295
1296=item $ua->proxy(\@schemes, $proxy_url)
1297
1298=item $ua->proxy($scheme, $proxy_url)
1299
1300Set/retrieve proxy URL for a scheme:
1301
1302 $ua->proxy(['http', 'ftp'], 'http://proxy.sn.no:8001/');
1303 $ua->proxy('gopher', 'http://proxy.sn.no:8001/');
1304
1305The first form specifies that the URL is to be used for proxying of
1306access methods listed in the list in the first method argument,
1307i.e. 'http' and 'ftp'.
1308
1309The second form shows a shorthand form for specifying
1310proxy URL for a single access scheme.
1311
1312=item $ua->no_proxy( $domain, ... )
1313
1314Do not proxy requests to the given domains. Calling no_proxy without
1315any domains clears the list of domains. Eg:
1316
1317 $ua->no_proxy('localhost', 'example.com');
1318
1319=item $ua->env_proxy
1320
1321Load proxy settings from *_proxy environment variables. You might
1322specify proxies like this (sh-syntax):
1323
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
1328
1329csh or tcsh users should use the C<setenv> command to define these
1330environment variables.
1331
1332On systems with case insensitive environment variables there exists a
1333name clash between the CGI environment variables and the C<HTTP_PROXY>
1334environment variable normally picked up by env_proxy(). Because of
1335this C<HTTP_PROXY> is not honored for CGI scripts. The
1336C<CGI_HTTP_PROXY> environment variable can be used instead.
1337
1338=back
1339
1340=head2 Handlers
1341
1342Handlers are code that injected at various phases during the
1343processing of requests. The following methods are provided to manage
1344the active handlers:
1345
1346=over
1347
1348=item $ua->add_handler( $phase => \&cb, %matchspec )
1349
1350Add handler to be invoked in the given processing phase. For how to
1351specify %matchspec see L<HTTP::Config/"Matching">.
1352
1353The possible values $phase and the corresponding callback signatures are:
1354
1355=over
1356
1357=item request_preprepare => sub { my($request, $ua, $h) = @_; ... }
1358
1359The handler is called before the C<request_prepare> and other standard
1360initialization of of the request. This can be used to set up headers
1361and attributes that the C<request_prepare> handler depends on. Proxy
1362initialization should take place here; but in general don't register
1363handlers for this phase.
1364
1365=item request_prepare => sub { my($request, $ua, $h) = @_; ... }
1366
1367The handler is called before the request is sent and can modify the
1368request any way it see fit. This can for instance be used to add
1369certain headers to specific requests.
1370
1371The method can assign a new request object to $_[0] to replace the
1372request that is sent fully.
1373
1374The return value from the callback is ignored. If an exceptions is
1375raised it will abort the request and make the request method return a
1376"400 Bad request" response.
1377
1378=item request_send => sub { my($request, $ua, $h) = @_; ... }
1379
1380This handler get a chance of handling requests before it's sent to the
1381protocol handlers. It should return an HTTP::Response object if it
1382wishes to terminate the processing; otherwise it should return nothing.
1383
1384The C<response_header> and C<response_data> handlers will not be
1385invoked for this response, but the C<response_done> will be.
1386
1387=item response_header => sub { my($response, $ua, $h) = @_; ... }
1388
1389This handler is called right after the response headers have been
1390received, but before any content data. The handler might set up
1391handlers for data and might croak to abort the request.
1392
1393The handler might set the $response->{default_add_content} value to
1394control if any received data should be added to the response object
1395directly. This will initially be false if the $ua->request() method
1396was called with a ':content_filename' or ':content_callbak' argument;
1397otherwise true.
1398
1399=item response_data => sub { my($response, $ua, $h, $data) = @_; ... }
1400
1401This handlers is called for each chunk of data received for the
1402response. The handler might croak to abort the request.
1403
1404This handler need to return a TRUE value to be called again for
1405subsequent chunks for the same request.
1406
1407=item response_done => sub { my($response, $ua, $h) = @_; ... }
1408
1409The handler is called after the response has been fully received, but
1410before any redirect handling is attempted. The handler can be used to
1411extract information or modify the response.
1412
1413=item response_redirect => sub { my($response, $ua, $h) = @_; ... }
1414
1415The handler is called in $ua->request after C<response_done>. If the
1416handler return an HTTP::Request object we'll start over with processing
1417this request instead.
1418
1419=back
1420
1421=item $ua->remove_handler( undef, %matchspec )
1422
1423=item $ua->remove_handler( $phase, %matchspec )
1424
1425Remove handlers that match the given %matchspec. If $phase is not
1426provided remove handlers from all phases.
1427
1428Be careful as calling this function with %matchspec that is not not
1429specific enough can remove handlers not owned by you. It's probably
1430better to use the set_my_handler() method instead.
1431
1432The removed handlers are returned.
1433
1434=item $ua->set_my_handler( $phase, $cb, %matchspec )
1435
1436Set handlers private to the executing subroutine. Works by defaulting
1437an C<owner> field to the %matchhspec that holds the name of the called
1438subroutine. You might pass an explicit C<owner> to override this.
1439
1440If $cb is passed as C<undef>, remove the handler.
1441
1442=item $ua->get_my_handler( $phase, %matchspec )
1443
1444=item $ua->get_my_handler( $phase, %matchspec, $init )
1445
1446Will retrieve the matching handler as hash ref.
1447
1448If C<$init> is passed passed as a TRUE value, create and add the
1449handler if it's not found. If $init is a subroutine reference, then
1450it's called with the created handler hash as argument. This sub might
1451populate the hash with extra fields; especially the callback. If
1452$init is a hash reference, merge the hashes.
1453
1454=item $ua->handlers( $phase, $request )
1455
1456=item $ua->handlers( $phase, $response )
1457
1458Returns the handlers that apply to the given request or response at
1459the given processing phase.
1460
1461=back
1462
1463=head1 REQUEST METHODS
1464
1465The methods described in this section are used to dispatch requests
1466via the user agent. The following request methods are provided:
1467
1468=over
1469
1470=item $ua->get( $url )
1471
1472=item $ua->get( $url , $field_name => $value, ... )
1473
1474This method will dispatch a C<GET> request on the given $url. Further
1475arguments can be given to initialize the headers of the request. These
1476are given as separate name/value pairs. The return value is a
1477response object. See L<HTTP::Response> for a description of the
1478interface it provides.
1479
1480There will still be a response object returned when LWP can't connect to the
1481server specified in the URL or when other failures in protocol handlers occur.
1482These internal responses use the standard HTTP status codes, so the responses
1483can't be differentiated by testing the response status code alone. Error
1484responses that LWP generates internally will have the "Client-Warning" header
1485set to the value "Internal response". If you need to differentiate these
1486internal responses from responses that a remote server actually generates, you
1487need to test this header value.
1488
1489Fields names that start with ":" are special. These will not
1490initialize headers of the request but will determine how the response
1491content is treated. The following special field names are recognized:
1492
1493 :content_file => $filename
1494 :content_cb => \&callback
1495 :read_size_hint => $bytes
1496
1497If a $filename is provided with the C<:content_file> option, then the
1498response content will be saved here instead of in the response
1499object. If a callback is provided with the C<:content_cb> option then
1500this function will be called for each chunk of the response content as
1501it is received from the server. If neither of these options are
1502given, then the response content will accumulate in the response
1503object itself. This might not be suitable for very large response
1504bodies. Only one of C<:content_file> or C<:content_cb> can be
1505specified. The content of unsuccessful responses will always
1506accumulate in the response object itself, regardless of the
1507C<:content_file> or C<:content_cb> options passed in.
1508
1509The C<:read_size_hint> option is passed to the protocol module which
1510will try to read data from the server in chunks of this size. A
1511smaller value for the C<:read_size_hint> will result in a higher
1512number of callback invocations.
1513
1514The callback function is called with 3 arguments: a chunk of data, a
1515reference to the response object, and a reference to the protocol
1516object. The callback can abort the request by invoking die(). The
1517exception message will show up as the "X-Died" header field in the
1518response returned by the get() function.
1519
1520=item $ua->head( $url )
1521
1522=item $ua->head( $url , $field_name => $value, ... )
1523
1524This method will dispatch a C<HEAD> request on the given $url.
1525Otherwise it works like the get() method described above.
1526
1527=item $ua->post( $url, \%form )
1528
1529=item $ua->post( $url, \@form )
1530
1531=item $ua->post( $url, \%form, $field_name => $value, ... )
1532
1533=item $ua->post( $url, $field_name => $value,... Content => \%form )
1534
1535=item $ua->post( $url, $field_name => $value,... Content => \@form )
1536
1537=item $ua->post( $url, $field_name => $value,... Content => $content )
1538
1539This 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
1541content. Additional headers and content options are the same as for
1542the get() method.
1543
1544This method will use the POST() function from C<HTTP::Request::Common>
1545to build the request. See L<HTTP::Request::Common> for a details on
1546how to pass form content and other advanced features.
1547
1548=item $ua->mirror( $url, $filename )
1549
1550This method will get the document identified by $url and store it in
1551file called $filename. If the file already exists, then the request
1552will contain an "If-Modified-Since" header matching the modification
1553time of the file. If the document on the server has not changed since
1554this time, then nothing happens. If the document has been updated, it
1555will be downloaded again. The modification time of the file will be
1556forced to match that of the server.
1557
1558The return value is the the response object.
1559
1560=item $ua->request( $request )
1561
1562=item $ua->request( $request, $content_file )
1563
1564=item $ua->request( $request, $content_cb )
1565
1566=item $ua->request( $request, $content_cb, $read_size_hint )
1567
1568This method will dispatch the given $request object. Normally this
1569will be an instance of the C<HTTP::Request> class, but any object with
1570a similar interface will do. The return value is a response object.
1571See L<HTTP::Request> and L<HTTP::Response> for a description of the
1572interface provided by these classes.
1573
1574The request() method will process redirects and authentication
1575responses transparently. This means that it may actually send several
1576simple requests via the simple_request() method described below.
1577
1578The request methods described above; get(), head(), post() and
1579mirror(), will all dispatch the request they build via this method.
1580They are convenience methods that simply hides the creation of the
1581request object for you.
1582
1583The $content_file, $content_cb and $read_size_hint all correspond to
1584options described with the get() method above.
1585
1586You are allowed to use a CODE reference as C<content> in the request
1587object passed in. The C<content> function should return the content
1588when called. The content can be returned in chunks. The content
1589function will be invoked repeatedly until it return an empty string to
1590signal that there is no more content.
1591
1592=item $ua->simple_request( $request )
1593
1594=item $ua->simple_request( $request, $content_file )
1595
1596=item $ua->simple_request( $request, $content_cb )
1597
1598=item $ua->simple_request( $request, $content_cb, $read_size_hint )
1599
1600This method dispatches a single request and returns the response
1601received. Arguments are the same as for request() described above.
1602
1603The difference from request() is that simple_request() will not try to
1604handle redirects or authentication responses. The request() method
1605will in fact invoke this method for each simple request it sends.
1606
1607=item $ua->is_protocol_supported( $scheme )
1608
1609You can use this method to test whether this user agent object supports the
1610specified C<scheme>. (The C<scheme> might be a string (like 'http' or
1611'ftp') or it might be an URI object reference.)
1612
1613Whether a scheme is supported, is determined by the user agent's
1614C<protocols_allowed> or C<protocols_forbidden> lists (if any), and by
1615the capabilities of LWP. I.e., this will return TRUE only if LWP
1616supports this protocol I<and> it's permitted for this particular
1617object.
1618
1619=back
1620
1621=head2 Callback methods
1622
1623The following methods will be invoked as requests are processed. These
1624methods are documented here because subclasses of C<LWP::UserAgent>
1625might want to override their behaviour.
1626
1627=over
1628
1629=item $ua->prepare_request( $request )
1630
1631This method is invoked by simple_request(). Its task is to modify the
1632given $request object by setting up various headers based on the
1633attributes of the user agent. The return value should normally be the
1634$request object passed in. If a different request object is returned
1635it will be the one actually processed.
1636
1637The headers affected by the base implementation are; "User-Agent",
1638"From", "Range" and "Cookie".
1639
1640=item $ua->redirect_ok( $prospective_request, $response )
1641
1642This method is called by request() before it tries to follow a
1643redirection to the request in $response. This should return a TRUE
1644value if this redirection is permissible. The $prospective_request
1645will be the request to be sent if this method returns TRUE.
1646
1647The base implementation will return FALSE unless the method
1648is in the object's C<requests_redirectable> list,
1649FALSE if the proposed redirection is to a "file://..."
1650URL, and TRUE otherwise.
1651
1652=item $ua->get_basic_credentials( $realm, $uri, $isproxy )
1653
1654This is called by request() to retrieve credentials for documents
1655protected by Basic or Digest Authentication. The arguments passed in
1656is the $realm provided by the server, the $uri requested and a boolean
1657flag to indicate if this is authentication against a proxy server.
1658
1659The method should return a username and password. It should return an
1660empty list to abort the authentication resolution attempt. Subclasses
1661can override this method to prompt the user for the information. An
1662example of this can be found in C<lwp-request> program distributed
1663with this library.
1664
1665The base implementation simply checks a set of pre-stored member
1666variables, set up with the credentials() method.
1667
1668=item $ua->progress( $status, $request_or_response )
1669
1670This is called frequently as the response is received regardless of
1671how the content is processed. The method is called with $status
1672"begin" at the start of processing the request and with $state "end"
1673before the request method returns. In between these $status will be
1674the fraction of the response currently received or the string "tick"
1675if the fraction can't be calculated.
1676
1677When $status is "begin" the second argument is the request object,
1678otherwise it is the response object.
1679
1680=back
1681
1682=head1 SEE ALSO
1683
1684See L<LWP> for a complete overview of libwww-perl5. See L<lwpcook>
1685and the scripts F<lwp-request> and F<lwp-download> for examples of
1686usage.
1687
1688See L<HTTP::Request> and L<HTTP::Response> for a description of the
1689message objects dispatched and received. See L<HTTP::Request::Common>
1690and L<HTML::Form> for other ways to build request objects.
1691
1692See L<WWW::Mechanize> and L<WWW::Search> for examples of more
1693specialized user agents based on C<LWP::UserAgent>.
1694
1695=head1 COPYRIGHT
1696
1697Copyright 1995-2009 Gisle Aas.
1698
1699This library is free software; you can redistribute it and/or
1700modify it under the same terms as Perl itself.
# spent 1µs within LWP::UserAgent::CORE:match which was called # once (1µs+0s) by LWP::UserAgent::agent at line 664 of LWP/UserAgent.pm
sub LWP::UserAgent::CORE:match; # xsub