← 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 11:58:52 2013
Reported on Tue Oct 15 12:01:04 2013

Filename/usr/share/perl5/HTTP/Headers.pm
StatementsExecuted 224 statements in 3.36ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
21144µs45µsHTTP::Headers::::_headerHTTP::Headers::_header
21130µs75µsHTTP::Headers::::headerHTTP::Headers::header
11121µs27µsHTTP::Headers::::BEGIN@3HTTP::Headers::BEGIN@3
11112µs12µsHTTP::Headers::::newHTTP::Headers::new
11111µs69µsHTTP::Headers::::BEGIN@6HTTP::Headers::BEGIN@6
1116µs6µsHTTP::Headers::::BEGIN@4HTTP::Headers::BEGIN@4
2111µs1µsHTTP::Headers::::CORE:matchHTTP::Headers::CORE:match (opcode)
0000s0sHTTP::Headers::::__ANON__[:288]HTTP::Headers::__ANON__[:288]
0000s0sHTTP::Headers::::__ANON__[:290]HTTP::Headers::__ANON__[:290]
0000s0sHTTP::Headers::::_basic_authHTTP::Headers::_basic_auth
0000s0sHTTP::Headers::::_date_headerHTTP::Headers::_date_header
0000s0sHTTP::Headers::::_process_newlineHTTP::Headers::_process_newline
0000s0sHTTP::Headers::::_sorted_field_namesHTTP::Headers::_sorted_field_names
0000s0sHTTP::Headers::::as_stringHTTP::Headers::as_string
0000s0sHTTP::Headers::::authorizationHTTP::Headers::authorization
0000s0sHTTP::Headers::::authorization_basicHTTP::Headers::authorization_basic
0000s0sHTTP::Headers::::clearHTTP::Headers::clear
0000s0sHTTP::Headers::::client_dateHTTP::Headers::client_date
0000s0sHTTP::Headers::::content_encodingHTTP::Headers::content_encoding
0000s0sHTTP::Headers::::content_is_htmlHTTP::Headers::content_is_html
0000s0sHTTP::Headers::::content_is_textHTTP::Headers::content_is_text
0000s0sHTTP::Headers::::content_is_xhtmlHTTP::Headers::content_is_xhtml
0000s0sHTTP::Headers::::content_is_xmlHTTP::Headers::content_is_xml
0000s0sHTTP::Headers::::content_languageHTTP::Headers::content_language
0000s0sHTTP::Headers::::content_lengthHTTP::Headers::content_length
0000s0sHTTP::Headers::::content_typeHTTP::Headers::content_type
0000s0sHTTP::Headers::::content_type_charsetHTTP::Headers::content_type_charset
0000s0sHTTP::Headers::::dateHTTP::Headers::date
0000s0sHTTP::Headers::::expiresHTTP::Headers::expires
0000s0sHTTP::Headers::::fromHTTP::Headers::from
0000s0sHTTP::Headers::::header_field_namesHTTP::Headers::header_field_names
0000s0sHTTP::Headers::::if_modified_sinceHTTP::Headers::if_modified_since
0000s0sHTTP::Headers::::if_unmodified_sinceHTTP::Headers::if_unmodified_since
0000s0sHTTP::Headers::::init_headerHTTP::Headers::init_header
0000s0sHTTP::Headers::::last_modifiedHTTP::Headers::last_modified
0000s0sHTTP::Headers::::proxy_authenticateHTTP::Headers::proxy_authenticate
0000s0sHTTP::Headers::::proxy_authorizationHTTP::Headers::proxy_authorization
0000s0sHTTP::Headers::::proxy_authorization_basicHTTP::Headers::proxy_authorization_basic
0000s0sHTTP::Headers::::push_headerHTTP::Headers::push_header
0000s0sHTTP::Headers::::refererHTTP::Headers::referer
0000s0sHTTP::Headers::::remove_content_headersHTTP::Headers::remove_content_headers
0000s0sHTTP::Headers::::remove_headerHTTP::Headers::remove_header
0000s0sHTTP::Headers::::scanHTTP::Headers::scan
0000s0sHTTP::Headers::::serverHTTP::Headers::server
0000s0sHTTP::Headers::::titleHTTP::Headers::title
0000s0sHTTP::Headers::::user_agentHTTP::Headers::user_agent
0000s0sHTTP::Headers::::warningHTTP::Headers::warning
0000s0sHTTP::Headers::::www_authenticateHTTP::Headers::www_authenticate
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package HTTP::Headers;
2
3330µs233µs
# spent 27µs (21+6) within HTTP::Headers::BEGIN@3 which was called: # once (21µs+6µs) by LWP::UserAgent::BEGIN@10 at line 3
use strict;
# spent 27µs making 1 call to HTTP::Headers::BEGIN@3 # spent 6µs making 1 call to strict::import
4329µs16µs
# spent 6µs within HTTP::Headers::BEGIN@4 which was called: # once (6µs+0s) by LWP::UserAgent::BEGIN@10 at line 4
use Carp ();
# spent 6µs making 1 call to HTTP::Headers::BEGIN@4
5
632.84ms2127µs
# spent 69µs (11+58) within HTTP::Headers::BEGIN@6 which was called: # once (11µs+58µs) by LWP::UserAgent::BEGIN@10 at line 6
use vars qw($VERSION $TRANSLATE_UNDERSCORE);
# spent 69µs making 1 call to HTTP::Headers::BEGIN@6 # spent 58µs making 1 call to vars::import
711µs$VERSION = "5.835";
8
9# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used
10# as a replacement for '-' in header field names.
111700ns$TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE;
12
13# "Good Practice" order of HTTP message headers:
14# - General-Headers
15# - Request-Headers
16# - Response-Headers
17# - Entity-Headers
18
1913µsmy @general_headers = qw(
20 Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade
21 Via Warning
22);
23
2414µsmy @request_headers = qw(
25 Accept Accept-Charset Accept-Encoding Accept-Language
26 Authorization Expect From Host
27 If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
28 Max-Forwards Proxy-Authorization Range Referer TE User-Agent
29);
30
3112µsmy @response_headers = qw(
32 Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server
33 Vary WWW-Authenticate
34);
35
3612µsmy @entity_headers = qw(
37 Allow Content-Encoding Content-Language Content-Length Content-Location
38 Content-MD5 Content-Range Content-Type Expires Last-Modified
39);
40
41114µsmy %entity_header = map { lc($_) => 1 } @entity_headers;
42
43111µsmy @header_order = (
44 @general_headers,
45 @request_headers,
46 @response_headers,
47 @entity_headers,
48);
49
50# Make alternative representations of @header_order. This is used
51# for sorting and case matching.
521200nsmy %header_order;
531200nsmy %standard_case;
54
55{
5621µs my $i = 0;
5712µs for (@header_order) {
584714µs my $lc = lc $_;
594734µs $header_order{$lc} = ++$i;
604744µs $standard_case{$lc} = $_;
61 }
62}
63
- -
66sub new
67
# spent 12µs within HTTP::Headers::new which was called: # once (12µs+0s) by LWP::UserAgent::default_headers at line 643 of LWP/UserAgent.pm
{
68414µs my($class) = shift;
69 my $self = bless {}, $class;
70 $self->header(@_) if @_; # set up initial headers
71 $self;
72}
73
74
75sub header
76
# spent 75µs (30+45) within HTTP::Headers::header which was called 2 times, avg 37µs/call: # 2 times (30µs+45µs) by LWP::UserAgent::default_header at line 654 of LWP/UserAgent.pm, avg 37µs/call
{
772029µs my $self = shift;
78 Carp::croak('Usage: $h->header($field, ...)') unless @_;
79 my(@old);
80 my %seen;
81 while (@_) {
82 my $field = shift;
83 my $op = @_ ? ($seen{lc($field)}++ ? 'PUSH' : 'SET') : 'GET';
84245µs @old = $self->_header($field, shift, $op);
# spent 45µs making 2 calls to HTTP::Headers::_header, avg 23µs/call
85 }
86 return @old if wantarray;
87 return $old[0] if @old <= 1;
88 join(", ", @old);
89}
90
91sub clear
92{
93 my $self = shift;
94 %$self = ();
95}
96
97
98sub push_header
99{
100 my $self = shift;
101 return $self->_header(@_, 'PUSH_H') if @_ == 2;
102 while (@_) {
103 $self->_header(splice(@_, 0, 2), 'PUSH_H');
104 }
105}
106
107
108sub init_header
109{
110 Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3;
111 shift->_header(@_, 'INIT');
112}
113
114
115sub remove_header
116{
117 my($self, @fields) = @_;
118 my $field;
119 my @values;
120 foreach $field (@fields) {
121 $field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE;
122 my $v = delete $self->{lc $field};
123 push(@values, ref($v) eq 'ARRAY' ? @$v : $v) if defined $v;
124 }
125 return @values;
126}
127
128sub remove_content_headers
129{
130 my $self = shift;
131 unless (defined(wantarray)) {
132 # fast branch that does not create return object
133 delete @$self{grep $entity_header{$_} || /^content-/, keys %$self};
134 return;
135 }
136
137 my $c = ref($self)->new;
138 for my $f (grep $entity_header{$_} || /^content-/, keys %$self) {
139 $c->{$f} = delete $self->{$f};
140 }
141 $c;
142}
143
144
145sub _header
146
# spent 45µs (44+1) within HTTP::Headers::_header which was called 2 times, avg 23µs/call: # 2 times (44µs+1µs) by HTTP::Headers::header at line 84, avg 23µs/call
{
1473248µs my($self, $field, $val, $op) = @_;
148
14921µs unless ($field =~ /^:/) {
# spent 1µs making 2 calls to HTTP::Headers::CORE:match, avg 700ns/call
150 $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
151 my $old = $field;
152 $field = lc $field;
153 unless(defined $standard_case{$field}) {
154 # generate a %standard_case entry for this field
155 $old =~ s/\b(\w)/\u$1/g;
156 $standard_case{$field} = $old;
157 }
158 }
159
160 $op ||= defined($val) ? 'SET' : 'GET';
161 if ($op eq 'PUSH_H') {
162 # Like PUSH but where we don't care about the return value
163 if (exists $self->{$field}) {
164 my $h = $self->{$field};
165 if (ref($h) eq 'ARRAY') {
166 push(@$h, ref($val) eq "ARRAY" ? @$val : $val);
167 }
168 else {
169 $self->{$field} = [$h, ref($val) eq "ARRAY" ? @$val : $val]
170 }
171 return;
172 }
173 $self->{$field} = $val;
174 return;
175 }
176
177 my $h = $self->{$field};
178 my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ());
179
180 unless ($op eq 'GET' || ($op eq 'INIT' && @old)) {
181 if (defined($val)) {
182 my @new = ($op eq 'PUSH') ? @old : ();
183 if (ref($val) ne 'ARRAY') {
184 push(@new, $val);
185 }
186 else {
187 push(@new, @$val);
188 }
189 $self->{$field} = @new > 1 ? \@new : $new[0];
190 }
191 elsif ($op ne 'PUSH') {
192 delete $self->{$field};
193 }
194 }
195 @old;
196}
197
198
199sub _sorted_field_names
200{
201 my $self = shift;
202 return [ sort {
203 ($header_order{$a} || 999) <=> ($header_order{$b} || 999) ||
204 $a cmp $b
205 } keys %$self ];
206}
207
208
209sub header_field_names {
210 my $self = shift;
211 return map $standard_case{$_} || $_, @{ $self->_sorted_field_names },
212 if wantarray;
213 return keys %$self;
214}
215
216
217sub scan
218{
219 my($self, $sub) = @_;
220 my $key;
221 for $key (@{ $self->_sorted_field_names }) {
222 next if substr($key, 0, 1) eq '_';
223 my $vals = $self->{$key};
224 if (ref($vals) eq 'ARRAY') {
225 my $val;
226 for $val (@$vals) {
227 $sub->($standard_case{$key} || $key, $val);
228 }
229 }
230 else {
231 $sub->($standard_case{$key} || $key, $vals);
232 }
233 }
234}
235
236
237sub as_string
238{
239 my($self, $endl) = @_;
240 $endl = "\n" unless defined $endl;
241
242 my @result = ();
243 for my $key (@{ $self->_sorted_field_names }) {
244 next if index($key, '_') == 0;
245 my $vals = $self->{$key};
246 if ( ref($vals) eq 'ARRAY' ) {
247 for my $val (@$vals) {
248 my $field = $standard_case{$key} || $key;
249 $field =~ s/^://;
250 if ( index($val, "\n") >= 0 ) {
251 $val = _process_newline($val, $endl);
252 }
253 push @result, $field . ': ' . $val;
254 }
255 }
256 else {
257 my $field = $standard_case{$key} || $key;
258 $field =~ s/^://;
259 if ( index($vals, "\n") >= 0 ) {
260 $vals = _process_newline($vals, $endl);
261 }
262 push @result, $field . ': ' . $vals;
263 }
264 }
265
266 join($endl, @result, '');
267}
268
269sub _process_newline {
270 local $_ = shift;
271 my $endl = shift;
272 # must handle header values with embedded newlines with care
273 s/\s+$//; # trailing newlines and space must go
274 s/\n(\x0d?\n)+/\n/g; # no empty lines
275 s/\n([^\040\t])/\n $1/g; # intial space for continuation
276 s/\n/$endl/g; # substitute with requested line ending
277 $_;
278}
279
- -
2823177µsif (eval { require Storable; 1 }) {
283 *clone = \&Storable::dclone;
284} else {
285 *clone = sub {
286 my $self = shift;
287 my $clone = HTTP::Headers->new;
288 $self->scan(sub { $clone->push_header(@_);} );
289 $clone;
290 };
291}
292
293
294sub _date_header
295{
296 require HTTP::Date;
297 my($self, $header, $time) = @_;
298 my($old) = $self->_header($header);
299 if (defined $time) {
300 $self->_header($header, HTTP::Date::time2str($time));
301 }
302 $old =~ s/;.*// if defined($old);
303 HTTP::Date::str2time($old);
304}
305
306
307sub date { shift->_date_header('Date', @_); }
308sub expires { shift->_date_header('Expires', @_); }
309sub if_modified_since { shift->_date_header('If-Modified-Since', @_); }
310sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); }
311sub last_modified { shift->_date_header('Last-Modified', @_); }
312
313# This is used as a private LWP extension. The Client-Date header is
314# added as a timestamp to a response when it has been received.
315sub client_date { shift->_date_header('Client-Date', @_); }
316
317# The retry_after field is dual format (can also be a expressed as
318# number of seconds from now), so we don't provide an easy way to
319# access it until we have know how both these interfaces can be
320# addressed. One possibility is to return a negative value for
321# relative seconds and a positive value for epoch based time values.
322#sub retry_after { shift->_date_header('Retry-After', @_); }
323
324sub content_type {
325 my $self = shift;
326 my $ct = $self->{'content-type'};
327 $self->{'content-type'} = shift if @_;
328 $ct = $ct->[0] if ref($ct) eq 'ARRAY';
329 return '' unless defined($ct) && length($ct);
330 my @ct = split(/;\s*/, $ct, 2);
331 for ($ct[0]) {
332 s/\s+//g;
333 $_ = lc($_);
334 }
335 wantarray ? @ct : $ct[0];
336}
337
338sub content_type_charset {
339 my $self = shift;
340 require HTTP::Headers::Util;
341 my $h = $self->{'content-type'};
342 $h = $h->[0] if ref($h);
343 $h = "" unless defined $h;
344 my @v = HTTP::Headers::Util::split_header_words($h);
345 if (@v) {
346 my($ct, undef, %ct_param) = @{$v[0]};
347 my $charset = $ct_param{charset};
348 if ($ct) {
349 $ct = lc($ct);
350 $ct =~ s/\s+//;
351 }
352 if ($charset) {
353 $charset = uc($charset);
354 $charset =~ s/^\s+//; $charset =~ s/\s+\z//;
355 undef($charset) if $charset eq "";
356 }
357 return $ct, $charset if wantarray;
358 return $charset;
359 }
360 return undef, undef if wantarray;
361 return undef;
362}
363
364sub content_is_text {
365 my $self = shift;
366 return $self->content_type =~ m,^text/,;
367}
368
369sub content_is_html {
370 my $self = shift;
371 return $self->content_type eq 'text/html' || $self->content_is_xhtml;
372}
373
374sub content_is_xhtml {
375 my $ct = shift->content_type;
376 return $ct eq "application/xhtml+xml" ||
377 $ct eq "application/vnd.wap.xhtml+xml";
378}
379
380sub content_is_xml {
381 my $ct = shift->content_type;
382 return 1 if $ct eq "text/xml";
383 return 1 if $ct eq "application/xml";
384 return 1 if $ct =~ /\+xml$/;
385 return 0;
386}
387
388sub referer {
389 my $self = shift;
390 if (@_ && $_[0] =~ /#/) {
391 # Strip fragment per RFC 2616, section 14.36.
392 my $uri = shift;
393 if (ref($uri)) {
394 $uri = $uri->clone;
395 $uri->fragment(undef);
396 }
397 else {
398 $uri =~ s/\#.*//;
399 }
400 unshift @_, $uri;
401 }
402 ($self->_header('Referer', @_))[0];
403}
40412µs*referrer = \&referer; # on tchrist's request
405
406sub title { (shift->_header('Title', @_))[0] }
407sub content_encoding { (shift->_header('Content-Encoding', @_))[0] }
408sub content_language { (shift->_header('Content-Language', @_))[0] }
409sub content_length { (shift->_header('Content-Length', @_))[0] }
410
411sub user_agent { (shift->_header('User-Agent', @_))[0] }
412sub server { (shift->_header('Server', @_))[0] }
413
414sub from { (shift->_header('From', @_))[0] }
415sub warning { (shift->_header('Warning', @_))[0] }
416
417sub www_authenticate { (shift->_header('WWW-Authenticate', @_))[0] }
418sub authorization { (shift->_header('Authorization', @_))[0] }
419
420sub proxy_authenticate { (shift->_header('Proxy-Authenticate', @_))[0] }
421sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] }
422
423sub authorization_basic { shift->_basic_auth("Authorization", @_) }
424sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) }
425
426sub _basic_auth {
427 require MIME::Base64;
428 my($self, $h, $user, $passwd) = @_;
429 my($old) = $self->_header($h);
430 if (defined $user) {
431 Carp::croak("Basic authorization user name can't contain ':'")
432 if $user =~ /:/;
433 $passwd = '' unless defined $passwd;
434 $self->_header($h => 'Basic ' .
435 MIME::Base64::encode("$user:$passwd", ''));
436 }
437 if (defined $old && $old =~ s/^\s*Basic\s+//) {
438 my $val = MIME::Base64::decode($old);
439 return $val unless wantarray;
440 return split(/:/, $val, 2);
441 }
442 return;
443}
444
445
446154µs1;
447
448__END__
 
# spent 1µs within HTTP::Headers::CORE:match which was called 2 times, avg 700ns/call: # 2 times (1µs+0s) by HTTP::Headers::_header at line 149, avg 700ns/call
sub HTTP::Headers::CORE:match; # opcode
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.