← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 17:10:45 2013
Reported on Tue Oct 15 17:12:28 2013

Filename/usr/share/perl5/LWP/UserAgent.pm
StatementsExecuted 200 statements in 10.0ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11112.3ms13.0msLWP::UserAgent::::BEGIN@10LWP::UserAgent::BEGIN@10
1113.43ms3.63msLWP::UserAgent::::add_handlerLWP::UserAgent::add_handler
1112.85ms3.61msLWP::UserAgent::::BEGIN@12LWP::UserAgent::BEGIN@12
1112.02ms2.05msLWP::UserAgent::::BEGIN@11LWP::UserAgent::BEGIN@11
1111.66ms1.77msLWP::UserAgent::::BEGIN@15LWP::UserAgent::BEGIN@15
111239µs264µsLWP::UserAgent::::env_proxyLWP::UserAgent::env_proxy
111165µs165µsLWP::UserAgent::::BEGIN@14LWP::UserAgent::BEGIN@14
111112µs4.05msLWP::UserAgent::::newLWP::UserAgent::new
22258µs343µsLWP::UserAgent::::agentLWP::UserAgent::agent
11151µs3.69msLWP::UserAgent::::set_my_handlerLWP::UserAgent::set_my_handler
21140µs265µsLWP::UserAgent::::default_headerLWP::UserAgent::default_header
282140µs40µsLWP::UserAgent::::CORE:matchLWP::UserAgent::CORE:match (opcode)
11132µs39µsLWP::UserAgent::::BEGIN@3LWP::UserAgent::BEGIN@3
21132µs63µsLWP::UserAgent::::default_headersLWP::UserAgent::default_headers
11130µs3.72msLWP::UserAgent::::parse_headLWP::UserAgent::parse_head
11119µs50µsLWP::UserAgent::::BEGIN@353LWP::UserAgent::BEGIN@353
11117µs73µsLWP::UserAgent::::BEGIN@4LWP::UserAgent::BEGIN@4
22113µs13µsLWP::UserAgent::::_agentLWP::UserAgent::_agent
11111µs11µsLWP::UserAgent::::remove_handlerLWP::UserAgent::remove_handler
1116µs6µsLWP::UserAgent::::BEGIN@17LWP::UserAgent::BEGIN@17
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::::conn_cacheLWP::UserAgent::conn_cache
0000s0sLWP::UserAgent::::cookie_jarLWP::UserAgent::cookie_jar
0000s0sLWP::UserAgent::::credentialsLWP::UserAgent::credentials
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::::handlersLWP::UserAgent::handlers
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::::prepare_requestLWP::UserAgent::prepare_request
0000s0sLWP::UserAgent::::progressLWP::UserAgent::progress
0000s0sLWP::UserAgent::::protocols_allowedLWP::UserAgent::protocols_allowed
0000s0sLWP::UserAgent::::protocols_forbiddenLWP::UserAgent::protocols_forbidden
0000s0sLWP::UserAgent::::proxyLWP::UserAgent::proxy
0000s0sLWP::UserAgent::::redirect_okLWP::UserAgent::redirect_ok
0000s0sLWP::UserAgent::::requestLWP::UserAgent::request
0000s0sLWP::UserAgent::::requests_redirectableLWP::UserAgent::requests_redirectable
0000s0sLWP::UserAgent::::run_handlersLWP::UserAgent::run_handlers
0000s0sLWP::UserAgent::::send_requestLWP::UserAgent::send_request
0000s0sLWP::UserAgent::::show_progressLWP::UserAgent::show_progress
0000s0sLWP::UserAgent::::simple_requestLWP::UserAgent::simple_request
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
3362µs246µs
# spent 39µs (32+7) within LWP::UserAgent::BEGIN@3 which was called: # once (32µs+7µs) by LWP::Simple::BEGIN@26 at line 3
use strict;
# spent 39µs making 1 call to LWP::UserAgent::BEGIN@3 # spent 7µs making 1 call to strict::import
4361µs2129µs
# spent 73µs (17+56) within LWP::UserAgent::BEGIN@4 which was called: # once (17µs+56µs) by LWP::Simple::BEGIN@26 at line 4
use vars qw(@ISA $VERSION);
# spent 73µs making 1 call to LWP::UserAgent::BEGIN@4 # spent 56µs making 1 call to vars::import
5
612µsrequire LWP::MemberMixin;
7122µs@ISA = qw(LWP::MemberMixin);
811µs$VERSION = "5.835";
9
103180µs113.0ms
# spent 13.0ms (12.3+633µs) within LWP::UserAgent::BEGIN@10 which was called: # once (12.3ms+633µs) by LWP::Simple::BEGIN@26 at line 10
use HTTP::Request ();
# spent 13.0ms making 1 call to LWP::UserAgent::BEGIN@10
113238µs12.05ms
# spent 2.05ms (2.02+37µs) within LWP::UserAgent::BEGIN@11 which was called: # once (2.02ms+37µs) by LWP::Simple::BEGIN@26 at line 11
use HTTP::Response ();
# spent 2.05ms making 1 call to LWP::UserAgent::BEGIN@11
123203µs13.61ms
# spent 3.61ms (2.85+759µs) within LWP::UserAgent::BEGIN@12 which was called: # once (2.85ms+759µs) by LWP::Simple::BEGIN@26 at line 12
use HTTP::Date ();
# spent 3.61ms making 1 call to LWP::UserAgent::BEGIN@12
13
143167µs1165µs
# spent 165µs within LWP::UserAgent::BEGIN@14 which was called: # once (165µs+0s) by LWP::Simple::BEGIN@26 at line 14
use LWP ();
# spent 165µs making 1 call to LWP::UserAgent::BEGIN@14
153131µs11.77ms
# spent 1.77ms (1.66+104µs) within LWP::UserAgent::BEGIN@15 which was called: # once (1.66ms+104µs) by LWP::Simple::BEGIN@26 at line 15
use LWP::Protocol ();
# spent 1.77ms making 1 call to LWP::UserAgent::BEGIN@15
16
1732.10ms16µs
# spent 6µs within LWP::UserAgent::BEGIN@17 which was called: # once (6µs+0s) by LWP::Simple::BEGIN@26 at line 17
use Carp ();
# spent 6µs making 1 call to LWP::UserAgent::BEGIN@17
18
1912µ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
- -
30sub new
31
# spent 4.05ms (112µs+3.93) within LWP::UserAgent::new which was called: # once (112µs+3.93ms) by C4::Auth::BEGIN@34 at line 29 of LWP/Simple.pm
{
32 # Check for common user mistake
3311µs 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
3812µs my $agent = delete $cnf{agent};
391700ns my $from = delete $cnf{from};
401800ns my $def_headers = delete $cnf{default_headers};
411600ns my $timeout = delete $cnf{timeout};
4211µs $timeout = 3*60 unless defined $timeout;
4311µs my $local_address = delete $cnf{local_address};
441900ns my $use_eval = delete $cnf{use_eval};
4511µs $use_eval = 1 unless defined $use_eval;
4611µs my $parse_head = delete $cnf{parse_head};
4711µs $parse_head = 1 unless defined $parse_head;
4811µs my $show_progress = delete $cnf{show_progress};
491800ns my $max_size = delete $cnf{max_size};
501800ns my $max_redirect = delete $cnf{max_redirect};
511500ns $max_redirect = 7 unless defined $max_redirect;
5211µs my $env_proxy = delete $cnf{env_proxy};
53
5411µs my $cookie_jar = delete $cnf{cookie_jar};
551800ns my $conn_cache = delete $cnf{conn_cache};
5611µs my $keep_alive = delete $cnf{keep_alive};
57
5811µs Carp::croak("Can't mix conn_cache and keep_alive")
59 if $conn_cache && $keep_alive;
60
61
621900ns my $protocols_allowed = delete $cnf{protocols_allowed};
6311µs my $protocols_forbidden = delete $cnf{protocols_forbidden};
64
6511µs my $requests_redirectable = delete $cnf{requests_redirectable};
6614µ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:
701900ns Carp::croak("protocols_allowed has to be an arrayref or 0, not \"$protocols_allowed\"!")
71 if $protocols_allowed and ref($protocols_allowed) ne 'ARRAY';
721700ns Carp::croak("protocols_forbidden has to be an arrayref or 0, not \"$protocols_forbidden\"!")
73 if $protocols_forbidden and ref($protocols_forbidden) ne 'ARRAY';
7413µ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
7812µs if (%cnf && $^W) {
79 Carp::carp("Unrecognized LWP::UserAgent options: @{[sort keys %cnf]}");
80 }
81
82129µ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
97116µs2217µs $self->agent(defined($agent) ? $agent : $class->_agent)
# spent 210µs making 1 call to LWP::UserAgent::agent # spent 8µs making 1 call to LWP::UserAgent::_agent
98 if defined($agent) || !$def_headers || !$def_headers->header("User-Agent");
991800ns $self->from($from) if $from;
1001600ns $self->cookie_jar($cookie_jar) if $cookie_jar;
10116µs13.72ms $self->parse_head($parse_head);
# spent 3.72ms making 1 call to LWP::UserAgent::parse_head
1021900ns $self->env_proxy if $env_proxy;
103
1041600ns $self->protocols_allowed( $protocols_allowed ) if $protocols_allowed;
1051500ns $self->protocols_forbidden($protocols_forbidden) if $protocols_forbidden;
106
1071700ns if ($keep_alive) {
108 $conn_cache ||= { total_capacity => $keep_alive };
109 }
1101800ns $self->conn_cache($conn_cache) if $conn_cache;
111
112111µs return $self;
113}
114
115
116sub send_request
117{
118 my($self, $request, $arg, $size) = @_;
119 my($method, $url) = ($request->method, $request->uri);
120 my $scheme = $url->scheme;
121
122 local($SIG{__DIE__}); # protect against user defined die handlers
123
124 $self->progress("begin", $request);
125
126 my $response = $self->run_handlers("request_send", $request);
127
128 unless ($response) {
129 my $protocol;
130
131 {
132 # Honor object-specific restrictions by forcing protocol objects
133 # into class LWP::Protocol::nogo.
134 my $x;
135 if($x = $self->protocols_allowed) {
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
153 my $proxy = $request->{proxy};
154 if ($proxy) {
155 $scheme = $proxy->scheme;
156 }
157
158 unless ($protocol) {
159 $protocol = eval { LWP::Protocol::create($scheme, $self) };
160 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
175 if (!$response && $self->{use_eval}) {
176 # we eval, and turn dies into responses below
177 eval {
178 $response = $protocol->request($request, $proxy,
179 $arg, $size, $self->{timeout});
180 };
181 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
195 $response->request($request); # record request for reference
196 $response->header("Client-Date" => HTTP::Date::time2str(time));
197
198 $self->run_handlers("response_done", $response);
199
200 $self->progress("end", $response);
201 return $response;
202}
203
204
205sub prepare_request
206{
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;
212
213 $self->run_handlers("request_preprepare", $request);
214
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)]);
218 }
219 }
220
221 $self->run_handlers("request_prepare", $request);
222
223 return $request;
224}
225
226
227sub simple_request
228{
229 my($self, $request, $arg, $size) = @_;
230
231 # sanity check the request passed in
232 if (defined $request) {
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
246 eval {
247 $request = $self->prepare_request($request);
248 };
249 if ($@) {
250 $@ =~ s/ at .* line \d+.*//s; # remove file/line number
251 return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, $@);
252 }
253 return $self->send_request($request, $arg, $size);
254}
255
256
257sub request
258{
259 my($self, $request, $arg, $size, $previous) = @_;
260
261 my $response = $self->simple_request($request, $arg, $size);
262 $response->previous($previous) if $previous;
263
264 if ($response->redirects >= $self->{max_redirect}) {
265 $response->header("Client-Warning" =>
266 "Redirect loop detected (max_redirect = $self->{max_redirect})");
267 return $response;
268 }
269
270 if (my $req = $self->run_handlers("response_redirect", $response)) {
271 return $self->request($req, $arg, $size, $response);
272 }
273
274 my $code = $response->code;
275
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)
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
35335.99ms280µs
# spent 50µs (19+30) within LWP::UserAgent::BEGIN@353 which was called: # once (19µs+30µs) by LWP::Simple::BEGIN@26 at line 353
no strict 'refs';
# spent 50µs making 1 call to LWP::UserAgent::BEGIN@353 # spent 30µ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 }
378 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
45813µsmy @ANI = qw(- \ | /);
459
460sub progress {
461 my($self, $status, $m) = @_;
462 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
524sub protocols_allowed { shift->_elem('protocols_allowed' , @_) }
525sub protocols_forbidden { shift->_elem('protocols_forbidden' , @_) }
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 3.72ms (30µs+3.69) within LWP::UserAgent::parse_head which was called: # once (30µs+3.69ms) by LWP::UserAgent::new at line 101
sub parse_head {
58611µs my $self = shift;
58711µs if (@_) {
58811µs 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,
612116µs13.69ms m_media_type => "html",
# spent 3.69ms making 1 call to LWP::UserAgent::set_my_handler
613 );
614110µ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 63µs (32+31) within LWP::UserAgent::default_headers which was called 2 times, avg 32µs/call: # 2 times (32µs+31µs) by LWP::UserAgent::default_header at line 654, avg 32µs/call
sub default_headers {
64222µs my $self = shift;
643214µs131µs my $old = $self->{def_headers} ||= HTTP::Headers->new;
# spent 31µs making 1 call to HTTP::Headers::new
64422µs 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 }
649213µs return $old;
650}
651
652
# spent 265µs (40+225) within LWP::UserAgent::default_header which was called 2 times, avg 133µs/call: # 2 times (40µs+225µs) by LWP::UserAgent::agent at line 669, avg 133µs/call
sub default_header {
65323µs my $self = shift;
654231µs4225µs return $self->default_headers->header(@_);
# spent 162µs making 2 calls to HTTP::Headers::header, avg 81µs/call # spent 63µs making 2 calls to LWP::UserAgent::default_headers, avg 32µs/call
655}
656
657222µs
# spent 13µs within LWP::UserAgent::_agent which was called 2 times, avg 7µs/call: # once (8µs+0s) by LWP::UserAgent::new at line 97 # once (5µs+0s) by LWP::UserAgent::agent at line 664
sub _agent { "libwww-perl/$LWP::VERSION" }
658
659
# spent 343µs (58+285) within LWP::UserAgent::agent which was called 2 times, avg 172µs/call: # once (29µs+181µs) by LWP::UserAgent::new at line 97 # once (29µs+105µs) by C4::Auth::BEGIN@34 at line 30 of LWP/Simple.pm
sub agent {
66023µs my $self = shift;
66123µs if (@_) {
66222µs my $agent = shift;
66322µs if ($agent) {
664240µs320µs $agent .= $self->_agent if $agent =~ /\s+$/;
# spent 15µs making 2 calls to LWP::UserAgent::CORE:match, avg 7µs/call # spent 5µs making 1 call to LWP::UserAgent::_agent
665 }
666 else {
667 undef($agent)
668 }
669223µs2265µs return $self->default_header("User-Agent", $agent);
# spent 265µs making 2 calls to LWP::UserAgent::default_header, avg 133µs/call
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
680sub conn_cache {
681 my $self = shift;
682 my $old = $self->{conn_cache};
683 if (@_) {
684 my $cache = shift;
685 if (ref($cache) eq "HASH") {
686 require LWP::ConnCache;
687 $cache = LWP::ConnCache->new(%$cache);
688 }
689 $self->{conn_cache} = $cache;
690 }
691 $old;
692}
693
694
695
# spent 3.63ms (3.43+200µs) within LWP::UserAgent::add_handler which was called: # once (3.43ms+200µs) by LWP::UserAgent::set_my_handler at line 710
sub add_handler {
696110µs my($self, $phase, $cb, %spec) = @_;
6971900ns $spec{line} ||= join(":", (caller)[1,2]);
69816µs my $conf = $self->{handlers}{$phase} ||= do {
6991178µs require HTTP::Config;
700112µs120µs HTTP::Config->new;
# spent 20µs making 1 call to HTTP::Config::new
701 };
702116µs114µs $conf->add(%spec, callback => $cb);
# spent 14µs making 1 call to HTTP::Config::add
703}
704
705
# spent 3.69ms (51µs+3.64) within LWP::UserAgent::set_my_handler which was called: # once (51µs+3.64ms) by LWP::UserAgent::parse_head at line 612
sub set_my_handler {
70615µs my($self, $phase, $cb, %spec) = @_;
707110µs $spec{owner} = (caller(1))[3] unless exists $spec{owner};
70817µs111µs $self->remove_handler($phase, %spec);
# spent 11µs making 1 call to LWP::UserAgent::remove_handler
70918µs $spec{line} ||= join(":", (caller)[1,2]);
710116µs13.63ms $self->add_handler($phase, $cb, %spec) if $cb;
# spent 3.63ms 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 11µs within LWP::UserAgent::remove_handler which was called: # once (11µs+0s) by LWP::UserAgent::set_my_handler at line 708
sub remove_handler {
74414µs my($self, $phase, %spec) = @_;
7451600ns if ($phase) {
746112µ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
756sub handlers {
757 my($self, $phase, $o) = @_;
758 my @h;
759 if ($o->{handlers} && $o->{handlers}{$phase}) {
760 push(@h, @{$o->{handlers}{$phase}});
761 }
762 if (my $conf = $self->{handlers}{$phase}) {
763 push(@h, $conf->matching($o));
764 }
765 return @h;
766}
767
768sub run_handlers {
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);
773 return $ret if $ret;
774 }
775 return undef;
776 }
777
778 for my $h ($self->handlers($phase, $o)) {
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
926
# spent 264µs (239+25) within LWP::UserAgent::env_proxy which was called: # once (239µs+25µs) by C4::Auth::BEGIN@34 at line 31 of LWP/Simple.pm
sub env_proxy {
92712µs my ($self) = @_;
92811µs my($k,$v);
929188µs while(($k, $v) = each %ENV) {
9302621µs 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 }
9362629µs $k = lc($k);
93726128µs2625µs next unless $k =~ /^(.*)_proxy$/;
# spent 25µs making 26 calls to LWP::UserAgent::CORE:match, avg 958ns/call
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
976118µs1;
977
978__END__
 
# spent 40µs within LWP::UserAgent::CORE:match which was called 28 times, avg 1µs/call: # 26 times (25µs+0s) by LWP::UserAgent::env_proxy at line 937, avg 958ns/call # 2 times (15µs+0s) by LWP::UserAgent::agent at line 664, avg 7µs/call
sub LWP::UserAgent::CORE:match; # opcode
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.