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

File /project/perl/lib/HTTP/Response.pm
Statements Executed 5081
Statement Execution Time 115ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
4611141.5ms140msHTTP::Response::::newHTTP::Response::new
9222229.9ms63.0msHTTP::Response::::requestHTTP::Response::request
9222227.9ms58.0msHTTP::Response::::codeHTTP::Response::code
4611113.1ms20.3msHTTP::Response::::is_successHTTP::Response::is_success
4611111.6ms25.6msHTTP::Response::::messageHTTP::Response::message
11220µs20µsHTTP::Response::::CORE:matchHTTP::Response::CORE:match (opcode)
0000s0sHTTP::Response::::BEGINHTTP::Response::BEGIN
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::::error_as_HTMLHTTP::Response::error_as_HTML
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::::previousHTTP::Response::previous
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
3# $Id: Response.pm,v 1.53 2005/12/06 13:19:09 gisle Exp $
4
516µsrequire HTTP::Message;
6111µs@ISA = qw(HTTP::Message);
7174µs120µs$VERSION = sprintf("%d.%02d", q$Revision: 1.53 $ =~ /(\d+)\.(\d+)/);
# spent 20µs making 1 call to HTTP::Response::CORE:match
8
9395µs125µsuse strict;
# spent 25µs making 1 call to strict::import
1032.51msuse HTTP::Status ();
11
12
13
14sub new
15
# spent 140ms (41.5+98.5) within HTTP::Response::new which was called 461 times, avg 304µs/call: # 461 times (41.5ms+98.5ms) by LWP::Protocol::http::request at line 318 of LWP/Protocol/http.pm, avg 304µs/call
{
16230539.9ms my($class, $rc, $msg, $header, $content) = @_;
17 my $self = $class->SUPER::new($header, $content);
# spent 43.9ms making 461 calls to HTTP::Message::new, avg 95µs/call
18 $self->code($rc);
# spent 29.0ms making 461 calls to HTTP::Response::code, avg 63µs/call
19 $self->message($msg);
# spent 25.6ms making 461 calls to HTTP::Response::message, avg 56µs/call
20 $self;
21}
22
23
24sub parse
25{
26 my($class, $str) = @_;
27 my $status_line;
28 if ($str =~ s/^(.*)\n//) {
29 $status_line = $1;
30 }
31 else {
32 $status_line = $str;
33 $str = "";
34 }
35
36 my $self = $class->SUPER::parse($str);
37 my($protocol, $code, $message);
38 if ($status_line =~ /^\d{3} /) {
39 # Looks like a response created by HTTP::Response->new
40 ($code, $message) = split(' ', $status_line, 2);
41 } else {
42 ($protocol, $code, $message) = split(' ', $status_line, 3);
43 }
44 $self->protocol($protocol) if $protocol;
45 $self->code($code) if defined($code);
46 $self->message($message) if defined($message);
47 $self;
48}
49
50
51sub clone
52{
53 my $self = shift;
54 my $clone = bless $self->SUPER::clone, ref($self);
55 $clone->code($self->code);
56 $clone->message($self->message);
57 $clone->request($self->request->clone) if $self->request;
58 # we don't clone previous
59 $clone;
60}
61
62
6392224.1ms92230.1ms
# spent 58.0ms (27.9+30.1) within HTTP::Response::code which was called 922 times, avg 63µs/call: # 461 times (14.6ms+14.5ms) by LWP::UserAgent::request at line 284 of LWP/UserAgent.pm, avg 63µs/call # 461 times (13.3ms+15.7ms) by HTTP::Response::new at line 18, avg 63µs/call
sub code { shift->_elem('_rc', @_); }
# spent 30.1ms making 922 calls to HTTP::Message::_elem, avg 33µs/call
6446110.5ms46114.0ms
# spent 25.6ms (11.6+14.0) within HTTP::Response::message which was called 461 times, avg 56µs/call: # 461 times (11.6ms+14.0ms) by HTTP::Response::new at line 19, avg 56µs/call
sub message { shift->_elem('_msg', @_); }
# spent 14.0ms making 461 calls to HTTP::Message::_elem, avg 30µs/call
65sub previous { shift->_elem('_previous',@_); }
6692225.7ms92233.1ms
# spent 63.0ms (29.9+33.1) within HTTP::Response::request which was called 922 times, avg 68µs/call: # 461 times (16.6ms+18.4ms) by LWP::UserAgent::send_request at line 231 of LWP/UserAgent.pm, avg 76µs/call # 461 times (13.3ms+14.7ms) by LWP::Protocol::http::request at line 327 of LWP/Protocol/http.pm, avg 61µs/call
sub request { shift->_elem('_request', @_); }
# spent 33.1ms making 922 calls to HTTP::Message::_elem, avg 36µs/call
67
68
69sub status_line
70{
71 my $self = shift;
72 my $code = $self->{'_rc'} || "000";
73 my $mess = $self->{'_msg'} || HTTP::Status::status_message($code) || "Unknown code";
74 return "$code $mess";
75}
76
77
78sub base
79{
80 my $self = shift;
81 my $base = $self->header('Content-Base') || # used to be HTTP/1.1
82 $self->header('Content-Location') || # HTTP/1.1
83 $self->header('Base'); # HTTP/1.0
84 if ($base && $base =~ /^$URI::scheme_re:/o) {
85 # already absolute
86 return $HTTP::URI_CLASS->new($base);
87 }
88
89 my $req = $self->request;
90 if ($req) {
91 # if $base is undef here, the return value is effectively
92 # just a copy of $self->request->uri.
93 return $HTTP::URI_CLASS->new_abs($base, $req->uri);
94 }
95
96 # can't find an absolute base
97 return undef;
98}
99
100
101sub as_string
102{
103 require HTTP::Status;
104 my $self = shift;
105 my($eol) = @_;
106 $eol = "\n" unless defined $eol;
107
108 my $status_line = $self->status_line;
109 my $proto = $self->protocol;
110 $status_line = "$proto $status_line" if $proto;
111
112 return join($eol, $status_line, $self->SUPER::as_string(@_));
113}
114
115
116sub is_info { HTTP::Status::is_info (shift->{'_rc'}); }
11746111.9ms4617.27ms
# spent 20.3ms (13.1+7.26) within HTTP::Response::is_success which was called 461 times, avg 44µs/call: # 461 times (13.1ms+7.26ms) by WWW::Google::PageRank::get at line 37 of WWW/Google/PageRank.pm, avg 44µs/call
sub is_success { HTTP::Status::is_success (shift->{'_rc'}); }
# spent 7.27ms making 461 calls to HTTP::Status::is_success, avg 16µs/call
118sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); }
119sub is_error { HTTP::Status::is_error (shift->{'_rc'}); }
120
121
122sub error_as_HTML
123{
124 my $self = shift;
125 my $title = 'An Error Occurred';
126 my $body = $self->status_line;
127 return <<EOM;
128<HTML>
129<HEAD><TITLE>$title</TITLE></HEAD>
130<BODY>
131<H1>$title</H1>
132$body
133</BODY>
134</HTML>
135EOM
136}
137
138
139sub current_age
140{
141 my $self = shift;
142 # Implementation of RFC 2616 section 13.2.3
143 # (age calculations)
144 my $response_time = $self->client_date;
145 my $date = $self->date;
146
147 my $age = 0;
148 if ($response_time && $date) {
149 $age = $response_time - $date; # apparent_age
150 $age = 0 if $age < 0;
151 }
152
153 my $age_v = $self->header('Age');
154 if ($age_v && $age_v > $age) {
155 $age = $age_v; # corrected_received_age
156 }
157
158 my $request = $self->request;
159 if ($request) {
160 my $request_time = $request->date;
161 if ($request_time) {
162 # Add response_delay to age to get 'corrected_initial_age'
163 $age += $response_time - $request_time;
164 }
165 }
166 if ($response_time) {
167 $age += time - $response_time;
168 }
169 return $age;
170}
171
172
173sub freshness_lifetime
174{
175 my $self = shift;
176
177 # First look for the Cache-Control: max-age=n header
178 my @cc = $self->header('Cache-Control');
179 if (@cc) {
180 my $cc;
181 for $cc (@cc) {
182 my $cc_dir;
183 for $cc_dir (split(/\s*,\s*/, $cc)) {
184 if ($cc_dir =~ /max-age\s*=\s*(\d+)/i) {
185 return $1;
186 }
187 }
188 }
189 }
190
191 # Next possibility is to look at the "Expires" header
192 my $date = $self->date || $self->client_date || time;
193 my $expires = $self->expires;
194 unless ($expires) {
195 # Must apply heuristic expiration
196 my $last_modified = $self->last_modified;
197 if ($last_modified) {
198 my $h_exp = ($date - $last_modified) * 0.10; # 10% since last-mod
199 if ($h_exp < 60) {
200 return 60; # minimum
201 }
202 elsif ($h_exp > 24 * 3600) {
203 # Should give a warning if more than 24 hours according to
204 # RFC 2616 section 13.2.4, but I don't know how to do it
205 # from this function interface, so I just make this the
206 # maximum value.
207 return 24 * 3600;
208 }
209 return $h_exp;
210 }
211 else {
212 return 3600; # 1 hour is fallback when all else fails
213 }
214 }
215 return $expires - $date;
216}
217
218
219sub is_fresh
220{
221 my $self = shift;
222 $self->freshness_lifetime > $self->current_age;
223}
224
225
226sub fresh_until
227{
228 my $self = shift;
229 return $self->freshness_lifetime - $self->current_age + time;
230}
231
232122µs1;
233
234
235__END__
236
237=head1 NAME
238
239HTTP::Response - HTTP style response message
240
241=head1 SYNOPSIS
242
243Response objects are returned by the request() method of the C<LWP::UserAgent>:
244
245 # ...
246 $response = $ua->request($request)
247 if ($response->is_success) {
248 print $response->content;
249 }
250 else {
251 print STDERR $response->status_line, "\n";
252 }
253
254=head1 DESCRIPTION
255
256The C<HTTP::Response> class encapsulates HTTP style responses. A
257response consists of a response line, some headers, and a content
258body. Note that the LWP library uses HTTP style responses even for
259non-HTTP protocol schemes. Instances of this class are usually
260created and returned by the request() method of an C<LWP::UserAgent>
261object.
262
263C<HTTP::Response> is a subclass of C<HTTP::Message> and therefore
264inherits its methods. The following additional methods are available:
265
266=over 4
267
268=item $r = HTTP::Response->new( $code )
269
270=item $r = HTTP::Response->new( $code, $msg )
271
272=item $r = HTTP::Response->new( $code, $msg, $header )
273
274=item $r = HTTP::Response->new( $code, $msg, $header, $content )
275
276Constructs a new C<HTTP::Response> object describing a response with
277response code $code and optional message $msg. The optional $header
278argument should be a reference to an C<HTTP::Headers> object or a
279plain array reference of key/value pairs. The optional $content
280argument should be a string of bytes. The meaning these arguments are
281described below.
282
283=item $r = HTTP::Response->parse( $str )
284
285This constructs a new response object by parsing the given string.
286
287=item $r->code
288
289=item $r->code( $code )
290
291This is used to get/set the code attribute. The code is a 3 digit
292number that encode the overall outcome of a HTTP response. The
293C<HTTP::Status> module provide constants that provide mnemonic names
294for the code attribute.
295
296=item $r->message
297
298=item $r->message( $message )
299
300This is used to get/set the message attribute. The message is a short
301human readable single line string that explains the response code.
302
303=item $r->header( $field )
304
305=item $r->header( $field => $value )
306
307This is used to get/set header values and it is inherited from
308C<HTTP::Headers> via C<HTTP::Message>. See L<HTTP::Headers> for
309details and other similar methods that can be used to access the
310headers.
311
312=item $r->content
313
314=item $r->content( $content )
315
316This is used to get/set the raw content and it is inherited from the
317C<HTTP::Message> base class. See L<HTTP::Message> for details and
318other methods that can be used to access the content.
319
320=item $r->decoded_content( %options )
321
322This will return the content after any C<Content-Encoding> and
323charsets has been decoded. See L<HTTP::Message> for details.
324
325=item $r->request
326
327=item $r->request( $request )
328
329This is used to get/set the request attribute. The request attribute
330is a reference to the the request that caused this response. It does
331not have to be the same request passed to the $ua->request() method,
332because there might have been redirects and authorization retries in
333between.
334
335=item $r->previous
336
337=item $r->previous( $response )
338
339This is used to get/set the previous attribute. The previous
340attribute is used to link together chains of responses. You get
341chains of responses if the first response is redirect or unauthorized.
342The value is C<undef> if this is the first response in a chain.
343
344=item $r->status_line
345
346Returns the string "E<lt>code> E<lt>message>". If the message attribute
347is not set then the official name of E<lt>code> (see L<HTTP::Status>)
348is substituted.
349
350=item $r->base
351
352Returns the base URI for this response. The return value will be a
353reference to a URI object.
354
355The base URI is obtained from one the following sources (in priority
356order):
357
358=over 4
359
360=item 1.
361
362Embedded in the document content, for instance <BASE HREF="...">
363in HTML documents.
364
365=item 2.
366
367A "Content-Base:" or a "Content-Location:" header in the response.
368
369For backwards compatibility with older HTTP implementations we will
370also look for the "Base:" header.
371
372=item 3.
373
374The URI used to request this response. This might not be the original
375URI that was passed to $ua->request() method, because we might have
376received some redirect responses first.
377
378=back
379
380If neither of these sources provide an absolute URI, undef is
381returned.
382
383When the LWP protocol modules produce the HTTP::Response object, then
384any base URI embedded in the document (step 1) will already have
385initialized the "Content-Base:" header. This means that this method
386only performs the last 2 steps (the content is not always available
387either).
388
389=item $r->as_string
390
391=item $r->as_string( $eol )
392
393Returns a textual representation of the response.
394
395=item $r->is_info
396
397=item $r->is_success
398
399=item $r->is_redirect
400
401=item $r->is_error
402
403These methods indicate if the response was informational, successful, a
404redirection, or an error. See L<HTTP::Status> for the meaning of these.
405
406=item $r->error_as_HTML
407
408Returns a string containing a complete HTML document indicating what
409error occurred. This method should only be called when $r->is_error
410is TRUE.
411
412=item $r->current_age
413
414Calculates the "current age" of the response as specified by RFC 2616
415section 13.2.3. The age of a response is the time since it was sent
416by the origin server. The returned value is a number representing the
417age in seconds.
418
419=item $r->freshness_lifetime
420
421Calculates the "freshness lifetime" of the response as specified by
422RFC 2616 section 13.2.4. The "freshness lifetime" is the length of
423time between the generation of a response and its expiration time.
424The returned value is a number representing the freshness lifetime in
425seconds.
426
427If the response does not contain an "Expires" or a "Cache-Control"
428header, then this function will apply some simple heuristic based on
429'Last-Modified' to determine a suitable lifetime.
430
431=item $r->is_fresh
432
433Returns TRUE if the response is fresh, based on the values of
434freshness_lifetime() and current_age(). If the response is no longer
435fresh, then it has to be refetched or revalidated by the origin
436server.
437
438=item $r->fresh_until
439
440Returns the time when this entity is no longer fresh.
441
442=back
443
444=head1 SEE ALSO
445
446L<HTTP::Headers>, L<HTTP::Message>, L<HTTP::Status>, L<HTTP::Request>
447
448=head1 COPYRIGHT
449
450Copyright 1995-2004 Gisle Aas.
451
452This library is free software; you can redistribute it and/or
453modify it under the same terms as Perl itself.
454
# spent 20µs within HTTP::Response::CORE:match which was called # once (20µs+0s) by LWP::UserAgent::BEGIN at line 7 of HTTP/Response.pm
sub HTTP::Response::CORE:match; # xsub
Report produced by the NYTProf 3.11 Perl profiler, developed by Tim Bunce and Adam Kaplan.