← Index
NYTProf Performance Profile   « block view • line view • sub view »
For ddd2.pl
  Run on Tue May 25 16:52:24 2010
Reported on Tue May 25 16:56:47 2010

File /project/perl/lib/LWP/Protocol.pm
Statements Executed 10216
Statement Execution Time 150ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
46111107ms515msLWP::Protocol::::collectLWP::Protocol::collect
4611140.8ms68.8msLWP::Protocol::::implementorLWP::Protocol::implementor
4611130.6ms115msLWP::Protocol::::createLWP::Protocol::create
4611115.9ms15.9msLWP::Protocol::::newLWP::Protocol::new
22229µs29µsLWP::Protocol::::CORE:matchLWP::Protocol::CORE:match (opcode)
1125µs5µsLWP::Protocol::::CORE:substLWP::Protocol::CORE:subst (opcode)
0000s0sLWP::Protocol::::BEGINLWP::Protocol::BEGIN
0000s0sLWP::Protocol::::__ANON__[:186]LWP::Protocol::__ANON__[:186]
0000s0sLWP::Protocol::::collect_onceLWP::Protocol::collect_once
0000s0sLWP::Protocol::::max_sizeLWP::Protocol::max_size
0000s0sLWP::Protocol::::parse_headLWP::Protocol::parse_head
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
3# $Id: Protocol.pm,v 1.43 2004/11/12 13:34:10 gisle Exp $
4
51272µsrequire LWP::MemberMixin;
6110µs@ISA = qw(LWP::MemberMixin);
7158µs120µs$VERSION = sprintf("%d.%02d", q$Revision: 1.43 $ =~ /(\d+)\.(\d+)/);
# spent 20µs making 1 call to LWP::Protocol::CORE:match
8
9392µs128µsuse strict;
# spent 28µs making 1 call to strict::import
10350µsuse Carp ();
11352µsuse HTTP::Status ();
123569µs1143µsuse HTTP::Response;
# spent 143µs making 1 call to Exporter::import
13
1415µsmy %ImplementedBy = (); # scheme => classname
15
16
17
18sub new
19
# spent 15.9ms within LWP::Protocol::new which was called 461 times, avg 35µs/call: # 461 times (15.9ms+0s) by LWP::Protocol::create at line 42, avg 35µs/call
{
20138317.5ms my($class, $scheme, $ua) = @_;
21
22 my $self = bless {
23 scheme => $scheme,
24 ua => $ua,
25
26 # historical/redundant
27 parse_head => $ua->{parse_head},
28 max_size => $ua->{max_size},
29 }, $class;
30
31 $self;
32}
33
34
35sub create
36
# spent 115ms (30.6+84.7) within LWP::Protocol::create which was called 461 times, avg 250µs/call: # 461 times (30.6ms+84.7ms) by LWP::UserAgent::send_request at line 191 of LWP/UserAgent.pm, avg 250µs/call
{
37184427.3ms my($scheme, $ua) = @_;
38 my $impclass = LWP::Protocol::implementor($scheme) or
# spent 68.8ms making 461 calls to LWP::Protocol::implementor, avg 149µs/call
39 Carp::croak("Protocol scheme '$scheme' is not supported");
40
41 # hand-off to scheme specific implementation sub-class
42 my $protocol = $impclass->new($scheme, $ua);
# spent 15.9ms making 461 calls to LWP::Protocol::new, avg 35µs/call
43
44 return $protocol;
45}
46
47
48sub implementor
49
# spent 68.8ms (40.8+27.9) within LWP::Protocol::implementor which was called 461 times, avg 149µs/call: # 461 times (40.8ms+27.9ms) by LWP::Protocol::create at line 38, avg 149µs/call
{
50185414.4ms my($scheme, $impclass) = @_;
51
52 if ($impclass) {
53 $ImplementedBy{$scheme} = $impclass;
54 }
55 my $ic = $ImplementedBy{$scheme};
56 return $ic if $ic;
57
58 return '' unless $scheme =~ /^([.+\-\w]+)$/; # check valid URL schemes
# spent 9µs making 1 call to LWP::Protocol::CORE:match
59 $scheme = $1; # untaint
60 $scheme =~ s/[.+\-]/_/g; # make it a legal module name
# spent 5µs making 1 call to LWP::Protocol::CORE:subst
61
62 # scheme not yet known, look for a 'use'd implementation
63 $ic = "LWP::Protocol::$scheme"; # default location
64 $ic = "LWP::Protocol::nntp" if $scheme eq 'news'; #XXX ugly hack
6531.64ms199µs no strict 'refs';
# spent 99µs making 1 call to strict::unimport
66 # check we actually have one for the scheme:
67 unless (@{"${ic}::ISA"}) {
68 # try to autoload it
691220µs eval "require $ic";
70 if ($@) {
71 if ($@ =~ /Can't locate/) { #' #emacs get confused by '
72 $ic = '';
73 }
74 else {
75 die "$@\n";
76 }
77 }
78 }
79 $ImplementedBy{$scheme} = $ic if $ic;
80 $ic;
81}
82
83
84sub request
85{
86 my($self, $request, $proxy, $arg, $size, $timeout) = @_;
87 Carp::croak('LWP::Protocol::request() needs to be overridden in subclasses');
88}
89
90
91# legacy
92sub timeout { shift->_elem('timeout', @_); }
93sub parse_head { shift->_elem('parse_head', @_); }
94sub max_size { shift->_elem('max_size', @_); }
95
96
97sub collect
98
# spent 515ms (107+408) within LWP::Protocol::collect which was called 461 times, avg 1.12ms/call: # 461 times (107ms+408ms) by LWP::Protocol::http::request at line 352 of LWP/Protocol/http.pm, avg 1.12ms/call
{
99511387.5ms my ($self, $arg, $response, $collector) = @_;
100 my $content;
101 my($parse_head, $max_size) = @{$self}{qw(parse_head max_size)};
102
103 my $parser;
104 if ($parse_head && $response->content_type eq 'text/html') {
# spent 101ms making 460 calls to HTTP::Message::__ANON__[(eval 0)[HTTP/Message.pm:371]:1], avg 219µs/call # spent 183µs making 1 call to HTTP::Message::AUTOLOAD
105 require HTML::HeadParser;
106 $parser = HTML::HeadParser->new($response->{'_headers'});
# spent 195ms making 461 calls to HTML::HeadParser::new, avg 423µs/call
107 }
108 my $content_size = 0;
109
110 if (!defined($arg) || !$response->is_success) {
111 # scalar
112 while ($content = &$collector, length $$content) {
# spent 88.5ms making 461 calls to LWP::Protocol::http::__ANON__[LWP/Protocol/http.pm:352], avg 192µs/call
113 if ($parser) {
1141133µs141.69ms $parser->parse($$content) or undef($parser);
# spent 986µs making 7 calls to HTML::Parser::parse, avg 141µs/call # spent 703µs making 7 calls to HTML::HeadParser::text, avg 100µs/call
115 }
116 LWP::Debug::debug("read " . length($$content) . " bytes");
# spent 94µs making 7 calls to LWP::Debug::debug, avg 13µs/call
117 $response->add_content($$content);
# spent 334µs making 7 calls to HTTP::Message::add_content, avg 48µs/call
118 $content_size += length($$content);
119 if (defined($max_size) && $content_size > $max_size) {
# spent 2.53ms making 7 calls to LWP::Protocol::http::__ANON__[LWP/Protocol/http.pm:352], avg 362µs/call
120 LWP::Debug::debug("Aborting because size limit exceeded");
121 $response->push_header("Client-Aborted", "max_size");
122 #my $tot = $response->header("Content-Length") || 0;
123 #$response->header("X-Content-Range", "bytes 0-$content_size/$tot");
124 last;
125 }
126 }
127 }
128 elsif (!ref($arg)) {
129 # filename
130 open(OUT, ">$arg") or
131 return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
132 "Cannot write to '$arg': $!");
133 binmode(OUT);
134 local($\) = ""; # ensure standard $OUTPUT_RECORD_SEPARATOR
135 while ($content = &$collector, length $$content) {
136 if ($parser) {
137 $parser->parse($$content) or undef($parser);
138 }
139 LWP::Debug::debug("read " . length($$content) . " bytes");
140 print OUT $$content or die "Can't write to '$arg': $!";
141 $content_size += length($$content);
142 if (defined($max_size) && $content_size > $max_size) {
143 LWP::Debug::debug("Aborting because size limit exceeded");
144 $response->push_header("Client-Aborted", "max_size");
145 #my $tot = $response->header("Content-Length") || 0;
146 #$response->header("X-Content-Range", "bytes 0-$content_size/$tot");
147 last;
148 }
149 }
150 close(OUT) or die "Can't write to '$arg': $!";
151 }
152 elsif (ref($arg) eq 'CODE') {
153 # read into callback
154 while ($content = &$collector, length $$content) {
155 if ($parser) {
156 $parser->parse($$content) or undef($parser);
157 }
158 LWP::Debug::debug("read " . length($$content) . " bytes");
159 eval {
160 &$arg($$content, $response, $self);
161 };
162 if ($@) {
163 chomp($@);
164 $response->push_header('X-Died' => $@);
165 $response->push_header("Client-Aborted", "die");
166 last;
167 }
168 }
169 }
170 else {
171 return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
172 "Unexpected collect argument '$arg'");
173 }
174 $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
189123µ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=head1 SEE ALSO
280
281Inspect the F<LWP/Protocol/file.pm> and F<LWP/Protocol/http.pm> files
282for examples of usage.
283
284=head1 COPYRIGHT
285
286Copyright 1995-2001 Gisle Aas.
287
288This library is free software; you can redistribute it and/or
289modify it under the same terms as Perl itself.
# spent 29µs within LWP::Protocol::CORE:match which was called 2 times, avg 14µs/call: # once (20µs+0s) by LWP::UserAgent::BEGIN at line 7 of LWP/Protocol.pm # once (9µs+0s) by LWP::Protocol::implementor at line 58 of LWP/Protocol.pm
sub LWP::Protocol::CORE:match; # xsub
# spent 5µs within LWP::Protocol::CORE:subst which was called # once (5µs+0s) by LWP::Protocol::implementor at line 60 of LWP/Protocol.pm
sub LWP::Protocol::CORE:subst; # xsub
Report produced by the NYTProf 3.11 Perl profiler, developed by Tim Bunce and Adam Kaplan.