← Index
NYTProf Performance Profile   « block view • line view • sub view »
For 05.Domain_and_Item.t
  Run on Tue May 4 17:21:41 2010
Reported on Tue May 4 17:22:21 2010

File /usr/local/lib/perl5/site_perl/5.10.1/HTTP/Response.pm
Statements Executed 789
Statement Execution Time 4.63ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1112.66ms2.78msHTTP::Response::::BEGIN@8HTTP::Response::BEGIN@8
41111.41ms3.56msHTTP::Response::::newHTTP::Response::new
12333663µs1.09msHTTP::Response::::requestHTTP::Response::request
12333630µs1.10msHTTP::Response::::codeHTTP::Response::code
4111421µs788µsHTTP::Response::::redirectsHTTP::Response::redirects
4111271µs431µsHTTP::Response::::is_successHTTP::Response::is_success
4111249µs411µsHTTP::Response::::messageHTTP::Response::message
4111242µs367µsHTTP::Response::::previousHTTP::Response::previous
11114µs18µsHTTP::Response::::BEGIN@7HTTP::Response::BEGIN@7
0000s0sHTTP::Response::::as_stringHTTP::Response::as_string
0000s0sHTTP::Response::::baseHTTP::Response::base
0000s0sHTTP::Response::::cloneHTTP::Response::clone
0000s0sHTTP::Response::::current_ageHTTP::Response::current_age
0000s0sHTTP::Response::::dumpHTTP::Response::dump
0000s0sHTTP::Response::::error_as_HTMLHTTP::Response::error_as_HTML
0000s0sHTTP::Response::::filenameHTTP::Response::filename
0000s0sHTTP::Response::::fresh_untilHTTP::Response::fresh_until
0000s0sHTTP::Response::::freshness_lifetimeHTTP::Response::freshness_lifetime
0000s0sHTTP::Response::::is_errorHTTP::Response::is_error
0000s0sHTTP::Response::::is_freshHTTP::Response::is_fresh
0000s0sHTTP::Response::::is_infoHTTP::Response::is_info
0000s0sHTTP::Response::::is_redirectHTTP::Response::is_redirect
0000s0sHTTP::Response::::parseHTTP::Response::parse
0000s0sHTTP::Response::::status_lineHTTP::Response::status_line
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package HTTP::Response;
2
31900nsrequire HTTP::Message;
418µs@ISA = qw(HTTP::Message);
51400ns$VERSION = "5.824";
6
7321µs221µs
# spent 18µs (14+3) within HTTP::Response::BEGIN@7 which was called # once (14µs+3µs) by LWP::UserAgent::BEGIN@11 at line 7
use strict;
# spent 18µs making 1 call to HTTP::Response::BEGIN@7 # spent 3µs making 1 call to strict::import
831.18ms12.78ms
# spent 2.78ms (2.66+113µs) within HTTP::Response::BEGIN@8 which was called # once (2.66ms+113µs) by LWP::UserAgent::BEGIN@11 at line 8
use HTTP::Status ();
# spent 2.78ms making 1 call to HTTP::Response::BEGIN@8
9
10
11
12sub new
13
# spent 3.56ms (1.41+2.15) within HTTP::Response::new which was called 41 times, avg 87µs/call: # 41 times (1.41ms+2.15ms) by LWP::Protocol::http::request at line 357 of LWP/Protocol/http.pm, avg 87µs/call
{
142051.26ms my($class, $rc, $msg, $header, $content) = @_;
15 my $self = $class->SUPER::new($header, $content);
# spent 1.14ms making 41 calls to HTTP::Message::new, avg 28µs/call
16 $self->code($rc);
# spent 594µs making 41 calls to HTTP::Response::code, avg 14µs/call
17 $self->message($msg);
# spent 411µs making 41 calls to HTTP::Response::message, avg 10µs/call
18 $self;
19}
20
21
22sub parse
23{
24 my($class, $str) = @_;
25 my $status_line;
26 if ($str =~ s/^(.*)\n//) {
27 $status_line = $1;
28 }
29 else {
30 $status_line = $str;
31 $str = "";
32 }
33
34 my $self = $class->SUPER::parse($str);
35 my($protocol, $code, $message);
36 if ($status_line =~ /^\d{3} /) {
37 # Looks like a response created by HTTP::Response->new
38 ($code, $message) = split(' ', $status_line, 2);
39 } else {
40 ($protocol, $code, $message) = split(' ', $status_line, 3);
41 }
42 $self->protocol($protocol) if $protocol;
43 $self->code($code) if defined($code);
44 $self->message($message) if defined($message);
45 $self;
46}
47
48
49sub clone
50{
51 my $self = shift;
52 my $clone = bless $self->SUPER::clone, ref($self);
53 $clone->code($self->code);
54 $clone->message($self->message);
55 $clone->request($self->request->clone) if $self->request;
56 # we don't clone previous
57 $clone;
58}
59
60
61123565µs123471µs
# spent 1.10ms (630µs+471µs) within HTTP::Response::code which was called 123 times, avg 9µs/call: # 41 times (336µs+258µs) by HTTP::Response::new at line 16, avg 14µs/call # 41 times (149µs+109µs) by LWP::UserAgent::request at line 274 of LWP/UserAgent.pm, avg 6µs/call # 41 times (145µs+104µs) by SimpleDB::Client::send_request at line 217 of SimpleDB/Client.pm, avg 6µs/call
sub code { shift->_elem('_rc', @_); }
# spent 471µs making 123 calls to HTTP::Message::_elem, avg 4µs/call
6241203µs41162µs
# spent 411µs (249+162) within HTTP::Response::message which was called 41 times, avg 10µs/call: # 41 times (249µs+162µs) by HTTP::Response::new at line 17, avg 10µs/call
sub message { shift->_elem('_msg', @_); }
# spent 162µs making 41 calls to HTTP::Message::_elem, avg 4µs/call
6341183µs41125µs
# spent 367µs (242+125) within HTTP::Response::previous which was called 41 times, avg 9µs/call: # 41 times (242µs+125µs) by HTTP::Response::redirects at line 103, avg 9µs/call
sub previous { shift->_elem('_previous',@_); }
# spent 125µs making 41 calls to HTTP::Message::_elem, avg 3µs/call
64123556µs123431µs
# spent 1.09ms (663µs+431µs) within HTTP::Response::request which was called 123 times, avg 9µs/call: # 41 times (274µs+150µs) by LWP::Protocol::http::request at line 366 of LWP/Protocol/http.pm, avg 10µs/call # 41 times (191µs+144µs) by HTTP::Config::matching at line 174 of HTTP/Config.pm, avg 8µs/call # 41 times (198µs+137µs) by LWP::UserAgent::send_request at line 195 of LWP/UserAgent.pm, avg 8µs/call
sub request { shift->_elem('_request', @_); }
# spent 431µs making 123 calls to HTTP::Message::_elem, avg 4µs/call
65
66
67sub status_line
68{
69 my $self = shift;
70 my $code = $self->{'_rc'} || "000";
71 my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code";
72 return "$code $mess";
73}
74
75
76sub base
77{
78 my $self = shift;
79 my $base = $self->header('Content-Base') || # used to be HTTP/1.1
80 $self->header('Content-Location') || # HTTP/1.1
81 $self->header('Base'); # HTTP/1.0
82 if ($base && $base =~ /^$URI::scheme_re:/o) {
83 # already absolute
84 return $HTTP::URI_CLASS->new($base);
85 }
86
87 my $req = $self->request;
88 if ($req) {
89 # if $base is undef here, the return value is effectively
90 # just a copy of $self->request->uri.
91 return $HTTP::URI_CLASS->new_abs($base, $req->uri);
92 }
93
94 # can't find an absolute base
95 return undef;
96}
97
98
99
# spent 788µs (421+367) within HTTP::Response::redirects which was called 41 times, avg 19µs/call: # 41 times (421µs+367µs) by LWP::UserAgent::request at line 264 of LWP/UserAgent.pm, avg 19µs/call
sub redirects {
100205411µs my $self = shift;
101 my @r;
102 my $r = $self;
103 while (my $p = $r->previous) {
# spent 367µs making 41 calls to HTTP::Response::previous, avg 9µs/call
104 push(@r, $p);
105 $r = $p;
106 }
107 return @r unless wantarray;
108 return reverse @r;
109}
110
111
112sub filename
113{
114 my $self = shift;
115 my $file;
116
117 my $cd = $self->header('Content-Disposition');
118 if ($cd) {
119 require HTTP::Headers::Util;
120 if (my @cd = HTTP::Headers::Util::split_header_words($cd)) {
121 my ($disposition, undef, %cd_param) = @{$cd[-1]};
122 $file = $cd_param{filename};
123
124 # RFC 2047 encoded?
125 if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) {
126 my $charset = $1;
127 my $encoding = uc($2);
128 my $encfile = $3;
129
130 if ($encoding eq 'Q' || $encoding eq 'B') {
131 local($SIG{__DIE__});
132 eval {
133 if ($encoding eq 'Q') {
134 $encfile =~ s/_/ /g;
135 require MIME::QuotedPrint;
136 $encfile = MIME::QuotedPrint::decode($encfile);
137 }
138 else { # $encoding eq 'B'
139 require MIME::Base64;
140 $encfile = MIME::Base64::decode($encfile);
141 }
142
143 require Encode;
144 require encoding;
145 # This is ugly use of non-public API, but is there
146 # a better way to accomplish what we want (locally
147 # as-is usable filename string)?
148 my $locale_charset = encoding::_get_locale_encoding();
149 Encode::from_to($encfile, $charset, $locale_charset);
150 };
151
152 $file = $encfile unless $@;
153 }
154 }
155 }
156 }
157
158 my $uri;
159 unless (defined($file) && length($file)) {
160 if (my $cl = $self->header('Content-Location')) {
161 $uri = URI->new($cl);
162 }
163 elsif (my $request = $self->request) {
164 $uri = $request->uri;
165 }
166
167 if ($uri) {
168 $file = ($uri->path_segments)[-1];
169 }
170 }
171
172 if ($file) {
173 $file =~ s,.*[\\/],,; # basename
174 }
175
176 if ($file && !length($file)) {
177 $file = undef;
178 }
179
180 $file;
181}
182
183
184sub as_string
185{
186 require HTTP::Status;
187 my $self = shift;
188 my($eol) = @_;
189 $eol = "\n" unless defined $eol;
190
191 my $status_line = $self->status_line;
192 my $proto = $self->protocol;
193 $status_line = "$proto $status_line" if $proto;
194
195 return join($eol, $status_line, $self->SUPER::as_string(@_));
196}
197
198
199sub dump
200{
201 my $self = shift;
202
203 my $status_line = $self->status_line;
204 my $proto = $self->protocol;
205 $status_line = "$proto $status_line" if $proto;
206
207 return $self->SUPER::dump(
208 preheader => $status_line,
209 @_,
210 );
211}
212
213
214sub is_info { HTTP::Status::is_info (shift->{'_rc'}); }
21541235µs41160µs
# spent 431µs (271+160) within HTTP::Response::is_success which was called 41 times, avg 11µs/call: # 41 times (271µs+160µs) by SimpleDB::Client::handle_response at line 256 of SimpleDB/Client.pm, avg 11µs/call
sub is_success { HTTP::Status::is_success (shift->{'_rc'}); }
# spent 160µs making 41 calls to HTTP::Status::is_success, avg 4µs/call
216sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); }
217sub is_error { HTTP::Status::is_error (shift->{'_rc'}); }
218
219
220sub error_as_HTML
221{
222 require HTML::Entities;
223 my $self = shift;
224 my $title = 'An Error Occurred';
225 my $body = HTML::Entities::encode($self->status_line);
226 return <<EOM;
227<html>
228<head><title>$title</title></head>
229<body>
230<h1>$title</h1>
231<p>$body</p>
232</body>
233</html>
234EOM
235}
236
237
238sub current_age
239{
240 my $self = shift;
241 my $time = shift;
242
243 # Implementation of RFC 2616 section 13.2.3
244 # (age calculations)
245 my $response_time = $self->client_date;
246 my $date = $self->date;
247
248 my $age = 0;
249 if ($response_time && $date) {
250 $age = $response_time - $date; # apparent_age
251 $age = 0 if $age < 0;
252 }
253
254 my $age_v = $self->header('Age');
255 if ($age_v && $age_v > $age) {
256 $age = $age_v; # corrected_received_age
257 }
258
259 if ($response_time) {
260 my $request = $self->request;
261 if ($request) {
262 my $request_time = $request->date;
263 if ($request_time && $request_time < $response_time) {
264 # Add response_delay to age to get 'corrected_initial_age'
265 $age += $response_time - $request_time;
266 }
267 }
268 $age += ($time || time) - $response_time;
269 }
270 return $age;
271}
272
273
274sub freshness_lifetime
275{
276 my($self, %opt) = @_;
277
278 # First look for the Cache-Control: max-age=n header
279 for my $cc ($self->header('Cache-Control')) {
280 for my $cc_dir (split(/\s*,\s*/, $cc)) {
281 return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i;
282 }
283 }
284
285 # Next possibility is to look at the "Expires" header
286 my $date = $self->date || $self->client_date || $opt{time} || time;
287 if (my $expires = $self->expires) {
288 return $expires - $date;
289 }
290
291 # Must apply heuristic expiration
292 return undef if exists $opt{heuristic_expiry} && !$opt{heuristic_expiry};
293
294 # Default heuristic expiration parameters
295 $opt{h_min} ||= 60;
296 $opt{h_max} ||= 24 * 3600;
297 $opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616
298 $opt{h_default} ||= 3600;
299
300 # Should give a warning if more than 24 hours according to
301 # RFC 2616 section 13.2.4. Here we just make this the default
302 # maximum value.
303
304 if (my $last_modified = $self->last_modified) {
305 my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction};
306 return $opt{h_min} if $h_exp < $opt{h_min};
307 return $opt{h_max} if $h_exp > $opt{h_max};
308 return $h_exp;
309 }
310
311 # default when all else fails
312 return $opt{h_min} if $opt{h_min} > $opt{h_default};
313 return $opt{h_default};
314}
315
316
317sub is_fresh
318{
319 my($self, %opt) = @_;
320 $opt{time} ||= time;
321 my $f = $self->freshness_lifetime(%opt);
322 return undef unless defined($f);
323 return $f > $self->current_age($opt{time});
324}
325
326
327sub fresh_until
328{
329 my($self, %opt) = @_;
330 $opt{time} ||= time;
331 my $f = $self->freshness_lifetime(%opt);
332 return undef unless defined($f);
333 return $f - $self->current_age($opt{time}) + $opt{time};
334}
335
33615µs1;
337
338
339__END__
340
341=head1 NAME
342
343HTTP::Response - HTTP style response message
344
345=head1 SYNOPSIS
346
347Response objects are returned by the request() method of the C<LWP::UserAgent>:
348
349 # ...
350 $response = $ua->request($request)
351 if ($response->is_success) {
352 print $response->content;
353 }
354 else {
355 print STDERR $response->status_line, "\n";
356 }
357
358=head1 DESCRIPTION
359
360The C<HTTP::Response> class encapsulates HTTP style responses. A
361response consists of a response line, some headers, and a content
362body. Note that the LWP library uses HTTP style responses even for
363non-HTTP protocol schemes. Instances of this class are usually
364created and returned by the request() method of an C<LWP::UserAgent>
365object.
366
367C<HTTP::Response> is a subclass of C<HTTP::Message> and therefore
368inherits its methods. The following additional methods are available:
369
370=over 4
371
372=item $r = HTTP::Response->new( $code )
373
374=item $r = HTTP::Response->new( $code, $msg )
375
376=item $r = HTTP::Response->new( $code, $msg, $header )
377
378=item $r = HTTP::Response->new( $code, $msg, $header, $content )
379
380Constructs a new C<HTTP::Response> object describing a response with
381response code $code and optional message $msg. The optional $header
382argument should be a reference to an C<HTTP::Headers> object or a
383plain array reference of key/value pairs. The optional $content
384argument should be a string of bytes. The meaning these arguments are
385described below.
386
387=item $r = HTTP::Response->parse( $str )
388
389This constructs a new response object by parsing the given string.
390
391=item $r->code
392
393=item $r->code( $code )
394
395This is used to get/set the code attribute. The code is a 3 digit
396number that encode the overall outcome of a HTTP response. The
397C<HTTP::Status> module provide constants that provide mnemonic names
398for the code attribute.
399
400=item $r->message
401
402=item $r->message( $message )
403
404This is used to get/set the message attribute. The message is a short
405human readable single line string that explains the response code.
406
407=item $r->header( $field )
408
409=item $r->header( $field => $value )
410
411This is used to get/set header values and it is inherited from
412C<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> for
413details and other similar methods that can be used to access the
414headers.
415
416=item $r->content
417
418=item $r->content( $bytes )
419
420This is used to get/set the raw content and it is inherited from the
421C<HTTP::Message> base class. See L<HTTP::Message> for details and
422other methods that can be used to access the content.
423
424=item $r->decoded_content( %options )
425
426This will return the content after any C<Content-Encoding> and
427charsets have been decoded. See L<HTTP::Message> for details.
428
429=item $r->request
430
431=item $r->request( $request )
432
433This is used to get/set the request attribute. The request attribute
434is a reference to the the request that caused this response. It does
435not have to be the same request passed to the $ua->request() method,
436because there might have been redirects and authorization retries in
437between.
438
439=item $r->previous
440
441=item $r->previous( $response )
442
443This is used to get/set the previous attribute. The previous
444attribute is used to link together chains of responses. You get
445chains of responses if the first response is redirect or unauthorized.
446The value is C<undef> if this is the first response in a chain.
447
448Note that the method $r->redirects is provided as a more convenient
449way to access the response chain.
450
451=item $r->status_line
452
453Returns the string "E<lt>code> E<lt>message>". If the message attribute
454is not set then the official name of E<lt>code> (see L<HTTP::Status>)
455is substituted.
456
457=item $r->base
458
459Returns the base URI for this response. The return value will be a
460reference to a URI object.
461
462The base URI is obtained from one the following sources (in priority
463order):
464
465=over 4
466
467=item 1.
468
469Embedded in the document content, for instance <BASE HREF="...">
470in HTML documents.
471
472=item 2.
473
474A "Content-Base:" or a "Content-Location:" header in the response.
475
476For backwards compatibility with older HTTP implementations we will
477also look for the "Base:" header.
478
479=item 3.
480
481The URI used to request this response. This might not be the original
482URI that was passed to $ua->request() method, because we might have
483received some redirect responses first.
484
485=back
486
487If none of these sources provide an absolute URI, undef is returned.
488
489When the LWP protocol modules produce the HTTP::Response object, then
490any base URI embedded in the document (step 1) will already have
491initialized the "Content-Base:" header. This means that this method
492only performs the last 2 steps (the content is not always available
493either).
494
495=item $r->filename
496
497Returns a filename for this response. Note that doing sanity checks
498on the returned filename (eg. removing characters that cannot be used
499on the target filesystem where the filename would be used, and
500laundering it for security purposes) are the caller's responsibility;
501the only related thing done by this method is that it makes a simple
502attempt to return a plain filename with no preceding path segments.
503
504The filename is obtained from one the following sources (in priority
505order):
506
507=over 4
508
509=item 1.
510
511A "Content-Disposition:" header in the response. Proper decoding of
512RFC 2047 encoded filenames requires the C<MIME::QuotedPrint> (for "Q"
513encoding), C<MIME::Base64> (for "B" encoding), and C<Encode> modules.
514
515=item 2.
516
517A "Content-Location:" header in the response.
518
519=item 3.
520
521The URI used to request this response. This might not be the original
522URI that was passed to $ua->request() method, because we might have
523received some redirect responses first.
524
525=back
526
527If a filename cannot be derived from any of these sources, undef is
528returned.
529
530=item $r->as_string
531
532=item $r->as_string( $eol )
533
534Returns a textual representation of the response.
535
536=item $r->is_info
537
538=item $r->is_success
539
540=item $r->is_redirect
541
542=item $r->is_error
543
544These methods indicate if the response was informational, successful, a
545redirection, or an error. See L<HTTP::Status> for the meaning of these.
546
547=item $r->error_as_HTML
548
549Returns a string containing a complete HTML document indicating what
550error occurred. This method should only be called when $r->is_error
551is TRUE.
552
553=item $r->redirects
554
555Returns the list of redirect responses that lead up to this response
556by following the $r->previous chain. The list order is oldest first.
557
558In scalar context return the number of redirect responses leading up
559to this one.
560
561=item $r->current_age
562
563Calculates the "current age" of the response as specified by RFC 2616
564section 13.2.3. The age of a response is the time since it was sent
565by the origin server. The returned value is a number representing the
566age in seconds.
567
568=item $r->freshness_lifetime( %opt )
569
570Calculates the "freshness lifetime" of the response as specified by
571RFC 2616 section 13.2.4. The "freshness lifetime" is the length of
572time between the generation of a response and its expiration time.
573The returned value is the number of seconds until expiry.
574
575If the response does not contain an "Expires" or a "Cache-Control"
576header, then this function will apply some simple heuristic based on
577the "Last-Modified" header to determine a suitable lifetime. The
578following options might be passed to control the heuristics:
579
580=over
581
582=item heuristic_expiry => $bool
583
584If passed as a FALSE value, don't apply heuristics and just return
585C<undef> when "Expires" or "Cache-Control" is lacking.
586
587=item h_lastmod_fraction => $num
588
589This number represent the fraction of the difference since the
590"Last-Modified" timestamp to make the expiry time. The default is
591C<0.10>, the suggested typical setting of 10% in RFC 2616.
592
593=item h_min => $sec
594
595This is the lower limit of the heuristic expiry age to use. The
596default is C<60> (1 minute).
597
598=item h_max => $sec
599
600This is the upper limit of the heuristic expiry age to use. The
601default is C<86400> (24 hours).
602
603=item h_default => $sec
604
605This is the expiry age to use when nothing else applies. The default
606is C<3600> (1 hour) or "h_min" if greater.
607
608=back
609
610=item $r->is_fresh( %opt )
611
612Returns TRUE if the response is fresh, based on the values of
613freshness_lifetime() and current_age(). If the response is no longer
614fresh, then it has to be re-fetched or re-validated by the origin
615server.
616
617Options might be passed to control expiry heuristics, see the
618description of freshness_lifetime().
619
620=item $r->fresh_until( %opt )
621
622Returns the time (seconds since epoch) when this entity is no longer fresh.
623
624Options might be passed to control expiry heuristics, see the
625description of freshness_lifetime().
626
627=back
628
629=head1 SEE ALSO
630
631L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Status>, L<HTTP::Request>
632
633=head1 COPYRIGHT
634
635Copyright 1995-2004 Gisle Aas.
636
637This library is free software; you can redistribute it and/or
638modify it under the same terms as Perl itself.
639