← 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:09 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
3117.91ms17.1msLWP::Protocol::::implementorLWP::Protocol::implementor
311303µs2.84msLWP::Protocol::::collectLWP::Protocol::collect
31156µs17.2msLWP::Protocol::::createLWP::Protocol::create
31142µs42µsLWP::Protocol::::newLWP::Protocol::new
41131µs123µsLWP::Protocol::::__ANON__[:139]LWP::Protocol::__ANON__[:139]
11121µs27µsLWP::Protocol::::BEGIN@7LWP::Protocol::BEGIN@7
11115µs15µsLWP::Protocol::::BEGIN@10LWP::Protocol::BEGIN@10
11111µs36µsLWP::Protocol::::BEGIN@62LWP::Protocol::BEGIN@62
1115µs5µsLWP::Protocol::::BEGIN@8LWP::Protocol::BEGIN@8
1115µs5µsLWP::Protocol::::BEGIN@9LWP::Protocol::BEGIN@9
1123µs3µsLWP::Protocol::::CORE:matchLWP::Protocol::CORE:match (opcode)
112900ns900nsLWP::Protocol::::CORE:substLWP::Protocol::CORE:subst (opcode)
0000s0sLWP::Protocol::::__ANON__[:111]LWP::Protocol::__ANON__[:111]
0000s0sLWP::Protocol::::__ANON__[:117]LWP::Protocol::__ANON__[:117]
0000s0sLWP::Protocol::::__ANON__[:125]LWP::Protocol::__ANON__[:125]
0000s0sLWP::Protocol::::__ANON__[:186]LWP::Protocol::__ANON__[:186]
0000s0sLWP::Protocol::::collect_onceLWP::Protocol::collect_once
0000s0sLWP::Protocol::::max_sizeLWP::Protocol::max_size
0000s0sLWP::Protocol::::requestLWP::Protocol::request
0000s0sLWP::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
1package LWP::Protocol;
2
31169µsrequire LWP::MemberMixin;
418µs@ISA = qw(LWP::MemberMixin);
51400ns$VERSION = "5.829";
6
7334µs234µ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
8329µs15µ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
9329µs15µ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
103311µs115µ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
121400nsmy %ImplementedBy = (); # scheme => classname
13
14
15
16sub 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
{
18942µ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
32sub 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
{
341248µ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
45sub 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
{
472063µ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
6231.45ms262µ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:
64224µs unless (@{"${ic}::ISA"}) {
65 # try to autoload it
661149µ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
81sub 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
89sub timeout { shift->_elem('timeout', @_); }
90sub max_size { shift->_elem('max_size', @_); }
91
92
93sub 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
{
952769µs my ($self, $arg, $response, $collector) = @_;
96 my $content;
97 my($ua, $max_size) = @{$self}{qw(ua max_size)};
98
992483µs 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
134321µs 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 {
137831µs492µ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
1491648µs427µs for my $h ($ua->handlers("response_data", $response)) {
# spent 27µs making 4 calls to LWP::UserAgent::handlers, avg 7µs/call
150819µs 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
178sub 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
189112µs1;
190
191
192__END__
193
194=head1 NAME
195
196LWP::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
206This class is used a the base class for all protocol implementations
207supported by the LWP library.
208
209When creating an instance of this class using
210C<LWP::Protocol::create($url)>, and you get an initialised subclass
211appropriate for that access method. In other words, the
212LWP::Protocol::create() function calls the constructor for one of its
213subclasses.
214
215All derived LWP::Protocol classes need to override the request()
216method which is used to service a request. The overridden method can
217make use of the collect() function to collect together chunks of data
218as it is received.
219
220The following methods and functions are provided:
221
222=over 4
223
224=item $prot = LWP::Protocol->new()
225
226The LWP::Protocol constructor is inherited by subclasses. As this is a
227virtual base class this method should B<not> be called directly.
228
229=item $prot = LWP::Protocol::create($scheme)
230
231Create an object of the class implementing the protocol to handle the
232given scheme. This is a function, not a method. It is more an object
233factory than a constructor. This is the function user agents should
234use to access protocols.
235
236=item $class = LWP::Protocol::implementor($scheme, [$class])
237
238Get and/or set implementor class for a scheme. Returns '' if the
239specified 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
247Dispatches a request over the protocol, and returns a response
248object. This method needs to be overridden in subclasses. Refer to
249L<LWP::UserAgent> for description of the arguments.
250
251=item $prot->collect($arg, $response, $collector)
252
253Called to collect the content of a request, and process it
254appropriately into a scalar, file, or by calling a callback. If $arg
255is 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
257the content is written to this file. If $arg is a reference to a
258routine, then content is passed to this routine.
259
260The $collector is a routine that will be called and which is
261responsible for returning pieces (as ref to scalar) of the content to
262process. The $collector signals EOF by returning a reference to an
263empty sting.
264
265The return value from collect() is the $response object reference.
266
267B<Note:> We will only use the callback or file argument if
268$response->is_success(). This avoids sending content data for
269redirects and authentication responses to the callback which would be
270confusing.
271
272=item $prot->collect_once($arg, $response, $content)
273
274Can be called when the whole response content is available as
275$content. This will invoke collect() with a collector callback that
276returns a reference to $content the first time and an empty string the
277next.
278
279=back
280
281=head1 SEE ALSO
282
283Inspect the F<LWP/Protocol/file.pm> and F<LWP/Protocol/http.pm> files
284for examples of usage.
285
286=head1 COPYRIGHT
287
288Copyright 1995-2001 Gisle Aas.
289
290This library is free software; you can redistribute it and/or
291modify 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