| File | /usr/local/lib/perl5/site_perl/5.10.1/LWP/Protocol.pm |
| Statements Executed | 149 |
| Statement Execution Time | 2.64ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 3 | 1 | 1 | 7.91ms | 17.1ms | LWP::Protocol::implementor |
| 3 | 1 | 1 | 303µs | 2.84ms | LWP::Protocol::collect |
| 3 | 1 | 1 | 56µs | 17.2ms | LWP::Protocol::create |
| 3 | 1 | 1 | 42µs | 42µs | LWP::Protocol::new |
| 4 | 1 | 1 | 31µs | 123µs | LWP::Protocol::__ANON__[:139] |
| 1 | 1 | 1 | 21µs | 27µs | LWP::Protocol::BEGIN@7 |
| 1 | 1 | 1 | 15µs | 15µs | LWP::Protocol::BEGIN@10 |
| 1 | 1 | 1 | 11µs | 36µs | LWP::Protocol::BEGIN@62 |
| 1 | 1 | 1 | 5µs | 5µs | LWP::Protocol::BEGIN@8 |
| 1 | 1 | 1 | 5µs | 5µs | LWP::Protocol::BEGIN@9 |
| 1 | 1 | 2 | 3µs | 3µs | LWP::Protocol::CORE:match (opcode) |
| 1 | 1 | 2 | 900ns | 900ns | LWP::Protocol::CORE:subst (opcode) |
| 0 | 0 | 0 | 0s | 0s | LWP::Protocol::__ANON__[:111] |
| 0 | 0 | 0 | 0s | 0s | LWP::Protocol::__ANON__[:117] |
| 0 | 0 | 0 | 0s | 0s | LWP::Protocol::__ANON__[:125] |
| 0 | 0 | 0 | 0s | 0s | LWP::Protocol::__ANON__[:186] |
| 0 | 0 | 0 | 0s | 0s | LWP::Protocol::collect_once |
| 0 | 0 | 0 | 0s | 0s | LWP::Protocol::max_size |
| 0 | 0 | 0 | 0s | 0s | LWP::Protocol::request |
| 0 | 0 | 0 | 0s | 0s | LWP::Protocol::timeout |
| 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 # 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 # 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 # 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 # 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 | 3 | 5µs | my($class, $scheme, $ua) = @_; | ||
| 19 | |||||
| 20 | 3 | 28µs | my $self = bless { | ||
| 21 | scheme => $scheme, | ||||
| 22 | ua => $ua, | ||||
| 23 | |||||
| 24 | # historical/redundant | ||||
| 25 | max_size => $ua->{max_size}, | ||||
| 26 | }, $class; | ||||
| 27 | |||||
| 28 | 3 | 10µs | $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 | 3 | 4µs | my($scheme, $ua) = @_; | ||
| 35 | 3 | 10µs | 3 | 17.1ms | 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 | 3 | 21µs | 3 | 42µs | my $protocol = $impclass->new($scheme, $ua); # spent 42µs making 3 calls to LWP::Protocol::new, avg 14µs/call |
| 40 | |||||
| 41 | 3 | 12µs | 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 | 3 | 3µs | my($scheme, $impclass) = @_; | ||
| 48 | |||||
| 49 | 3 | 1µs | if ($impclass) { | ||
| 50 | $ImplementedBy{$scheme} = $impclass; | ||||
| 51 | } | ||||
| 52 | 3 | 3µs | my $ic = $ImplementedBy{$scheme}; | ||
| 53 | 3 | 8µs | return $ic if $ic; | ||
| 54 | |||||
| 55 | 1 | 11µs | 1 | 3µs | return '' unless $scheme =~ /^([.+\-\w]+)$/; # check valid URL schemes # spent 3µs making 1 call to LWP::Protocol::CORE:match |
| 56 | 1 | 1µs | $scheme = $1; # untaint | ||
| 57 | 1 | 7µs | 1 | 900ns | $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 | 1 | 2µs | $ic = "LWP::Protocol::$scheme"; # default location | ||
| 61 | 1 | 900ns | $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 # 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 | 1 | 14µs | unless (@{"${ic}::ISA"}) { | ||
| 65 | # try to autoload it | ||||
| 66 | 1 | 171µs | eval "require $ic"; | ||
| 67 | 1 | 1µs | if ($@) { | ||
| 68 | if ($@ =~ /Can't locate/) { #' #emacs get confused by ' | ||||
| 69 | $ic = ''; | ||||
| 70 | } | ||||
| 71 | else { | ||||
| 72 | die "$@\n"; | ||||
| 73 | } | ||||
| 74 | } | ||||
| 75 | } | ||||
| 76 | 1 | 2µs | $ImplementedBy{$scheme} = $ic if $ic; | ||
| 77 | 1 | 9µs | $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 | 3 | 5µs | my ($self, $arg, $response, $collector) = @_; | ||
| 96 | 3 | 800ns | my $content; | ||
| 97 | 3 | 9µs | my($ua, $max_size) = @{$self}{qw(ua max_size)}; | ||
| 98 | |||||
| 99 | 3 | 6µs | eval { | ||
| 100 | 3 | 13µs | local $\; # protect the print below from surprises | ||
| 101 | 3 | 5µs | 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 | 3 | 15µs | 3 | 1.50ms | $ua->run_handlers("response_header", $response); # spent 1.50ms making 3 calls to LWP::UserAgent::run_handlers, avg 501µs/call |
| 133 | |||||
| 134 | 3 | 6µ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 | ||||
| 137 | 4 | 16µs | 4 | 92µs | $_[0]->add_content($_[3]); # spent 92µs making 4 calls to HTTP::Message::add_content, avg 23µs/call |
| 138 | 4 | 14µs | 1; | ||
| 139 | }, | ||||
| 140 | 3 | 21µs | }); | ||
| 141 | } | ||||
| 142 | |||||
| 143 | |||||
| 144 | 3 | 2µs | my $content_size = 0; | ||
| 145 | 3 | 16µs | 3 | 87µs | 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 | 3 | 1µs | my %skip_h; | ||
| 147 | |||||
| 148 | 3 | 29µs | 3 | 288µs | 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 | 4 | 15µs | 4 | 27µs | for my $h ($ua->handlers("response_data", $response)) { # spent 27µs making 4 calls to LWP::UserAgent::handlers, avg 7µs/call |
| 150 | 4 | 4µs | next if $skip_h{$h}; | ||
| 151 | 4 | 15µs | 4 | 123µs | 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 | 4 | 4µs | $content_size += length($$content); | ||
| 157 | 4 | 14µs | 4 | 18µs | $ua->progress(($length ? ($content_size / $length) : "tick"), $response); # spent 18µs making 4 calls to LWP::UserAgent::progress, avg 5µs/call |
| 158 | 4 | 12µs | 4 | 440µs | 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 | 3 | 2µs | my $err = $@; | ||
| 165 | 3 | 22µs | delete $response->{handlers}{response_data}; | ||
| 166 | 3 | 6µs | delete $response->{handlers} unless %{$response->{handlers}}; | ||
| 167 | 3 | 2µs | 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 | 3 | 16µs | 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 | |||||
# spent 900ns within LWP::Protocol::CORE:subst which was called
# once (900ns+0s) by LWP::Protocol::implementor at line 57 of LWP/Protocol.pm |