← 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:12:29 2013

Filename/usr/share/perl5/HTTP/Message.pm
StatementsExecuted 18 statements in 5.14ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11126µs35µsHTTP::Message::::BEGIN@3HTTP::Message::BEGIN@3
11122µs56µsHTTP::Message::::BEGIN@643HTTP::Message::BEGIN@643
11111µs52µsHTTP::Message::::BEGIN@4HTTP::Message::BEGIN@4
0000s0sHTTP::Message::::AUTOLOADHTTP::Message::AUTOLOAD
0000s0sHTTP::Message::::DESTROYHTTP::Message::DESTROY
0000s0sHTTP::Message::::__ANON__[:18]HTTP::Message::__ANON__[:18]
0000s0sHTTP::Message::::__ANON__[:21]HTTP::Message::__ANON__[:21]
0000s0sHTTP::Message::::__ANON__[:261]HTTP::Message::__ANON__[:261]
0000s0sHTTP::Message::::__ANON__[:644]HTTP::Message::__ANON__[:644]
0000s0sHTTP::Message::::_boundaryHTTP::Message::_boundary
0000s0sHTTP::Message::::_contentHTTP::Message::_content
0000s0sHTTP::Message::::_elemHTTP::Message::_elem
0000s0sHTTP::Message::::_partsHTTP::Message::_parts
0000s0sHTTP::Message::::_set_contentHTTP::Message::_set_content
0000s0sHTTP::Message::::_stale_contentHTTP::Message::_stale_content
0000s0sHTTP::Message::::add_contentHTTP::Message::add_content
0000s0sHTTP::Message::::add_content_utf8HTTP::Message::add_content_utf8
0000s0sHTTP::Message::::add_partHTTP::Message::add_part
0000s0sHTTP::Message::::as_stringHTTP::Message::as_string
0000s0sHTTP::Message::::clearHTTP::Message::clear
0000s0sHTTP::Message::::cloneHTTP::Message::clone
0000s0sHTTP::Message::::contentHTTP::Message::content
0000s0sHTTP::Message::::content_charsetHTTP::Message::content_charset
0000s0sHTTP::Message::::content_refHTTP::Message::content_ref
0000s0sHTTP::Message::::decodableHTTP::Message::decodable
0000s0sHTTP::Message::::decodeHTTP::Message::decode
0000s0sHTTP::Message::::decoded_contentHTTP::Message::decoded_content
0000s0sHTTP::Message::::dumpHTTP::Message::dump
0000s0sHTTP::Message::::encodeHTTP::Message::encode
0000s0sHTTP::Message::::headersHTTP::Message::headers
0000s0sHTTP::Message::::headers_as_stringHTTP::Message::headers_as_string
0000s0sHTTP::Message::::newHTTP::Message::new
0000s0sHTTP::Message::::parseHTTP::Message::parse
0000s0sHTTP::Message::::partsHTTP::Message::parts
0000s0sHTTP::Message::::protocolHTTP::Message::protocol
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package HTTP::Message;
2
3353µs244µs
# spent 35µs (26+9) within HTTP::Message::BEGIN@3 which was called: # once (26µs+9µs) by LWP::UserAgent::BEGIN@10 at line 3
use strict;
# spent 35µs making 1 call to HTTP::Message::BEGIN@3 # spent 9µs making 1 call to strict::import
434.07ms293µs
# spent 52µs (11+41) within HTTP::Message::BEGIN@4 which was called: # once (11µs+41µs) by LWP::UserAgent::BEGIN@10 at line 4
use vars qw($VERSION $AUTOLOAD);
# spent 52µs making 1 call to HTTP::Message::BEGIN@4 # spent 41µs making 1 call to vars::import
511µs$VERSION = "5.835";
6
71140µsrequire HTTP::Headers;
812µsrequire Carp;
9
1012µsmy $CRLF = "\015\012"; # "\r\n" is not portable
1114µs$HTTP::URI_CLASS ||= $ENV{PERL_HTTP_URI_CLASS} || "URI";
12248µseval "require $HTTP::URI_CLASS"; die $@ if $@;
# spent 113µs executing statements in string eval
13
14*_utf8_downgrade = defined(&utf8::downgrade) ?
15 sub {
16 utf8::downgrade($_[0], 1) or
17 Carp::croak("HTTP::Message content must be bytes")
18 }
19 :
20 sub {
2118µs };
22
23sub new
24{
25 my($class, $header, $content) = @_;
26 if (defined $header) {
27 Carp::croak("Bad header argument") unless ref $header;
28 if (ref($header) eq "ARRAY") {
29 $header = HTTP::Headers->new(@$header);
30 }
31 else {
32 $header = $header->clone;
33 }
34 }
35 else {
36 $header = HTTP::Headers->new;
37 }
38 if (defined $content) {
39 _utf8_downgrade($content);
40 }
41 else {
42 $content = '';
43 }
44
45 bless {
46 '_headers' => $header,
47 '_content' => $content,
48 }, $class;
49}
50
51
52sub parse
53{
54 my($class, $str) = @_;
55
56 my @hdr;
57 while (1) {
58 if ($str =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?//) {
59 push(@hdr, $1, $2);
60 $hdr[-1] =~ s/\r\z//;
61 }
62 elsif (@hdr && $str =~ s/^([ \t].*)\n?//) {
63 $hdr[-1] .= "\n$1";
64 $hdr[-1] =~ s/\r\z//;
65 }
66 else {
67 $str =~ s/^\r?\n//;
68 last;
69 }
70 }
71 local $HTTP::Headers::TRANSLATE_UNDERSCORE;
72 new($class, \@hdr, $str);
73}
74
75
76sub clone
77{
78 my $self = shift;
79 my $clone = HTTP::Message->new($self->headers,
80 $self->content);
81 $clone->protocol($self->protocol);
82 $clone;
83}
84
85
86sub clear {
87 my $self = shift;
88 $self->{_headers}->clear;
89 $self->content("");
90 delete $self->{_parts};
91 return;
92}
93
94
95sub protocol {
96 shift->_elem('_protocol', @_);
97}
98
99sub headers {
100 my $self = shift;
101
102 # recalculation of _content might change headers, so we
103 # need to force it now
104 $self->_content unless exists $self->{_content};
105
106 $self->{_headers};
107}
108
109sub headers_as_string {
110 shift->headers->as_string(@_);
111}
112
113
114sub content {
115
116 my $self = $_[0];
117 if (defined(wantarray)) {
118 $self->_content unless exists $self->{_content};
119 my $old = $self->{_content};
120 $old = $$old if ref($old) eq "SCALAR";
121 &_set_content if @_ > 1;
122 return $old;
123 }
124
125 if (@_ > 1) {
126 &_set_content;
127 }
128 else {
129 Carp::carp("Useless content call in void context") if $^W;
130 }
131}
132
133
134sub _set_content {
135 my $self = $_[0];
136 _utf8_downgrade($_[1]);
137 if (!ref($_[1]) && ref($self->{_content}) eq "SCALAR") {
138 ${$self->{_content}} = $_[1];
139 }
140 else {
141 die "Can't set content to be a scalar reference" if ref($_[1]) eq "SCALAR";
142 $self->{_content} = $_[1];
143 delete $self->{_content_ref};
144 }
145 delete $self->{_parts} unless $_[2];
146}
147
148
149sub add_content
150{
151 my $self = shift;
152 $self->_content unless exists $self->{_content};
153 my $chunkref = \$_[0];
154 $chunkref = $$chunkref if ref($$chunkref); # legacy
155
156 _utf8_downgrade($$chunkref);
157
158 my $ref = ref($self->{_content});
159 if (!$ref) {
160 $self->{_content} .= $$chunkref;
161 }
162 elsif ($ref eq "SCALAR") {
163 ${$self->{_content}} .= $$chunkref;
164 }
165 else {
166 Carp::croak("Can't append to $ref content");
167 }
168 delete $self->{_parts};
169}
170
171sub add_content_utf8 {
172 my($self, $buf) = @_;
173 utf8::upgrade($buf);
174 utf8::encode($buf);
175 $self->add_content($buf);
176}
177
178sub content_ref
179{
180 my $self = shift;
181 $self->_content unless exists $self->{_content};
182 delete $self->{_parts};
183 my $old = \$self->{_content};
184 my $old_cref = $self->{_content_ref};
185 if (@_) {
186 my $new = shift;
187 Carp::croak("Setting content_ref to a non-ref") unless ref($new);
188 delete $self->{_content}; # avoid modifying $$old
189 $self->{_content} = $new;
190 $self->{_content_ref}++;
191 }
192 $old = $$old if $old_cref;
193 return $old;
194}
195
196
197sub content_charset
198{
199 my $self = shift;
200 if (my $charset = $self->content_type_charset) {
201 return $charset;
202 }
203
204 # time to start guessing
205 my $cref = $self->decoded_content(ref => 1, charset => "none");
206
207 # Unicode BOM
208 for ($$cref) {
209 return "UTF-8" if /^\xEF\xBB\xBF/;
210 return "UTF-32-LE" if /^\xFF\xFE\x00\x00/;
211 return "UTF-32-BE" if /^\x00\x00\xFE\xFF/;
212 return "UTF-16-LE" if /^\xFF\xFE/;
213 return "UTF-16-BE" if /^\xFE\xFF/;
214 }
215
216 if ($self->content_is_xml) {
217 # http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing
218 # XML entity not accompanied by external encoding information and not
219 # in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration,
220 # in which the first characters must be '<?xml'
221 for ($$cref) {
222 return "UTF-32-BE" if /^\x00\x00\x00</;
223 return "UTF-32-LE" if /^<\x00\x00\x00/;
224 return "UTF-16-BE" if /^(?:\x00\s)*\x00</;
225 return "UTF-16-LE" if /^(?:\s\x00)*<\x00/;
226 if (/^\s*(<\?xml[^\x00]*?\?>)/) {
227 if ($1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/) {
228 my $enc = $2;
229 $enc =~ s/^\s+//; $enc =~ s/\s+\z//;
230 return $enc if $enc;
231 }
232 }
233 }
234 return "UTF-8";
235 }
236 elsif ($self->content_is_html) {
237 # look for <META charset="..."> or <META content="...">
238 # http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding
239 my $charset;
240 require HTML::Parser;
241 my $p = HTML::Parser->new(
242 start_h => [sub {
243 my($tag, $attr, $self) = @_;
244 $charset = $attr->{charset};
245 unless ($charset) {
246 # look at $attr->{content} ...
247 if (my $c = $attr->{content}) {
248 require HTTP::Headers::Util;
249 my @v = HTTP::Headers::Util::split_header_words($c);
250 return unless @v;
251 my($ct, undef, %ct_param) = @{$v[0]};
252 $charset = $ct_param{charset};
253 }
254 return unless $charset;
255 }
256 if ($charset =~ /^utf-?16/i) {
257 # converted document, assume UTF-8
258 $charset = "UTF-8";
259 }
260 $self->eof;
261 }, "tagname, attr, self"],
262 report_tags => [qw(meta)],
263 utf8_mode => 1,
264 );
265 $p->parse($$cref);
266 return $charset if $charset;
267 }
268 if ($self->content_type =~ /^text\//) {
269 for ($$cref) {
270 if (length) {
271 return "US-ASCII" unless /[\x80-\xFF]/;
272 require Encode;
273 eval {
274 Encode::decode_utf8($_, Encode::FB_CROAK());
275 };
276 return "UTF-8" unless $@;
277 return "ISO-8859-1";
278 }
279 }
280 }
281
282 return undef;
283}
284
285
286sub decoded_content
287{
288 my($self, %opt) = @_;
289 my $content_ref;
290 my $content_ref_iscopy;
291
292 eval {
293 $content_ref = $self->content_ref;
294 die "Can't decode ref content" if ref($content_ref) ne "SCALAR";
295
296 if (my $h = $self->header("Content-Encoding")) {
297 $h =~ s/^\s+//;
298 $h =~ s/\s+$//;
299 for my $ce (reverse split(/\s*,\s*/, lc($h))) {
300 next unless $ce;
301 next if $ce eq "identity";
302 if ($ce eq "gzip" || $ce eq "x-gzip") {
303 require IO::Uncompress::Gunzip;
304 my $output;
305 IO::Uncompress::Gunzip::gunzip($content_ref, \$output, Transparent => 0)
306 or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
307 $content_ref = \$output;
308 $content_ref_iscopy++;
309 }
310 elsif ($ce eq "x-bzip2") {
311 require IO::Uncompress::Bunzip2;
312 my $output;
313 IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0)
314 or die "Can't bunzip content: $IO::Uncompress::Bunzip2::Bunzip2Error";
315 $content_ref = \$output;
316 $content_ref_iscopy++;
317 }
318 elsif ($ce eq "deflate") {
319 require IO::Uncompress::Inflate;
320 my $output;
321 my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0);
322 my $error = $IO::Uncompress::Inflate::InflateError;
323 unless ($status) {
324 # "Content-Encoding: deflate" is supposed to mean the
325 # "zlib" format of RFC 1950, but Microsoft got that
326 # wrong, so some servers sends the raw compressed
327 # "deflate" data. This tries to inflate this format.
328 $output = undef;
329 require IO::Uncompress::RawInflate;
330 unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) {
331 $self->push_header("Client-Warning" =>
332 "Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError");
333 $output = undef;
334 }
335 }
336 die "Can't inflate content: $error" unless defined $output;
337 $content_ref = \$output;
338 $content_ref_iscopy++;
339 }
340 elsif ($ce eq "compress" || $ce eq "x-compress") {
341 die "Can't uncompress content";
342 }
343 elsif ($ce eq "base64") { # not really C-T-E, but should be harmless
344 require MIME::Base64;
345 $content_ref = \MIME::Base64::decode($$content_ref);
346 $content_ref_iscopy++;
347 }
348 elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless
349 require MIME::QuotedPrint;
350 $content_ref = \MIME::QuotedPrint::decode($$content_ref);
351 $content_ref_iscopy++;
352 }
353 else {
354 die "Don't know how to decode Content-Encoding '$ce'";
355 }
356 }
357 }
358
359 if ($self->content_is_text || (my $is_xml = $self->content_is_xml)) {
360 my $charset = lc(
361 $opt{charset} ||
362 $self->content_type_charset ||
363 $opt{default_charset} ||
364 $self->content_charset ||
365 "ISO-8859-1"
366 );
367 unless ($charset =~ /^(?:none|us-ascii|iso-8859-1)\z/) {
368 require Encode;
369 if (do{my $v = $Encode::VERSION; $v =~ s/_//g; $v} < 2.0901 &&
370 !$content_ref_iscopy)
371 {
372 # LEAVE_SRC did not work before Encode-2.0901
373 my $copy = $$content_ref;
374 $content_ref = \$copy;
375 $content_ref_iscopy++;
376 }
377 eval {
378 $content_ref = \Encode::decode($charset, $$content_ref,
379 ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC());
380 };
381 if ($@) {
382 my $retried;
383 if ($@ =~ /^Unknown encoding/) {
384 my $alt_charset = lc($opt{alt_charset} || "");
385 if ($alt_charset && $charset ne $alt_charset) {
386 # Retry decoding with the alternative charset
387 $content_ref = \Encode::decode($alt_charset, $$content_ref,
388 ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC())
389 unless $alt_charset =~ /^(?:none|us-ascii|iso-8859-1)\z/;
390 $retried++;
391 }
392 }
393 die unless $retried;
394 }
395 die "Encode::decode() returned undef improperly" unless defined $$content_ref;
396 if ($is_xml) {
397 # Get rid of the XML encoding declaration if present
398 $$content_ref =~ s/^\x{FEFF}//;
399 if ($$content_ref =~ /^(\s*<\?xml[^\x00]*?\?>)/) {
400 substr($$content_ref, 0, length($1)) =~ s/\sencoding\s*=\s*(["']).*?\1//;
401 }
402 }
403 }
404 }
405 };
406 if ($@) {
407 Carp::croak($@) if $opt{raise_error};
408 return undef;
409 }
410
411 return $opt{ref} ? $content_ref : $$content_ref;
412}
413
414
415sub decodable
416{
417 # should match the Content-Encoding values that decoded_content can deal with
418 my $self = shift;
419 my @enc;
420 # XXX preferably we should determine if the modules are available without loading
421 # them here
422 eval {
423 require IO::Uncompress::Gunzip;
424 push(@enc, "gzip", "x-gzip");
425 };
426 eval {
427 require IO::Uncompress::Inflate;
428 require IO::Uncompress::RawInflate;
429 push(@enc, "deflate");
430 };
431 eval {
432 require IO::Uncompress::Bunzip2;
433 push(@enc, "x-bzip2");
434 };
435 # we don't care about announcing the 'identity', 'base64' and
436 # 'quoted-printable' stuff
437 return wantarray ? @enc : join(", ", @enc);
438}
439
440
441sub decode
442{
443 my $self = shift;
444 return 1 unless $self->header("Content-Encoding");
445 if (defined(my $content = $self->decoded_content(charset => "none"))) {
446 $self->remove_header("Content-Encoding", "Content-Length", "Content-MD5");
447 $self->content($content);
448 return 1;
449 }
450 return 0;
451}
452
453
454sub encode
455{
456 my($self, @enc) = @_;
457
458 Carp::croak("Can't encode multipart/* messages") if $self->content_type =~ m,^multipart/,;
459 Carp::croak("Can't encode message/* messages") if $self->content_type =~ m,^message/,;
460
461 return 1 unless @enc; # nothing to do
462
463 my $content = $self->content;
464 for my $encoding (@enc) {
465 if ($encoding eq "identity") {
466 # nothing to do
467 }
468 elsif ($encoding eq "base64") {
469 require MIME::Base64;
470 $content = MIME::Base64::encode($content);
471 }
472 elsif ($encoding eq "gzip" || $encoding eq "x-gzip") {
473 require IO::Compress::Gzip;
474 my $output;
475 IO::Compress::Gzip::gzip(\$content, \$output, Minimal => 1)
476 or die "Can't gzip content: $IO::Compress::Gzip::GzipError";
477 $content = $output;
478 }
479 elsif ($encoding eq "deflate") {
480 require IO::Compress::Deflate;
481 my $output;
482 IO::Compress::Deflate::deflate(\$content, \$output)
483 or die "Can't deflate content: $IO::Compress::Deflate::DeflateError";
484 $content = $output;
485 }
486 elsif ($encoding eq "x-bzip2") {
487 require IO::Compress::Bzip2;
488 my $output;
489 IO::Compress::Bzip2::bzip2(\$content, \$output)
490 or die "Can't bzip2 content: $IO::Compress::Bzip2::Bzip2Error";
491 $content = $output;
492 }
493 elsif ($encoding eq "rot13") { # for the fun of it
494 $content =~ tr/A-Za-z/N-ZA-Mn-za-m/;
495 }
496 else {
497 return 0;
498 }
499 }
500 my $h = $self->header("Content-Encoding");
501 unshift(@enc, $h) if $h;
502 $self->header("Content-Encoding", join(", ", @enc));
503 $self->remove_header("Content-Length", "Content-MD5");
504 $self->content($content);
505 return 1;
506}
507
508
509sub as_string
510{
511 my($self, $eol) = @_;
512 $eol = "\n" unless defined $eol;
513
514 # The calculation of content might update the headers
515 # so we need to do that first.
516 my $content = $self->content;
517
518 return join("", $self->{'_headers'}->as_string($eol),
519 $eol,
520 $content,
521 (@_ == 1 && length($content) &&
522 $content !~ /\n\z/) ? "\n" : "",
523 );
524}
525
526
527sub dump
528{
529 my($self, %opt) = @_;
530 my $content = $self->content;
531 my $chopped = 0;
532 if (!ref($content)) {
533 my $maxlen = $opt{maxlength};
534 $maxlen = 512 unless defined($maxlen);
535 if ($maxlen && length($content) > $maxlen * 1.1 + 3) {
536 $chopped = length($content) - $maxlen;
537 $content = substr($content, 0, $maxlen) . "...";
538 }
539
540 $content =~ s/\\/\\\\/g;
541 $content =~ s/\t/\\t/g;
542 $content =~ s/\r/\\r/g;
543
544 # no need for 3 digits in escape for these
545 $content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
546
547 $content =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
548 $content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
549
550 # remaining whitespace
551 $content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg;
552 $content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg;
553 $content =~ s/\n\z/\\n/;
554
555 my $no_content = "(no content)";
556 if ($content eq $no_content) {
557 # escape our $no_content marker
558 $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg;
559 }
560 elsif ($content eq "") {
561 $content = "(no content)";
562 }
563 }
564
565 my @dump;
566 push(@dump, $opt{preheader}) if $opt{preheader};
567 push(@dump, $self->{_headers}->as_string, $content);
568 push(@dump, "(+ $chopped more bytes not shown)") if $chopped;
569
570 my $dump = join("\n", @dump, "");
571 $dump =~ s/^/$opt{prefix}/gm if $opt{prefix};
572
573 print $dump unless defined wantarray;
574 return $dump;
575}
576
577
578sub parts {
579 my $self = shift;
580 if (defined(wantarray) && (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR")) {
581 $self->_parts;
582 }
583 my $old = $self->{_parts};
584 if (@_) {
585 my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
586 my $ct = $self->content_type || "";
587 if ($ct =~ m,^message/,) {
588 Carp::croak("Only one part allowed for $ct content")
589 if @parts > 1;
590 }
591 elsif ($ct !~ m,^multipart/,) {
592 $self->remove_content_headers;
593 $self->content_type("multipart/mixed");
594 }
595 $self->{_parts} = \@parts;
596 _stale_content($self);
597 }
598 return @$old if wantarray;
599 return $old->[0];
600}
601
602sub add_part {
603 my $self = shift;
604 if (($self->content_type || "") !~ m,^multipart/,) {
605 my $p = HTTP::Message->new($self->remove_content_headers,
606 $self->content(""));
607 $self->content_type("multipart/mixed");
608 $self->{_parts} = [];
609 if ($p->headers->header_field_names || $p->content ne "") {
610 push(@{$self->{_parts}}, $p);
611 }
612 }
613 elsif (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR") {
614 $self->_parts;
615 }
616
617 push(@{$self->{_parts}}, @_);
618 _stale_content($self);
619 return;
620}
621
622sub _stale_content {
623 my $self = shift;
624 if (ref($self->{_content}) eq "SCALAR") {
625 # must recalculate now
626 $self->_content;
627 }
628 else {
629 # just invalidate cache
630 delete $self->{_content};
631 delete $self->{_content_ref};
632 }
633}
634
635
636# delegate all other method calls the the headers object.
637sub AUTOLOAD
638{
639 my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
640
641 # We create the function here so that it will not need to be
642 # autoloaded the next time.
6433806µs290µs
# spent 56µs (22+34) within HTTP::Message::BEGIN@643 which was called: # once (22µs+34µs) by LWP::UserAgent::BEGIN@10 at line 643
no strict 'refs';
# spent 56µs making 1 call to HTTP::Message::BEGIN@643 # spent 34µs making 1 call to strict::unimport
644 *$method = sub { shift->headers->$method(@_) };
645 goto &$method;
646}
647
648
649sub DESTROY {} # avoid AUTOLOADing it
650
651
652# Private method to access members in %$self
653sub _elem
654{
655 my $self = shift;
656 my $elem = shift;
657 my $old = $self->{$elem};
658 $self->{$elem} = $_[0] if @_;
659 return $old;
660}
661
662
663# Create private _parts attribute from current _content
664sub _parts {
665 my $self = shift;
666 my $ct = $self->content_type;
667 if ($ct =~ m,^multipart/,) {
668 require HTTP::Headers::Util;
669 my @h = HTTP::Headers::Util::split_header_words($self->header("Content-Type"));
670 die "Assert" unless @h;
671 my %h = @{$h[0]};
672 if (defined(my $b = $h{boundary})) {
673 my $str = $self->content;
674 $str =~ s/\r?\n--\Q$b\E--\r?\n.*//s;
675 if ($str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s) {
676 $self->{_parts} = [map HTTP::Message->parse($_),
677 split(/\r?\n--\Q$b\E\r?\n/, $str)]
678 }
679 }
680 }
681 elsif ($ct eq "message/http") {
682 require HTTP::Request;
683 require HTTP::Response;
684 my $content = $self->content;
685 my $class = ($content =~ m,^(HTTP/.*)\n,) ?
686 "HTTP::Response" : "HTTP::Request";
687 $self->{_parts} = [$class->parse($content)];
688 }
689 elsif ($ct =~ m,^message/,) {
690 $self->{_parts} = [ HTTP::Message->parse($self->content) ];
691 }
692
693 $self->{_parts} ||= [];
694}
695
696
697# Create private _content attribute from current _parts
698sub _content {
699 my $self = shift;
700 my $ct = $self->{_headers}->header("Content-Type") || "multipart/mixed";
701 if ($ct =~ m,^\s*message/,i) {
702 _set_content($self, $self->{_parts}[0]->as_string($CRLF), 1);
703 return;
704 }
705
706 require HTTP::Headers::Util;
707 my @v = HTTP::Headers::Util::split_header_words($ct);
708 Carp::carp("Multiple Content-Type headers") if @v > 1;
709 @v = @{$v[0]};
710
711 my $boundary;
712 my $boundary_index;
713 for (my @tmp = @v; @tmp;) {
714 my($k, $v) = splice(@tmp, 0, 2);
715 if ($k eq "boundary") {
716 $boundary = $v;
717 $boundary_index = @v - @tmp - 1;
718 last;
719 }
720 }
721
722 my @parts = map $_->as_string($CRLF), @{$self->{_parts}};
723
724 my $bno = 0;
725 $boundary = _boundary() unless defined $boundary;
726 CHECK_BOUNDARY:
727 {
728 for (@parts) {
729 if (index($_, $boundary) >= 0) {
730 # must have a better boundary
731 $boundary = _boundary(++$bno);
732 redo CHECK_BOUNDARY;
733 }
734 }
735 }
736
737 if ($boundary_index) {
738 $v[$boundary_index] = $boundary;
739 }
740 else {
741 push(@v, boundary => $boundary);
742 }
743
744 $ct = HTTP::Headers::Util::join_header_words(@v);
745 $self->{_headers}->header("Content-Type", $ct);
746
747 _set_content($self, "--$boundary$CRLF" .
748 join("$CRLF--$boundary$CRLF", @parts) .
749 "$CRLF--$boundary--$CRLF",
750 1);
751}
752
753
754sub _boundary
755{
756 my $size = shift || return "xYzZY";
757 require MIME::Base64;
758 my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
759 $b =~ s/[\W]/X/g; # ensure alnum only
760 $b;
761}
762
763
764112µs1;
765
766
767__END__
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.