← 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:23 2010

File /usr/local/lib/perl5/site_perl/5.10.1/HTTP/Response.pm
Statements Executed 67
Statement Execution Time 1.53ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1112.39ms2.52msHTTP::Response::::BEGIN@8HTTP::Response::BEGIN@8
311126µs314µsHTTP::Response::::newHTTP::Response::new
93368µs105µsHTTP::Response::::codeHTTP::Response::code
93363µs100µsHTTP::Response::::requestHTTP::Response::request
31133µs60µsHTTP::Response::::redirectsHTTP::Response::redirects
31121µs33µsHTTP::Response::::messageHTTP::Response::message
31121µs35µsHTTP::Response::::is_successHTTP::Response::is_success
31118µs27µsHTTP::Response::::previousHTTP::Response::previous
11117µs22µ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
31500nsrequire HTTP::Message;
417µs@ISA = qw(HTTP::Message);
51400ns$VERSION = "5.824";
6
7323µs228µs
# spent 22µs (17+5) within HTTP::Response::BEGIN@7 which was called # once (17µs+5µs) by LWP::UserAgent::BEGIN@11 at line 7
use strict;
# spent 22µs making 1 call to HTTP::Response::BEGIN@7 # spent 5µs making 1 call to strict::import
831.20ms12.52ms
# spent 2.52ms (2.39+127µs) within HTTP::Response::BEGIN@8 which was called # once (2.39ms+127µs) by LWP::UserAgent::BEGIN@11 at line 8
use HTTP::Status ();
# spent 2.52ms making 1 call to HTTP::Response::BEGIN@8
9
10
11
12sub new
13
# spent 314µs (126+189) within HTTP::Response::new which was called 3 times, avg 105µs/call: # 3 times (126µs+189µs) by LWP::Protocol::http::request at line 357 of LWP/Protocol/http.pm, avg 105µs/call
{
14311µs my($class, $rc, $msg, $header, $content) = @_;
15362µs393µs my $self = $class->SUPER::new($header, $content);
# spent 93µs making 3 calls to HTTP::Message::new, avg 31µs/call
16312µs363µs $self->code($rc);
# spent 63µs making 3 calls to HTTP::Response::code, avg 21µs/call
17311µs333µs $self->message($msg);
# spent 33µs making 3 calls to HTTP::Response::message, avg 11µs/call
18320µs $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
61950µs936µs
# spent 105µs (68+36) within HTTP::Response::code which was called 9 times, avg 12µs/call: # 3 times (44µs+19µs) by HTTP::Response::new at line 16, avg 21µs/call # 3 times (12µs+9µs) by LWP::UserAgent::request at line 274 of LWP/UserAgent.pm, avg 7µs/call # 3 times (12µs+8µs) by SimpleDB::Client::send_request at line 212 of ../lib/SimpleDB/Client.pm, avg 7µs/call
sub code { shift->_elem('_rc', @_); }
# spent 36µs making 9 calls to HTTP::Message::_elem, avg 4µs/call
62318µs312µs
# spent 33µs (21+12) within HTTP::Response::message which was called 3 times, avg 11µs/call: # 3 times (21µs+12µs) by HTTP::Response::new at line 17, avg 11µs/call
sub message { shift->_elem('_msg', @_); }
# spent 12µs making 3 calls to HTTP::Message::_elem, avg 4µs/call
63316µs39µs
# spent 27µs (18+9) within HTTP::Response::previous which was called 3 times, avg 9µs/call: # 3 times (18µs+9µs) by HTTP::Response::redirects at line 103, avg 9µs/call
sub previous { shift->_elem('_previous',@_); }
# spent 9µs making 3 calls to HTTP::Message::_elem, avg 3µs/call
64954µs937µs
# spent 100µs (63+37) within HTTP::Response::request which was called 9 times, avg 11µs/call: # 3 times (25µs+14µs) by LWP::UserAgent::send_request at line 195 of LWP/UserAgent.pm, avg 13µs/call # 3 times (24µs+12µs) by LWP::Protocol::http::request at line 366 of LWP/Protocol/http.pm, avg 12µs/call # 3 times (15µs+11µs) by HTTP::Config::matching at line 174 of HTTP/Config.pm, avg 9µs/call
sub request { shift->_elem('_request', @_); }
# spent 37µs making 9 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 60µs (33+27) within HTTP::Response::redirects which was called 3 times, avg 20µs/call: # 3 times (33µs+27µs) by LWP::UserAgent::request at line 264 of LWP/UserAgent.pm, avg 20µs/call
sub redirects {
10032µs my $self = shift;
1013900ns my @r;
10232µs my $r = $self;
103311µs327µs while (my $p = $r->previous) {
# spent 27µs making 3 calls to HTTP::Response::previous, avg 9µs/call
104 push(@r, $p);
105 $r = $p;
106 }
107313µs 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'}); }
215319µs314µs
# spent 35µs (21+14) within HTTP::Response::is_success which was called 3 times, avg 12µs/call: # 3 times (21µs+14µs) by SimpleDB::Client::handle_response at line 248 of ../lib/SimpleDB/Client.pm, avg 12µs/call
sub is_success { HTTP::Status::is_success (shift->{'_rc'}); }
# spent 14µs making 3 calls to HTTP::Status::is_success, avg 5µ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
33614µ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