← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 17:10:45 2013
Reported on Tue Oct 15 17:11:44 2013

Filename/usr/share/perl5/HTTP/Response.pm
StatementsExecuted 10 statements in 1.83ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11124µs30µsHTTP::Response::::BEGIN@7HTTP::Response::BEGIN@7
1117µs7µsHTTP::Response::::BEGIN@8HTTP::Response::BEGIN@8
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
311µsrequire HTTP::Message;
4110µs@ISA = qw(HTTP::Message);
51600ns$VERSION = "5.836";
6
7335µs236µs
# spent 30µs (24+6) within HTTP::Response::BEGIN@7 which was called: # once (24µs+6µs) by LWP::UserAgent::BEGIN@11 at line 7
use strict;
# spent 30µs making 1 call to HTTP::Response::BEGIN@7 # spent 6µs making 1 call to strict::import
831.78ms17µs
# spent 7µs within HTTP::Response::BEGIN@8 which was called: # once (7µs+0s) by LWP::UserAgent::BEGIN@11 at line 8
use HTTP::Status ();
# spent 7µs 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 encoding;
147 # This is ugly use of non-public API, but is there
148 # a better way to accomplish what we want (locally
149 # as-is usable filename string)?
150 my $locale_charset = encoding::_get_locale_encoding();
151 Encode::from_to($encfile, $charset, $locale_charset);
152 };
153
154 $file = $encfile unless $@;
155 }
156 }
157 }
158 }
159
160 unless (defined($file) && length($file)) {
161 my $uri;
162 if (my $cl = $self->header('Content-Location')) {
163 $uri = URI->new($cl);
164 }
165 elsif (my $request = $self->request) {
166 $uri = $request->uri;
167 }
168
169 if ($uri) {
170 $file = ($uri->path_segments)[-1];
171 }
172 }
173
174 if ($file) {
175 $file =~ s,.*[\\/],,; # basename
176 }
177
178 if ($file && !length($file)) {
179 $file = undef;
180 }
181
182 $file;
183}
184
185
186sub as_string
187{
188 require HTTP::Status;
189 my $self = shift;
190 my($eol) = @_;
191 $eol = "\n" unless defined $eol;
192
193 my $status_line = $self->status_line;
194 my $proto = $self->protocol;
195 $status_line = "$proto $status_line" if $proto;
196
197 return join($eol, $status_line, $self->SUPER::as_string(@_));
198}
199
200
201sub dump
202{
203 my $self = shift;
204
205 my $status_line = $self->status_line;
206 my $proto = $self->protocol;
207 $status_line = "$proto $status_line" if $proto;
208
209 return $self->SUPER::dump(
210 preheader => $status_line,
211 @_,
212 );
213}
214
215
216sub is_info { HTTP::Status::is_info (shift->{'_rc'}); }
217sub is_success { HTTP::Status::is_success (shift->{'_rc'}); }
218sub is_redirect { HTTP::Status::is_redirect (shift->{'_rc'}); }
219sub is_error { HTTP::Status::is_error (shift->{'_rc'}); }
220
221
222sub error_as_HTML
223{
224 require HTML::Entities;
225 my $self = shift;
226 my $title = 'An Error Occurred';
227 my $body = HTML::Entities::encode($self->status_line);
228 return <<EOM;
229<html>
230<head><title>$title</title></head>
231<body>
232<h1>$title</h1>
233<p>$body</p>
234</body>
235</html>
236EOM
237}
238
239
240sub current_age
241{
242 my $self = shift;
243 my $time = shift;
244
245 # Implementation of RFC 2616 section 13.2.3
246 # (age calculations)
247 my $response_time = $self->client_date;
248 my $date = $self->date;
249
250 my $age = 0;
251 if ($response_time && $date) {
252 $age = $response_time - $date; # apparent_age
253 $age = 0 if $age < 0;
254 }
255
256 my $age_v = $self->header('Age');
257 if ($age_v && $age_v > $age) {
258 $age = $age_v; # corrected_received_age
259 }
260
261 if ($response_time) {
262 my $request = $self->request;
263 if ($request) {
264 my $request_time = $request->date;
265 if ($request_time && $request_time < $response_time) {
266 # Add response_delay to age to get 'corrected_initial_age'
267 $age += $response_time - $request_time;
268 }
269 }
270 $age += ($time || time) - $response_time;
271 }
272 return $age;
273}
274
275
276sub freshness_lifetime
277{
278 my($self, %opt) = @_;
279
280 # First look for the Cache-Control: max-age=n header
281 for my $cc ($self->header('Cache-Control')) {
282 for my $cc_dir (split(/\s*,\s*/, $cc)) {
283 return $1 if $cc_dir =~ /^max-age\s*=\s*(\d+)/i;
284 }
285 }
286
287 # Next possibility is to look at the "Expires" header
288 my $date = $self->date || $self->client_date || $opt{time} || time;
289 if (my $expires = $self->expires) {
290 return $expires - $date;
291 }
292
293 # Must apply heuristic expiration
294 return undef if exists $opt{heuristic_expiry} && !$opt{heuristic_expiry};
295
296 # Default heuristic expiration parameters
297 $opt{h_min} ||= 60;
298 $opt{h_max} ||= 24 * 3600;
299 $opt{h_lastmod_fraction} ||= 0.10; # 10% since last-mod suggested by RFC2616
300 $opt{h_default} ||= 3600;
301
302 # Should give a warning if more than 24 hours according to
303 # RFC 2616 section 13.2.4. Here we just make this the default
304 # maximum value.
305
306 if (my $last_modified = $self->last_modified) {
307 my $h_exp = ($date - $last_modified) * $opt{h_lastmod_fraction};
308 return $opt{h_min} if $h_exp < $opt{h_min};
309 return $opt{h_max} if $h_exp > $opt{h_max};
310 return $h_exp;
311 }
312
313 # default when all else fails
314 return $opt{h_min} if $opt{h_min} > $opt{h_default};
315 return $opt{h_default};
316}
317
318
319sub is_fresh
320{
321 my($self, %opt) = @_;
322 $opt{time} ||= time;
323 my $f = $self->freshness_lifetime(%opt);
324 return undef unless defined($f);
325 return $f > $self->current_age($opt{time});
326}
327
328
329sub fresh_until
330{
331 my($self, %opt) = @_;
332 $opt{time} ||= time;
333 my $f = $self->freshness_lifetime(%opt);
334 return undef unless defined($f);
335 return $f - $self->current_age($opt{time}) + $opt{time};
336}
337
33814µs1;
339
340
341__END__
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.