← Index
NYTProf Performance Profile   « line view »
For starman worker -M FindBin --max-requests 50 --workers 2 --user=kohadev-koha --group kohadev-koha --pid /var/run/koha/kohadev/plack.pid --daemonize --access-log /var/log/koha/kohadev/plack.log --error-log /var/log/koha/kohadev/plack-error.log -E deployment --socket /var/run/koha/kohadev/plack.sock /etc/koha/sites/kohadev/plack.psgi
  Run on Fri Jan 8 14:31:06 2016
Reported on Fri Jan 8 14:31:39 2016

Filename/usr/share/perl5/LWP/UserAgent.pm
StatementsExecuted 23 statements in 5.62ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1111.54ms1.61msLWP::UserAgent::::BEGIN@15LWP::UserAgent::BEGIN@15
111832µs852µsLWP::UserAgent::::BEGIN@10LWP::UserAgent::BEGIN@10
111134µs134µsLWP::UserAgent::::BEGIN@14LWP::UserAgent::BEGIN@14
11115µs27µsLWP::UserAgent::::BEGIN@3LWP::UserAgent::BEGIN@3
11112µs21µsLWP::UserAgent::::BEGIN@375LWP::UserAgent::BEGIN@375
11110µs37µsLWP::UserAgent::::BEGIN@4LWP::UserAgent::BEGIN@4
1117µs7µsLWP::UserAgent::::BEGIN@17LWP::UserAgent::BEGIN@17
1115µs5µsLWP::UserAgent::::BEGIN@11LWP::UserAgent::BEGIN@11
1114µs4µsLWP::UserAgent::::BEGIN@12LWP::UserAgent::BEGIN@12
0000s0sLWP::UserAgent::::__ANON__[:680]LWP::UserAgent::__ANON__[:680]
0000s0sLWP::UserAgent::::__ANON__[:683]LWP::UserAgent::__ANON__[:683]
0000s0sLWP::UserAgent::::__ANON__[:704]LWP::UserAgent::__ANON__[:704]
0000s0sLWP::UserAgent::::__ANON__[:707]LWP::UserAgent::__ANON__[:707]
0000s0sLWP::UserAgent::::__ANON__[:807]LWP::UserAgent::__ANON__[:807]
0000s0sLWP::UserAgent::::_agentLWP::UserAgent::_agent
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::::add_handlerLWP::UserAgent::add_handler
0000s0sLWP::UserAgent::::agentLWP::UserAgent::agent
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::::default_headerLWP::UserAgent::default_header
0000s0sLWP::UserAgent::::default_headersLWP::UserAgent::default_headers
0000s0sLWP::UserAgent::::deleteLWP::UserAgent::delete
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::::handlersLWP::UserAgent::handlers
0000s0sLWP::UserAgent::::headLWP::UserAgent::head
0000s0sLWP::UserAgent::::is_onlineLWP::UserAgent::is_online
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::::newLWP::UserAgent::new
0000s0sLWP::UserAgent::::no_proxyLWP::UserAgent::no_proxy
0000s0sLWP::UserAgent::::parse_headLWP::UserAgent::parse_head
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::::putLWP::UserAgent::put
0000s0sLWP::UserAgent::::redirect_okLWP::UserAgent::redirect_ok
0000s0sLWP::UserAgent::::remove_handlerLWP::UserAgent::remove_handler
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::::set_my_handlerLWP::UserAgent::set_my_handler
0000s0sLWP::UserAgent::::show_progressLWP::UserAgent::show_progress
0000s0sLWP::UserAgent::::simple_requestLWP::UserAgent::simple_request
0000s0sLWP::UserAgent::::ssl_optsLWP::UserAgent::ssl_opts
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
3246µs238µs
# spent 27µs (15+11) within LWP::UserAgent::BEGIN@3 which was called: # once (15µs+11µs) by Authen::CAS::Client::BEGIN@9 at line 3
use strict;
# spent 27µs making 1 call to LWP::UserAgent::BEGIN@3 # spent 11µs making 1 call to strict::import
4284µs264µs
# spent 37µs (10+27) within LWP::UserAgent::BEGIN@4 which was called: # once (10µs+27µs) by Authen::CAS::Client::BEGIN@9 at line 4
use vars qw(@ISA $VERSION);
# spent 37µs making 1 call to LWP::UserAgent::BEGIN@4 # spent 27µs making 1 call to vars::import
5
611µsrequire LWP::MemberMixin;
7110µs@ISA = qw(LWP::MemberMixin);
81400ns$VERSION = "6.06";
9
102173µs1852µs
# spent 852µs (832+21) within LWP::UserAgent::BEGIN@10 which was called: # once (832µs+21µs) by Authen::CAS::Client::BEGIN@9 at line 10
use HTTP::Request ();
# spent 852µs making 1 call to LWP::UserAgent::BEGIN@10
11223µs15µs
# spent 5µs within LWP::UserAgent::BEGIN@11 which was called: # once (5µs+0s) by Authen::CAS::Client::BEGIN@9 at line 11
use HTTP::Response ();
# spent 5µs making 1 call to LWP::UserAgent::BEGIN@11
12220µs14µs
# spent 4µs within LWP::UserAgent::BEGIN@12 which was called: # once (4µs+0s) by Authen::CAS::Client::BEGIN@9 at line 12
use HTTP::Date ();
# spent 4µs making 1 call to LWP::UserAgent::BEGIN@12
13
142162µs1134µs
# spent 134µs within LWP::UserAgent::BEGIN@14 which was called: # once (134µs+0s) by Authen::CAS::Client::BEGIN@9 at line 14
use LWP ();
# spent 134µs making 1 call to LWP::UserAgent::BEGIN@14
152166µs11.61ms
# spent 1.61ms (1.54+67µs) within LWP::UserAgent::BEGIN@15 which was called: # once (1.54ms+67µs) by Authen::CAS::Client::BEGIN@9 at line 15
use LWP::Protocol ();
# spent 1.61ms making 1 call to LWP::UserAgent::BEGIN@15
16
1721.52ms17µs
# spent 7µs within LWP::UserAgent::BEGIN@17 which was called: # once (7µs+0s) by Authen::CAS::Client::BEGIN@9 at line 17
use Carp ();
# spent 7µs making 1 call to LWP::UserAgent::BEGIN@17
18
19
20sub new
21{
22 # Check for common user mistake
23 Carp::croak("Options to LWP::UserAgent should be key/value pairs, not hash reference")
24 if ref($_[1]) eq 'HASH';
25
26 my($class, %cnf) = @_;
27
28 my $agent = delete $cnf{agent};
29 my $from = delete $cnf{from};
30 my $def_headers = delete $cnf{default_headers};
31 my $timeout = delete $cnf{timeout};
32 $timeout = 3*60 unless defined $timeout;
33 my $local_address = delete $cnf{local_address};
34 my $ssl_opts = delete $cnf{ssl_opts} || {};
35 unless (exists $ssl_opts->{verify_hostname}) {
36 # The processing of HTTPS_CA_* below is for compatibility with Crypt::SSLeay
37 if (exists $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME}) {
38 $ssl_opts->{verify_hostname} = $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME};
39 }
40 elsif ($ENV{HTTPS_CA_FILE} || $ENV{HTTPS_CA_DIR}) {
41 # Crypt-SSLeay compatibility (verify peer certificate; but not the hostname)
42 $ssl_opts->{verify_hostname} = 0;
43 $ssl_opts->{SSL_verify_mode} = 1;
44 }
45 else {
46 $ssl_opts->{verify_hostname} = 1;
47 }
48 }
49 unless (exists $ssl_opts->{SSL_ca_file}) {
50 if (my $ca_file = $ENV{PERL_LWP_SSL_CA_FILE} || $ENV{HTTPS_CA_FILE}) {
51 $ssl_opts->{SSL_ca_file} = $ca_file;
52 }
53 }
54 unless (exists $ssl_opts->{SSL_ca_path}) {
55 if (my $ca_path = $ENV{PERL_LWP_SSL_CA_PATH} || $ENV{HTTPS_CA_DIR}) {
56 $ssl_opts->{SSL_ca_path} = $ca_path;
57 }
58 }
59 my $use_eval = delete $cnf{use_eval};
60 $use_eval = 1 unless defined $use_eval;
61 my $parse_head = delete $cnf{parse_head};
62 $parse_head = 1 unless defined $parse_head;
63 my $show_progress = delete $cnf{show_progress};
64 my $max_size = delete $cnf{max_size};
65 my $max_redirect = delete $cnf{max_redirect};
66 $max_redirect = 7 unless defined $max_redirect;
67 my $env_proxy = exists $cnf{env_proxy} ? delete $cnf{env_proxy} : $ENV{PERL_LWP_ENV_PROXY};
68
69 my $cookie_jar = delete $cnf{cookie_jar};
70 my $conn_cache = delete $cnf{conn_cache};
71 my $keep_alive = delete $cnf{keep_alive};
72
73 Carp::croak("Can't mix conn_cache and keep_alive")
74 if $conn_cache && $keep_alive;
75
76 my $protocols_allowed = delete $cnf{protocols_allowed};
77 my $protocols_forbidden = delete $cnf{protocols_forbidden};
78
79 my $requests_redirectable = delete $cnf{requests_redirectable};
80 $requests_redirectable = ['GET', 'HEAD']
81 unless defined $requests_redirectable;
82
83 # Actually ""s are just as good as 0's, but for concision we'll just say:
84 Carp::croak("protocols_allowed has to be an arrayref or 0, not \"$protocols_allowed\"!")
85 if $protocols_allowed and ref($protocols_allowed) ne 'ARRAY';
86 Carp::croak("protocols_forbidden has to be an arrayref or 0, not \"$protocols_forbidden\"!")
87 if $protocols_forbidden and ref($protocols_forbidden) ne 'ARRAY';
88 Carp::croak("requests_redirectable has to be an arrayref or 0, not \"$requests_redirectable\"!")
89 if $requests_redirectable and ref($requests_redirectable) ne 'ARRAY';
90
91
92 if (%cnf && $^W) {
93 Carp::carp("Unrecognized LWP::UserAgent options: @{[sort keys %cnf]}");
94 }
95
96 my $self = bless {
97 def_headers => $def_headers,
98 timeout => $timeout,
99 local_address => $local_address,
100 ssl_opts => $ssl_opts,
101 use_eval => $use_eval,
102 show_progress=> $show_progress,
103 max_size => $max_size,
104 max_redirect => $max_redirect,
105 proxy => {},
106 no_proxy => [],
107 protocols_allowed => $protocols_allowed,
108 protocols_forbidden => $protocols_forbidden,
109 requests_redirectable => $requests_redirectable,
110 }, $class;
111
112 $self->agent(defined($agent) ? $agent : $class->_agent)
113 if defined($agent) || !$def_headers || !$def_headers->header("User-Agent");
114 $self->from($from) if $from;
115 $self->cookie_jar($cookie_jar) if $cookie_jar;
116 $self->parse_head($parse_head);
117 $self->env_proxy if $env_proxy;
118
119 $self->protocols_allowed( $protocols_allowed ) if $protocols_allowed;
120 $self->protocols_forbidden($protocols_forbidden) if $protocols_forbidden;
121
122 if ($keep_alive) {
123 $conn_cache ||= { total_capacity => $keep_alive };
124 }
125 $self->conn_cache($conn_cache) if $conn_cache;
126
127 return $self;
128}
129
130
131sub send_request
132{
133 my($self, $request, $arg, $size) = @_;
134 my($method, $url) = ($request->method, $request->uri);
135 my $scheme = $url->scheme;
136
137 local($SIG{__DIE__}); # protect against user defined die handlers
138
139 $self->progress("begin", $request);
140
141 my $response = $self->run_handlers("request_send", $request);
142
143 unless ($response) {
144 my $protocol;
145
146 {
147 # Honor object-specific restrictions by forcing protocol objects
148 # into class LWP::Protocol::nogo.
149 my $x;
150 if($x = $self->protocols_allowed) {
151 if (grep lc($_) eq $scheme, @$x) {
152 }
153 else {
154 require LWP::Protocol::nogo;
155 $protocol = LWP::Protocol::nogo->new;
156 }
157 }
158 elsif ($x = $self->protocols_forbidden) {
159 if(grep lc($_) eq $scheme, @$x) {
160 require LWP::Protocol::nogo;
161 $protocol = LWP::Protocol::nogo->new;
162 }
163 }
164 # else fall thru and create the protocol object normally
165 }
166
167 # Locate protocol to use
168 my $proxy = $request->{proxy};
169 if ($proxy) {
170 $scheme = $proxy->scheme;
171 }
172
173 unless ($protocol) {
174 $protocol = eval { LWP::Protocol::create($scheme, $self) };
175 if ($@) {
176 $@ =~ s/ at .* line \d+.*//s; # remove file/line number
177 $response = _new_response($request, &HTTP::Status::RC_NOT_IMPLEMENTED, $@);
178 if ($scheme eq "https") {
179 $response->message($response->message . " (LWP::Protocol::https not installed)");
180 $response->content_type("text/plain");
181 $response->content(<<EOT);
182LWP will support https URLs if the LWP::Protocol::https module
183is installed.
184EOT
185 }
186 }
187 }
188
189 if (!$response && $self->{use_eval}) {
190 # we eval, and turn dies into responses below
191 eval {
192 $response = $protocol->request($request, $proxy, $arg, $size, $self->{timeout}) ||
193 die "No response returned by $protocol";
194 };
195 if ($@) {
196 if (UNIVERSAL::isa($@, "HTTP::Response")) {
197 $response = $@;
198 $response->request($request);
199 }
200 else {
201 my $full = $@;
202 (my $status = $@) =~ s/\n.*//s;
203 $status =~ s/ at .* line \d+.*//s; # remove file/line number
204 my $code = ($status =~ s/^(\d\d\d)\s+//) ? $1 : &HTTP::Status::RC_INTERNAL_SERVER_ERROR;
205 $response = _new_response($request, $code, $status, $full);
206 }
207 }
208 }
209 elsif (!$response) {
210 $response = $protocol->request($request, $proxy,
211 $arg, $size, $self->{timeout});
212 # XXX: Should we die unless $response->is_success ???
213 }
214 }
215
216 $response->request($request); # record request for reference
217 $response->header("Client-Date" => HTTP::Date::time2str(time));
218
219 $self->run_handlers("response_done", $response);
220
221 $self->progress("end", $response);
222 return $response;
223}
224
225
226sub prepare_request
227{
228 my($self, $request) = @_;
229 die "Method missing" unless $request->method;
230 my $url = $request->uri;
231 die "URL missing" unless $url;
232 die "URL must be absolute" unless $url->scheme;
233
234 $self->run_handlers("request_preprepare", $request);
235
236 if (my $def_headers = $self->{def_headers}) {
237 for my $h ($def_headers->header_field_names) {
238 $request->init_header($h => [$def_headers->header($h)]);
239 }
240 }
241
242 $self->run_handlers("request_prepare", $request);
243
244 return $request;
245}
246
247
248sub simple_request
249{
250 my($self, $request, $arg, $size) = @_;
251
252 # sanity check the request passed in
253 if (defined $request) {
254 if (ref $request) {
255 Carp::croak("You need a request object, not a " . ref($request) . " object")
256 if ref($request) eq 'ARRAY' or ref($request) eq 'HASH' or
257 !$request->can('method') or !$request->can('uri');
258 }
259 else {
260 Carp::croak("You need a request object, not '$request'");
261 }
262 }
263 else {
264 Carp::croak("No request object passed in");
265 }
266
267 eval {
268 $request = $self->prepare_request($request);
269 };
270 if ($@) {
271 $@ =~ s/ at .* line \d+.*//s; # remove file/line number
272 return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, $@);
273 }
274 return $self->send_request($request, $arg, $size);
275}
276
277
278sub request
279{
280 my($self, $request, $arg, $size, $previous) = @_;
281
282 my $response = $self->simple_request($request, $arg, $size);
283 $response->previous($previous) if $previous;
284
285 if ($response->redirects >= $self->{max_redirect}) {
286 $response->header("Client-Warning" =>
287 "Redirect loop detected (max_redirect = $self->{max_redirect})");
288 return $response;
289 }
290
291 if (my $req = $self->run_handlers("response_redirect", $response)) {
292 return $self->request($req, $arg, $size, $response);
293 }
294
295 my $code = $response->code;
296
297 if ($code == &HTTP::Status::RC_MOVED_PERMANENTLY or
298 $code == &HTTP::Status::RC_FOUND or
299 $code == &HTTP::Status::RC_SEE_OTHER or
300 $code == &HTTP::Status::RC_TEMPORARY_REDIRECT)
301 {
302 my $referral = $request->clone;
303
304 # These headers should never be forwarded
305 $referral->remove_header('Host', 'Cookie');
306
307 if ($referral->header('Referer') &&
308 $request->uri->scheme eq 'https' &&
309 $referral->uri->scheme eq 'http')
310 {
311 # RFC 2616, section 15.1.3.
312 # https -> http redirect, suppressing Referer
313 $referral->remove_header('Referer');
314 }
315
316 if ($code == &HTTP::Status::RC_SEE_OTHER ||
317 $code == &HTTP::Status::RC_FOUND)
318 {
319 my $method = uc($referral->method);
320 unless ($method eq "GET" || $method eq "HEAD") {
321 $referral->method("GET");
322 $referral->content("");
323 $referral->remove_content_headers;
324 }
325 }
326
327 # And then we update the URL based on the Location:-header.
328 my $referral_uri = $response->header('Location');
329 {
330 # Some servers erroneously return a relative URL for redirects,
331 # so make it absolute if it not already is.
332 local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
333 my $base = $response->base;
334 $referral_uri = "" unless defined $referral_uri;
335 $referral_uri = $HTTP::URI_CLASS->new($referral_uri, $base)
336 ->abs($base);
337 }
338 $referral->uri($referral_uri);
339
340 return $response unless $self->redirect_ok($referral, $response);
341 return $self->request($referral, $arg, $size, $response);
342
343 }
344 elsif ($code == &HTTP::Status::RC_UNAUTHORIZED ||
345 $code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED
346 )
347 {
348 my $proxy = ($code == &HTTP::Status::RC_PROXY_AUTHENTICATION_REQUIRED);
349 my $ch_header = $proxy || $request->method eq 'CONNECT'
350 ? "Proxy-Authenticate" : "WWW-Authenticate";
351 my @challenge = $response->header($ch_header);
352 unless (@challenge) {
353 $response->header("Client-Warning" =>
354 "Missing Authenticate header");
355 return $response;
356 }
357
358 require HTTP::Headers::Util;
359 CHALLENGE: for my $challenge (@challenge) {
360 $challenge =~ tr/,/;/; # "," is used to separate auth-params!!
361 ($challenge) = HTTP::Headers::Util::split_header_words($challenge);
362 my $scheme = shift(@$challenge);
363 shift(@$challenge); # no value
364 $challenge = { @$challenge }; # make rest into a hash
365
366 unless ($scheme =~ /^([a-z]+(?:-[a-z]+)*)$/) {
367 $response->header("Client-Warning" =>
368 "Bad authentication scheme '$scheme'");
369 return $response;
370 }
371 $scheme = $1; # untainted now
372 my $class = "LWP::Authen::\u$scheme";
373 $class =~ s/-/_/g;
374
37523.41ms230µs
# spent 21µs (12+9) within LWP::UserAgent::BEGIN@375 which was called: # once (12µs+9µs) by Authen::CAS::Client::BEGIN@9 at line 375
no strict 'refs';
# spent 21µs making 1 call to LWP::UserAgent::BEGIN@375 # spent 9µs making 1 call to strict::unimport
376 unless (%{"$class\::"}) {
377 # try to load it
378 eval "require $class";
379 if ($@) {
380 if ($@ =~ /^Can\'t locate/) {
381 $response->header("Client-Warning" =>
382 "Unsupported authentication scheme '$scheme'");
383 }
384 else {
385 $response->header("Client-Warning" => $@);
386 }
387 next CHALLENGE;
388 }
389 }
390 unless ($class->can("authenticate")) {
391 $response->header("Client-Warning" =>
392 "Unsupported authentication scheme '$scheme'");
393 next CHALLENGE;
394 }
395 return $class->authenticate($self, $proxy, $challenge, $response,
396 $request, $arg, $size);
397 }
398 return $response;
399 }
400 return $response;
401}
402
403
404#
405# Now the shortcuts...
406#
407sub get {
408 require HTTP::Request::Common;
409 my($self, @parameters) = @_;
410 my @suff = $self->_process_colonic_headers(\@parameters,1);
411 return $self->request( HTTP::Request::Common::GET( @parameters ), @suff );
412}
413
414
415sub post {
416 require HTTP::Request::Common;
417 my($self, @parameters) = @_;
418 my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1));
419 return $self->request( HTTP::Request::Common::POST( @parameters ), @suff );
420}
421
422
423sub head {
424 require HTTP::Request::Common;
425 my($self, @parameters) = @_;
426 my @suff = $self->_process_colonic_headers(\@parameters,1);
427 return $self->request( HTTP::Request::Common::HEAD( @parameters ), @suff );
428}
429
430
431sub put {
432 require HTTP::Request::Common;
433 my($self, @parameters) = @_;
434 my @suff = $self->_process_colonic_headers(\@parameters, (ref($parameters[1]) ? 2 : 1));
435 return $self->request( HTTP::Request::Common::PUT( @parameters ), @suff );
436}
437
438
439sub delete {
440 require HTTP::Request::Common;
441 my($self, @parameters) = @_;
442 my @suff = $self->_process_colonic_headers(\@parameters,1);
443 return $self->request( HTTP::Request::Common::DELETE( @parameters ), @suff );
444}
445
446
447sub _process_colonic_headers {
448 # Process :content_cb / :content_file / :read_size_hint headers.
449 my($self, $args, $start_index) = @_;
450
451 my($arg, $size);
452 for(my $i = $start_index; $i < @$args; $i += 2) {
453 next unless defined $args->[$i];
454
455 #printf "Considering %s => %s\n", $args->[$i], $args->[$i + 1];
456
457 if($args->[$i] eq ':content_cb') {
458 # Some sanity-checking...
459 $arg = $args->[$i + 1];
460 Carp::croak("A :content_cb value can't be undef") unless defined $arg;
461 Carp::croak("A :content_cb value must be a coderef")
462 unless ref $arg and UNIVERSAL::isa($arg, 'CODE');
463
464 }
465 elsif ($args->[$i] eq ':content_file') {
466 $arg = $args->[$i + 1];
467
468 # Some sanity-checking...
469 Carp::croak("A :content_file value can't be undef")
470 unless defined $arg;
471 Carp::croak("A :content_file value can't be a reference")
472 if ref $arg;
473 Carp::croak("A :content_file value can't be \"\"")
474 unless length $arg;
475
476 }
477 elsif ($args->[$i] eq ':read_size_hint') {
478 $size = $args->[$i + 1];
479 # Bother checking it?
480
481 }
482 else {
483 next;
484 }
485 splice @$args, $i, 2;
486 $i -= 2;
487 }
488
489 # And return a suitable suffix-list for request(REQ,...)
490
491 return unless defined $arg;
492 return $arg, $size if defined $size;
493 return $arg;
494}
495
496
497sub is_online {
498 my $self = shift;
499 return 1 if $self->get("http://www.msftncsi.com/ncsi.txt")->content eq "Microsoft NCSI";
500 return 1 if $self->get("http://www.apple.com")->content =~ m,<title>Apple</title>,;
501 return 0;
502}
503
504
50511µsmy @ANI = qw(- \ | /);
506
507sub progress {
508 my($self, $status, $m) = @_;
509 return unless $self->{show_progress};
510
511 local($,, $\);
512 if ($status eq "begin") {
513 print STDERR "** ", $m->method, " ", $m->uri, " ==> ";
514 $self->{progress_start} = time;
515 $self->{progress_lastp} = "";
516 $self->{progress_ani} = 0;
517 }
518 elsif ($status eq "end") {
519 delete $self->{progress_lastp};
520 delete $self->{progress_ani};
521 print STDERR $m->status_line;
522 my $t = time - delete $self->{progress_start};
523 print STDERR " (${t}s)" if $t;
524 print STDERR "\n";
525 }
526 elsif ($status eq "tick") {
527 print STDERR "$ANI[$self->{progress_ani}++]\b";
528 $self->{progress_ani} %= @ANI;
529 }
530 else {
531 my $p = sprintf "%3.0f%%", $status * 100;
532 return if $p eq $self->{progress_lastp};
533 print STDERR "$p\b\b\b\b";
534 $self->{progress_lastp} = $p;
535 }
536 STDERR->flush;
537}
538
539
540#
541# This whole allow/forbid thing is based on man 1 at's way of doing things.
542#
543sub is_protocol_supported
544{
545 my($self, $scheme) = @_;
546 if (ref $scheme) {
547 # assume we got a reference to an URI object
548 $scheme = $scheme->scheme;
549 }
550 else {
551 Carp::croak("Illegal scheme '$scheme' passed to is_protocol_supported")
552 if $scheme =~ /\W/;
553 $scheme = lc $scheme;
554 }
555
556 my $x;
557 if(ref($self) and $x = $self->protocols_allowed) {
558 return 0 unless grep lc($_) eq $scheme, @$x;
559 }
560 elsif (ref($self) and $x = $self->protocols_forbidden) {
561 return 0 if grep lc($_) eq $scheme, @$x;
562 }
563
564 local($SIG{__DIE__}); # protect against user defined die handlers
565 $x = LWP::Protocol::implementor($scheme);
566 return 1 if $x and $x ne 'LWP::Protocol::nogo';
567 return 0;
568}
569
570
571sub protocols_allowed { shift->_elem('protocols_allowed' , @_) }
572sub protocols_forbidden { shift->_elem('protocols_forbidden' , @_) }
573sub requests_redirectable { shift->_elem('requests_redirectable', @_) }
574
575
576sub redirect_ok
577{
578 # RFC 2616, section 10.3.2 and 10.3.3 say:
579 # If the 30[12] status code is received in response to a request other
580 # than GET or HEAD, the user agent MUST NOT automatically redirect the
581 # request unless it can be confirmed by the user, since this might
582 # change the conditions under which the request was issued.
583
584 # Note that this routine used to be just:
585 # return 0 if $_[1]->method eq "POST"; return 1;
586
587 my($self, $new_request, $response) = @_;
588 my $method = $response->request->method;
589 return 0 unless grep $_ eq $method,
590 @{ $self->requests_redirectable || [] };
591
592 if ($new_request->uri->scheme eq 'file') {
593 $response->header("Client-Warning" =>
594 "Can't redirect to a file:// URL!");
595 return 0;
596 }
597
598 # Otherwise it's apparently okay...
599 return 1;
600}
601
602
603sub credentials
604{
605 my $self = shift;
606 my $netloc = lc(shift);
607 my $realm = shift || "";
608 my $old = $self->{basic_authentication}{$netloc}{$realm};
609 if (@_) {
610 $self->{basic_authentication}{$netloc}{$realm} = [@_];
611 }
612 return unless $old;
613 return @$old if wantarray;
614 return join(":", @$old);
615}
616
617
618sub get_basic_credentials
619{
620 my($self, $realm, $uri, $proxy) = @_;
621 return if $proxy;
622 return $self->credentials($uri->host_port, $realm);
623}
624
625
626sub timeout { shift->_elem('timeout', @_); }
627sub local_address{ shift->_elem('local_address',@_); }
628sub max_size { shift->_elem('max_size', @_); }
629sub max_redirect { shift->_elem('max_redirect', @_); }
630sub show_progress{ shift->_elem('show_progress', @_); }
631
632sub ssl_opts {
633 my $self = shift;
634 if (@_ == 1) {
635 my $k = shift;
636 return $self->{ssl_opts}{$k};
637 }
638 if (@_) {
639 my $old;
640 while (@_) {
641 my($k, $v) = splice(@_, 0, 2);
642 $old = $self->{ssl_opts}{$k} unless @_;
643 if (defined $v) {
644 $self->{ssl_opts}{$k} = $v;
645 }
646 else {
647 delete $self->{ssl_opts}{$k};
648 }
649 }
650 %{$self->{ssl_opts}} = (%{$self->{ssl_opts}}, @_);
651 return $old;
652 }
653
654 return keys %{$self->{ssl_opts}};
655}
656
657sub parse_head {
658 my $self = shift;
659 if (@_) {
660 my $flag = shift;
661 my $parser;
662 my $old = $self->set_my_handler("response_header", $flag ? sub {
663 my($response, $ua) = @_;
664 require HTML::HeadParser;
665 $parser = HTML::HeadParser->new;
666 $parser->xml_mode(1) if $response->content_is_xhtml;
667 $parser->utf8_mode(1) if $] >= 5.008 && $HTML::Parser::VERSION >= 3.40;
668
669 push(@{$response->{handlers}{response_data}}, {
670 callback => sub {
671 return unless $parser;
672 unless ($parser->parse($_[3])) {
673 my $h = $parser->header;
674 my $r = $_[0];
675 for my $f ($h->header_field_names) {
676 $r->init_header($f, [$h->header($f)]);
677 }
678 undef($parser);
679 }
680 },
681 });
682
683 } : undef,
684 m_media_type => "html",
685 );
686 return !!$old;
687 }
688 else {
689 return !!$self->get_my_handler("response_header");
690 }
691}
692
693sub cookie_jar {
694 my $self = shift;
695 my $old = $self->{cookie_jar};
696 if (@_) {
697 my $jar = shift;
698 if (ref($jar) eq "HASH") {
699 require HTTP::Cookies;
700 $jar = HTTP::Cookies->new(%$jar);
701 }
702 $self->{cookie_jar} = $jar;
703 $self->set_my_handler("request_prepare",
704 $jar ? sub { $jar->add_cookie_header($_[0]); } : undef,
705 );
706 $self->set_my_handler("response_done",
707 $jar ? sub { $jar->extract_cookies($_[0]); } : undef,
708 );
709 }
710 $old;
711}
712
713sub default_headers {
714 my $self = shift;
715 my $old = $self->{def_headers} ||= HTTP::Headers->new;
716 if (@_) {
717 Carp::croak("default_headers not set to HTTP::Headers compatible object")
718 unless @_ == 1 && $_[0]->can("header_field_names");
719 $self->{def_headers} = shift;
720 }
721 return $old;
722}
723
724sub default_header {
725 my $self = shift;
726 return $self->default_headers->header(@_);
727}
728
729sub _agent { "libwww-perl/$LWP::VERSION" }
730
731sub agent {
732 my $self = shift;
733 if (@_) {
734 my $agent = shift;
735 if ($agent) {
736 $agent .= $self->_agent if $agent =~ /\s+$/;
737 }
738 else {
739 undef($agent)
740 }
741 return $self->default_header("User-Agent", $agent);
742 }
743 return $self->default_header("User-Agent");
744}
745
746sub from { # legacy
747 my $self = shift;
748 return $self->default_header("From", @_);
749}
750
751
752sub conn_cache {
753 my $self = shift;
754 my $old = $self->{conn_cache};
755 if (@_) {
756 my $cache = shift;
757 if (ref($cache) eq "HASH") {
758 require LWP::ConnCache;
759 $cache = LWP::ConnCache->new(%$cache);
760 }
761 $self->{conn_cache} = $cache;
762 }
763 $old;
764}
765
766
767sub add_handler {
768 my($self, $phase, $cb, %spec) = @_;
769 $spec{line} ||= join(":", (caller)[1,2]);
770 my $conf = $self->{handlers}{$phase} ||= do {
771 require HTTP::Config;
772 HTTP::Config->new;
773 };
774 $conf->add(%spec, callback => $cb);
775}
776
777sub set_my_handler {
778 my($self, $phase, $cb, %spec) = @_;
779 $spec{owner} = (caller(1))[3] unless exists $spec{owner};
780 $self->remove_handler($phase, %spec);
781 $spec{line} ||= join(":", (caller)[1,2]);
782 $self->add_handler($phase, $cb, %spec) if $cb;
783}
784
785sub get_my_handler {
786 my $self = shift;
787 my $phase = shift;
788 my $init = pop if @_ % 2;
789 my %spec = @_;
790 my $conf = $self->{handlers}{$phase};
791 unless ($conf) {
792 return unless $init;
793 require HTTP::Config;
794 $conf = $self->{handlers}{$phase} = HTTP::Config->new;
795 }
796 $spec{owner} = (caller(1))[3] unless exists $spec{owner};
797 my @h = $conf->find(%spec);
798 if (!@h && $init) {
799 if (ref($init) eq "CODE") {
800 $init->(\%spec);
801 }
802 elsif (ref($init) eq "HASH") {
803 while (my($k, $v) = each %$init) {
804 $spec{$k} = $v;
805 }
806 }
807 $spec{callback} ||= sub {};
808 $spec{line} ||= join(":", (caller)[1,2]);
809 $conf->add(\%spec);
810 return \%spec;
811 }
812 return wantarray ? @h : $h[0];
813}
814
815sub remove_handler {
816 my($self, $phase, %spec) = @_;
817 if ($phase) {
818 my $conf = $self->{handlers}{$phase} || return;
819 my @h = $conf->remove(%spec);
820 delete $self->{handlers}{$phase} if $conf->empty;
821 return @h;
822 }
823
824 return unless $self->{handlers};
825 return map $self->remove_handler($_), sort keys %{$self->{handlers}};
826}
827
828sub handlers {
829 my($self, $phase, $o) = @_;
830 my @h;
831 if ($o->{handlers} && $o->{handlers}{$phase}) {
832 push(@h, @{$o->{handlers}{$phase}});
833 }
834 if (my $conf = $self->{handlers}{$phase}) {
835 push(@h, $conf->matching($o));
836 }
837 return @h;
838}
839
840sub run_handlers {
841 my($self, $phase, $o) = @_;
842 if (defined(wantarray)) {
843 for my $h ($self->handlers($phase, $o)) {
844 my $ret = $h->{callback}->($o, $self, $h);
845 return $ret if $ret;
846 }
847 return undef;
848 }
849
850 for my $h ($self->handlers($phase, $o)) {
851 $h->{callback}->($o, $self, $h);
852 }
853}
854
855
856# deprecated
857sub use_eval { shift->_elem('use_eval', @_); }
858sub use_alarm
859{
860 Carp::carp("LWP::UserAgent->use_alarm(BOOL) is a no-op")
861 if @_ > 1 && $^W;
862 "";
863}
864
865
866sub clone
867{
868 my $self = shift;
869 my $copy = bless { %$self }, ref $self; # copy most fields
870
871 delete $copy->{handlers};
872 delete $copy->{conn_cache};
873
874 # copy any plain arrays and hashes; known not to need recursive copy
875 for my $k (qw(proxy no_proxy requests_redirectable ssl_opts)) {
876 next unless $copy->{$k};
877 if (ref($copy->{$k}) eq "ARRAY") {
878 $copy->{$k} = [ @{$copy->{$k}} ];
879 }
880 elsif (ref($copy->{$k}) eq "HASH") {
881 $copy->{$k} = { %{$copy->{$k}} };
882 }
883 }
884
885 if ($self->{def_headers}) {
886 $copy->{def_headers} = $self->{def_headers}->clone;
887 }
888
889 # re-enable standard handlers
890 $copy->parse_head($self->parse_head);
891
892 # no easy way to clone the cookie jar; so let's just remove it for now
893 $copy->cookie_jar(undef);
894
895 $copy;
896}
897
898
899sub mirror
900{
901 my($self, $url, $file) = @_;
902
903 my $request = HTTP::Request->new('GET', $url);
904
905 # If the file exists, add a cache-related header
906 if ( -e $file ) {
907 my ($mtime) = ( stat($file) )[9];
908 if ($mtime) {
909 $request->header( 'If-Modified-Since' => HTTP::Date::time2str($mtime) );
910 }
911 }
912 my $tmpfile = "$file-$$";
913
914 my $response = $self->request($request, $tmpfile);
915 if ( $response->header('X-Died') ) {
916 die $response->header('X-Died');
917 }
918
919 # Only fetching a fresh copy of the would be considered success.
920 # If the file was not modified, "304" would returned, which
921 # is considered by HTTP::Status to be a "redirect", /not/ "success"
922 if ( $response->is_success ) {
923 my @stat = stat($tmpfile) or die "Could not stat tmpfile '$tmpfile': $!";
924 my $file_length = $stat[7];
925 my ($content_length) = $response->header('Content-length');
926
927 if ( defined $content_length and $file_length < $content_length ) {
928 unlink($tmpfile);
929 die "Transfer truncated: " . "only $file_length out of $content_length bytes received\n";
930 }
931 elsif ( defined $content_length and $file_length > $content_length ) {
932 unlink($tmpfile);
933 die "Content-length mismatch: " . "expected $content_length bytes, got $file_length\n";
934 }
935 # The file was the expected length.
936 else {
937 # Replace the stale file with a fresh copy
938 if ( -e $file ) {
939 # Some DOSish systems fail to rename if the target exists
940 chmod 0777, $file;
941 unlink $file;
942 }
943 rename( $tmpfile, $file )
944 or die "Cannot rename '$tmpfile' to '$file': $!\n";
945
946 # make sure the file has the same last modification time
947 if ( my $lm = $response->last_modified ) {
948 utime $lm, $lm, $file;
949 }
950 }
951 }
952 # The local copy is fresh enough, so just delete the temp file
953 else {
954 unlink($tmpfile);
955 }
956 return $response;
957}
958
959
960sub _need_proxy {
961 my($req, $ua) = @_;
962 return if exists $req->{proxy};
963 my $proxy = $ua->{proxy}{$req->uri->scheme} || return;
964 if ($ua->{no_proxy}) {
965 if (my $host = eval { $req->uri->host }) {
966 for my $domain (@{$ua->{no_proxy}}) {
967 if ($host =~ /\Q$domain\E$/) {
968 return;
969 }
970 }
971 }
972 }
973 $req->{proxy} = $HTTP::URI_CLASS->new($proxy);
974}
975
976
977sub proxy
978{
979 my $self = shift;
980 my $key = shift;
981 return map $self->proxy($_, @_), @$key if ref $key;
982
983 Carp::croak("'$key' is not a valid URI scheme") unless $key =~ /^$URI::scheme_re\z/;
984 my $old = $self->{'proxy'}{$key};
985 if (@_) {
986 my $url = shift;
987 if (defined($url) && length($url)) {
988 Carp::croak("Proxy must be specified as absolute URI; '$url' is not") unless $url =~ /^$URI::scheme_re:/;
989 Carp::croak("Bad http proxy specification '$url'")
990 if $url =~ /^https?:/ && $url !~ m,^https?://(\w|\[),;
991 }
992 $self->{proxy}{$key} = $url;
993 $self->set_my_handler("request_preprepare", \&_need_proxy)
994 }
995 return $old;
996}
997
998
999sub env_proxy {
1000 my ($self) = @_;
1001 require Encode;
1002 require Encode::Locale;
1003 my($k,$v);
1004 while(($k, $v) = each %ENV) {
1005 if ($ENV{REQUEST_METHOD}) {
1006 # Need to be careful when called in the CGI environment, as
1007 # the HTTP_PROXY variable is under control of that other guy.
1008 next if $k =~ /^HTTP_/;
1009 $k = "HTTP_PROXY" if $k eq "CGI_HTTP_PROXY";
1010 }
1011 $k = lc($k);
1012 next unless $k =~ /^(.*)_proxy$/;
1013 $k = $1;
1014 if ($k eq 'no') {
1015 $self->no_proxy(split(/\s*,\s*/, $v));
1016 }
1017 else {
1018 # Ignore random _proxy variables, allow only valid schemes
1019 next unless $k =~ /^$URI::scheme_re\z/;
1020 # Ignore xxx_proxy variables if xxx isn't a supported protocol
1021 next unless LWP::Protocol::implementor($k);
1022 $self->proxy($k, Encode::decode(locale => $v));
1023 }
1024 }
1025}
1026
1027
1028sub no_proxy {
1029 my($self, @no) = @_;
1030 if (@no) {
1031 push(@{ $self->{'no_proxy'} }, @no);
1032 }
1033 else {
1034 $self->{'no_proxy'} = [];
1035 }
1036}
1037
1038
1039sub _new_response {
1040 my($request, $code, $message, $content) = @_;
1041 $message ||= HTTP::Status::status_message($code);
1042 my $response = HTTP::Response->new($code, $message);
1043 $response->request($request);
1044 $response->header("Client-Date" => HTTP::Date::time2str(time));
1045 $response->header("Client-Warning" => "Internal response");
1046 $response->header("Content-Type" => "text/plain");
1047 $response->content($content || "$code $message\n");
1048 return $response;
1049}
1050
1051
105216µs1;
1053
1054__END__
Report produced by the NYTProf 6.02 Perl profiler, developed by Tim Bunce and Adam Kaplan.