← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:51 2015

Filename/usr/share/perl5/HTTP/Response.pm
StatementsExecuted 8 statements in 1.87ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1112.67ms2.79msHTTP::Response::::BEGIN@8HTTP::Response::BEGIN@8
11111µs23µ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::::codeHTTP::Response::code
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::::is_successHTTP::Response::is_success
0000s0sHTTP::Response::::messageHTTP::Response::message
0000s0sHTTP::Response::::newHTTP::Response::new
0000s0sHTTP::Response::::parseHTTP::Response::parse
0000s0sHTTP::Response::::previousHTTP::Response::previous
0000s0sHTTP::Response::::redirectsHTTP::Response::redirects
0000s0sHTTP::Response::::requestHTTP::Response::request
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
31700nsrequire HTTP::Message;
416µs@ISA = qw(HTTP::Message);
51200ns$VERSION = "6.04";
6
7223µs235µs
# spent 23µs (11+12) within HTTP::Response::BEGIN@7 which was called: # once (11µs+12µs) by LWP::UserAgent::BEGIN@11 at line 7
use strict;
# spent 23µs making 1 call to HTTP::Response::BEGIN@7 # spent 12µs making 1 call to strict::import
821.83ms12.79ms
# spent 2.79ms (2.67+120µs) within HTTP::Response::BEGIN@8 which was called: # once (2.67ms+120µs) by LWP::UserAgent::BEGIN@11 at line 8
use HTTP::Status ();
# spent 2.79ms making 1 call to HTTP::Response::BEGIN@8
9
- -
12sub new
13{
14 my($class, $rc, $msg, $header, $content) = @_;
15 my $self = $class->SUPER::new($header, $content);
16 $self->code($rc);
17 $self->message($msg);
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
61sub code { shift->_elem('_rc', @_); }
62sub message { shift->_elem('_msg', @_); }
63sub previous { shift->_elem('_previous',@_); }
64sub request { shift->_elem('_request', @_); }
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 = (
80 $self->header('Content-Base'), # used to be HTTP/1.1
81 $self->header('Content-Location'), # HTTP/1.1
82 $self->header('Base'), # HTTP/1.0
83 )[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 redirects {
102 my $self = shift;
103 my @r;
104 my $r = $self;
105 while (my $p = $r->previous) {
106 push(@r, $p);
107 $r = $p;
108 }
109 return @r unless wantarray;
110 return reverse @r;
111}
112
113
114sub filename
115{
116 my $self = shift;
117 my $file;
118
119 my $cd = $self->header('Content-Disposition');
120 if ($cd) {
121 require HTTP::Headers::Util;
122 if (my @cd = HTTP::Headers::Util::split_header_words($cd)) {
123 my ($disposition, undef, %cd_param) = @{$cd[-1]};
124 $file = $cd_param{filename};
125
126 # RFC 2047 encoded?
127 if ($file && $file =~ /^=\?(.+?)\?(.+?)\?(.+)\?=$/) {
128 my $charset = $1;
129 my $encoding = uc($2);
130 my $encfile = $3;
131
132 if ($encoding eq 'Q' || $encoding eq 'B') {
133 local($SIG{__DIE__});
134 eval {
135 if ($encoding eq 'Q') {
136 $encfile =~ s/_/ /g;
137 require MIME::QuotedPrint;
138 $encfile = MIME::QuotedPrint::decode($encfile);
139 }
140 else { # $encoding eq 'B'
141 require MIME::Base64;
142 $encfile = MIME::Base64::decode($encfile);
143 }
144
145 require Encode;
146 require Encode::Locale;
147 Encode::from_to($encfile, $charset, "locale_fs");
148 };
149
150 $file = $encfile unless $@;
151 }
152 }
153 }
154 }
155
156 unless (defined($file) && length($file)) {
157 my $uri;
158 if (my $cl = $self->header('Content-Location')) {
159 $uri = URI->new($cl);
160 }
161 elsif (my $request = $self->request) {
162 $uri = $request->uri;
163 }
164
165 if ($uri) {
166 $file = ($uri->path_segments)[-1];
167 }
168 }
169
170 if ($file) {
171 $file =~ s,.*[\\/],,; # basename
172 }
173
174 if ($file && !length($file)) {
175 $file = undef;
176 }
177
178 $file;
179}
180
181
182sub as_string
183{
184 my $self = shift;
185 my($eol) = @_;
186 $eol = "\n" unless defined $eol;
187
188 my $status_line = $self->status_line;
189 my $proto = $self->protocol;
190 $status_line = "$proto $status_line" if $proto;
191
192 return join($eol, $status_line, $self->SUPER::as_string(@_));
193}
194
195
196sub dump
197{
198 my $self = shift;
199
200 my $status_line = $self->status_line;
201 my $proto = $self->protocol;
202 $status_line = "$proto $status_line" if $proto;
203
204 return $self->SUPER::dump(
205 preheader => $status_line,
206 @_,
207 );
208}
209
210
211sub is_info { HTTP::Status::is_info (shift->{'_rc'}); }
212sub is_success { HTTP::Status::is_success (shift->{'_rc'}); }
213sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); }
214sub is_error { HTTP::Status::is_error (shift->{'_rc'}); }
215
216
217sub error_as_HTML
218{
219 my $self = shift;
220 my $title = 'An Error Occurred';
221 my $body = $self->status_line;
222 $body =~ s/&/&/g;
223 $body =~ s/</&lt;/g;
224 return <<EOM;
225<html>
226<head><title>$title</title></head>
227<body>
228<h1>$title</h1>
229<p>$body</p>
230</body>
231</html>
232EOM
233}
234
235
236sub current_age
237{
238 my $self = shift;
239 my $time = shift;
240
241 # Implementation of RFC 2616 section 13.2.3
242 # (age calculations)
243 my $response_time = $self->client_date;
244 my $date = $self->date;
245
246 my $age = 0;
247 if ($response_time && $date) {
248 $age = $response_time - $date; # apparent_age
249 $age = 0 if $age < 0;
250 }
251
252 my $age_v = $self->header('Age');
253 if ($age_v && $age_v > $age) {
254 $age = $age_v; # corrected_received_age
255 }
256
257 if ($response_time) {
258 my $request = $self->request;
259 if ($request) {
260 my $request_time = $request->date;
261 if ($request_time && $request_time < $response_time) {
262 # Add response_delay to age to get 'corrected_initial_age'
263 $age += $response_time - $request_time;
264 }
265 }
266 $age += ($time || time) - $response_time;
267 }
268 return $age;
269}
270
271
272sub freshness_lifetime
273{
274 my($self, %opt) = @_;
275
276 # First look for the Cache-Control: max-age=n header
277 for my $cc ($self->header('Cache-Control')) {
278 for my $cc_dir (split(/\s*,\s*/, $cc)) {
279 return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i;
280 }
281 }
282
283 # Next possibility is to look at the "Expires" header
284 my $date = $self->date || $self->client_date || $opt{time} || time;
285 if (my $expires = $self->expires) {
286 return $expires - $date;
287 }
288
289 # Must apply heuristic expiration
290 return undef if exists $opt{heuristic_expiry} && !$opt{heuristic_expiry};
291
292 # Default heuristic expiration parameters
293 $opt{h_min} ||= 60;
294 $opt{h_max} ||= 24 * 3600;
295 $opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616
296 $opt{h_default} ||= 3600;
297
298 # Should give a warning if more than 24 hours according to
299 # RFC 2616 section 13.2.4. Here we just make this the default
300 # maximum value.
301
302 if (my $last_modified = $self->last_modified) {
303 my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction};
304 return $opt{h_min} if $h_exp < $opt{h_min};
305 return $opt{h_max} if $h_exp > $opt{h_max};
306 return $h_exp;
307 }
308
309 # default when all else fails
310 return $opt{h_min} if $opt{h_min} > $opt{h_default};
311 return $opt{h_default};
312}
313
314
315sub is_fresh
316{
317 my($self, %opt) = @_;
318 $opt{time} ||= time;
319 my $f = $self->freshness_lifetime(%opt);
320 return undef unless defined($f);
321 return $f > $self->current_age($opt{time});
322}
323
324
325sub fresh_until
326{
327 my($self, %opt) = @_;
328 $opt{time} ||= time;
329 my $f = $self->freshness_lifetime(%opt);
330 return undef unless defined($f);
331 return $f - $self->current_age($opt{time}) + $opt{time};
332}
333
33413µs1;
335
336
337__END__
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.