Profile of /usr/local/lib/perl5/site_perl/5.10.1/LWP/UserAgent.pm

← 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
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 7.84ms | 9.41ms | LWP::UserAgent::::BEGIN@10LWP::UserAgent::BEGIN@10
41 | 1 | 1 | 3.12ms | 15.5s | LWP::UserAgent::::send_requestLWP::UserAgent::send_request
1 | 1 | 1 | 2.59ms | 3.06ms | LWP::UserAgent::::BEGIN@12LWP::UserAgent::BEGIN@12
41 | 1 | 1 | 1.78ms | 15.5s | LWP::UserAgent::::requestLWP::UserAgent::request
246 | 6 | 2 | 1.77ms | 19.6ms | LWP::UserAgent::::run_handlersLWP::UserAgent::run_handlers
1 | 1 | 1 | 1.63ms | 1.72ms | LWP::UserAgent::::add_handlerLWP::UserAgent::add_handler
41 | 1 | 1 | 1.61ms | 6.36ms | LWP::UserAgent::::prepare_requestLWP::UserAgent::prepare_request
303 | 3 | 2 | 1.49ms | 18.1ms | LWP::UserAgent::::handlersLWP::UserAgent::handlers
1 | 1 | 1 | 1.24ms | 4.04ms | LWP::UserAgent::::BEGIN@11LWP::UserAgent::BEGIN@11
1 | 1 | 1 | 994µs | 1.05ms | LWP::UserAgent::::BEGIN@15LWP::UserAgent::BEGIN@15
41 | 1 | 1 | 876µs | 15.5s | LWP::UserAgent::::simple_requestLWP::UserAgent::simple_request
1 | 1 | 1 | 851µs | 939µs | LWP::UserAgent::::conn_cacheLWP::UserAgent::conn_cache
139 | 3 | 2 | 502µs | 502µs | LWP::UserAgent::::progressLWP::UserAgent::progress
41 | 1 | 1 | 258µs | 485µs | LWP::UserAgent::::protocols_allowedLWP::UserAgent::protocols_allowed
41 | 1 | 1 | 183µs | 269µs | LWP::UserAgent::::protocols_forbiddenLWP::UserAgent::protocols_forbidden
1 | 1 | 1 | 116µs | 116µs | LWP::UserAgent::::BEGIN@14LWP::UserAgent::BEGIN@14
1 | 1 | 1 | 63µs | 2.88ms | LWP::UserAgent::::newLWP::UserAgent::new
1 | 1 | 1 | 32µs | 1.76ms | LWP::UserAgent::::set_my_handlerLWP::UserAgent::set_my_handler
1 | 1 | 1 | 16µs | 20µs | LWP::UserAgent::::BEGIN@3LWP::UserAgent::BEGIN@3
1 | 1 | 1 | 16µs | 96µs | LWP::UserAgent::::agentLWP::UserAgent::agent
1 | 1 | 1 | 15µs | 1.78ms | LWP::UserAgent::::parse_headLWP::UserAgent::parse_head
1 | 1 | 1 | 13µs | 79µs | LWP::UserAgent::::default_headerLWP::UserAgent::default_header
1 | 1 | 1 | 12µs | 22µs | LWP::UserAgent::::default_headersLWP::UserAgent::default_headers
1 | 1 | 1 | 8µs | 8µs | LWP::UserAgent::::remove_handlerLWP::UserAgent::remove_handler
1 | 1 | 1 | 7µs | 19µs | LWP::UserAgent::::BEGIN@353LWP::UserAgent::BEGIN@353
1 | 1 | 1 | 7µs | 49µs | LWP::UserAgent::::BEGIN@4LWP::UserAgent::BEGIN@4
1 | 1 | 1 | 4µs | 4µs | LWP::UserAgent::::BEGIN@17LWP::UserAgent::BEGIN@17
1 | 1 | 1 | 4µs | 4µs | LWP::UserAgent::::_agentLWP::UserAgent::_agent
1 | 1 | 2 | 1µs | 1µs | LWP::UserAgent::::CORE:matchLWP::UserAgent::CORE:match (opcode)
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::__ANON__[:608]LWP::UserAgent::__ANON__[:608]
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::__ANON__[:611]LWP::UserAgent::__ANON__[:611]
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::__ANON__[:632]LWP::UserAgent::__ANON__[:632]
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::__ANON__[:635]LWP::UserAgent::__ANON__[:635]
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::__ANON__[:735]LWP::UserAgent::__ANON__[:735]
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::_need_proxyLWP::UserAgent::_need_proxy
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::_new_responseLWP::UserAgent::_new_response
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::_process_colonic_headersLWP::UserAgent::_process_colonic_headers
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::cloneLWP::UserAgent::clone
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::cookie_jarLWP::UserAgent::cookie_jar
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::credentialsLWP::UserAgent::credentials
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::env_proxyLWP::UserAgent::env_proxy
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::fromLWP::UserAgent::from
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::getLWP::UserAgent::get
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::get_basic_credentialsLWP::UserAgent::get_basic_credentials
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::get_my_handlerLWP::UserAgent::get_my_handler
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::headLWP::UserAgent::head
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::is_protocol_supportedLWP::UserAgent::is_protocol_supported
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::local_addressLWP::UserAgent::local_address
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::max_redirectLWP::UserAgent::max_redirect
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::max_sizeLWP::UserAgent::max_size
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::mirrorLWP::UserAgent::mirror
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::no_proxyLWP::UserAgent::no_proxy
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::postLWP::UserAgent::post
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::proxyLWP::UserAgent::proxy
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::redirect_okLWP::UserAgent::redirect_ok
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::requests_redirectableLWP::UserAgent::requests_redirectable
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::show_progressLWP::UserAgent::show_progress
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::timeoutLWP::UserAgent::timeout
0 | 0 | 0 | 0s | 0s | LWP::UserAgent::::use_alarmLWP::UserAgent::use_alarm
0 | 0 | 0 | 0s | 0s | LWP::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
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package LWP::UserAgent;
2 |  |  |  |  |
3 | 3 | 25µs | 2 | 23µ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
4 | 3 | 42µs | 2 | 92µ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 |  |  |  |  |
6 | 1 | 700ns |  |  | require LWP::MemberMixin;
7 | 1 | 8µs |  |  | @ISA = qw(LWP::MemberMixin);
8 | 1 | 500ns |  |  | $VERSION = "5.834";
9 |  |  |  |  |
10 | 3 | 164µs | 1 | 9.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
11 | 3 | 141µs | 1 | 4.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
12 | 3 | 176µs | 1 | 3.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 |  |  |  |  |
14 | 3 | 116µs | 1 | 116µ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
15 | 3 | 109µs | 1 | 1.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 |  |  |  |  |
17 | 3 | 1.15ms | 1 | 4µ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 |  |  |  |  |
19 | 1 | 1µs |  |  | if ($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 |  |  |  |  |
30 |  |  |  |  | sub 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
33 | 1 | 800ns |  |  | Carp::croak("Options to LWP::UserAgent should be key/value pairs, not hash reference")
34 |  |  |  |  | if ref($_[1]) eq 'HASH';
35 |  |  |  |  |
36 | 1 | 3µs |  |  | my($class, %cnf) = @_;
37 |  |  |  |  |
38 | 1 | 1µs |  |  | my $agent = delete $cnf{agent};
39 | 1 | 800ns |  |  | my $from = delete $cnf{from};
40 | 1 | 600ns |  |  | my $def_headers = delete $cnf{default_headers};
41 | 1 | 800ns |  |  | my $timeout = delete $cnf{timeout};
42 | 1 | 200ns |  |  | $timeout = 3*60 unless defined $timeout;
43 | 1 | 800ns |  |  | my $local_address = delete $cnf{local_address};
44 | 1 | 300ns |  |  | my $use_eval = delete $cnf{use_eval};
45 | 1 | 300ns |  |  | $use_eval = 1 unless defined $use_eval;
46 | 1 | 300ns |  |  | my $parse_head = delete $cnf{parse_head};
47 | 1 | 200ns |  |  | $parse_head = 1 unless defined $parse_head;
48 | 1 | 400ns |  |  | my $show_progress = delete $cnf{show_progress};
49 | 1 | 400ns |  |  | my $max_size = delete $cnf{max_size};
50 | 1 | 300ns |  |  | my $max_redirect = delete $cnf{max_redirect};
51 | 1 | 500ns |  |  | $max_redirect = 7 unless defined $max_redirect;
52 | 1 | 400ns |  |  | my $env_proxy = delete $cnf{env_proxy};
53 |  |  |  |  |
54 | 1 | 200ns |  |  | my $cookie_jar = delete $cnf{cookie_jar};
55 | 1 | 200ns |  |  | my $conn_cache = delete $cnf{conn_cache};
56 | 1 | 700ns |  |  | my $keep_alive = delete $cnf{keep_alive};
57 |  |  |  |  |
58 | 1 | 100ns |  |  | Carp::croak("Can't mix conn_cache and keep_alive")
59 |  |  |  |  | if $conn_cache && $keep_alive;
60 |  |  |  |  |
61 |  |  |  |  |
62 | 1 | 400ns |  |  | my $protocols_allowed = delete $cnf{protocols_allowed};
63 | 1 | 400ns |  |  | my $protocols_forbidden = delete $cnf{protocols_forbidden};
64 |  |  |  |  |
65 | 1 | 500ns |  |  | my $requests_redirectable = delete $cnf{requests_redirectable};
66 | 1 | 2µ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:
70 | 1 | 300ns |  |  | Carp::croak("protocols_allowed has to be an arrayref or 0, not \"$protocols_allowed\"!")
71 |  |  |  |  | if $protocols_allowed and ref($protocols_allowed) ne 'ARRAY';
72 | 1 | 300ns |  |  | Carp::croak("protocols_forbidden has to be an arrayref or 0, not \"$protocols_forbidden\"!")
73 |  |  |  |  | if $protocols_forbidden and ref($protocols_forbidden) ne 'ARRAY';
74 | 1 | 1µ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 |  |  |  |  |
78 | 1 | 500ns |  |  | if (%cnf && $^W) {
79 |  |  |  |  | Carp::carp("Unrecognized LWP::UserAgent options: @{[sort keys %cnf]}");
80 |  |  |  |  | }
81 |  |  |  |  |
82 | 1 | 18µ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 |  |  |  |  |
97 | 1 | 6µs | 2 | 99µ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");
99 | 1 | 500ns |  |  | $self->from($from) if $from;
100 | 1 | 300ns |  |  | $self->cookie_jar($cookie_jar) if $cookie_jar;
101 | 1 | 3µs | 1 | 1.78ms | $self->parse_head($parse_head); # spent 1.78ms making 1 call to LWP::UserAgent::parse_head
102 | 1 | 500ns |  |  | $self->env_proxy if $env_proxy;
103 |  |  |  |  |
104 | 1 | 300ns |  |  | $self->protocols_allowed( $protocols_allowed ) if $protocols_allowed;
105 | 1 | 100ns |  |  | $self->protocols_forbidden($protocols_forbidden) if $protocols_forbidden;
106 |  |  |  |  |
107 | 1 | 1µs |  |  | if ($keep_alive) {
108 |  |  |  |  | $conn_cache ||= { total_capacity => $keep_alive };
109 |  |  |  |  | }
110 | 1 | 2µs | 1 | 939µs | $self->conn_cache($conn_cache) if $conn_cache; # spent 939µs making 1 call to LWP::UserAgent::conn_cache
111 |  |  |  |  |
112 | 1 | 4µs |  |  | return $self;
113 |  |  |  |  | }
114 |  |  |  |  |
115 |  |  |  |  |
116 |  |  |  |  | sub 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 {
118 | 41 | 54µs |  |  | my($self, $request, $arg, $size) = @_;
119 | 41 | 143µs | 82 | 297µ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
120 | 41 | 66µs | 41 | 453µs | my $scheme = $url->scheme; # spent 453µs making 41 calls to URI::scheme, avg 11µs/call
121 |  |  |  |  |
122 | 41 | 129µs |  |  | local($SIG{__DIE__}); # protect against user defined die handlers
123 |  |  |  |  |
124 | 41 | 107µs | 41 | 138µs | $self->progress("begin", $request); # spent 138µs making 41 calls to LWP::UserAgent::progress, avg 3µs/call
125 |  |  |  |  |
126 | 41 | 75µs | 41 | 341µ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 |  |  |  |  |
128 | 41 | 27µs |  |  | unless ($response) {
129 | 41 | 8µs |  |  | my $protocol;
130 |  |  |  |  |
131 |  |  |  |  | {
132 |  |  |  |  | # Honor object-specific restrictions by forcing protocol objects
133 |  |  |  |  | # into class LWP::Protocol::nogo.
134 | 82 | 39µs |  |  | my $x;
135 | 41 | 275µs | 82 | 754µ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
153 | 41 | 32µs |  |  | my $proxy = $request->{proxy};
154 | 41 | 17µs |  |  | if ($proxy) {
155 |  |  |  |  | $scheme = $proxy->scheme;
156 |  |  |  |  | }
157 |  |  |  |  |
158 | 41 | 20µs |  |  | unless ($protocol) {
159 | 82 | 136µs | 41 | 17.0ms | $protocol = eval { LWP::Protocol::create($scheme, $self) }; # spent 17.0ms making 41 calls to LWP::Protocol::create, avg 414µs/call
160 | 41 | 14µ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);
167 |  |  |  |  | LWP will support https URLs if either Crypt::SSLeay or IO::Socket::SSL
168 |  |  |  |  | is installed. More information at
169 |  |  |  |  | <http://search.cpan.org/dist/libwww-perl/README.SSL>.
170 |  |  |  |  | EOT
171 |  |  |  |  | }
172 |  |  |  |  | }
173 |  |  |  |  | }
174 |  |  |  |  |
175 | 41 | 139µs |  |  | if (!$response && $self->{use_eval}) {
176 |  |  |  |  | # we eval, and turn dies into responses below
177 | 41 | 21µs |  |  | eval {
178 | 41 | 185µs | 41 | 15.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 |  |  |  |  | };
181 | 41 | 17µ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 |  |  |  |  |
195 | 41 | 114µs | 41 | 335µs | $response->request($request); # record request for reference # spent 335µs making 41 calls to HTTP::Response::request, avg 8µs/call
196 | 41 | 254µs | 82 | 2.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 |  |  |  |  |
198 | 41 | 104µs | 41 | 406µs | $self->run_handlers("response_done", $response); # spent 406µs making 41 calls to LWP::UserAgent::run_handlers, avg 10µs/call
199 |  |  |  |  |
200 | 41 | 90µs | 41 | 93µs | $self->progress("end", $response); # spent 93µs making 41 calls to LWP::UserAgent::progress, avg 2µs/call
201 | 41 | 374µs |  |  | return $response;
202 |  |  |  |  | }
203 |  |  |  |  |
204 |  |  |  |  |
205 |  |  |  |  | sub 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 {
207 | 41 | 46µs |  |  | my($self, $request) = @_;
208 | 41 | 69µs | 41 | 231µs | die "Method missing" unless $request->method; # spent 231µs making 41 calls to HTTP::Request::method, avg 6µs/call
209 | 41 | 59µs | 41 | 79µs | my $url = $request->uri; # spent 79µs making 41 calls to HTTP::Request::uri, avg 2µs/call
210 | 41 | 152µs | 41 | 124µs | die "URL missing" unless $url; # spent 124µs making 41 calls to URI::__ANON__[URI.pm:24], avg 3µs/call
211 | 41 | 128µs | 41 | 673µs | die "URL must be absolute" unless $url->scheme; # spent 673µs making 41 calls to URI::scheme, avg 16µs/call
212 |  |  |  |  |
213 | 41 | 114µs | 41 | 470µs | $self->run_handlers("request_preprepare", $request); # spent 470µs making 41 calls to LWP::UserAgent::run_handlers, avg 11µs/call
214 |  |  |  |  |
215 | 41 | 219µs | 41 | 651µ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) {
217 | 41 | 257µs | 82 | 2.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 |  |  |  |  |
221 | 41 | 72µs | 41 | 312µs | $self->run_handlers("request_prepare", $request); # spent 312µs making 41 calls to LWP::UserAgent::run_handlers, avg 8µs/call
222 |  |  |  |  |
223 | 41 | 124µs |  |  | return $request;
224 |  |  |  |  | }
225 |  |  |  |  |
226 |  |  |  |  |
227 |  |  |  |  | sub 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 {
229 | 41 | 54µs |  |  | my($self, $request, $arg, $size) = @_;
230 |  |  |  |  |
231 |  |  |  |  | # sanity check the request passed in
232 | 41 | 355µs | 82 | 78µ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 |  |  |  |  |
246 | 41 | 36µs |  |  | eval {
247 | 41 | 167µs | 41 | 6.36ms | $request = $self->prepare_request($request); # spent 6.36ms making 41 calls to LWP::UserAgent::prepare_request, avg 155µs/call
248 |  |  |  |  | };
249 | 41 | 16µs |  |  | if ($@) {
250 |  |  |  |  | $@ =~ s/ at .* line \d+.*//s; # remove file/line number
251 |  |  |  |  | return _new_response($request, &HTTP::Status::RC_BAD_REQUEST, $@);
252 |  |  |  |  | }
253 | 41 | 255µs | 41 | 15.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 |  |  |  |  |
257 |  |  |  |  | sub 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 {
259 | 41 | 52µs |  |  | my($self, $request, $arg, $size, $previous) = @_;
260 |  |  |  |  |
261 | 41 | 148µs | 41 | 15.5s | my $response = $self->simple_request($request, $arg, $size); # spent 15.5s making 41 calls to LWP::UserAgent::simple_request, avg 378ms/call
262 | 41 | 17µs |  |  | $response->previous($previous) if $previous;
263 |  |  |  |  |
264 | 41 | 188µs | 41 | 788µ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 |  |  |  |  |
270 | 41 | 102µs | 41 | 440µ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 |  |  |  |  |
274 | 41 | 88µs | 41 | 258µs | my $code = $response->code; # spent 258µs making 41 calls to HTTP::Response::code, avg 6µs/call
275 |  |  |  |  |
276 | 41 | 1.25ms | 246 | 406µ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 |  |  |  |  |
353 | 3 | 2.65ms | 2 | 30µ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 |  |  |  |  | }
378 | 41 | 172µs |  |  | return $response;
379 |  |  |  |  | }
380 |  |  |  |  |
381 |  |  |  |  |
382 |  |  |  |  | #
383 |  |  |  |  | # Now the shortcuts...
384 |  |  |  |  | #
385 |  |  |  |  | sub 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 |  |  |  |  |
393 |  |  |  |  | sub 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 |  |  |  |  |
401 |  |  |  |  | sub 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 |  |  |  |  |
409 |  |  |  |  | sub _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 |  |  |  |  |
458 | 1 | 1µs |  |  | my @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 {
461 | 139 | 145µs |  |  | my($self, $status, $m) = @_;
462 | 139 | 502µ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 |  |  |  |  | #
496 |  |  |  |  | sub 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 |  |  |  |  |
524 | 41 | 229µs | 41 | 226µ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
525 | 41 | 148µs | 41 | 87µ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
526 |  |  |  |  | sub requests_redirectable { shift->_elem('requests_redirectable', @_) }
527 |  |  |  |  |
528 |  |  |  |  |
529 |  |  |  |  | sub 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 |  |  |  |  |
556 |  |  |  |  | sub 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 |  |  |  |  |
571 |  |  |  |  | sub 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 |  |  |  |  |
579 |  |  |  |  | sub timeout { shift->_elem('timeout', @_); }
580 |  |  |  |  | sub local_address{ shift->_elem('local_address',@_); }
581 |  |  |  |  | sub max_size { shift->_elem('max_size', @_); }
582 |  |  |  |  | sub max_redirect { shift->_elem('max_redirect', @_); }
583 |  |  |  |  | sub show_progress{ shift->_elem('show_progress', @_); }
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 {
586 | 1 | 700ns |  |  | my $self = shift;
587 | 1 | 600ns |  |  | if (@_) {
588 | 1 | 600ns |  |  | my $flag = shift;
589 | 1 | 400ns |  |  | 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,
612 | 1 | 9µs | 1 | 1.76ms | m_media_type => "html", # spent 1.76ms making 1 call to LWP::UserAgent::set_my_handler
613 |  |  |  |  | );
614 | 1 | 3µs |  |  | return !!$old;
615 |  |  |  |  | }
616 |  |  |  |  | else {
617 |  |  |  |  | return !!$self->get_my_handler("response_header");
618 |  |  |  |  | }
619 |  |  |  |  | }
620 |  |  |  |  |
621 |  |  |  |  | sub 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 {
642 | 1 | 400ns |  |  | my $self = shift;
643 | 1 | 7µs | 1 | 10µs | my $old = $self->{def_headers} ||= HTTP::Headers->new; # spent 10µs making 1 call to HTTP::Headers::new
644 | 1 | 300ns |  |  | 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 |  |  |  |  | }
649 | 1 | 3µ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 {
653 | 1 | 500ns |  |  | my $self = shift;
654 | 1 | 9µs | 2 | 66µ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 |  |  |  |  |
657 | 1 | 6µ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 {
660 | 1 | 600ns |  |  | my $self = shift;
661 | 1 | 600ns |  |  | if (@_) {
662 | 1 | 600ns |  |  | my $agent = shift;
663 | 1 | 800ns |  |  | if ($agent) {
664 | 1 | 7µs | 1 | 1µ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 |  |  |  |  | }
669 | 1 | 5µs | 1 | 79µ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 |  |  |  |  |
674 |  |  |  |  | sub 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 {
681 | 1 | 700ns |  |  | my $self = shift;
682 | 1 | 800ns |  |  | my $old = $self->{conn_cache};
683 | 1 | 700ns |  |  | if (@_) {
684 | 1 | 400ns |  |  | my $cache = shift;
685 | 1 | 900ns |  |  | if (ref($cache) eq "HASH") {
686 | 1 | 100µs |  |  | require LWP::ConnCache;
687 | 1 | 5µs | 1 | 34µs | $cache = LWP::ConnCache->new(%$cache); # spent 34µs making 1 call to LWP::ConnCache::new
688 |  |  |  |  | }
689 | 1 | 1µs |  |  | $self->{conn_cache} = $cache;
690 |  |  |  |  | }
691 | 1 | 3µ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 {
696 | 1 | 2µs |  |  | my($self, $phase, $cb, %spec) = @_;
697 | 1 | 700ns |  |  | $spec{line} ||= join(":", (caller)[1,2]);
698 | 1 | 1µs |  |  | my $conf = $self->{handlers}{$phase} ||= do {
699 | 1 | 134µs |  |  | require HTTP::Config;
700 | 1 | 4µs | 1 | 9µs | HTTP::Config->new; # spent 9µs making 1 call to HTTP::Config::new
701 |  |  |  |  | };
702 | 1 | 7µs | 1 | 5µ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 {
706 | 1 | 3µs |  |  | my($self, $phase, $cb, %spec) = @_;
707 | 1 | 11µs |  |  | $spec{owner} = (caller(1))[3] unless exists $spec{owner};
708 | 1 | 5µs | 1 | 8µs | $self->remove_handler($phase, %spec); # spent 8µs making 1 call to LWP::UserAgent::remove_handler
709 | 1 | 4µs |  |  | $spec{line} ||= join(":", (caller)[1,2]);
710 | 1 | 7µs | 1 | 1.72ms | $self->add_handler($phase, $cb, %spec) if $cb; # spent 1.72ms making 1 call to LWP::UserAgent::add_handler
711 |  |  |  |  | }
712 |  |  |  |  |
713 |  |  |  |  | sub 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 {
744 | 1 | 2µs |  |  | my($self, $phase, %spec) = @_;
745 | 1 | 500ns |  |  | if ($phase) {
746 | 1 | 6µ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 {
757 | 303 | 180µs |  |  | my($self, $phase, $o) = @_;
758 | 303 | 52µs |  |  | my @h;
759 | 303 | 224µs |  |  | if ($o->{handlers} && $o->{handlers}{$phase}) {
760 |  |  |  |  | push(@h, @{$o->{handlers}{$phase}});
761 |  |  |  |  | }
762 | 303 | 399µs | 41 | 16.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 |  |  |  |  | }
765 | 303 | 797µ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 {
769 | 246 | 190µs |  |  | my($self, $phase, $o) = @_;
770 | 246 | 89µs |  |  | if (defined(wantarray)) {
771 | 82 | 218µs | 82 | 213µ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 |  |  |  |  | }
775 | 82 | 205µs |  |  | return undef;
776 |  |  |  |  | }
777 |  |  |  |  |
778 | 164 | 858µs | 164 | 17.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
785 |  |  |  |  | sub use_eval { shift->_elem('use_eval', @_); }
786 |  |  |  |  | sub use_alarm
787 |  |  |  |  | {
788 |  |  |  |  | Carp::carp("LWP::UserAgent->use_alarm(BOOL) is a no-op")
789 |  |  |  |  | if @_ > 1 && $^W;
790 |  |  |  |  | "";
791 |  |  |  |  | }
792 |  |  |  |  |
793 |  |  |  |  |
794 |  |  |  |  | sub 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 |  |  |  |  |
827 |  |  |  |  | sub 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 |  |  |  |  |
888 |  |  |  |  | sub _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 |  |  |  |  |
905 |  |  |  |  | sub 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 |  |  |  |  | sub 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 |  |  |  |  |
953 |  |  |  |  | sub 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 |  |  |  |  |
964 |  |  |  |  | sub _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 |  |  |  |  |
976 | 1 | 12µs |  |  | 1;
977 |  |  |  |  |
978 |  |  |  |  | __END__
979 |  |  |  |  |
980 |  |  |  |  | =head1 NAME
981 |  |  |  |  |
982 |  |  |  |  | LWP::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 |  |  |  |  |
1003 |  |  |  |  | The C<LWP::UserAgent> is a class implementing a web user agent.
1004 |  |  |  |  | C<LWP::UserAgent> objects can be used to dispatch web requests.
1005 |  |  |  |  |
1006 |  |  |  |  | In normal use the application creates an C<LWP::UserAgent> object, and
1007 |  |  |  |  | then configures it with values for timeouts, proxies, name, etc. It
1008 |  |  |  |  | then creates an instance of C<HTTP::Request> for the request that
1009 |  |  |  |  | needs to be performed. This request is then passed to one of the
1010 |  |  |  |  | request method the UserAgent, which dispatches it using the relevant
1011 |  |  |  |  | protocol, and returns a C<HTTP::Response> object. There are
1012 |  |  |  |  | convenience methods for sending the most common request types: get(),
1013 |  |  |  |  | head() and post(). When using these methods then the creation of the
1014 |  |  |  |  | request object is hidden as shown in the synopsis above.
1015 |  |  |  |  |
1016 |  |  |  |  | The basic approach of the library is to use HTTP style communication
1017 |  |  |  |  | for all protocol schemes. This means that you will construct
1018 |  |  |  |  | C<HTTP::Request> objects and receive C<HTTP::Response> objects even
1019 |  |  |  |  | for non-HTTP resources like I<gopher> and I<ftp>. In order to achieve
1020 |  |  |  |  | even more similarity to HTTP style communications, gopher menus and
1021 |  |  |  |  | file directories are converted to HTML documents.
1022 |  |  |  |  |
1023 |  |  |  |  | =head1 CONSTRUCTOR METHODS
1024 |  |  |  |  |
1025 |  |  |  |  | The following constructor methods are available:
1026 |  |  |  |  |
1027 |  |  |  |  | =over 4
1028 |  |  |  |  |
1029 |  |  |  |  | =item $ua = LWP::UserAgent->new( %options )
1030 |  |  |  |  |
1031 |  |  |  |  | This method constructs a new C<LWP::UserAgent> object and returns it.
1032 |  |  |  |  | Key/value pair arguments may be provided to set up the initial state.
1033 |  |  |  |  | The following options correspond to attribute methods described below:
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 |  |  |  |  |
1051 |  |  |  |  | The following additional options are also accepted: If the
1052 |  |  |  |  | C<env_proxy> option is passed in with a TRUE value, then proxy
1053 |  |  |  |  | settings are read from environment variables (see env_proxy() method
1054 |  |  |  |  | below). If the C<keep_alive> option is passed in, then a
1055 |  |  |  |  | C<LWP::ConnCache> is set up (see conn_cache() method below). The
1056 |  |  |  |  | C<keep_alive> value is passed on as the C<total_capacity> for the
1057 |  |  |  |  | connection cache.
1058 |  |  |  |  |
1059 |  |  |  |  | =item $ua->clone
1060 |  |  |  |  |
1061 |  |  |  |  | Returns a copy of the LWP::UserAgent object.
1062 |  |  |  |  |
1063 |  |  |  |  | =back
1064 |  |  |  |  |
1065 |  |  |  |  | =head1 ATTRIBUTES
1066 |  |  |  |  |
1067 |  |  |  |  | The settings of the configuration attributes modify the behaviour of the
1068 |  |  |  |  | C<LWP::UserAgent> when it dispatches requests. Most of these can also
1069 |  |  |  |  | be initialized by options passed to the constructor method.
1070 |  |  |  |  |
1071 |  |  |  |  | The following attribute methods are provided. The attribute value is
1072 |  |  |  |  | left unchanged if no argument is given. The return value from each
1073 |  |  |  |  | method is the old attribute value.
1074 |  |  |  |  |
1075 |  |  |  |  | =over
1076 |  |  |  |  |
1077 |  |  |  |  | =item $ua->agent
1078 |  |  |  |  |
1079 |  |  |  |  | =item $ua->agent( $product_id )
1080 |  |  |  |  |
1081 |  |  |  |  | Get/set the product token that is used to identify the user agent on
1082 |  |  |  |  | the network. The agent value is sent as the "User-Agent" header in
1083 |  |  |  |  | the requests. The default is the string returned by the _agent()
1084 |  |  |  |  | method (see below).
1085 |  |  |  |  |
1086 |  |  |  |  | If the $product_id ends with space then the _agent() string is
1087 |  |  |  |  | appended to it.
1088 |  |  |  |  |
1089 |  |  |  |  | The user agent string should be one or more simple product identifiers
1090 |  |  |  |  | with an optional version number separated by the "/" character.
1091 |  |  |  |  | Examples 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 |  |  |  |  |
1100 |  |  |  |  | Returns the default agent identifier. This is a string of the form
1101 |  |  |  |  | "libwww-perl/#.###", where "#.###" is substituted with the version number
1102 |  |  |  |  | of this library.
1103 |  |  |  |  |
1104 |  |  |  |  | =item $ua->from
1105 |  |  |  |  |
1106 |  |  |  |  | =item $ua->from( $email_address )
1107 |  |  |  |  |
1108 |  |  |  |  | Get/set the e-mail address for the human user who controls
1109 |  |  |  |  | the requesting user agent. The address should be machine-usable, as
1110 |  |  |  |  | defined in RFC 822. The C<from> value is send as the "From" header in
1111 |  |  |  |  | the requests. Example:
1112 |  |  |  |  |
1113 |  |  |  |  | $ua->from('gaas@cpan.org');
1114 |  |  |  |  |
1115 |  |  |  |  | The default is to not send a "From" header. See the default_headers()
1116 |  |  |  |  | method for the more general interface that allow any header to be defaulted.
1117 |  |  |  |  |
1118 |  |  |  |  | =item $ua->cookie_jar
1119 |  |  |  |  |
1120 |  |  |  |  | =item $ua->cookie_jar( $cookie_jar_obj )
1121 |  |  |  |  |
1122 |  |  |  |  | Get/set the cookie jar object to use. The only requirement is that
1123 |  |  |  |  | the cookie jar object must implement the extract_cookies($request) and
1124 |  |  |  |  | add_cookie_header($response) methods. These methods will then be
1125 |  |  |  |  | invoked by the user agent as requests are sent and responses are
1126 |  |  |  |  | received. Normally this will be a C<HTTP::Cookies> object or some
1127 |  |  |  |  | subclass.
1128 |  |  |  |  |
1129 |  |  |  |  | The default is to have no cookie_jar, i.e. never automatically add
1130 |  |  |  |  | "Cookie" headers to the requests.
1131 |  |  |  |  |
1132 |  |  |  |  | Shortcut: If a reference to a plain hash is passed in as the
1133 |  |  |  |  | $cookie_jar_object, then it is replaced with an instance of
1134 |  |  |  |  | C<HTTP::Cookies> that is initialized based on the hash. This form also
1135 |  |  |  |  | automatically loads the C<HTTP::Cookies> module. It means that:
1136 |  |  |  |  |
1137 |  |  |  |  | $ua->cookie_jar({ file => "$ENV{HOME}/.cookies.txt" });
1138 |  |  |  |  |
1139 |  |  |  |  | is 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 |  |  |  |  |
1148 |  |  |  |  | Get/set the headers object that will provide default header values for
1149 |  |  |  |  | any requests sent. By default this will be an empty C<HTTP::Headers>
1150 |  |  |  |  | object.
1151 |  |  |  |  |
1152 |  |  |  |  | =item $ua->default_header( $field )
1153 |  |  |  |  |
1154 |  |  |  |  | =item $ua->default_header( $field => $value )
1155 |  |  |  |  |
1156 |  |  |  |  | This 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 |  |  |  |  |
1166 |  |  |  |  | Get/set the C<LWP::ConnCache> object to use. See L<LWP::ConnCache>
1167 |  |  |  |  | for details.
1168 |  |  |  |  |
1169 |  |  |  |  | =item $ua->credentials( $netloc, $realm )
1170 |  |  |  |  |
1171 |  |  |  |  | =item $ua->credentials( $netloc, $realm, $uname, $pass )
1172 |  |  |  |  |
1173 |  |  |  |  | Get/set the user name and password to be used for a realm.
1174 |  |  |  |  |
1175 |  |  |  |  | The $netloc is a string of the form "<host>:<port>". The username and
1176 |  |  |  |  | password 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 |  |  |  |  |
1184 |  |  |  |  | Get/set the local interface to bind to for network connections. The interface
1185 |  |  |  |  | can be specified as a hostname or an IP address. This value is passed as the
1186 |  |  |  |  | C<LocalAddr> argument to L<IO::Socket::INET>.
1187 |  |  |  |  |
1188 |  |  |  |  | =item $ua->max_size
1189 |  |  |  |  |
1190 |  |  |  |  | =item $ua->max_size( $bytes )
1191 |  |  |  |  |
1192 |  |  |  |  | Get/set the size limit for response content. The default is C<undef>,
1193 |  |  |  |  | which means that there is no limit. If the returned response content
1194 |  |  |  |  | is only partial, because the size limit was exceeded, then a
1195 |  |  |  |  | "Client-Aborted" header will be added to the response. The content
1196 |  |  |  |  | might end up longer than C<max_size> as we abort once appending a
1197 |  |  |  |  | chunk of data makes the length exceed the limit. The "Content-Length"
1198 |  |  |  |  | header, if present, will indicate the length of the full content and
1199 |  |  |  |  | will normally not be the same as C<< length($res->content) >>.
1200 |  |  |  |  |
1201 |  |  |  |  | =item $ua->max_redirect
1202 |  |  |  |  |
1203 |  |  |  |  | =item $ua->max_redirect( $n )
1204 |  |  |  |  |
1205 |  |  |  |  | This reads or sets the object's limit of how many times it will obey
1206 |  |  |  |  | redirection responses in a given request cycle.
1207 |  |  |  |  |
1208 |  |  |  |  | By default, the value is 7. This means that if you call request()
1209 |  |  |  |  | method and the response is a redirect elsewhere which is in turn a
1210 |  |  |  |  | redirect, and so on seven times, then LWP gives up after that seventh
1211 |  |  |  |  | request.
1212 |  |  |  |  |
1213 |  |  |  |  | =item $ua->parse_head
1214 |  |  |  |  |
1215 |  |  |  |  | =item $ua->parse_head( $boolean )
1216 |  |  |  |  |
1217 |  |  |  |  | Get/set a value indicating whether we should initialize response
1218 |  |  |  |  | headers from the E<lt>head> section of HTML documents. The default is
1219 |  |  |  |  | TRUE. Do not turn this off, unless you know what you are doing.
1220 |  |  |  |  |
1221 |  |  |  |  | =item $ua->protocols_allowed
1222 |  |  |  |  |
1223 |  |  |  |  | =item $ua->protocols_allowed( \@protocols )
1224 |  |  |  |  |
1225 |  |  |  |  | This reads (or sets) this user agent's list of protocols that the
1226 |  |  |  |  | request methods will exclusively allow. The protocol names are case
1227 |  |  |  |  | insensitive.
1228 |  |  |  |  |
1229 |  |  |  |  | For example: C<$ua-E<gt>protocols_allowed( [ 'http', 'https'] );>
1230 |  |  |  |  | means that this user agent will I<allow only> those protocols,
1231 |  |  |  |  | and attempts to use this user agent to access URLs with any other
1232 |  |  |  |  | schemes (like "ftp://...") will result in a 500 error.
1233 |  |  |  |  |
1234 |  |  |  |  | To delete the list, call: C<$ua-E<gt>protocols_allowed(undef)>
1235 |  |  |  |  |
1236 |  |  |  |  | By default, an object has neither a C<protocols_allowed> list, nor a
1237 |  |  |  |  | C<protocols_forbidden> list.
1238 |  |  |  |  |
1239 |  |  |  |  | Note that having a C<protocols_allowed> list causes any
1240 |  |  |  |  | C<protocols_forbidden> list to be ignored.
1241 |  |  |  |  |
1242 |  |  |  |  | =item $ua->protocols_forbidden
1243 |  |  |  |  |
1244 |  |  |  |  | =item $ua->protocols_forbidden( \@protocols )
1245 |  |  |  |  |
1246 |  |  |  |  | This reads (or sets) this user agent's list of protocols that the
1247 |  |  |  |  | request method will I<not> allow. The protocol names are case
1248 |  |  |  |  | insensitive.
1249 |  |  |  |  |
1250 |  |  |  |  | For example: C<$ua-E<gt>protocols_forbidden( [ 'file', 'mailto'] );>
1251 |  |  |  |  | means that this user agent will I<not> allow those protocols, and
1252 |  |  |  |  | attempts to use this user agent to access URLs with those schemes
1253 |  |  |  |  | will result in a 500 error.
1254 |  |  |  |  |
1255 |  |  |  |  | To 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 |  |  |  |  |
1261 |  |  |  |  | This reads or sets the object's list of request names that
1262 |  |  |  |  | C<$ua-E<gt>redirect_ok(...)> will allow redirection for. By
1263 |  |  |  |  | default, this is C<['GET', 'HEAD']>, as per RFC 2616. To
1264 |  |  |  |  | change to include 'POST', consider:
1265 |  |  |  |  |
1266 |  |  |  |  | push @{ $ua->requests_redirectable }, 'POST';
1267 |  |  |  |  |
1268 |  |  |  |  | =item $ua->show_progress
1269 |  |  |  |  |
1270 |  |  |  |  | =item $ua->show_progress( $boolean )
1271 |  |  |  |  |
1272 |  |  |  |  | Get/set a value indicating whether a progress bar should be displayed
1273 |  |  |  |  | on on the terminal as requests are processed. The default is FALSE.
1274 |  |  |  |  |
1275 |  |  |  |  | =item $ua->timeout
1276 |  |  |  |  |
1277 |  |  |  |  | =item $ua->timeout( $secs )
1278 |  |  |  |  |
1279 |  |  |  |  | Get/set the timeout value in seconds. The default timeout() value is
1280 |  |  |  |  | 180 seconds, i.e. 3 minutes.
1281 |  |  |  |  |
1282 |  |  |  |  | The requests is aborted if no activity on the connection to the server
1283 |  |  |  |  | is observed for C<timeout> seconds. This means that the time it takes
1284 |  |  |  |  | for the complete transaction and the request() method to actually
1285 |  |  |  |  | return might be longer.
1286 |  |  |  |  |
1287 |  |  |  |  | =back
1288 |  |  |  |  |
1289 |  |  |  |  | =head2 Proxy attributes
1290 |  |  |  |  |
1291 |  |  |  |  | The following methods set up when requests should be passed via a
1292 |  |  |  |  | proxy server.
1293 |  |  |  |  |
1294 |  |  |  |  | =over
1295 |  |  |  |  |
1296 |  |  |  |  | =item $ua->proxy(\@schemes, $proxy_url)
1297 |  |  |  |  |
1298 |  |  |  |  | =item $ua->proxy($scheme, $proxy_url)
1299 |  |  |  |  |
1300 |  |  |  |  | Set/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 |  |  |  |  |
1305 |  |  |  |  | The first form specifies that the URL is to be used for proxying of
1306 |  |  |  |  | access methods listed in the list in the first method argument,
1307 |  |  |  |  | i.e. 'http' and 'ftp'.
1308 |  |  |  |  |
1309 |  |  |  |  | The second form shows a shorthand form for specifying
1310 |  |  |  |  | proxy URL for a single access scheme.
1311 |  |  |  |  |
1312 |  |  |  |  | =item $ua->no_proxy( $domain, ... )
1313 |  |  |  |  |
1314 |  |  |  |  | Do not proxy requests to the given domains. Calling no_proxy without
1315 |  |  |  |  | any domains clears the list of domains. Eg:
1316 |  |  |  |  |
1317 |  |  |  |  | $ua->no_proxy('localhost', 'example.com');
1318 |  |  |  |  |
1319 |  |  |  |  | =item $ua->env_proxy
1320 |  |  |  |  |
1321 |  |  |  |  | Load proxy settings from *_proxy environment variables. You might
1322 |  |  |  |  | specify 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 |  |  |  |  |
1329 |  |  |  |  | csh or tcsh users should use the C<setenv> command to define these
1330 |  |  |  |  | environment variables.
1331 |  |  |  |  |
1332 |  |  |  |  | On systems with case insensitive environment variables there exists a
1333 |  |  |  |  | name clash between the CGI environment variables and the C<HTTP_PROXY>
1334 |  |  |  |  | environment variable normally picked up by env_proxy(). Because of
1335 |  |  |  |  | this C<HTTP_PROXY> is not honored for CGI scripts. The
1336 |  |  |  |  | C<CGI_HTTP_PROXY> environment variable can be used instead.
1337 |  |  |  |  |
1338 |  |  |  |  | =back
1339 |  |  |  |  |
1340 |  |  |  |  | =head2 Handlers
1341 |  |  |  |  |
1342 |  |  |  |  | Handlers are code that injected at various phases during the
1343 |  |  |  |  | processing of requests. The following methods are provided to manage
1344 |  |  |  |  | the active handlers:
1345 |  |  |  |  |
1346 |  |  |  |  | =over
1347 |  |  |  |  |
1348 |  |  |  |  | =item $ua->add_handler( $phase => \&cb, %matchspec )
1349 |  |  |  |  |
1350 |  |  |  |  | Add handler to be invoked in the given processing phase. For how to
1351 |  |  |  |  | specify %matchspec see L<HTTP::Config/"Matching">.
1352 |  |  |  |  |
1353 |  |  |  |  | The possible values $phase and the corresponding callback signatures are:
1354 |  |  |  |  |
1355 |  |  |  |  | =over
1356 |  |  |  |  |
1357 |  |  |  |  | =item request_preprepare => sub { my($request, $ua, $h) = @_; ... }
1358 |  |  |  |  |
1359 |  |  |  |  | The handler is called before the C<request_prepare> and other standard
1360 |  |  |  |  | initialization of of the request. This can be used to set up headers
1361 |  |  |  |  | and attributes that the C<request_prepare> handler depends on. Proxy
1362 |  |  |  |  | initialization should take place here; but in general don't register
1363 |  |  |  |  | handlers for this phase.
1364 |  |  |  |  |
1365 |  |  |  |  | =item request_prepare => sub { my($request, $ua, $h) = @_; ... }
1366 |  |  |  |  |
1367 |  |  |  |  | The handler is called before the request is sent and can modify the
1368 |  |  |  |  | request any way it see fit. This can for instance be used to add
1369 |  |  |  |  | certain headers to specific requests.
1370 |  |  |  |  |
1371 |  |  |  |  | The method can assign a new request object to $_[0] to replace the
1372 |  |  |  |  | request that is sent fully.
1373 |  |  |  |  |
1374 |  |  |  |  | The return value from the callback is ignored. If an exceptions is
1375 |  |  |  |  | raised it will abort the request and make the request method return a
1376 |  |  |  |  | "400 Bad request" response.
1377 |  |  |  |  |
1378 |  |  |  |  | =item request_send => sub { my($request, $ua, $h) = @_; ... }
1379 |  |  |  |  |
1380 |  |  |  |  | This handler get a chance of handling requests before it's sent to the
1381 |  |  |  |  | protocol handlers. It should return an HTTP::Response object if it
1382 |  |  |  |  | wishes to terminate the processing; otherwise it should return nothing.
1383 |  |  |  |  |
1384 |  |  |  |  | The C<response_header> and C<response_data> handlers will not be
1385 |  |  |  |  | invoked for this response, but the C<response_done> will be.
1386 |  |  |  |  |
1387 |  |  |  |  | =item response_header => sub { my($response, $ua, $h) = @_; ... }
1388 |  |  |  |  |
1389 |  |  |  |  | This handler is called right after the response headers have been
1390 |  |  |  |  | received, but before any content data. The handler might set up
1391 |  |  |  |  | handlers for data and might croak to abort the request.
1392 |  |  |  |  |
1393 |  |  |  |  | The handler might set the $response->{default_add_content} value to
1394 |  |  |  |  | control if any received data should be added to the response object
1395 |  |  |  |  | directly. This will initially be false if the $ua->request() method
1396 |  |  |  |  | was called with a ':content_filename' or ':content_callbak' argument;
1397 |  |  |  |  | otherwise true.
1398 |  |  |  |  |
1399 |  |  |  |  | =item response_data => sub { my($response, $ua, $h, $data) = @_; ... }
1400 |  |  |  |  |
1401 |  |  |  |  | This handlers is called for each chunk of data received for the
1402 |  |  |  |  | response. The handler might croak to abort the request.
1403 |  |  |  |  |
1404 |  |  |  |  | This handler need to return a TRUE value to be called again for
1405 |  |  |  |  | subsequent chunks for the same request.
1406 |  |  |  |  |
1407 |  |  |  |  | =item response_done => sub { my($response, $ua, $h) = @_; ... }
1408 |  |  |  |  |
1409 |  |  |  |  | The handler is called after the response has been fully received, but
1410 |  |  |  |  | before any redirect handling is attempted. The handler can be used to
1411 |  |  |  |  | extract information or modify the response.
1412 |  |  |  |  |
1413 |  |  |  |  | =item response_redirect => sub { my($response, $ua, $h) = @_; ... }
1414 |  |  |  |  |
1415 |  |  |  |  | The handler is called in $ua->request after C<response_done>. If the
1416 |  |  |  |  | handler return an HTTP::Request object we'll start over with processing
1417 |  |  |  |  | this request instead.
1418 |  |  |  |  |
1419 |  |  |  |  | =back
1420 |  |  |  |  |
1421 |  |  |  |  | =item $ua->remove_handler( undef, %matchspec )
1422 |  |  |  |  |
1423 |  |  |  |  | =item $ua->remove_handler( $phase, %matchspec )
1424 |  |  |  |  |
1425 |  |  |  |  | Remove handlers that match the given %matchspec. If $phase is not
1426 |  |  |  |  | provided remove handlers from all phases.
1427 |  |  |  |  |
1428 |  |  |  |  | Be careful as calling this function with %matchspec that is not not
1429 |  |  |  |  | specific enough can remove handlers not owned by you. It's probably
1430 |  |  |  |  | better to use the set_my_handler() method instead.
1431 |  |  |  |  |
1432 |  |  |  |  | The removed handlers are returned.
1433 |  |  |  |  |
1434 |  |  |  |  | =item $ua->set_my_handler( $phase, $cb, %matchspec )
1435 |  |  |  |  |
1436 |  |  |  |  | Set handlers private to the executing subroutine. Works by defaulting
1437 |  |  |  |  | an C<owner> field to the %matchhspec that holds the name of the called
1438 |  |  |  |  | subroutine. You might pass an explicit C<owner> to override this.
1439 |  |  |  |  |
1440 |  |  |  |  | If $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 |  |  |  |  |
1446 |  |  |  |  | Will retrieve the matching handler as hash ref.
1447 |  |  |  |  |
1448 |  |  |  |  | If C<$init> is passed passed as a TRUE value, create and add the
1449 |  |  |  |  | handler if it's not found. If $init is a subroutine reference, then
1450 |  |  |  |  | it's called with the created handler hash as argument. This sub might
1451 |  |  |  |  | populate the hash with extra fields; especially the callback. If
1452 |  |  |  |  | $init is a hash reference, merge the hashes.
1453 |  |  |  |  |
1454 |  |  |  |  | =item $ua->handlers( $phase, $request )
1455 |  |  |  |  |
1456 |  |  |  |  | =item $ua->handlers( $phase, $response )
1457 |  |  |  |  |
1458 |  |  |  |  | Returns the handlers that apply to the given request or response at
1459 |  |  |  |  | the given processing phase.
1460 |  |  |  |  |
1461 |  |  |  |  | =back
1462 |  |  |  |  |
1463 |  |  |  |  | =head1 REQUEST METHODS
1464 |  |  |  |  |
1465 |  |  |  |  | The methods described in this section are used to dispatch requests
1466 |  |  |  |  | via 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 |  |  |  |  |
1474 |  |  |  |  | This method will dispatch a C<GET> request on the given $url. Further
1475 |  |  |  |  | arguments can be given to initialize the headers of the request. These
1476 |  |  |  |  | are given as separate name/value pairs. The return value is a
1477 |  |  |  |  | response object. See L<HTTP::Response> for a description of the
1478 |  |  |  |  | interface it provides.
1479 |  |  |  |  |
1480 |  |  |  |  | There will still be a response object returned when LWP can't connect to the
1481 |  |  |  |  | server specified in the URL or when other failures in protocol handlers occur.
1482 |  |  |  |  | These internal responses use the standard HTTP status codes, so the responses
1483 |  |  |  |  | can't be differentiated by testing the response status code alone. Error
1484 |  |  |  |  | responses that LWP generates internally will have the "Client-Warning" header
1485 |  |  |  |  | set to the value "Internal response". If you need to differentiate these
1486 |  |  |  |  | internal responses from responses that a remote server actually generates, you
1487 |  |  |  |  | need to test this header value.
1488 |  |  |  |  |
1489 |  |  |  |  | Fields names that start with ":" are special. These will not
1490 |  |  |  |  | initialize headers of the request but will determine how the response
1491 |  |  |  |  | content is treated. The following special field names are recognized:
1492 |  |  |  |  |
1493 |  |  |  |  | :content_file => $filename
1494 |  |  |  |  | :content_cb => \&callback
1495 |  |  |  |  | :read_size_hint => $bytes
1496 |  |  |  |  |
1497 |  |  |  |  | If a $filename is provided with the C<:content_file> option, then the
1498 |  |  |  |  | response content will be saved here instead of in the response
1499 |  |  |  |  | object. If a callback is provided with the C<:content_cb> option then
1500 |  |  |  |  | this function will be called for each chunk of the response content as
1501 |  |  |  |  | it is received from the server. If neither of these options are
1502 |  |  |  |  | given, then the response content will accumulate in the response
1503 |  |  |  |  | object itself. This might not be suitable for very large response
1504 |  |  |  |  | bodies. Only one of C<:content_file> or C<:content_cb> can be
1505 |  |  |  |  | specified. The content of unsuccessful responses will always
1506 |  |  |  |  | accumulate in the response object itself, regardless of the
1507 |  |  |  |  | C<:content_file> or C<:content_cb> options passed in.
1508 |  |  |  |  |
1509 |  |  |  |  | The C<:read_size_hint> option is passed to the protocol module which
1510 |  |  |  |  | will try to read data from the server in chunks of this size. A
1511 |  |  |  |  | smaller value for the C<:read_size_hint> will result in a higher
1512 |  |  |  |  | number of callback invocations.
1513 |  |  |  |  |
1514 |  |  |  |  | The callback function is called with 3 arguments: a chunk of data, a
1515 |  |  |  |  | reference to the response object, and a reference to the protocol
1516 |  |  |  |  | object. The callback can abort the request by invoking die(). The
1517 |  |  |  |  | exception message will show up as the "X-Died" header field in the
1518 |  |  |  |  | response returned by the get() function.
1519 |  |  |  |  |
1520 |  |  |  |  | =item $ua->head( $url )
1521 |  |  |  |  |
1522 |  |  |  |  | =item $ua->head( $url , $field_name => $value, ... )
1523 |  |  |  |  |
1524 |  |  |  |  | This method will dispatch a C<HEAD> request on the given $url.
1525 |  |  |  |  | Otherwise 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 |  |  |  |  |
1539 |  |  |  |  | This method will dispatch a C<POST> request on the given $url, with
1540 |  |  |  |  | %form or @form providing the key/value pairs for the fill-in form
1541 |  |  |  |  | content. Additional headers and content options are the same as for
1542 |  |  |  |  | the get() method.
1543 |  |  |  |  |
1544 |  |  |  |  | This method will use the POST() function from C<HTTP::Request::Common>
1545 |  |  |  |  | to build the request. See L<HTTP::Request::Common> for a details on
1546 |  |  |  |  | how to pass form content and other advanced features.
1547 |  |  |  |  |
1548 |  |  |  |  | =item $ua->mirror( $url, $filename )
1549 |  |  |  |  |
1550 |  |  |  |  | This method will get the document identified by $url and store it in
1551 |  |  |  |  | file called $filename. If the file already exists, then the request
1552 |  |  |  |  | will contain an "If-Modified-Since" header matching the modification
1553 |  |  |  |  | time of the file. If the document on the server has not changed since
1554 |  |  |  |  | this time, then nothing happens. If the document has been updated, it
1555 |  |  |  |  | will be downloaded again. The modification time of the file will be
1556 |  |  |  |  | forced to match that of the server.
1557 |  |  |  |  |
1558 |  |  |  |  | The 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 |  |  |  |  |
1568 |  |  |  |  | This method will dispatch the given $request object. Normally this
1569 |  |  |  |  | will be an instance of the C<HTTP::Request> class, but any object with
1570 |  |  |  |  | a similar interface will do. The return value is a response object.
1571 |  |  |  |  | See L<HTTP::Request> and L<HTTP::Response> for a description of the
1572 |  |  |  |  | interface provided by these classes.
1573 |  |  |  |  |
1574 |  |  |  |  | The request() method will process redirects and authentication
1575 |  |  |  |  | responses transparently. This means that it may actually send several
1576 |  |  |  |  | simple requests via the simple_request() method described below.
1577 |  |  |  |  |
1578 |  |  |  |  | The request methods described above; get(), head(), post() and
1579 |  |  |  |  | mirror(), will all dispatch the request they build via this method.
1580 |  |  |  |  | They are convenience methods that simply hides the creation of the
1581 |  |  |  |  | request object for you.
1582 |  |  |  |  |
1583 |  |  |  |  | The $content_file, $content_cb and $read_size_hint all correspond to
1584 |  |  |  |  | options described with the get() method above.
1585 |  |  |  |  |
1586 |  |  |  |  | You are allowed to use a CODE reference as C<content> in the request
1587 |  |  |  |  | object passed in. The C<content> function should return the content
1588 |  |  |  |  | when called. The content can be returned in chunks. The content
1589 |  |  |  |  | function will be invoked repeatedly until it return an empty string to
1590 |  |  |  |  | signal that there is no more content.
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 |  |  |  |  |
1600 |  |  |  |  | This method dispatches a single request and returns the response
1601 |  |  |  |  | received. Arguments are the same as for request() described above.
1602 |  |  |  |  |
1603 |  |  |  |  | The difference from request() is that simple_request() will not try to
1604 |  |  |  |  | handle redirects or authentication responses. The request() method
1605 |  |  |  |  | will in fact invoke this method for each simple request it sends.
1606 |  |  |  |  |
1607 |  |  |  |  | =item $ua->is_protocol_supported( $scheme )
1608 |  |  |  |  |
1609 |  |  |  |  | You can use this method to test whether this user agent object supports the
1610 |  |  |  |  | specified C<scheme>. (The C<scheme> might be a string (like 'http' or
1611 |  |  |  |  | 'ftp') or it might be an URI object reference.)
1612 |  |  |  |  |
1613 |  |  |  |  | Whether a scheme is supported, is determined by the user agent's
1614 |  |  |  |  | C<protocols_allowed> or C<protocols_forbidden> lists (if any), and by
1615 |  |  |  |  | the capabilities of LWP. I.e., this will return TRUE only if LWP
1616 |  |  |  |  | supports this protocol I<and> it's permitted for this particular
1617 |  |  |  |  | object.
1618 |  |  |  |  |
1619 |  |  |  |  | =back
1620 |  |  |  |  |
1621 |  |  |  |  | =head2 Callback methods
1622 |  |  |  |  |
1623 |  |  |  |  | The following methods will be invoked as requests are processed. These
1624 |  |  |  |  | methods are documented here because subclasses of C<LWP::UserAgent>
1625 |  |  |  |  | might want to override their behaviour.
1626 |  |  |  |  |
1627 |  |  |  |  | =over
1628 |  |  |  |  |
1629 |  |  |  |  | =item $ua->prepare_request( $request )
1630 |  |  |  |  |
1631 |  |  |  |  | This method is invoked by simple_request(). Its task is to modify the
1632 |  |  |  |  | given $request object by setting up various headers based on the
1633 |  |  |  |  | attributes of the user agent. The return value should normally be the
1634 |  |  |  |  | $request object passed in. If a different request object is returned
1635 |  |  |  |  | it will be the one actually processed.
1636 |  |  |  |  |
1637 |  |  |  |  | The headers affected by the base implementation are; "User-Agent",
1638 |  |  |  |  | "From", "Range" and "Cookie".
1639 |  |  |  |  |
1640 |  |  |  |  | =item $ua->redirect_ok( $prospective_request, $response )
1641 |  |  |  |  |
1642 |  |  |  |  | This method is called by request() before it tries to follow a
1643 |  |  |  |  | redirection to the request in $response. This should return a TRUE
1644 |  |  |  |  | value if this redirection is permissible. The $prospective_request
1645 |  |  |  |  | will be the request to be sent if this method returns TRUE.
1646 |  |  |  |  |
1647 |  |  |  |  | The base implementation will return FALSE unless the method
1648 |  |  |  |  | is in the object's C<requests_redirectable> list,
1649 |  |  |  |  | FALSE if the proposed redirection is to a "file://..."
1650 |  |  |  |  | URL, and TRUE otherwise.
1651 |  |  |  |  |
1652 |  |  |  |  | =item $ua->get_basic_credentials( $realm, $uri, $isproxy )
1653 |  |  |  |  |
1654 |  |  |  |  | This is called by request() to retrieve credentials for documents
1655 |  |  |  |  | protected by Basic or Digest Authentication. The arguments passed in
1656 |  |  |  |  | is the $realm provided by the server, the $uri requested and a boolean
1657 |  |  |  |  | flag to indicate if this is authentication against a proxy server.
1658 |  |  |  |  |
1659 |  |  |  |  | The method should return a username and password. It should return an
1660 |  |  |  |  | empty list to abort the authentication resolution attempt. Subclasses
1661 |  |  |  |  | can override this method to prompt the user for the information. An
1662 |  |  |  |  | example of this can be found in C<lwp-request> program distributed
1663 |  |  |  |  | with this library.
1664 |  |  |  |  |
1665 |  |  |  |  | The base implementation simply checks a set of pre-stored member
1666 |  |  |  |  | variables, set up with the credentials() method.
1667 |  |  |  |  |
1668 |  |  |  |  | =item $ua->progress( $status, $request_or_response )
1669 |  |  |  |  |
1670 |  |  |  |  | This is called frequently as the response is received regardless of
1671 |  |  |  |  | how the content is processed. The method is called with $status
1672 |  |  |  |  | "begin" at the start of processing the request and with $state "end"
1673 |  |  |  |  | before the request method returns. In between these $status will be
1674 |  |  |  |  | the fraction of the response currently received or the string "tick"
1675 |  |  |  |  | if the fraction can't be calculated.
1676 |  |  |  |  |
1677 |  |  |  |  | When $status is "begin" the second argument is the request object,
1678 |  |  |  |  | otherwise it is the response object.
1679 |  |  |  |  |
1680 |  |  |  |  | =back
1681 |  |  |  |  |
1682 |  |  |  |  | =head1 SEE ALSO
1683 |  |  |  |  |
1684 |  |  |  |  | See L<LWP> for a complete overview of libwww-perl5. See L<lwpcook>
1685 |  |  |  |  | and the scripts F<lwp-request> and F<lwp-download> for examples of
1686 |  |  |  |  | usage.
1687 |  |  |  |  |
1688 |  |  |  |  | See L<HTTP::Request> and L<HTTP::Response> for a description of the
1689 |  |  |  |  | message objects dispatched and received. See L<HTTP::Request::Common>
1690 |  |  |  |  | and L<HTML::Form> for other ways to build request objects.
1691 |  |  |  |  |
1692 |  |  |  |  | See L<WWW::Mechanize> and L<WWW::Search> for examples of more
1693 |  |  |  |  | specialized user agents based on C<LWP::UserAgent>.
1694 |  |  |  |  |
1695 |  |  |  |  | =head1 COPYRIGHT
1696 |  |  |  |  |
1697 |  |  |  |  | Copyright 1995-2009 Gisle Aas.
1698 |  |  |  |  |
1699 |  |  |  |  | This library is free software; you can redistribute it and/or
1700 |  |  |  |  | modify 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