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

← Index
NYTProf Performance Profile «block view•line view•sub view»
For 01.HTTP.t
Run on Tue May 4 15:25:55 2010
Reported on Tue May 4 15:26:05 2010

File | /usr/local/lib/perl5/site_perl/5.10.1/LWP/Protocol.pm
Statements Executed | 150
Statement Execution Time | 2.64ms

Subroutines — ordered by exclusive time
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
3 | 1 | 1 | 7.91ms | 17.1ms | LWP::Protocol::::implementorLWP::Protocol::implementor
3 | 1 | 1 | 303µs | 2.84ms | LWP::Protocol::::collectLWP::Protocol::collect
3 | 1 | 1 | 56µs | 17.2ms | LWP::Protocol::::createLWP::Protocol::create
3 | 1 | 1 | 42µs | 42µs | LWP::Protocol::::newLWP::Protocol::new
4 | 1 | 1 | 31µs | 123µs | LWP::Protocol::::__ANON__[:139]LWP::Protocol::__ANON__[:139]
1 | 1 | 1 | 21µs | 27µs | LWP::Protocol::::BEGIN@7LWP::Protocol::BEGIN@7
1 | 1 | 1 | 15µs | 15µs | LWP::Protocol::::BEGIN@10LWP::Protocol::BEGIN@10
1 | 1 | 1 | 11µs | 36µs | LWP::Protocol::::BEGIN@62LWP::Protocol::BEGIN@62
1 | 1 | 1 | 5µs | 5µs | LWP::Protocol::::BEGIN@8LWP::Protocol::BEGIN@8
1 | 1 | 1 | 5µs | 5µs | LWP::Protocol::::BEGIN@9LWP::Protocol::BEGIN@9
1 | 1 | 2 | 3µs | 3µs | LWP::Protocol::::CORE:matchLWP::Protocol::CORE:match (opcode)
1 | 1 | 2 | 900ns | 900ns | LWP::Protocol::::CORE:substLWP::Protocol::CORE:subst (opcode)
0 | 0 | 0 | 0s | 0s | LWP::Protocol::::__ANON__[:111]LWP::Protocol::__ANON__[:111]
0 | 0 | 0 | 0s | 0s | LWP::Protocol::::__ANON__[:117]LWP::Protocol::__ANON__[:117]
0 | 0 | 0 | 0s | 0s | LWP::Protocol::::__ANON__[:125]LWP::Protocol::__ANON__[:125]
0 | 0 | 0 | 0s | 0s | LWP::Protocol::::__ANON__[:186]LWP::Protocol::__ANON__[:186]
0 | 0 | 0 | 0s | 0s | LWP::Protocol::::collect_onceLWP::Protocol::collect_once
0 | 0 | 0 | 0s | 0s | LWP::Protocol::::max_sizeLWP::Protocol::max_size
0 | 0 | 0 | 0s | 0s | LWP::Protocol::::requestLWP::Protocol::request
0 | 0 | 0 | 0s | 0s | LWP::Protocol::::timeoutLWP::Protocol::timeout

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::Protocol;
2 |  |  |  |  |
3 | 1 | 169µs |  |  | require LWP::MemberMixin;
4 | 1 | 8µs |  |  | @ISA = qw(LWP::MemberMixin);
5 | 1 | 400ns |  |  | $VERSION = "5.829";
6 |  |  |  |  |
7 | 3 | 34µs | 2 | 34µs | # spent 27µs (21+7) within LWP::Protocol::BEGIN@7 which was called # once (21µs+7µs) by LWP::UserAgent::BEGIN@15 at line 7 use strict; # spent 27µs making 1 call to LWP::Protocol::BEGIN@7 # spent 7µs making 1 call to strict::import
8 | 3 | 29µs | 1 | 5µs | # spent 5µs within LWP::Protocol::BEGIN@8 which was called # once (5µs+0s) by LWP::UserAgent::BEGIN@15 at line 8 use Carp (); # spent 5µs making 1 call to LWP::Protocol::BEGIN@8
9 | 3 | 29µs | 1 | 5µs | # spent 5µs within LWP::Protocol::BEGIN@9 which was called # once (5µs+0s) by LWP::UserAgent::BEGIN@15 at line 9 use HTTP::Status (); # spent 5µs making 1 call to LWP::Protocol::BEGIN@9
10 | 3 | 311µs | 1 | 15µs | # spent 15µs within LWP::Protocol::BEGIN@10 which was called # once (15µs+0s) by LWP::UserAgent::BEGIN@15 at line 10 use HTTP::Response; # spent 15µs making 1 call to LWP::Protocol::BEGIN@10
11 |  |  |  |  |
12 | 1 | 400ns |  |  | my %ImplementedBy = (); # scheme => classname
13 |  |  |  |  |
14 |  |  |  |  |
15 |  |  |  |  |
16 |  |  |  |  | sub new
17 |  |  |  |  | # spent 42µs within LWP::Protocol::new which was called 3 times, avg 14µs/call: # 3 times (42µs+0s) by LWP::Protocol::create at line 39, avg 14µs/call {
18 | 9 | 42µs |  |  | my($class, $scheme, $ua) = @_;
19 |  |  |  |  |
20 |  |  |  |  | my $self = bless {
21 |  |  |  |  | scheme => $scheme,
22 |  |  |  |  | ua => $ua,
23 |  |  |  |  |
24 |  |  |  |  | # historical/redundant
25 |  |  |  |  | max_size => $ua->{max_size},
26 |  |  |  |  | }, $class;
27 |  |  |  |  |
28 |  |  |  |  | $self;
29 |  |  |  |  | }
30 |  |  |  |  |
31 |  |  |  |  |
32 |  |  |  |  | sub create
33 |  |  |  |  | # spent 17.2ms (56µs+17.1) within LWP::Protocol::create which was called 3 times, avg 5.73ms/call: # 3 times (56µs+17.1ms) by LWP::UserAgent::send_request at line 159 of LWP/UserAgent.pm, avg 5.73ms/call {
34 | 12 | 48µs |  |  | my($scheme, $ua) = @_;
35 |  |  |  |  | my $impclass = LWP::Protocol::implementor($scheme) or # spent 17.1ms making 3 calls to LWP::Protocol::implementor, avg 5.70ms/call
36 |  |  |  |  | Carp::croak("Protocol scheme '$scheme' is not supported");
37 |  |  |  |  |
38 |  |  |  |  | # hand-off to scheme specific implementation sub-class
39 |  |  |  |  | my $protocol = $impclass->new($scheme, $ua); # spent 42µs making 3 calls to LWP::Protocol::new, avg 14µs/call
40 |  |  |  |  |
41 |  |  |  |  | return $protocol;
42 |  |  |  |  | }
43 |  |  |  |  |
44 |  |  |  |  |
45 |  |  |  |  | sub implementor
46 |  |  |  |  | # spent 17.1ms (7.91+9.19) within LWP::Protocol::implementor which was called 3 times, avg 5.70ms/call: # 3 times (7.91ms+9.19ms) by LWP::Protocol::create at line 35, avg 5.70ms/call {
47 | 22 | 87µs |  |  | my($scheme, $impclass) = @_;
48 |  |  |  |  |
49 |  |  |  |  | if ($impclass) {
50 |  |  |  |  | $ImplementedBy{$scheme} = $impclass;
51 |  |  |  |  | }
52 |  |  |  |  | my $ic = $ImplementedBy{$scheme};
53 |  |  |  |  | return $ic if $ic;
54 |  |  |  |  |
55 |  |  |  |  | return '' unless $scheme =~ /^([.+\-\w]+)$/; # check valid URL schemes # spent 3µs making 1 call to LWP::Protocol::CORE:match
56 |  |  |  |  | $scheme = $1; # untaint
57 |  |  |  |  | $scheme =~ s/[.+\-]/_/g; # make it a legal module name # spent 900ns making 1 call to LWP::Protocol::CORE:subst
58 |  |  |  |  |
59 |  |  |  |  | # scheme not yet known, look for a 'use'd implementation
60 |  |  |  |  | $ic = "LWP::Protocol::$scheme"; # default location
61 |  |  |  |  | $ic = "LWP::Protocol::nntp" if $scheme eq 'news'; #XXX ugly hack
62 | 3 | 1.45ms | 2 | 62µs | # spent 36µs (11+25) within LWP::Protocol::BEGIN@62 which was called # once (11µs+25µs) by LWP::UserAgent::BEGIN@15 at line 62 no strict 'refs'; # spent 36µs making 1 call to LWP::Protocol::BEGIN@62 # spent 25µs making 1 call to strict::unimport
63 |  |  |  |  | # check we actually have one for the scheme:
64 |  |  |  |  | unless (@{"${ic}::ISA"}) {
65 |  |  |  |  | # try to autoload it
66 | 1 | 149µs |  |  | eval "require $ic";
67 |  |  |  |  | if ($@) {
68 |  |  |  |  | if ($@ =~ /Can't locate/) { #' #emacs get confused by '
69 |  |  |  |  | $ic = '';
70 |  |  |  |  | }
71 |  |  |  |  | else {
72 |  |  |  |  | die "$@\n";
73 |  |  |  |  | }
74 |  |  |  |  | }
75 |  |  |  |  | }
76 |  |  |  |  | $ImplementedBy{$scheme} = $ic if $ic;
77 |  |  |  |  | $ic;
78 |  |  |  |  | }
79 |  |  |  |  |
80 |  |  |  |  |
81 |  |  |  |  | sub request
82 |  |  |  |  | {
83 |  |  |  |  | my($self, $request, $proxy, $arg, $size, $timeout) = @_;
84 |  |  |  |  | Carp::croak('LWP::Protocol::request() needs to be overridden in subclasses');
85 |  |  |  |  | }
86 |  |  |  |  |
87 |  |  |  |  |
88 |  |  |  |  | # legacy
89 |  |  |  |  | sub timeout { shift->_elem('timeout', @_); }
90 |  |  |  |  | sub max_size { shift->_elem('max_size', @_); }
91 |  |  |  |  |
92 |  |  |  |  |
93 |  |  |  |  | sub collect
94 |  |  |  |  | # spent 2.84ms (303µs+2.53) within LWP::Protocol::collect which was called 3 times, avg 945µs/call: # 3 times (303µs+2.53ms) by LWP::Protocol::http::request at line 394 of LWP/Protocol/http.pm, avg 945µs/call {
95 | 78 | 241µs |  |  | my ($self, $arg, $response, $collector) = @_;
96 |  |  |  |  | my $content;
97 |  |  |  |  | my($ua, $max_size) = @{$self}{qw(ua max_size)};
98 |  |  |  |  |
99 |  |  |  |  | eval {
100 |  |  |  |  | local $\; # protect the print below from surprises
101 |  |  |  |  | if (!defined($arg) || !$response->is_success) {
102 |  |  |  |  | $response->{default_add_content} = 1;
103 |  |  |  |  | }
104 |  |  |  |  | elsif (!ref($arg) && length($arg)) {
105 |  |  |  |  | open(my $fh, ">", $arg) or die "Can't write to '$arg': $!";
106 |  |  |  |  | binmode($fh);
107 |  |  |  |  | push(@{$response->{handlers}{response_data}}, {
108 |  |  |  |  | callback => sub {
109 |  |  |  |  | print $fh $_[3] or die "Can't write to '$arg': $!";
110 |  |  |  |  | 1;
111 |  |  |  |  | },
112 |  |  |  |  | });
113 |  |  |  |  | push(@{$response->{handlers}{response_done}}, {
114 |  |  |  |  | callback => sub {
115 |  |  |  |  | close($fh) or die "Can't write to '$arg': $!";
116 |  |  |  |  | undef($fh);
117 |  |  |  |  | },
118 |  |  |  |  | });
119 |  |  |  |  | }
120 |  |  |  |  | elsif (ref($arg) eq 'CODE') {
121 |  |  |  |  | push(@{$response->{handlers}{response_data}}, {
122 |  |  |  |  | callback => sub {
123 |  |  |  |  | &$arg($_[3], $_[0], $self);
124 |  |  |  |  | 1;
125 |  |  |  |  | },
126 |  |  |  |  | });
127 |  |  |  |  | }
128 |  |  |  |  | else {
129 |  |  |  |  | die "Unexpected collect argument '$arg'";
130 |  |  |  |  | }
131 |  |  |  |  |
132 |  |  |  |  | $ua->run_handlers("response_header", $response); # spent 1.50ms making 3 calls to LWP::UserAgent::run_handlers, avg 501µs/call
133 |  |  |  |  |
134 |  |  |  |  | if (delete $response->{default_add_content}) {
135 |  |  |  |  | push(@{$response->{handlers}{response_data}}, {
136 |  |  |  |  | # spent 123µs (31+92) within LWP::Protocol::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/LWP/Protocol.pm:139] which was called 4 times, avg 31µs/call: # 4 times (31µs+92µs) by LWP::Protocol::collect at line 151, avg 31µs/call callback => sub {
137 | 8 | 31µs | 4 | 92µs | $_[0]->add_content($_[3]); # spent 92µs making 4 calls to HTTP::Message::add_content, avg 23µs/call
138 |  |  |  |  | 1;
139 |  |  |  |  | },
140 |  |  |  |  | });
141 |  |  |  |  | }
142 |  |  |  |  |
143 |  |  |  |  |
144 |  |  |  |  | my $content_size = 0;
145 |  |  |  |  | my $length = $response->content_length; # spent 65µs making 2 calls to HTTP::Message::__ANON__[HTTP/Message.pm:622], avg 32µs/call # spent 22µs making 1 call to HTTP::Message::AUTOLOAD
146 |  |  |  |  | my %skip_h;
147 |  |  |  |  |
148 |  |  |  |  | while ($content = &$collector, length $$content) { # spent 288µs making 3 calls to LWP::Protocol::http::__ANON__[LWP/Protocol/http.pm:394], avg 96µs/call
149 |  |  |  |  | for my $h ($ua->handlers("response_data", $response)) { # spent 27µs making 4 calls to LWP::UserAgent::handlers, avg 7µs/call
150 |  |  |  |  | next if $skip_h{$h};
151 |  |  |  |  | unless ($h->{callback}->($response, $ua, $h, $$content)) { # spent 123µs making 4 calls to LWP::Protocol::__ANON__[LWP/Protocol.pm:139], avg 31µs/call
152 |  |  |  |  | # XXX remove from $response->{handlers}{response_data} if present
153 |  |  |  |  | $skip_h{$h}++;
154 |  |  |  |  | }
155 |  |  |  |  | }
156 |  |  |  |  | $content_size += length($$content);
157 |  |  |  |  | $ua->progress(($length ? ($content_size / $length) : "tick"), $response); # spent 18µs making 4 calls to LWP::UserAgent::progress, avg 5µs/call
158 |  |  |  |  | if (defined($max_size) && $content_size > $max_size) { # spent 440µs making 4 calls to LWP::Protocol::http::__ANON__[LWP/Protocol/http.pm:394], avg 110µs/call
159 |  |  |  |  | $response->push_header("Client-Aborted", "max_size");
160 |  |  |  |  | last;
161 |  |  |  |  | }
162 |  |  |  |  | }
163 |  |  |  |  | };
164 |  |  |  |  | my $err = $@;
165 |  |  |  |  | delete $response->{handlers}{response_data};
166 |  |  |  |  | delete $response->{handlers} unless %{$response->{handlers}};
167 |  |  |  |  | if ($err) {
168 |  |  |  |  | chomp($err);
169 |  |  |  |  | $response->push_header('X-Died' => $err);
170 |  |  |  |  | $response->push_header("Client-Aborted", "die");
171 |  |  |  |  | return $response;
172 |  |  |  |  | }
173 |  |  |  |  |
174 |  |  |  |  | return $response;
175 |  |  |  |  | }
176 |  |  |  |  |
177 |  |  |  |  |
178 |  |  |  |  | sub collect_once
179 |  |  |  |  | {
180 |  |  |  |  | my($self, $arg, $response) = @_;
181 |  |  |  |  | my $content = \ $_[3];
182 |  |  |  |  | my $first = 1;
183 |  |  |  |  | $self->collect($arg, $response, sub {
184 |  |  |  |  | return $content if $first--;
185 |  |  |  |  | return \ "";
186 |  |  |  |  | });
187 |  |  |  |  | }
188 |  |  |  |  |
189 | 1 | 12µs |  |  | 1;
190 |  |  |  |  |
191 |  |  |  |  |
192 |  |  |  |  | __END__
193 |  |  |  |  |
194 |  |  |  |  | =head1 NAME
195 |  |  |  |  |
196 |  |  |  |  | LWP::Protocol - Base class for LWP protocols
197 |  |  |  |  |
198 |  |  |  |  | =head1 SYNOPSIS
199 |  |  |  |  |
200 |  |  |  |  | package LWP::Protocol::foo;
201 |  |  |  |  | require LWP::Protocol;
202 |  |  |  |  | @ISA=qw(LWP::Protocol);
203 |  |  |  |  |
204 |  |  |  |  | =head1 DESCRIPTION
205 |  |  |  |  |
206 |  |  |  |  | This class is used a the base class for all protocol implementations
207 |  |  |  |  | supported by the LWP library.
208 |  |  |  |  |
209 |  |  |  |  | When creating an instance of this class using
210 |  |  |  |  | C<LWP::Protocol::create($url)>, and you get an initialised subclass
211 |  |  |  |  | appropriate for that access method. In other words, the
212 |  |  |  |  | LWP::Protocol::create() function calls the constructor for one of its
213 |  |  |  |  | subclasses.
214 |  |  |  |  |
215 |  |  |  |  | All derived LWP::Protocol classes need to override the request()
216 |  |  |  |  | method which is used to service a request. The overridden method can
217 |  |  |  |  | make use of the collect() function to collect together chunks of data
218 |  |  |  |  | as it is received.
219 |  |  |  |  |
220 |  |  |  |  | The following methods and functions are provided:
221 |  |  |  |  |
222 |  |  |  |  | =over 4
223 |  |  |  |  |
224 |  |  |  |  | =item $prot = LWP::Protocol->new()
225 |  |  |  |  |
226 |  |  |  |  | The LWP::Protocol constructor is inherited by subclasses. As this is a
227 |  |  |  |  | virtual base class this method should B<not> be called directly.
228 |  |  |  |  |
229 |  |  |  |  | =item $prot = LWP::Protocol::create($scheme)
230 |  |  |  |  |
231 |  |  |  |  | Create an object of the class implementing the protocol to handle the
232 |  |  |  |  | given scheme. This is a function, not a method. It is more an object
233 |  |  |  |  | factory than a constructor. This is the function user agents should
234 |  |  |  |  | use to access protocols.
235 |  |  |  |  |
236 |  |  |  |  | =item $class = LWP::Protocol::implementor($scheme, [$class])
237 |  |  |  |  |
238 |  |  |  |  | Get and/or set implementor class for a scheme. Returns '' if the
239 |  |  |  |  | specified scheme is not supported.
240 |  |  |  |  |
241 |  |  |  |  | =item $prot->request(...)
242 |  |  |  |  |
243 |  |  |  |  | $response = $protocol->request($request, $proxy, undef);
244 |  |  |  |  | $response = $protocol->request($request, $proxy, '/tmp/sss');
245 |  |  |  |  | $response = $protocol->request($request, $proxy, \&callback, 1024);
246 |  |  |  |  |
247 |  |  |  |  | Dispatches a request over the protocol, and returns a response
248 |  |  |  |  | object. This method needs to be overridden in subclasses. Refer to
249 |  |  |  |  | L<LWP::UserAgent> for description of the arguments.
250 |  |  |  |  |
251 |  |  |  |  | =item $prot->collect($arg, $response, $collector)
252 |  |  |  |  |
253 |  |  |  |  | Called to collect the content of a request, and process it
254 |  |  |  |  | appropriately into a scalar, file, or by calling a callback. If $arg
255 |  |  |  |  | is undefined, then the content is stored within the $response. If
256 |  |  |  |  | $arg is a simple scalar, then $arg is interpreted as a file name and
257 |  |  |  |  | the content is written to this file. If $arg is a reference to a
258 |  |  |  |  | routine, then content is passed to this routine.
259 |  |  |  |  |
260 |  |  |  |  | The $collector is a routine that will be called and which is
261 |  |  |  |  | responsible for returning pieces (as ref to scalar) of the content to
262 |  |  |  |  | process. The $collector signals EOF by returning a reference to an
263 |  |  |  |  | empty sting.
264 |  |  |  |  |
265 |  |  |  |  | The return value from collect() is the $response object reference.
266 |  |  |  |  |
267 |  |  |  |  | B<Note:> We will only use the callback or file argument if
268 |  |  |  |  | $response->is_success(). This avoids sending content data for
269 |  |  |  |  | redirects and authentication responses to the callback which would be
270 |  |  |  |  | confusing.
271 |  |  |  |  |
272 |  |  |  |  | =item $prot->collect_once($arg, $response, $content)
273 |  |  |  |  |
274 |  |  |  |  | Can be called when the whole response content is available as
275 |  |  |  |  | $content. This will invoke collect() with a collector callback that
276 |  |  |  |  | returns a reference to $content the first time and an empty string the
277 |  |  |  |  | next.
278 |  |  |  |  |
279 |  |  |  |  | =back
280 |  |  |  |  |
281 |  |  |  |  | =head1 SEE ALSO
282 |  |  |  |  |
283 |  |  |  |  | Inspect the F<LWP/Protocol/file.pm> and F<LWP/Protocol/http.pm> files
284 |  |  |  |  | for examples of usage.
285 |  |  |  |  |
286 |  |  |  |  | =head1 COPYRIGHT
287 |  |  |  |  |
288 |  |  |  |  | Copyright 1995-2001 Gisle Aas.
289 |  |  |  |  |
290 |  |  |  |  | This library is free software; you can redistribute it and/or
291 |  |  |  |  | modify it under the same terms as Perl itself.
|  |  |  |  | # spent 3µs within LWP::Protocol::CORE:match which was called # once (3µs+0s) by LWP::Protocol::implementor at line 55 of LWP/Protocol.pm sub LWP::Protocol::CORE:match; # xsub
|  |  |  |  | # spent 900ns within LWP::Protocol::CORE:subst which was called # once (900ns+0s) by LWP::Protocol::implementor at line 57 of LWP/Protocol.pm sub LWP::Protocol::CORE:subst; # xsub