← Index
NYTProf Performance Profile   « line view »
For script/ponapi
  Run on Wed Feb 10 15:51:26 2016
Reported on Thu Feb 11 09:43:09 2016

Filename/usr/local/share/perl/5.18.2/HTTP/Message.pm
StatementsExecuted 18 statements in 5.18ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
11116µs39µsHTTP::Message::::BEGIN@3HTTP::Message::BEGIN@3
11112µs21µsHTTP::Message::::BEGIN@4HTTP::Message::BEGIN@4
11112µs33µsHTTP::Message::::BEGIN@651HTTP::Message::BEGIN@651
0000s0sHTTP::Message::::AUTOLOADHTTP::Message::AUTOLOAD
0000s0sHTTP::Message::::DESTROYHTTP::Message::DESTROY
0000s0sHTTP::Message::::__ANON__[:26]HTTP::Message::__ANON__[:26]
0000s0sHTTP::Message::::__ANON__[:29]HTTP::Message::__ANON__[:29]
0000s0sHTTP::Message::::__ANON__[:652]HTTP::Message::__ANON__[:652]
0000s0sHTTP::Message::::_boundaryHTTP::Message::_boundary
0000s0sHTTP::Message::::_contentHTTP::Message::_content
0000s0sHTTP::Message::::_elemHTTP::Message::_elem
0000s0sHTTP::Message::::_part_classHTTP::Message::_part_class
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
3235µs262µs
# spent 39µs (16+23) within HTTP::Message::BEGIN@3 which was called: # once (16µs+23µs) by HTTP::Body::BEGIN@26 at line 3
use strict;
# spent 39µs making 1 call to HTTP::Message::BEGIN@3 # spent 23µs making 1 call to strict::import
424.50ms230µs
# spent 21µs (12+9) within HTTP::Message::BEGIN@4 which was called: # once (12µs+9µs) by HTTP::Body::BEGIN@26 at line 4
use warnings;
# spent 21µs making 1 call to HTTP::Message::BEGIN@4 # spent 9µs making 1 call to warnings::import
5
61400nsour $VERSION = "6.11";
7
81500nsrequire HTTP::Headers;
91400nsrequire Carp;
10
111200nsmy $CRLF = "\015\012"; # "\r\n" is not portable
121200nsunless ($HTTP::URI_CLASS) {
131900ns if ($ENV{PERL_HTTP_URI_CLASS}
14 && $ENV{PERL_HTTP_URI_CLASS} =~ /^([\w:]+)$/) {
15 $HTTP::URI_CLASS = $1;
16 } else {
171300ns $HTTP::URI_CLASS = "URI";
18 }
19}
20219µseval "require $HTTP::URI_CLASS"; die $@ if $@;
# spent 78µs executing statements in string eval
21
22*_utf8_downgrade = defined(&utf8::downgrade) ?
23 sub {
24 utf8::downgrade($_[0], 1) or
25 Carp::croak("HTTP::Message content must be bytes")
26 }
27 :
28 sub {
2917µs };
30
31sub new
32{
33 my($class, $header, $content) = @_;
34 if (defined $header) {
35 Carp::croak("Bad header argument") unless ref $header;
36 if (ref($header) eq "ARRAY") {
37 $header = HTTP::Headers->new(@$header);
38 }
39 else {
40 $header = $header->clone;
41 }
42 }
43 else {
44 $header = HTTP::Headers->new;
45 }
46 if (defined $content) {
47 _utf8_downgrade($content);
48 }
49 else {
50 $content = '';
51 }
52
53 bless {
54 '_headers' => $header,
55 '_content' => $content,
56 }, $class;
57}
58
59
60sub parse
61{
62 my($class, $str) = @_;
63
64 my @hdr;
65 while (1) {
66 if ($str =~ s/^([^\s:]+)[ \t]*: ?(.*)\n?//) {
67 push(@hdr, $1, $2);
68 $hdr[-1] =~ s/\r\z//;
69 }
70 elsif (@hdr && $str =~ s/^([ \t].*)\n?//) {
71 $hdr[-1] .= "\n$1";
72 $hdr[-1] =~ s/\r\z//;
73 }
74 else {
75 $str =~ s/^\r?\n//;
76 last;
77 }
78 }
79 local $HTTP::Headers::TRANSLATE_UNDERSCORE;
80 new($class, \@hdr, $str);
81}
82
83
84sub clone
85{
86 my $self = shift;
87 my $clone = HTTP::Message->new($self->headers,
88 $self->content);
89 $clone->protocol($self->protocol);
90 $clone;
91}
92
93
94sub clear {
95 my $self = shift;
96 $self->{_headers}->clear;
97 $self->content("");
98 delete $self->{_parts};
99 return;
100}
101
102
103sub protocol {
104 shift->_elem('_protocol', @_);
105}
106
107sub headers {
108 my $self = shift;
109
110 # recalculation of _content might change headers, so we
111 # need to force it now
112 $self->_content unless exists $self->{_content};
113
114 $self->{_headers};
115}
116
117sub headers_as_string {
118 shift->headers->as_string(@_);
119}
120
121
122sub content {
123
124 my $self = $_[0];
125 if (defined(wantarray)) {
126 $self->_content unless exists $self->{_content};
127 my $old = $self->{_content};
128 $old = $$old if ref($old) eq "SCALAR";
129 &_set_content if @_ > 1;
130 return $old;
131 }
132
133 if (@_ > 1) {
134 &_set_content;
135 }
136 else {
137 Carp::carp("Useless content call in void context") if $^W;
138 }
139}
140
141
142sub _set_content {
143 my $self = $_[0];
144 _utf8_downgrade($_[1]);
145 if (!ref($_[1]) && ref($self->{_content}) eq "SCALAR") {
146 ${$self->{_content}} = $_[1];
147 }
148 else {
149 die "Can't set content to be a scalar reference" if ref($_[1]) eq "SCALAR";
150 $self->{_content} = $_[1];
151 delete $self->{_content_ref};
152 }
153 delete $self->{_parts} unless $_[2];
154}
155
156
157sub add_content
158{
159 my $self = shift;
160 $self->_content unless exists $self->{_content};
161 my $chunkref = \$_[0];
162 $chunkref = $$chunkref if ref($$chunkref); # legacy
163
164 _utf8_downgrade($$chunkref);
165
166 my $ref = ref($self->{_content});
167 if (!$ref) {
168 $self->{_content} .= $$chunkref;
169 }
170 elsif ($ref eq "SCALAR") {
171 ${$self->{_content}} .= $$chunkref;
172 }
173 else {
174 Carp::croak("Can't append to $ref content");
175 }
176 delete $self->{_parts};
177}
178
179sub add_content_utf8 {
180 my($self, $buf) = @_;
181 utf8::upgrade($buf);
182 utf8::encode($buf);
183 $self->add_content($buf);
184}
185
186sub content_ref
187{
188 my $self = shift;
189 $self->_content unless exists $self->{_content};
190 delete $self->{_parts};
191 my $old = \$self->{_content};
192 my $old_cref = $self->{_content_ref};
193 if (@_) {
194 my $new = shift;
195 Carp::croak("Setting content_ref to a non-ref") unless ref($new);
196 delete $self->{_content}; # avoid modifying $$old
197 $self->{_content} = $new;
198 $self->{_content_ref}++;
199 }
200 $old = $$old if $old_cref;
201 return $old;
202}
203
204
205sub content_charset
206{
207 my $self = shift;
208 if (my $charset = $self->content_type_charset) {
209 return $charset;
210 }
211
212 # time to start guessing
213 my $cref = $self->decoded_content(ref => 1, charset => "none");
214
215 # Unicode BOM
216 for ($$cref) {
217 return "UTF-8" if /^\xEF\xBB\xBF/;
218 return "UTF-32LE" if /^\xFF\xFE\x00\x00/;
219 return "UTF-32BE" if /^\x00\x00\xFE\xFF/;
220 return "UTF-16LE" if /^\xFF\xFE/;
221 return "UTF-16BE" if /^\xFE\xFF/;
222 }
223
224 if ($self->content_is_xml) {
225 # http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing
226 # XML entity not accompanied by external encoding information and not
227 # in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration,
228 # in which the first characters must be '<?xml'
229 for ($$cref) {
230 return "UTF-32BE" if /^\x00\x00\x00</;
231 return "UTF-32LE" if /^<\x00\x00\x00/;
232 return "UTF-16BE" if /^(?:\x00\s)*\x00</;
233 return "UTF-16LE" if /^(?:\s\x00)*<\x00/;
234 if (/^\s*(<\?xml[^\x00]*?\?>)/) {
235 if ($1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/) {
236 my $enc = $2;
237 $enc =~ s/^\s+//; $enc =~ s/\s+\z//;
238 return $enc if $enc;
239 }
240 }
241 }
242 return "UTF-8";
243 }
244 elsif ($self->content_is_html) {
245 # look for <META charset="..."> or <META content="...">
246 # http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding
247 require IO::HTML;
248 # Use relaxed search to match previous versions of HTTP::Message:
249 my $encoding = IO::HTML::find_charset_in($$cref, { encoding => 1,
250 need_pragma => 0 });
251 return $encoding->mime_name if $encoding;
252 }
253 elsif ($self->content_type eq "application/json") {
254 for ($$cref) {
255 # RFC 4627, ch 3
256 return "UTF-32BE" if /^\x00\x00\x00./s;
257 return "UTF-32LE" if /^.\x00\x00\x00/s;
258 return "UTF-16BE" if /^\x00.\x00./s;
259 return "UTF-16LE" if /^.\x00.\x00/s;
260 return "UTF-8";
261 }
262 }
263 if ($self->content_type =~ /^text\//) {
264 for ($$cref) {
265 if (length) {
266 return "US-ASCII" unless /[\x80-\xFF]/;
267 require Encode;
268 eval {
269 Encode::decode_utf8($_, Encode::FB_CROAK() | Encode::LEAVE_SRC());
270 };
271 return "UTF-8" unless $@;
272 return "ISO-8859-1";
273 }
274 }
275 }
276
277 return undef;
278}
279
280
281sub decoded_content
282{
283 my($self, %opt) = @_;
284 my $content_ref;
285 my $content_ref_iscopy;
286
287 eval {
288 $content_ref = $self->content_ref;
289 die "Can't decode ref content" if ref($content_ref) ne "SCALAR";
290
291 if (my $h = $self->header("Content-Encoding")) {
292 $h =~ s/^\s+//;
293 $h =~ s/\s+$//;
294 for my $ce (reverse split(/\s*,\s*/, lc($h))) {
295 next unless $ce;
296 next if $ce eq "identity" || $ce eq "none";
297 if ($ce eq "gzip" || $ce eq "x-gzip") {
298 require IO::Uncompress::Gunzip;
299 my $output;
300 IO::Uncompress::Gunzip::gunzip($content_ref, \$output, Transparent => 0)
301 or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
302 $content_ref = \$output;
303 $content_ref_iscopy++;
304 }
305 elsif ($ce eq "x-bzip2" or $ce eq "bzip2") {
306 require IO::Uncompress::Bunzip2;
307 my $output;
308 IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0)
309 or die "Can't bunzip content: $IO::Uncompress::Bunzip2::Bunzip2Error";
310 $content_ref = \$output;
311 $content_ref_iscopy++;
312 }
313 elsif ($ce eq "deflate") {
314 require IO::Uncompress::Inflate;
315 my $output;
316 my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0);
317 my $error = $IO::Uncompress::Inflate::InflateError;
318 unless ($status) {
319 # "Content-Encoding: deflate" is supposed to mean the
320 # "zlib" format of RFC 1950, but Microsoft got that
321 # wrong, so some servers sends the raw compressed
322 # "deflate" data. This tries to inflate this format.
323 $output = undef;
324 require IO::Uncompress::RawInflate;
325 unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) {
326 $self->push_header("Client-Warning" =>
327 "Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError");
328 $output = undef;
329 }
330 }
331 die "Can't inflate content: $error" unless defined $output;
332 $content_ref = \$output;
333 $content_ref_iscopy++;
334 }
335 elsif ($ce eq "compress" || $ce eq "x-compress") {
336 die "Can't uncompress content";
337 }
338 elsif ($ce eq "base64") { # not really C-T-E, but should be harmless
339 require MIME::Base64;
340 $content_ref = \MIME::Base64::decode($$content_ref);
341 $content_ref_iscopy++;
342 }
343 elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless
344 require MIME::QuotedPrint;
345 $content_ref = \MIME::QuotedPrint::decode($$content_ref);
346 $content_ref_iscopy++;
347 }
348 else {
349 die "Don't know how to decode Content-Encoding '$ce'";
350 }
351 }
352 }
353
354 if ($self->content_is_text || (my $is_xml = $self->content_is_xml)) {
355 my $charset = lc(
356 $opt{charset} ||
357 $self->content_type_charset ||
358 $opt{default_charset} ||
359 $self->content_charset ||
360 "ISO-8859-1"
361 );
362 if ($charset eq "none") {
363 # leave it as is
364 }
365 elsif ($charset eq "us-ascii" || $charset eq "iso-8859-1") {
366 if ($$content_ref =~ /[^\x00-\x7F]/ && defined &utf8::upgrade) {
367 unless ($content_ref_iscopy) {
368 my $copy = $$content_ref;
369 $content_ref = \$copy;
370 $content_ref_iscopy++;
371 }
372 utf8::upgrade($$content_ref);
373 }
374 }
375 else {
376 require Encode;
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 eq "none";
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 = $opt{no_content};
556 $no_content = "(no content)" unless defined $no_content;
557 if ($content eq $no_content) {
558 # escape our $no_content marker
559 $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg;
560 }
561 elsif ($content eq "") {
562 $content = $no_content;
563 }
564 }
565
566 my @dump;
567 push(@dump, $opt{preheader}) if $opt{preheader};
568 push(@dump, $self->{_headers}->as_string, $content);
569 push(@dump, "(+ $chopped more bytes not shown)") if $chopped;
570
571 my $dump = join("\n", @dump, "");
572 $dump =~ s/^/$opt{prefix}/gm if $opt{prefix};
573
574 print $dump unless defined wantarray;
575 return $dump;
576}
577
578# allow subclasses to override what will handle individual parts
579sub _part_class {
580 return __PACKAGE__;
581}
582
583sub parts {
584 my $self = shift;
585 if (defined(wantarray) && (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR")) {
586 $self->_parts;
587 }
588 my $old = $self->{_parts};
589 if (@_) {
590 my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
591 my $ct = $self->content_type || "";
592 if ($ct =~ m,^message/,) {
593 Carp::croak("Only one part allowed for $ct content")
594 if @parts > 1;
595 }
596 elsif ($ct !~ m,^multipart/,) {
597 $self->remove_content_headers;
598 $self->content_type("multipart/mixed");
599 }
600 $self->{_parts} = \@parts;
601 _stale_content($self);
602 }
603 return @$old if wantarray;
604 return $old->[0];
605}
606
607sub add_part {
608 my $self = shift;
609 if (($self->content_type || "") !~ m,^multipart/,) {
610 my $p = $self->_part_class->new(
611 $self->remove_content_headers,
612 $self->content(""),
613 );
614 $self->content_type("multipart/mixed");
615 $self->{_parts} = [];
616 if ($p->headers->header_field_names || $p->content ne "") {
617 push(@{$self->{_parts}}, $p);
618 }
619 }
620 elsif (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR") {
621 $self->_parts;
622 }
623
624 push(@{$self->{_parts}}, @_);
625 _stale_content($self);
626 return;
627}
628
629sub _stale_content {
630 my $self = shift;
631 if (ref($self->{_content}) eq "SCALAR") {
632 # must recalculate now
633 $self->_content;
634 }
635 else {
636 # just invalidate cache
637 delete $self->{_content};
638 delete $self->{_content_ref};
639 }
640}
641
642
643# delegate all other method calls to the headers object.
6441200nsour $AUTOLOAD;
645sub AUTOLOAD
646{
647 my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
648
649 # We create the function here so that it will not need to be
650 # autoloaded the next time.
6512593µs255µs
# spent 33µs (12+22) within HTTP::Message::BEGIN@651 which was called: # once (12µs+22µs) by HTTP::Body::BEGIN@26 at line 651
no strict 'refs';
# spent 33µs making 1 call to HTTP::Message::BEGIN@651 # spent 22µs making 1 call to strict::unimport
652 *$method = sub { local $Carp::Internal{+__PACKAGE__} = 1; shift->headers->$method(@_) };
653 goto &$method;
654}
655
656
657sub DESTROY {} # avoid AUTOLOADing it
658
659
660# Private method to access members in %$self
661sub _elem
662{
663 my $self = shift;
664 my $elem = shift;
665 my $old = $self->{$elem};
666 $self->{$elem} = $_[0] if @_;
667 return $old;
668}
669
670
671# Create private _parts attribute from current _content
672sub _parts {
673 my $self = shift;
674 my $ct = $self->content_type;
675 if ($ct =~ m,^multipart/,) {
676 require HTTP::Headers::Util;
677 my @h = HTTP::Headers::Util::split_header_words($self->header("Content-Type"));
678 die "Assert" unless @h;
679 my %h = @{$h[0]};
680 if (defined(my $b = $h{boundary})) {
681 my $str = $self->content;
682 $str =~ s/\r?\n--\Q$b\E--.*//s;
683 if ($str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s) {
684 $self->{_parts} = [map $self->_part_class->parse($_),
685 split(/\r?\n--\Q$b\E\r?\n/, $str)]
686 }
687 }
688 }
689 elsif ($ct eq "message/http") {
690 require HTTP::Request;
691 require HTTP::Response;
692 my $content = $self->content;
693 my $class = ($content =~ m,^(HTTP/.*)\n,) ?
694 "HTTP::Response" : "HTTP::Request";
695 $self->{_parts} = [$class->parse($content)];
696 }
697 elsif ($ct =~ m,^message/,) {
698 $self->{_parts} = [ $self->_part_class->parse($self->content) ];
699 }
700
701 $self->{_parts} ||= [];
702}
703
704
705# Create private _content attribute from current _parts
706sub _content {
707 my $self = shift;
708 my $ct = $self->{_headers}->header("Content-Type") || "multipart/mixed";
709 if ($ct =~ m,^\s*message/,i) {
710 _set_content($self, $self->{_parts}[0]->as_string($CRLF), 1);
711 return;
712 }
713
714 require HTTP::Headers::Util;
715 my @v = HTTP::Headers::Util::split_header_words($ct);
716 Carp::carp("Multiple Content-Type headers") if @v > 1;
717 @v = @{$v[0]};
718
719 my $boundary;
720 my $boundary_index;
721 for (my @tmp = @v; @tmp;) {
722 my($k, $v) = splice(@tmp, 0, 2);
723 if ($k eq "boundary") {
724 $boundary = $v;
725 $boundary_index = @v - @tmp - 1;
726 last;
727 }
728 }
729
730 my @parts = map $_->as_string($CRLF), @{$self->{_parts}};
731
732 my $bno = 0;
733 $boundary = _boundary() unless defined $boundary;
734 CHECK_BOUNDARY:
735 {
736 for (@parts) {
737 if (index($_, $boundary) >= 0) {
738 # must have a better boundary
739 $boundary = _boundary(++$bno);
740 redo CHECK_BOUNDARY;
741 }
742 }
743 }
744
745 if ($boundary_index) {
746 $v[$boundary_index] = $boundary;
747 }
748 else {
749 push(@v, boundary => $boundary);
750 }
751
752 $ct = HTTP::Headers::Util::join_header_words(@v);
753 $self->{_headers}->header("Content-Type", $ct);
754
755 _set_content($self, "--$boundary$CRLF" .
756 join("$CRLF--$boundary$CRLF", @parts) .
757 "$CRLF--$boundary--$CRLF",
758 1);
759}
760
761
762sub _boundary
763{
764 my $size = shift || return "xYzZY";
765 require MIME::Base64;
766 my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
767 $b =~ s/[\W]/X/g; # ensure alnum only
768 $b;
769}
770
771
772119µs1;
773
774
775__END__