File | /usr/local/lib/perl5/site_perl/5.10.1/LWP/Protocol.pm |
Statements Executed | 1676 |
Statement Execution Time | 5.81ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
41 | 1 | 1 | 6.83ms | 15.9ms | implementor | LWP::Protocol::
41 | 1 | 1 | 3.71ms | 112ms | collect | LWP::Protocol::
41 | 1 | 1 | 589µs | 17.0ms | create | LWP::Protocol::
41 | 1 | 1 | 445µs | 445µs | new | LWP::Protocol::
57 | 1 | 1 | 377µs | 1.57ms | __ANON__[:139] | LWP::Protocol::
1 | 1 | 1 | 13µs | 29µs | BEGIN@62 | LWP::Protocol::
1 | 1 | 1 | 13µs | 16µs | BEGIN@7 | LWP::Protocol::
1 | 1 | 1 | 8µs | 8µs | BEGIN@10 | LWP::Protocol::
1 | 1 | 1 | 3µs | 3µs | BEGIN@9 | LWP::Protocol::
1 | 1 | 1 | 3µs | 3µs | BEGIN@8 | LWP::Protocol::
1 | 1 | 2 | 2µs | 2µs | CORE:match (opcode) | LWP::Protocol::
1 | 1 | 2 | 600ns | 600ns | CORE:subst (opcode) | LWP::Protocol::
0 | 0 | 0 | 0s | 0s | __ANON__[:111] | LWP::Protocol::
0 | 0 | 0 | 0s | 0s | __ANON__[:117] | LWP::Protocol::
0 | 0 | 0 | 0s | 0s | __ANON__[:125] | LWP::Protocol::
0 | 0 | 0 | 0s | 0s | __ANON__[:186] | LWP::Protocol::
0 | 0 | 0 | 0s | 0s | collect_once | LWP::Protocol::
0 | 0 | 0 | 0s | 0s | max_size | LWP::Protocol::
0 | 0 | 0 | 0s | 0s | request | LWP::Protocol::
0 | 0 | 0 | 0s | 0s | timeout | LWP::Protocol::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package LWP::Protocol; | ||||
2 | |||||
3 | 1 | 102µs | require LWP::MemberMixin; | ||
4 | 1 | 7µs | @ISA = qw(LWP::MemberMixin); | ||
5 | 1 | 400ns | $VERSION = "5.829"; | ||
6 | |||||
7 | 3 | 19µs | 2 | 19µs | # spent 16µs (13+3) within LWP::Protocol::BEGIN@7 which was called
# once (13µs+3µs) by LWP::UserAgent::BEGIN@15 at line 7 # spent 16µs making 1 call to LWP::Protocol::BEGIN@7
# spent 3µs making 1 call to strict::import |
8 | 3 | 15µs | 1 | 3µs | # spent 3µs within LWP::Protocol::BEGIN@8 which was called
# once (3µs+0s) by LWP::UserAgent::BEGIN@15 at line 8 # spent 3µs making 1 call to LWP::Protocol::BEGIN@8 |
9 | 3 | 17µs | 1 | 3µs | # spent 3µs within LWP::Protocol::BEGIN@9 which was called
# once (3µs+0s) by LWP::UserAgent::BEGIN@15 at line 9 # spent 3µs making 1 call to LWP::Protocol::BEGIN@9 |
10 | 3 | 161µs | 1 | 8µs | # spent 8µs within LWP::Protocol::BEGIN@10 which was called
# once (8µs+0s) by LWP::UserAgent::BEGIN@15 at line 10 # spent 8µs making 1 call to LWP::Protocol::BEGIN@10 |
11 | |||||
12 | 1 | 500ns | my %ImplementedBy = (); # scheme => classname | ||
13 | |||||
14 | |||||
15 | |||||
16 | sub new | ||||
17 | # spent 445µs within LWP::Protocol::new which was called 41 times, avg 11µs/call:
# 41 times (445µs+0s) by LWP::Protocol::create at line 39, avg 11µs/call | ||||
18 | 123 | 474µ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.0ms (589µs+16.4) within LWP::Protocol::create which was called 41 times, avg 414µs/call:
# 41 times (589µs+16.4ms) by LWP::UserAgent::send_request at line 159 of LWP/UserAgent.pm, avg 414µs/call | ||||
34 | 164 | 509µs | my($scheme, $ua) = @_; | ||
35 | my $impclass = LWP::Protocol::implementor($scheme) or # spent 15.9ms making 41 calls to LWP::Protocol::implementor, avg 389µs/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 445µs making 41 calls to LWP::Protocol::new, avg 11µs/call | ||||
40 | |||||
41 | return $protocol; | ||||
42 | } | ||||
43 | |||||
44 | |||||
45 | sub implementor | ||||
46 | # spent 15.9ms (6.83+9.10) within LWP::Protocol::implementor which was called 41 times, avg 389µs/call:
# 41 times (6.83ms+9.10ms) by LWP::Protocol::create at line 35, avg 389µs/call | ||||
47 | 172 | 291µ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 2µs making 1 call to LWP::Protocol::CORE:match | ||||
56 | $scheme = $1; # untaint | ||||
57 | $scheme =~ s/[.+\-]/_/g; # make it a legal module name # spent 600ns 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 | 594µs | 2 | 45µs | # spent 29µs (13+16) within LWP::Protocol::BEGIN@62 which was called
# once (13µs+16µs) by LWP::UserAgent::BEGIN@15 at line 62 # spent 29µs making 1 call to LWP::Protocol::BEGIN@62
# spent 16µs making 1 call to strict::unimport |
63 | # check we actually have one for the scheme: | ||||
64 | 2 | 23µs | unless (@{"${ic}::ISA"}) { | ||
65 | # try to autoload it | ||||
66 | 1 | 117µ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 112ms (3.71+108) within LWP::Protocol::collect which was called 41 times, avg 2.73ms/call:
# 41 times (3.71ms+108ms) by LWP::Protocol::http::request at line 394 of LWP/Protocol/http.pm, avg 2.73ms/call | ||||
95 | 369 | 876µs | my ($self, $arg, $response, $collector) = @_; | ||
96 | my $content; | ||||
97 | my($ua, $max_size) = @{$self}{qw(ua max_size)}; | ||||
98 | |||||
99 | 328 | 992µ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 17.6ms making 41 calls to LWP::UserAgent::run_handlers, avg 429µs/call | ||||
133 | |||||
134 | 41 | 325µs | if (delete $response->{default_add_content}) { | ||
135 | push(@{$response->{handlers}{response_data}}, { | ||||
136 | # spent 1.57ms (377µs+1.20) within LWP::Protocol::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/LWP/Protocol.pm:139] which was called 57 times, avg 28µs/call:
# 57 times (377µs+1.20ms) by LWP::Protocol::collect at line 151, avg 28µs/call | ||||
137 | 114 | 345µs | 57 | 1.20ms | $_[0]->add_content($_[3]); # spent 1.20ms making 57 calls to HTTP::Message::add_content, avg 21µs/call |
138 | 1; | ||||
139 | }, | ||||
140 | }); | ||||
141 | } | ||||
142 | |||||
143 | |||||
144 | my $content_size = 0; | ||||
145 | my $length = $response->content_length; # spent 1.23ms making 40 calls to HTTP::Message::__ANON__[HTTP/Message.pm:622], avg 31µs/call
# spent 10µs making 1 call to HTTP::Message::AUTOLOAD | ||||
146 | my %skip_h; | ||||
147 | |||||
148 | while ($content = &$collector, length $$content) { # spent 4.03ms making 41 calls to LWP::Protocol::http::__ANON__[LWP/Protocol/http.pm:394], avg 98µs/call | ||||
149 | 228 | 645µs | 57 | 350µs | for my $h ($ua->handlers("response_data", $response)) { # spent 350µs making 57 calls to LWP::UserAgent::handlers, avg 6µs/call |
150 | 114 | 288µs | next if $skip_h{$h}; | ||
151 | unless ($h->{callback}->($response, $ua, $h, $$content)) { # spent 1.57ms making 57 calls to LWP::Protocol::__ANON__[LWP/Protocol.pm:139], avg 28µ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 270µs making 57 calls to LWP::UserAgent::progress, avg 5µs/call | ||||
158 | if (defined($max_size) && $content_size > $max_size) { # spent 83.1ms making 57 calls to LWP::Protocol::http::__ANON__[LWP/Protocol/http.pm:394], avg 1.46ms/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 2µs within LWP::Protocol::CORE:match which was called
# once (2µs+0s) by LWP::Protocol::implementor at line 55 of LWP/Protocol.pm | |||||
# spent 600ns within LWP::Protocol::CORE:subst which was called
# once (600ns+0s) by LWP::Protocol::implementor at line 57 of LWP/Protocol.pm |