← Index
NYTProf Performance Profile   « block view • line view • sub view »
For 01.HTTP.t
  Run on Tue May 4 15:25:55 2010
Reported on Tue May 4 15:26:06 2010

File /usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm
Statements Executed 551
Statement Execution Time 4.82ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
38136403µs1.65msHTTP::Message::::__ANON__[:622]HTTP::Message::__ANON__[:622]
3963148µs148µsHTTP::Message::::_elemHTTP::Message::_elem
885134µs134µsHTTP::Message::::AUTOLOADHTTP::Message::AUTOLOAD
4122115µs115µsHTTP::Message::::headersHTTP::Message::headers
622106µs141µsHTTP::Message::::newHTTP::Message::new
41158µs92µsHTTP::Message::::add_contentHTTP::Message::add_content
72144µs61µsHTTP::Message::::__ANON__[:18]HTTP::Message::__ANON__[:18]
62144µs108µsHTTP::Message::::contentHTTP::Message::content
31137µs64µsHTTP::Message::::_set_contentHTTP::Message::_set_content
31125µs25µsHTTP::Message::::content_refHTTP::Message::content_ref
11122µs29µsHTTP::Message::::BEGIN@3HTTP::Message::BEGIN@3
31119µs32µsHTTP::Message::::protocolHTTP::Message::protocol
11110µs29µsHTTP::Message::::BEGIN@621HTTP::Message::BEGIN@621
1117µs43µsHTTP::Message::::BEGIN@4HTTP::Message::BEGIN@4
0000s0sHTTP::Message::::DESTROYHTTP::Message::DESTROY
0000s0sHTTP::Message::::__ANON__[:21]HTTP::Message::__ANON__[:21]
0000s0sHTTP::Message::::__ANON__[:262]HTTP::Message::__ANON__[:262]
0000s0sHTTP::Message::::_boundaryHTTP::Message::_boundary
0000s0sHTTP::Message::::_contentHTTP::Message::_content
0000s0sHTTP::Message::::_partsHTTP::Message::_parts
0000s0sHTTP::Message::::_stale_contentHTTP::Message::_stale_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::::content_charsetHTTP::Message::content_charset
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::::headers_as_stringHTTP::Message::headers_as_string
0000s0sHTTP::Message::::parseHTTP::Message::parse
0000s0sHTTP::Message::::partsHTTP::Message::parts
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
3332µs236µs
# spent 29µs (22+7) within HTTP::Message::BEGIN@3 which was called # once (22µs+7µs) by LWP::UserAgent::BEGIN@10 at line 3
use strict;
# spent 29µs making 1 call to HTTP::Message::BEGIN@3 # spent 7µs making 1 call to strict::import
432.68ms279µs
# spent 43µs (7+36) within HTTP::Message::BEGIN@4 which was called # once (7µs+36µs) by LWP::UserAgent::BEGIN@10 at line 4
use vars qw($VERSION $AUTOLOAD);
# spent 43µs making 1 call to HTTP::Message::BEGIN@4 # spent 36µs making 1 call to vars::import
51700ns$VERSION = "5.834";
6
7183µsrequire HTTP::Headers;
81700nsrequire Carp;
9
1011µsmy $CRLF = "\015\012"; # "\r\n" is not portable
1112µs$HTTP::URI_CLASS ||= $ENV{PERL_HTTP_URI_CLASS} || "URI";
122101µseval "require $HTTP::URI_CLASS"; die $@ if $@;
13
14*_utf8_downgrade = defined(&utf8::downgrade) ?
15
# spent 61µs (44+17) within HTTP::Message::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm:18] which was called 7 times, avg 9µs/call: # 4 times (26µs+8µs) by HTTP::Message::add_content at line 156, avg 9µs/call # 3 times (18µs+9µs) by HTTP::Message::_set_content at line 136, avg 9µs/call
sub {
16769µs717µs utf8::downgrade($_[0], 1) or
# spent 17µs making 7 calls to utf8::downgrade, avg 2µs/call
17 Carp::croak("HTTP::Message content must be bytes")
18 }
19 :
20 sub {
2117µs };
22
23sub new
24
# spent 141µs (106+35) within HTTP::Message::new which was called 6 times, avg 23µs/call: # 3 times (68µs+24µs) by HTTP::Response::new at line 15 of HTTP/Response.pm, avg 31µs/call # 3 times (37µs+11µs) by HTTP::Request::new at line 14 of HTTP/Request.pm, avg 16µs/call
{
253698µs 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;
# spent 35µs making 6 calls to HTTP::Headers::new, avg 6µs/call
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
95
# spent 32µs (19+14) within HTTP::Message::protocol which was called 3 times, avg 11µs/call: # 3 times (19µs+14µs) by LWP::Protocol::http::request at line 359 of LWP/Protocol/http.pm, avg 11µs/call
sub protocol {
96317µs314µs shift->_elem('_protocol', @_);
# spent 14µs making 3 calls to HTTP::Message::_elem, avg 5µs/call
97}
98
99
# spent 115µs within HTTP::Message::headers which was called 41 times, avg 3µs/call: # 38 times (102µs+0s) by HTTP::Message::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm:622] at line 622, avg 3µs/call # 3 times (13µs+0s) by LWP::Protocol::http::request at line 159 of LWP/Protocol/http.pm, avg 4µs/call
sub headers {
100123183µs 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
114
# spent 108µs (44+64) within HTTP::Message::content which was called 6 times, avg 18µs/call: # 3 times (20µs+64µs) by SimpleDB::Client::construct_request at line 178 of ../lib/SimpleDB/Client.pm, avg 28µs/call # 3 times (24µs+0s) by SimpleDB::Client::handle_response at line 245 of ../lib/SimpleDB/Client.pm, avg 8µs/call
sub content {
115
1163050µs 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) {
# spent 64µs making 3 calls to HTTP::Message::_set_content, avg 21µs/call
126 &_set_content;
127 }
128 else {
129 Carp::carp("Useless content call in void context") if $^W;
130 }
131}
132
133
134
# spent 64µs (37+27) within HTTP::Message::_set_content which was called 3 times, avg 21µs/call: # 3 times (37µs+27µs) by HTTP::Message::content at line 125, avg 21µs/call
sub _set_content {
1352135µs my $self = $_[0];
136 _utf8_downgrade($_[1]);
# spent 27µs making 3 calls to HTTP::Message::__ANON__[HTTP/Message.pm:18], avg 9µs/call
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
# spent 92µs (58+34) within HTTP::Message::add_content which was called 4 times, avg 23µs/call: # 4 times (58µs+34µs) by LWP::Protocol::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/LWP/Protocol.pm:139] at line 137 of LWP/Protocol.pm, avg 23µs/call
{
1513257µs 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);
# spent 34µs making 4 calls to HTTP::Message::__ANON__[HTTP/Message.pm:18], avg 9µs/call
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
# spent 25µs within HTTP::Message::content_ref which was called 3 times, avg 8µs/call: # 3 times (25µs+0s) by LWP::Protocol::http::request at line 169 of LWP/Protocol/http.pm, avg 8µs/call
{
1802427µs 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 local $_;
209 for ($$cref) {
210 return "UTF-8" if /^\xEF\xBB\xBF/;
211 return "UTF-32-LE" if /^\xFF\xFE\x00\x00/;
212 return "UTF-32-BE" if /^\x00\x00\xFE\xFF/;
213 return "UTF-16-LE" if /^\xFF\xFE/;
214 return "UTF-16-BE" if /^\xFE\xFF/;
215 }
216
217 if ($self->content_is_xml) {
218 # http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing
219 # XML entity not accompanied by external encoding information and not
220 # in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration,
221 # in which the first characters must be '<?xml'
222 for ($$cref) {
223 return "UTF-32-BE" if /^\x00\x00\x00</;
224 return "UTF-32-LE" if /^<\x00\x00\x00/;
225 return "UTF-16-BE" if /^(?:\x00\s)*\x00</;
226 return "UTF-16-LE" if /^(?:\s\x00)*<\x00/;
227 if (/^\s*(<\?xml[^\x00]*?\?>)/) {
228 if ($1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/) {
229 my $enc = $2;
230 $enc =~ s/^\s+//; $enc =~ s/\s+\z//;
231 return $enc if $enc;
232 }
233 }
234 }
235 return "UTF-8";
236 }
237 elsif ($self->content_is_html) {
238 # look for <META charset="..."> or <META content="...">
239 # http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding
240 my $charset;
241 require HTML::Parser;
242 my $p = HTML::Parser->new(
243 start_h => [sub {
244 my($tag, $attr, $self) = @_;
245 $charset = $attr->{charset};
246 unless ($charset) {
247 # look at $attr->{content} ...
248 if (my $c = $attr->{content}) {
249 require HTTP::Headers::Util;
250 my @v = HTTP::Headers::Util::split_header_words($c);
251 return unless @v;
252 my($ct, undef, %ct_param) = @{$v[0]};
253 $charset = $ct_param{charset};
254 }
255 return unless $charset;
256 }
257 if ($charset =~ /^utf-?16/i) {
258 # converted document, assume UTF-8
259 $charset = "UTF-8";
260 }
261 $self->eof;
262 }, "tagname, attr, self"],
263 report_tags => [qw(meta)],
264 utf8_mode => 1,
265 );
266 $p->parse($$cref);
267 return $charset if $charset;
268 }
269 if ($self->content_type =~ /^text\//) {
270 for ($$cref) {
271 if (length) {
272 return "US-ASCII" unless /[\x80-\xFF]/;
273 require Encode;
274 eval {
275 Encode::decode_utf8($_, Encode::FB_CROAK());
276 };
277 return "UTF-8" unless $@;
278 return "ISO-8859-1";
279 }
280 }
281 }
282
283 return undef;
284}
285
286
287sub decoded_content
288{
289 my($self, %opt) = @_;
290 my $content_ref;
291 my $content_ref_iscopy;
292
293 eval {
294 $content_ref = $self->content_ref;
295 die "Can't decode ref content" if ref($content_ref) ne "SCALAR";
296
297 if (my $h = $self->header("Content-Encoding")) {
298 $h =~ s/^\s+//;
299 $h =~ s/\s+$//;
300 for my $ce (reverse split(/\s*,\s*/, lc($h))) {
301 next unless $ce;
302 next if $ce eq "identity";
303 if ($ce eq "gzip" || $ce eq "x-gzip") {
304 require IO::Uncompress::Gunzip;
305 my $output;
306 IO::Uncompress::Gunzip::gunzip($content_ref, \$output, Transparent => 0)
307 or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
308 $content_ref = \$output;
309 $content_ref_iscopy++;
310 }
311 elsif ($ce eq "x-bzip2") {
312 require IO::Uncompress::Bunzip2;
313 my $output;
314 IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0)
315 or die "Can't bunzip content: $IO::Uncompress::Bunzip2::Bunzip2Error";
316 $content_ref = \$output;
317 $content_ref_iscopy++;
318 }
319 elsif ($ce eq "deflate") {
320 require IO::Uncompress::Inflate;
321 my $output;
322 my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0);
323 my $error = $IO::Uncompress::Inflate::InflateError;
324 unless ($status) {
325 # "Content-Encoding: deflate" is supposed to mean the
326 # "zlib" format of RFC 1950, but Microsoft got that
327 # wrong, so some servers sends the raw compressed
328 # "deflate" data. This tries to inflate this format.
329 $output = undef;
330 require IO::Uncompress::RawInflate;
331 unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) {
332 $self->push_header("Client-Warning" =>
333 "Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError");
334 $output = undef;
335 }
336 }
337 die "Can't inflate content: $error" unless defined $output;
338 $content_ref = \$output;
339 $content_ref_iscopy++;
340 }
341 elsif ($ce eq "compress" || $ce eq "x-compress") {
342 die "Can't uncompress content";
343 }
344 elsif ($ce eq "base64") { # not really C-T-E, but should be harmless
345 require MIME::Base64;
346 $content_ref = \MIME::Base64::decode($$content_ref);
347 $content_ref_iscopy++;
348 }
349 elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless
350 require MIME::QuotedPrint;
351 $content_ref = \MIME::QuotedPrint::decode($$content_ref);
352 $content_ref_iscopy++;
353 }
354 else {
355 die "Don't know how to decode Content-Encoding '$ce'";
356 }
357 }
358 }
359
360 if ($self->content_is_text || $self->content_is_xml) {
361 my $charset = lc(
362 $opt{charset} ||
363 $self->content_type_charset ||
364 $opt{default_charset} ||
365 $self->content_charset ||
366 "ISO-8859-1"
367 );
368 unless ($charset =~ /^(?:none|us-ascii|iso-8859-1)\z/) {
369 require Encode;
370 if (do{my $v = $Encode::VERSION; $v =~ s/_//g; $v} < 2.0901 &&
371 !$content_ref_iscopy)
372 {
373 # LEAVE_SRC did not work before Encode-2.0901
374 my $copy = $$content_ref;
375 $content_ref = \$copy;
376 $content_ref_iscopy++;
377 }
378 $content_ref = \Encode::decode($charset, $$content_ref,
379 ($opt{charset_strict} ? Encode::FB_CROAK() : 0) | Encode::LEAVE_SRC());
380 die "Encode::decode() returned undef improperly" unless defined $$content_ref;
381 }
382 }
383 };
384 if ($@) {
385 Carp::croak($@) if $opt{raise_error};
386 return undef;
387 }
388
389 return $opt{ref} ? $content_ref : $$content_ref;
390}
391
392
393sub decodable
394{
395 # should match the Content-Encoding values that decoded_content can deal with
396 my $self = shift;
397 my @enc;
398 # XXX preferably we should determine if the modules are available without loading
399 # them here
400 eval {
401 require IO::Uncompress::Gunzip;
402 push(@enc, "gzip", "x-gzip");
403 };
404 eval {
405 require IO::Uncompress::Inflate;
406 require IO::Uncompress::RawInflate;
407 push(@enc, "deflate");
408 };
409 eval {
410 require IO::Uncompress::Bunzip2;
411 push(@enc, "x-bzip2");
412 };
413 # we don't care about announcing the 'identity', 'base64' and
414 # 'quoted-printable' stuff
415 return wantarray ? @enc : join(", ", @enc);
416}
417
418
419sub decode
420{
421 my $self = shift;
422 return 1 unless $self->header("Content-Encoding");
423 if (defined(my $content = $self->decoded_content(charset => "none"))) {
424 $self->remove_header("Content-Encoding", "Content-Length", "Content-MD5");
425 $self->content($content);
426 return 1;
427 }
428 return 0;
429}
430
431
432sub encode
433{
434 my($self, @enc) = @_;
435
436 Carp::croak("Can't encode multipart/* messages") if $self->content_type =~ m,^multipart/,;
437 Carp::croak("Can't encode message/* messages") if $self->content_type =~ m,^message/,;
438
439 return 1 unless @enc; # nothing to do
440
441 my $content = $self->content;
442 for my $encoding (@enc) {
443 if ($encoding eq "identity") {
444 # nothing to do
445 }
446 elsif ($encoding eq "base64") {
447 require MIME::Base64;
448 $content = MIME::Base64::encode($content);
449 }
450 elsif ($encoding eq "gzip" || $encoding eq "x-gzip") {
451 require IO::Compress::Gzip;
452 my $output;
453 IO::Compress::Gzip::gzip(\$content, \$output, Minimal => 1)
454 or die "Can't gzip content: $IO::Compress::Gzip::GzipError";
455 $content = $output;
456 }
457 elsif ($encoding eq "deflate") {
458 require IO::Compress::Deflate;
459 my $output;
460 IO::Compress::Deflate::deflate(\$content, \$output)
461 or die "Can't deflate content: $IO::Compress::Deflate::DeflateError";
462 $content = $output;
463 }
464 elsif ($encoding eq "x-bzip2") {
465 require IO::Compress::Bzip2;
466 my $output;
467 IO::Compress::Bzip2::bzip2(\$content, \$output)
468 or die "Can't bzip2 content: $IO::Compress::Bzip2::Bzip2Error";
469 $content = $output;
470 }
471 elsif ($encoding eq "rot13") { # for the fun of it
472 $content =~ tr/A-Za-z/N-ZA-Mn-za-m/;
473 }
474 else {
475 return 0;
476 }
477 }
478 my $h = $self->header("Content-Encoding");
479 unshift(@enc, $h) if $h;
480 $self->header("Content-Encoding", join(", ", @enc));
481 $self->remove_header("Content-Length", "Content-MD5");
482 $self->content($content);
483 return 1;
484}
485
486
487sub as_string
488{
489 my($self, $eol) = @_;
490 $eol = "\n" unless defined $eol;
491
492 # The calculation of content might update the headers
493 # so we need to do that first.
494 my $content = $self->content;
495
496 return join("", $self->{'_headers'}->as_string($eol),
497 $eol,
498 $content,
499 (@_ == 1 && length($content) &&
500 $content !~ /\n\z/) ? "\n" : "",
501 );
502}
503
504
505sub dump
506{
507 my($self, %opt) = @_;
508 my $content = $self->content;
509 my $chopped = 0;
510 if (!ref($content)) {
511 my $maxlen = $opt{maxlength};
512 $maxlen = 512 unless defined($maxlen);
513 if ($maxlen && length($content) > $maxlen * 1.1 + 3) {
514 $chopped = length($content) - $maxlen;
515 $content = substr($content, 0, $maxlen) . "...";
516 }
517
518 $content =~ s/\\/\\\\/g;
519 $content =~ s/\t/\\t/g;
520 $content =~ s/\r/\\r/g;
521
522 # no need for 3 digits in escape for these
523 $content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
524
525 $content =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
526 $content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
527
528 # remaining whitespace
529 $content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg;
530 $content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg;
531 $content =~ s/\n\z/\\n/;
532
533 my $no_content = "(no content)";
534 if ($content eq $no_content) {
535 # escape our $no_content marker
536 $content =~ s/^(.)/sprintf('\\x%02X',ord($1))/eg;
537 }
538 elsif ($content eq "") {
539 $content = "(no content)";
540 }
541 }
542
543 my @dump;
544 push(@dump, $opt{preheader}) if $opt{preheader};
545 push(@dump, $self->{_headers}->as_string, $content);
546 push(@dump, "(+ $chopped more bytes not shown)") if $chopped;
547
548 my $dump = join("\n", @dump, "");
549 $dump =~ s/^/$opt{prefix}/gm if $opt{prefix};
550
551 print $dump unless defined wantarray;
552 return $dump;
553}
554
555
556sub parts {
557 my $self = shift;
558 if (defined(wantarray) && (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR")) {
559 $self->_parts;
560 }
561 my $old = $self->{_parts};
562 if (@_) {
563 my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
564 my $ct = $self->content_type || "";
565 if ($ct =~ m,^message/,) {
566 Carp::croak("Only one part allowed for $ct content")
567 if @parts > 1;
568 }
569 elsif ($ct !~ m,^multipart/,) {
570 $self->remove_content_headers;
571 $self->content_type("multipart/mixed");
572 }
573 $self->{_parts} = \@parts;
574 _stale_content($self);
575 }
576 return @$old if wantarray;
577 return $old->[0];
578}
579
580sub add_part {
581 my $self = shift;
582 if (($self->content_type || "") !~ m,^multipart/,) {
583 my $p = HTTP::Message->new($self->remove_content_headers,
584 $self->content(""));
585 $self->content_type("multipart/mixed");
586 $self->{_parts} = [];
587 if ($p->headers->header_field_names || $p->content ne "") {
588 push(@{$self->{_parts}}, $p);
589 }
590 }
591 elsif (!exists $self->{_parts} || ref($self->{_content}) eq "SCALAR") {
592 $self->_parts;
593 }
594
595 push(@{$self->{_parts}}, @_);
596 _stale_content($self);
597 return;
598}
599
600sub _stale_content {
601 my $self = shift;
602 if (ref($self->{_content}) eq "SCALAR") {
603 # must recalculate now
604 $self->_content;
605 }
606 else {
607 # just invalidate cache
608 delete $self->{_content};
609 delete $self->{_content_ref};
610 }
611}
612
613
614# delegate all other method calls the the headers object.
615sub AUTOLOAD
616
# spent 134µs within HTTP::Message::AUTOLOAD which was called 8 times, avg 17µs/call: # once (28µs+0s) by LWP::Protocol::http::request at line 362 of LWP/Protocol/http.pm # once (22µs+0s) by LWP::Protocol::collect at line 145 of LWP/Protocol.pm # once (20µs+0s) by SimpleDB::Client::construct_request at line 177 of ../lib/SimpleDB/Client.pm # once (13µs+0s) by HTTP::Config::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Config.pm:152] at line 148 of HTTP/Config.pm # once (13µs+0s) by LWP::Protocol::http::_get_sock_info at line 77 of LWP/Protocol/http.pm # once (13µs+0s) by LWP::UserAgent::prepare_request at line 217 of LWP/UserAgent.pm # once (13µs+0s) by LWP::Protocol::http::request at line 374 of LWP/Protocol/http.pm # once (12µs+0s) by HTTP::Config::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Config.pm:152] at line 149 of HTTP/Config.pm
{
61724168µs my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
618
619 # We create the function here so that it will not need to be
620 # autoloaded the next time.
6213623µs249µs
# spent 29µs (10+20) within HTTP::Message::BEGIN@621 which was called # once (10µs+20µs) by LWP::UserAgent::BEGIN@10 at line 621
no strict 'refs';
# spent 29µs making 1 call to HTTP::Message::BEGIN@621 # spent 20µs making 1 call to strict::unimport
62238337µs761.24ms
# spent 1.65ms (403µs+1.24) within HTTP::Message::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm:622] which was called 38 times, avg 43µs/call: # 8 times (108µs+318µs) by HTTP::Config::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Config.pm:152] or LWP::Protocol::collect or LWP::Protocol::http::_get_sock_info or LWP::Protocol::http::request or LWP::UserAgent::prepare_request or SimpleDB::Client::construct_request at line 623, avg 53µs/call # 4 times (39µs+104µs) by LWP::Protocol::http::request at line 374 of LWP/Protocol/http.pm, avg 36µs/call # 3 times (31µs+132µs) by LWP::UserAgent::send_request at line 196 of LWP/UserAgent.pm, avg 54µs/call # 3 times (24µs+85µs) by LWP::Protocol::http::request at line 377 of LWP/Protocol/http.pm, avg 37µs/call # 3 times (30µs+78µs) by LWP::Protocol::http::request at line 406 of LWP/Protocol/http.pm, avg 36µs/call # 3 times (32µs+66µs) by HTTP::Config::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Config.pm:152] at line 146 of HTTP/Config.pm, avg 33µs/call # 2 times (28µs+156µs) by LWP::Protocol::http::request at line 362 of LWP/Protocol/http.pm, avg 92µs/call # 2 times (19µs+87µs) by HTTP::Config::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Config.pm:152] at line 148 of HTTP/Config.pm, avg 53µs/call # 2 times (20µs+83µs) by LWP::Protocol::http::_get_sock_info at line 77 of LWP/Protocol/http.pm, avg 52µs/call # 2 times (21µs+44µs) by LWP::Protocol::collect at line 145 of LWP/Protocol.pm, avg 32µs/call # 2 times (16µs+42µs) by LWP::UserAgent::prepare_request at line 217 of LWP/UserAgent.pm, avg 29µs/call # 2 times (19µs+37µs) by HTTP::Config::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Config.pm:152] at line 149 of HTTP/Config.pm, avg 28µs/call # 2 times (16µs+13µs) by SimpleDB::Client::construct_request at line 177 of ../lib/SimpleDB/Client.pm, avg 14µs/call
*$method = sub { shift->headers->$method(@_) };
# spent 361µs making 8 calls to HTTP::Headers::push_header, avg 45µs/call # spent 349µs making 9 calls to HTTP::Headers::header, avg 39µs/call # spent 126µs making 3 calls to HTTP::Headers::content_is_html, avg 42µs/call # spent 102µs making 38 calls to HTTP::Message::headers, avg 3µs/call # spent 74µs making 6 calls to HTTP::Headers::content_type, avg 12µs/call # spent 66µs making 3 calls to HTTP::Headers::content_length, avg 22µs/call # spent 63µs making 3 calls to HTTP::Headers::init_header, avg 21µs/call # spent 53µs making 3 calls to HTTP::Headers::remove_header, avg 18µs/call # spent 49µs making 3 calls to HTTP::Headers::content_is_xhtml, avg 16µs/call
623 goto &$method;
# spent 426µs making 8 calls to HTTP::Message::__ANON__[HTTP/Message.pm:622], avg 53µs/call
624}
625
626
627sub DESTROY {} # avoid AUTOLOADing it
628
629
630# Private method to access members in %$self
631sub _elem
632
# spent 148µs within HTTP::Message::_elem which was called 39 times, avg 4µs/call: # 12 times (40µs+0s) by HTTP::Request::method at line 54 of HTTP/Request.pm, avg 3µs/call # 9 times (37µs+0s) by HTTP::Response::request at line 64 of HTTP/Response.pm, avg 4µs/call # 9 times (36µs+0s) by HTTP::Response::code at line 61 of HTTP/Response.pm, avg 4µs/call # 3 times (14µs+0s) by HTTP::Message::protocol at line 96, avg 5µs/call # 3 times (12µs+0s) by HTTP::Response::message at line 62 of HTTP/Response.pm, avg 4µs/call # 3 times (9µs+0s) by HTTP::Response::previous at line 63 of HTTP/Response.pm, avg 3µs/call
{
633195224µs my $self = shift;
634 my $elem = shift;
635 my $old = $self->{$elem};
636 $self->{$elem} = $_[0] if @_;
637 return $old;
638}
639
640
641# Create private _parts attribute from current _content
642sub _parts {
643 my $self = shift;
644 my $ct = $self->content_type;
645 if ($ct =~ m,^multipart/,) {
646 require HTTP::Headers::Util;
647 my @h = HTTP::Headers::Util::split_header_words($self->header("Content-Type"));
648 die "Assert" unless @h;
649 my %h = @{$h[0]};
650 if (defined(my $b = $h{boundary})) {
651 my $str = $self->content;
652 $str =~ s/\r?\n--\Q$b\E--\r?\n.*//s;
653 if ($str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s) {
654 $self->{_parts} = [map HTTP::Message->parse($_),
655 split(/\r?\n--\Q$b\E\r?\n/, $str)]
656 }
657 }
658 }
659 elsif ($ct eq "message/http") {
660 require HTTP::Request;
661 require HTTP::Response;
662 my $content = $self->content;
663 my $class = ($content =~ m,^(HTTP/.*)\n,) ?
664 "HTTP::Response" : "HTTP::Request";
665 $self->{_parts} = [$class->parse($content)];
666 }
667 elsif ($ct =~ m,^message/,) {
668 $self->{_parts} = [ HTTP::Message->parse($self->content) ];
669 }
670
671 $self->{_parts} ||= [];
672}
673
674
675# Create private _content attribute from current _parts
676sub _content {
677 my $self = shift;
678 my $ct = $self->{_headers}->header("Content-Type") || "multipart/mixed";
679 if ($ct =~ m,^\s*message/,i) {
680 _set_content($self, $self->{_parts}[0]->as_string($CRLF), 1);
681 return;
682 }
683
684 require HTTP::Headers::Util;
685 my @v = HTTP::Headers::Util::split_header_words($ct);
686 Carp::carp("Multiple Content-Type headers") if @v > 1;
687 @v = @{$v[0]};
688
689 my $boundary;
690 my $boundary_index;
691 for (my @tmp = @v; @tmp;) {
692 my($k, $v) = splice(@tmp, 0, 2);
693 if ($k eq "boundary") {
694 $boundary = $v;
695 $boundary_index = @v - @tmp - 1;
696 last;
697 }
698 }
699
700 my @parts = map $_->as_string($CRLF), @{$self->{_parts}};
701
702 my $bno = 0;
703 $boundary = _boundary() unless defined $boundary;
704 CHECK_BOUNDARY:
705 {
706 for (@parts) {
707 if (index($_, $boundary) >= 0) {
708 # must have a better boundary
709 $boundary = _boundary(++$bno);
710 redo CHECK_BOUNDARY;
711 }
712 }
713 }
714
715 if ($boundary_index) {
716 $v[$boundary_index] = $boundary;
717 }
718 else {
719 push(@v, boundary => $boundary);
720 }
721
722 $ct = HTTP::Headers::Util::join_header_words(@v);
723 $self->{_headers}->header("Content-Type", $ct);
724
725 _set_content($self, "--$boundary$CRLF" .
726 join("$CRLF--$boundary$CRLF", @parts) .
727 "$CRLF--$boundary--$CRLF",
728 1);
729}
730
731
732sub _boundary
733{
734 my $size = shift || return "xYzZY";
735 require MIME::Base64;
736 my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
737 $b =~ s/[\W]/X/g; # ensure alnum only
738 $b;
739}
740
741
742118µs1;
743
744
745__END__
746
747=head1 NAME
748
749HTTP::Message - HTTP style message (base class)
750
751=head1 SYNOPSIS
752
753 use base 'HTTP::Message';
754
755=head1 DESCRIPTION
756
757An C<HTTP::Message> object contains some headers and a content body.
758The following methods are available:
759
760=over 4
761
762=item $mess = HTTP::Message->new
763
764=item $mess = HTTP::Message->new( $headers )
765
766=item $mess = HTTP::Message->new( $headers, $content )
767
768This constructs a new message object. Normally you would want
769construct C<HTTP::Request> or C<HTTP::Response> objects instead.
770
771The optional $header argument should be a reference to an
772C<HTTP::Headers> object or a plain array reference of key/value pairs.
773If an C<HTTP::Headers> object is provided then a copy of it will be
774embedded into the constructed message, i.e. it will not be owned and
775can be modified afterwards without affecting the message.
776
777The optional $content argument should be a string of bytes.
778
779=item $mess = HTTP::Message->parse( $str )
780
781This constructs a new message object by parsing the given string.
782
783=item $mess->headers
784
785Returns the embedded C<HTTP::Headers> object.
786
787=item $mess->headers_as_string
788
789=item $mess->headers_as_string( $eol )
790
791Call the as_string() method for the headers in the
792message. This will be the same as
793
794 $mess->headers->as_string
795
796but it will make your program a whole character shorter :-)
797
798=item $mess->content
799
800=item $mess->content( $bytes )
801
802The content() method sets the raw content if an argument is given. If no
803argument is given the content is not touched. In either case the
804original raw content is returned.
805
806Note that the content should be a string of bytes. Strings in perl
807can contain characters outside the range of a byte. The C<Encode>
808module can be used to turn such strings into a string of bytes.
809
810=item $mess->add_content( $bytes )
811
812The add_content() methods appends more data bytes to the end of the
813current content buffer.
814
815=item $mess->add_content_utf8( $string )
816
817The add_content_utf8() method appends the UTF-8 bytes representing the
818string to the end of the current content buffer.
819
820=item $mess->content_ref
821
822=item $mess->content_ref( \$bytes )
823
824The content_ref() method will return a reference to content buffer string.
825It can be more efficient to access the content this way if the content
826is huge, and it can even be used for direct manipulation of the content,
827for instance:
828
829 ${$res->content_ref} =~ s/\bfoo\b/bar/g;
830
831This example would modify the content buffer in-place.
832
833If an argument is passed it will setup the content to reference some
834external source. The content() and add_content() methods
835will automatically dereference scalar references passed this way. For
836other references content() will return the reference itself and
837add_content() will refuse to do anything.
838
839=item $mess->content_charset
840
841This returns the charset used by the content in the message. The
842charset is either found as the charset attribute of the
843C<Content-Type> header or by guessing.
844
845See L<http://www.w3.org/TR/REC-html40/charset.html#spec-char-encoding>
846for details about how charset is determined.
847
848=item $mess->decoded_content( %options )
849
850Returns the content with any C<Content-Encoding> undone and the raw
851content encoded to perl's Unicode strings. If the C<Content-Encoding>
852or C<charset> of the message is unknown this method will fail by
853returning C<undef>.
854
855The following options can be specified.
856
857=over
858
859=item C<charset>
860
861This override the charset parameter for text content. The value
862C<none> can used to suppress decoding of the charset.
863
864=item C<default_charset>
865
866This override the default charset guessed by content_charset() or
867if that fails "ISO-8859-1".
868
869=item C<charset_strict>
870
871Abort decoding if malformed characters is found in the content. By
872default you get the substitution character ("\x{FFFD}") in place of
873malformed characters.
874
875=item C<raise_error>
876
877If TRUE then raise an exception if not able to decode content. Reason
878might be that the specified C<Content-Encoding> or C<charset> is not
879supported. If this option is FALSE, then decoded_content() will return
880C<undef> on errors, but will still set $@.
881
882=item C<ref>
883
884If TRUE then a reference to decoded content is returned. This might
885be more efficient in cases where the decoded content is identical to
886the raw content as no data copying is required in this case.
887
888=back
889
890=item $mess->decodable
891
892=item HTTP::Message::decodable()
893
894This returns the encoding identifiers that decoded_content() can
895process. In scalar context returns a comma separated string of
896identifiers.
897
898This value is suitable for initializing the C<Accept-Encoding> request
899header field.
900
901=item $mess->decode
902
903This method tries to replace the content of the message with the
904decoded version and removes the C<Content-Encoding> header. Returns
905TRUE if successful and FALSE if not.
906
907If the message does not have a C<Content-Encoding> header this method
908does nothing and returns TRUE.
909
910Note that the content of the message is still bytes after this method
911has been called and you still need to call decoded_content() if you
912want to process its content as a string.
913
914=item $mess->encode( $encoding, ... )
915
916Apply the given encodings to the content of the message. Returns TRUE
917if successful. The "identity" (non-)encoding is always supported; other
918currently supported encodings, subject to availability of required
919additional modules, are "gzip", "deflate", "x-bzip2" and "base64".
920
921A successful call to this function will set the C<Content-Encoding>
922header.
923
924Note that C<multipart/*> or C<message/*> messages can't be encoded and
925this method will croak if you try.
926
927=item $mess->parts
928
929=item $mess->parts( @parts )
930
931=item $mess->parts( \@parts )
932
933Messages can be composite, i.e. contain other messages. The composite
934messages have a content type of C<multipart/*> or C<message/*>. This
935method give access to the contained messages.
936
937The argumentless form will return a list of C<HTTP::Message> objects.
938If the content type of $msg is not C<multipart/*> or C<message/*> then
939this will return the empty list. In scalar context only the first
940object is returned. The returned message parts should be regarded as
941read-only (future versions of this library might make it possible
942to modify the parent by modifying the parts).
943
944If the content type of $msg is C<message/*> then there will only be
945one part returned.
946
947If the content type is C<message/http>, then the return value will be
948either an C<HTTP::Request> or an C<HTTP::Response> object.
949
950If an @parts argument is given, then the content of the message will be
951modified. The array reference form is provided so that an empty list
952can be provided. The @parts array should contain C<HTTP::Message>
953objects. The @parts objects are owned by $mess after this call and
954should not be modified or made part of other messages.
955
956When updating the message with this method and the old content type of
957$mess is not C<multipart/*> or C<message/*>, then the content type is
958set to C<multipart/mixed> and all other content headers are cleared.
959
960This method will croak if the content type is C<message/*> and more
961than one part is provided.
962
963=item $mess->add_part( $part )
964
965This will add a part to a message. The $part argument should be
966another C<HTTP::Message> object. If the previous content type of
967$mess is not C<multipart/*> then the old content (together with all
968content headers) will be made part #1 and the content type made
969C<multipart/mixed> before the new part is added. The $part object is
970owned by $mess after this call and should not be modified or made part
971of other messages.
972
973There is no return value.
974
975=item $mess->clear
976
977Will clear the headers and set the content to the empty string. There
978is no return value
979
980=item $mess->protocol
981
982=item $mess->protocol( $proto )
983
984Sets the HTTP protocol used for the message. The protocol() is a string
985like C<HTTP/1.0> or C<HTTP/1.1>.
986
987=item $mess->clone
988
989Returns a copy of the message object.
990
991=item $mess->as_string
992
993=item $mess->as_string( $eol )
994
995Returns the message formatted as a single string.
996
997The optional $eol parameter specifies the line ending sequence to use.
998The default is "\n". If no $eol is given then as_string will ensure
999that the returned string is newline terminated (even when the message
1000content is not). No extra newline is appended if an explicit $eol is
1001passed.
1002
1003=item $mess->dump( %opt )
1004
1005Returns the message formatted as a string. In void context print the string.
1006
1007This differs from C<< $mess->as_string >> in that it escapes the bytes
1008of the content so that it's safe to print them and it limits how much
1009content to print. The escapes syntax used is the same as for Perl's
1010double quoted strings. If there is no content the string "(no
1011content)" is shown in its place.
1012
1013Options to influence the output can be passed as key/value pairs. The
1014following options are recognized:
1015
1016=over
1017
1018=item maxlength => $num
1019
1020How much of the content to show. The default is 512. Set this to 0
1021for unlimited.
1022
1023If the content is longer then the string is chopped at the limit and
1024the string "...\n(### more bytes not shown)" appended.
1025
1026=item prefix => $str
1027
1028A string that will be prefixed to each line of the dump.
1029
1030=back
1031
1032=back
1033
1034All methods unknown to C<HTTP::Message> itself are delegated to the
1035C<HTTP::Headers> object that is part of every message. This allows
1036convenient access to these methods. Refer to L<HTTP::Headers> for
1037details of these methods:
1038
1039 $mess->header( $field => $val )
1040 $mess->push_header( $field => $val )
1041 $mess->init_header( $field => $val )
1042 $mess->remove_header( $field )
1043 $mess->remove_content_headers
1044 $mess->header_field_names
1045 $mess->scan( \&doit )
1046
1047 $mess->date
1048 $mess->expires
1049 $mess->if_modified_since
1050 $mess->if_unmodified_since
1051 $mess->last_modified
1052 $mess->content_type
1053 $mess->content_encoding
1054 $mess->content_length
1055 $mess->content_language
1056 $mess->title
1057 $mess->user_agent
1058 $mess->server
1059 $mess->from
1060 $mess->referer
1061 $mess->www_authenticate
1062 $mess->authorization
1063 $mess->proxy_authorization
1064 $mess->authorization_basic
1065 $mess->proxy_authorization_basic
1066
1067=head1 COPYRIGHT
1068
1069Copyright 1995-2004 Gisle Aas.
1070
1071This library is free software; you can redistribute it and/or
1072modify it under the same terms as Perl itself.
1073