| File | /usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm |
| Statements Executed | 551 |
| Statement Execution Time | 4.82ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 38 | 13 | 6 | 403µs | 1.65ms | HTTP::Message::__ANON__[:622] |
| 39 | 6 | 3 | 148µs | 148µs | HTTP::Message::_elem |
| 8 | 8 | 5 | 134µs | 134µs | HTTP::Message::AUTOLOAD |
| 41 | 2 | 2 | 115µs | 115µs | HTTP::Message::headers |
| 6 | 2 | 2 | 106µs | 141µs | HTTP::Message::new |
| 4 | 1 | 1 | 58µs | 92µs | HTTP::Message::add_content |
| 7 | 2 | 1 | 44µs | 61µs | HTTP::Message::__ANON__[:18] |
| 6 | 2 | 1 | 44µs | 108µs | HTTP::Message::content |
| 3 | 1 | 1 | 37µs | 64µs | HTTP::Message::_set_content |
| 3 | 1 | 1 | 25µs | 25µs | HTTP::Message::content_ref |
| 1 | 1 | 1 | 22µs | 29µs | HTTP::Message::BEGIN@3 |
| 3 | 1 | 1 | 19µs | 32µs | HTTP::Message::protocol |
| 1 | 1 | 1 | 10µs | 29µs | HTTP::Message::BEGIN@621 |
| 1 | 1 | 1 | 7µs | 43µs | HTTP::Message::BEGIN@4 |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::DESTROY |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::__ANON__[:21] |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::__ANON__[:262] |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::_boundary |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::_content |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::_parts |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::_stale_content |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::add_content_utf8 |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::add_part |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::as_string |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::clear |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::clone |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::content_charset |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::decodable |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::decode |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::decoded_content |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::dump |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::encode |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::headers_as_string |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::parse |
| 0 | 0 | 0 | 0s | 0s | HTTP::Message::parts |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package HTTP::Message; | ||||
| 2 | |||||
| 3 | 3 | 32µs | 2 | 36µ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 # spent 29µs making 1 call to HTTP::Message::BEGIN@3
# spent 7µs making 1 call to strict::import |
| 4 | 3 | 2.68ms | 2 | 79µ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 # spent 43µs making 1 call to HTTP::Message::BEGIN@4
# spent 36µs making 1 call to vars::import |
| 5 | 1 | 700ns | $VERSION = "5.834"; | ||
| 6 | |||||
| 7 | 1 | 83µs | require HTTP::Headers; | ||
| 8 | 1 | 700ns | require Carp; | ||
| 9 | |||||
| 10 | 1 | 1µs | my $CRLF = "\015\012"; # "\r\n" is not portable | ||
| 11 | 1 | 2µs | $HTTP::URI_CLASS ||= $ENV{PERL_HTTP_URI_CLASS} || "URI"; | ||
| 12 | 2 | 101µs | eval "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 | ||||
| 16 | 7 | 69µs | 7 | 17µ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 { | ||||
| 21 | 1 | 7µs | }; | ||
| 22 | |||||
| 23 | sub 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 | ||||
| 25 | 36 | 98µ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 | |||||
| 52 | sub 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 | |||||
| 76 | sub 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 | |||||
| 86 | sub 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 | ||||
| 96 | 3 | 17µs | 3 | 14µ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 | ||||
| 100 | 123 | 183µ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 | |||||
| 109 | sub 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 | ||||
| 115 | |||||
| 116 | 30 | 50µ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 | ||||
| 135 | 21 | 35µ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 | |||||
| 149 | sub 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 | ||||
| 151 | 32 | 57µ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 | |||||
| 171 | sub add_content_utf8 { | ||||
| 172 | my($self, $buf) = @_; | ||||
| 173 | utf8::upgrade($buf); | ||||
| 174 | utf8::encode($buf); | ||||
| 175 | $self->add_content($buf); | ||||
| 176 | } | ||||
| 177 | |||||
| 178 | sub 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 | ||||
| 180 | 24 | 27µ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 | |||||
| 197 | sub 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 | |||||
| 287 | sub 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 | |||||
| 393 | sub 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 | |||||
| 419 | sub 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 | |||||
| 432 | sub 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 | |||||
| 487 | sub 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 | |||||
| 505 | sub 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 | |||||
| 556 | sub 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 | |||||
| 580 | sub 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 | |||||
| 600 | sub _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. | ||||
| 615 | sub 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 | ||||
| 617 | 24 | 168µ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. | ||||
| 621 | 3 | 623µs | 2 | 49µ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 # spent 29µs making 1 call to HTTP::Message::BEGIN@621
# spent 20µs making 1 call to strict::unimport |
| 622 | 38 | 337µs | 76 | 1.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 # 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 | |||||
| 627 | sub DESTROY {} # avoid AUTOLOADing it | ||||
| 628 | |||||
| 629 | |||||
| 630 | # Private method to access members in %$self | ||||
| 631 | sub _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 | ||||
| 633 | 195 | 224µ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 | ||||
| 642 | sub _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 | ||||
| 676 | sub _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 | |||||
| 732 | sub _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 | |||||
| 742 | 1 | 18µs | 1; | ||
| 743 | |||||
| 744 | |||||
| 745 | __END__ | ||||
| 746 | |||||
| 747 | =head1 NAME | ||||
| 748 | |||||
| 749 | HTTP::Message - HTTP style message (base class) | ||||
| 750 | |||||
| 751 | =head1 SYNOPSIS | ||||
| 752 | |||||
| 753 | use base 'HTTP::Message'; | ||||
| 754 | |||||
| 755 | =head1 DESCRIPTION | ||||
| 756 | |||||
| 757 | An C<HTTP::Message> object contains some headers and a content body. | ||||
| 758 | The 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 | |||||
| 768 | This constructs a new message object. Normally you would want | ||||
| 769 | construct C<HTTP::Request> or C<HTTP::Response> objects instead. | ||||
| 770 | |||||
| 771 | The optional $header argument should be a reference to an | ||||
| 772 | C<HTTP::Headers> object or a plain array reference of key/value pairs. | ||||
| 773 | If an C<HTTP::Headers> object is provided then a copy of it will be | ||||
| 774 | embedded into the constructed message, i.e. it will not be owned and | ||||
| 775 | can be modified afterwards without affecting the message. | ||||
| 776 | |||||
| 777 | The optional $content argument should be a string of bytes. | ||||
| 778 | |||||
| 779 | =item $mess = HTTP::Message->parse( $str ) | ||||
| 780 | |||||
| 781 | This constructs a new message object by parsing the given string. | ||||
| 782 | |||||
| 783 | =item $mess->headers | ||||
| 784 | |||||
| 785 | Returns the embedded C<HTTP::Headers> object. | ||||
| 786 | |||||
| 787 | =item $mess->headers_as_string | ||||
| 788 | |||||
| 789 | =item $mess->headers_as_string( $eol ) | ||||
| 790 | |||||
| 791 | Call the as_string() method for the headers in the | ||||
| 792 | message. This will be the same as | ||||
| 793 | |||||
| 794 | $mess->headers->as_string | ||||
| 795 | |||||
| 796 | but it will make your program a whole character shorter :-) | ||||
| 797 | |||||
| 798 | =item $mess->content | ||||
| 799 | |||||
| 800 | =item $mess->content( $bytes ) | ||||
| 801 | |||||
| 802 | The content() method sets the raw content if an argument is given. If no | ||||
| 803 | argument is given the content is not touched. In either case the | ||||
| 804 | original raw content is returned. | ||||
| 805 | |||||
| 806 | Note that the content should be a string of bytes. Strings in perl | ||||
| 807 | can contain characters outside the range of a byte. The C<Encode> | ||||
| 808 | module can be used to turn such strings into a string of bytes. | ||||
| 809 | |||||
| 810 | =item $mess->add_content( $bytes ) | ||||
| 811 | |||||
| 812 | The add_content() methods appends more data bytes to the end of the | ||||
| 813 | current content buffer. | ||||
| 814 | |||||
| 815 | =item $mess->add_content_utf8( $string ) | ||||
| 816 | |||||
| 817 | The add_content_utf8() method appends the UTF-8 bytes representing the | ||||
| 818 | string to the end of the current content buffer. | ||||
| 819 | |||||
| 820 | =item $mess->content_ref | ||||
| 821 | |||||
| 822 | =item $mess->content_ref( \$bytes ) | ||||
| 823 | |||||
| 824 | The content_ref() method will return a reference to content buffer string. | ||||
| 825 | It can be more efficient to access the content this way if the content | ||||
| 826 | is huge, and it can even be used for direct manipulation of the content, | ||||
| 827 | for instance: | ||||
| 828 | |||||
| 829 | ${$res->content_ref} =~ s/\bfoo\b/bar/g; | ||||
| 830 | |||||
| 831 | This example would modify the content buffer in-place. | ||||
| 832 | |||||
| 833 | If an argument is passed it will setup the content to reference some | ||||
| 834 | external source. The content() and add_content() methods | ||||
| 835 | will automatically dereference scalar references passed this way. For | ||||
| 836 | other references content() will return the reference itself and | ||||
| 837 | add_content() will refuse to do anything. | ||||
| 838 | |||||
| 839 | =item $mess->content_charset | ||||
| 840 | |||||
| 841 | This returns the charset used by the content in the message. The | ||||
| 842 | charset is either found as the charset attribute of the | ||||
| 843 | C<Content-Type> header or by guessing. | ||||
| 844 | |||||
| 845 | See L<http://www.w3.org/TR/REC-html40/charset.html#spec-char-encoding> | ||||
| 846 | for details about how charset is determined. | ||||
| 847 | |||||
| 848 | =item $mess->decoded_content( %options ) | ||||
| 849 | |||||
| 850 | Returns the content with any C<Content-Encoding> undone and the raw | ||||
| 851 | content encoded to perl's Unicode strings. If the C<Content-Encoding> | ||||
| 852 | or C<charset> of the message is unknown this method will fail by | ||||
| 853 | returning C<undef>. | ||||
| 854 | |||||
| 855 | The following options can be specified. | ||||
| 856 | |||||
| 857 | =over | ||||
| 858 | |||||
| 859 | =item C<charset> | ||||
| 860 | |||||
| 861 | This override the charset parameter for text content. The value | ||||
| 862 | C<none> can used to suppress decoding of the charset. | ||||
| 863 | |||||
| 864 | =item C<default_charset> | ||||
| 865 | |||||
| 866 | This override the default charset guessed by content_charset() or | ||||
| 867 | if that fails "ISO-8859-1". | ||||
| 868 | |||||
| 869 | =item C<charset_strict> | ||||
| 870 | |||||
| 871 | Abort decoding if malformed characters is found in the content. By | ||||
| 872 | default you get the substitution character ("\x{FFFD}") in place of | ||||
| 873 | malformed characters. | ||||
| 874 | |||||
| 875 | =item C<raise_error> | ||||
| 876 | |||||
| 877 | If TRUE then raise an exception if not able to decode content. Reason | ||||
| 878 | might be that the specified C<Content-Encoding> or C<charset> is not | ||||
| 879 | supported. If this option is FALSE, then decoded_content() will return | ||||
| 880 | C<undef> on errors, but will still set $@. | ||||
| 881 | |||||
| 882 | =item C<ref> | ||||
| 883 | |||||
| 884 | If TRUE then a reference to decoded content is returned. This might | ||||
| 885 | be more efficient in cases where the decoded content is identical to | ||||
| 886 | the 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 | |||||
| 894 | This returns the encoding identifiers that decoded_content() can | ||||
| 895 | process. In scalar context returns a comma separated string of | ||||
| 896 | identifiers. | ||||
| 897 | |||||
| 898 | This value is suitable for initializing the C<Accept-Encoding> request | ||||
| 899 | header field. | ||||
| 900 | |||||
| 901 | =item $mess->decode | ||||
| 902 | |||||
| 903 | This method tries to replace the content of the message with the | ||||
| 904 | decoded version and removes the C<Content-Encoding> header. Returns | ||||
| 905 | TRUE if successful and FALSE if not. | ||||
| 906 | |||||
| 907 | If the message does not have a C<Content-Encoding> header this method | ||||
| 908 | does nothing and returns TRUE. | ||||
| 909 | |||||
| 910 | Note that the content of the message is still bytes after this method | ||||
| 911 | has been called and you still need to call decoded_content() if you | ||||
| 912 | want to process its content as a string. | ||||
| 913 | |||||
| 914 | =item $mess->encode( $encoding, ... ) | ||||
| 915 | |||||
| 916 | Apply the given encodings to the content of the message. Returns TRUE | ||||
| 917 | if successful. The "identity" (non-)encoding is always supported; other | ||||
| 918 | currently supported encodings, subject to availability of required | ||||
| 919 | additional modules, are "gzip", "deflate", "x-bzip2" and "base64". | ||||
| 920 | |||||
| 921 | A successful call to this function will set the C<Content-Encoding> | ||||
| 922 | header. | ||||
| 923 | |||||
| 924 | Note that C<multipart/*> or C<message/*> messages can't be encoded and | ||||
| 925 | this method will croak if you try. | ||||
| 926 | |||||
| 927 | =item $mess->parts | ||||
| 928 | |||||
| 929 | =item $mess->parts( @parts ) | ||||
| 930 | |||||
| 931 | =item $mess->parts( \@parts ) | ||||
| 932 | |||||
| 933 | Messages can be composite, i.e. contain other messages. The composite | ||||
| 934 | messages have a content type of C<multipart/*> or C<message/*>. This | ||||
| 935 | method give access to the contained messages. | ||||
| 936 | |||||
| 937 | The argumentless form will return a list of C<HTTP::Message> objects. | ||||
| 938 | If the content type of $msg is not C<multipart/*> or C<message/*> then | ||||
| 939 | this will return the empty list. In scalar context only the first | ||||
| 940 | object is returned. The returned message parts should be regarded as | ||||
| 941 | read-only (future versions of this library might make it possible | ||||
| 942 | to modify the parent by modifying the parts). | ||||
| 943 | |||||
| 944 | If the content type of $msg is C<message/*> then there will only be | ||||
| 945 | one part returned. | ||||
| 946 | |||||
| 947 | If the content type is C<message/http>, then the return value will be | ||||
| 948 | either an C<HTTP::Request> or an C<HTTP::Response> object. | ||||
| 949 | |||||
| 950 | If an @parts argument is given, then the content of the message will be | ||||
| 951 | modified. The array reference form is provided so that an empty list | ||||
| 952 | can be provided. The @parts array should contain C<HTTP::Message> | ||||
| 953 | objects. The @parts objects are owned by $mess after this call and | ||||
| 954 | should not be modified or made part of other messages. | ||||
| 955 | |||||
| 956 | When 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 | ||||
| 958 | set to C<multipart/mixed> and all other content headers are cleared. | ||||
| 959 | |||||
| 960 | This method will croak if the content type is C<message/*> and more | ||||
| 961 | than one part is provided. | ||||
| 962 | |||||
| 963 | =item $mess->add_part( $part ) | ||||
| 964 | |||||
| 965 | This will add a part to a message. The $part argument should be | ||||
| 966 | another C<HTTP::Message> object. If the previous content type of | ||||
| 967 | $mess is not C<multipart/*> then the old content (together with all | ||||
| 968 | content headers) will be made part #1 and the content type made | ||||
| 969 | C<multipart/mixed> before the new part is added. The $part object is | ||||
| 970 | owned by $mess after this call and should not be modified or made part | ||||
| 971 | of other messages. | ||||
| 972 | |||||
| 973 | There is no return value. | ||||
| 974 | |||||
| 975 | =item $mess->clear | ||||
| 976 | |||||
| 977 | Will clear the headers and set the content to the empty string. There | ||||
| 978 | is no return value | ||||
| 979 | |||||
| 980 | =item $mess->protocol | ||||
| 981 | |||||
| 982 | =item $mess->protocol( $proto ) | ||||
| 983 | |||||
| 984 | Sets the HTTP protocol used for the message. The protocol() is a string | ||||
| 985 | like C<HTTP/1.0> or C<HTTP/1.1>. | ||||
| 986 | |||||
| 987 | =item $mess->clone | ||||
| 988 | |||||
| 989 | Returns a copy of the message object. | ||||
| 990 | |||||
| 991 | =item $mess->as_string | ||||
| 992 | |||||
| 993 | =item $mess->as_string( $eol ) | ||||
| 994 | |||||
| 995 | Returns the message formatted as a single string. | ||||
| 996 | |||||
| 997 | The optional $eol parameter specifies the line ending sequence to use. | ||||
| 998 | The default is "\n". If no $eol is given then as_string will ensure | ||||
| 999 | that the returned string is newline terminated (even when the message | ||||
| 1000 | content is not). No extra newline is appended if an explicit $eol is | ||||
| 1001 | passed. | ||||
| 1002 | |||||
| 1003 | =item $mess->dump( %opt ) | ||||
| 1004 | |||||
| 1005 | Returns the message formatted as a string. In void context print the string. | ||||
| 1006 | |||||
| 1007 | This differs from C<< $mess->as_string >> in that it escapes the bytes | ||||
| 1008 | of the content so that it's safe to print them and it limits how much | ||||
| 1009 | content to print. The escapes syntax used is the same as for Perl's | ||||
| 1010 | double quoted strings. If there is no content the string "(no | ||||
| 1011 | content)" is shown in its place. | ||||
| 1012 | |||||
| 1013 | Options to influence the output can be passed as key/value pairs. The | ||||
| 1014 | following options are recognized: | ||||
| 1015 | |||||
| 1016 | =over | ||||
| 1017 | |||||
| 1018 | =item maxlength => $num | ||||
| 1019 | |||||
| 1020 | How much of the content to show. The default is 512. Set this to 0 | ||||
| 1021 | for unlimited. | ||||
| 1022 | |||||
| 1023 | If the content is longer then the string is chopped at the limit and | ||||
| 1024 | the string "...\n(### more bytes not shown)" appended. | ||||
| 1025 | |||||
| 1026 | =item prefix => $str | ||||
| 1027 | |||||
| 1028 | A string that will be prefixed to each line of the dump. | ||||
| 1029 | |||||
| 1030 | =back | ||||
| 1031 | |||||
| 1032 | =back | ||||
| 1033 | |||||
| 1034 | All methods unknown to C<HTTP::Message> itself are delegated to the | ||||
| 1035 | C<HTTP::Headers> object that is part of every message. This allows | ||||
| 1036 | convenient access to these methods. Refer to L<HTTP::Headers> for | ||||
| 1037 | details 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 | |||||
| 1069 | Copyright 1995-2004 Gisle Aas. | ||||
| 1070 | |||||
| 1071 | This library is free software; you can redistribute it and/or | ||||
| 1072 | modify it under the same terms as Perl itself. | ||||
| 1073 |