File | /usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm |
Statements Executed | 7070 |
Statement Execution Time | 15.9ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
532 | 13 | 6 | 4.92ms | 19.0ms | __ANON__[:622] | HTTP::Message::
533 | 6 | 3 | 1.83ms | 1.83ms | _elem | HTTP::Message::
573 | 2 | 2 | 1.42ms | 1.42ms | headers | HTTP::Message::
82 | 2 | 2 | 1.26ms | 1.78ms | new | HTTP::Message::
57 | 1 | 1 | 728µs | 1.20ms | add_content | HTTP::Message::
98 | 2 | 1 | 558µs | 712µs | __ANON__[:18] | HTTP::Message::
82 | 2 | 1 | 557µs | 1.25ms | content | HTTP::Message::
41 | 1 | 1 | 447µs | 690µs | _set_content | HTTP::Message::
41 | 1 | 1 | 333µs | 333µs | content_ref | HTTP::Message::
41 | 1 | 1 | 255µs | 429µs | protocol | HTTP::Message::
8 | 8 | 5 | 107µs | 107µs | AUTOLOAD | HTTP::Message::
1 | 1 | 1 | 16µs | 19µs | BEGIN@3 | HTTP::Message::
1 | 1 | 1 | 9µs | 28µs | BEGIN@621 | HTTP::Message::
1 | 1 | 1 | 5µs | 33µs | BEGIN@4 | HTTP::Message::
0 | 0 | 0 | 0s | 0s | DESTROY | HTTP::Message::
0 | 0 | 0 | 0s | 0s | __ANON__[:21] | HTTP::Message::
0 | 0 | 0 | 0s | 0s | __ANON__[:262] | HTTP::Message::
0 | 0 | 0 | 0s | 0s | _boundary | HTTP::Message::
0 | 0 | 0 | 0s | 0s | _content | HTTP::Message::
0 | 0 | 0 | 0s | 0s | _parts | HTTP::Message::
0 | 0 | 0 | 0s | 0s | _stale_content | HTTP::Message::
0 | 0 | 0 | 0s | 0s | add_content_utf8 | HTTP::Message::
0 | 0 | 0 | 0s | 0s | add_part | HTTP::Message::
0 | 0 | 0 | 0s | 0s | as_string | HTTP::Message::
0 | 0 | 0 | 0s | 0s | clear | HTTP::Message::
0 | 0 | 0 | 0s | 0s | clone | HTTP::Message::
0 | 0 | 0 | 0s | 0s | content_charset | HTTP::Message::
0 | 0 | 0 | 0s | 0s | decodable | HTTP::Message::
0 | 0 | 0 | 0s | 0s | decode | HTTP::Message::
0 | 0 | 0 | 0s | 0s | decoded_content | HTTP::Message::
0 | 0 | 0 | 0s | 0s | dump | HTTP::Message::
0 | 0 | 0 | 0s | 0s | encode | HTTP::Message::
0 | 0 | 0 | 0s | 0s | headers_as_string | HTTP::Message::
0 | 0 | 0 | 0s | 0s | parse | HTTP::Message::
0 | 0 | 0 | 0s | 0s | parts | HTTP::Message::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package HTTP::Message; | ||||
2 | |||||
3 | 3 | 24µs | 2 | 22µs | # spent 19µs (16+3) within HTTP::Message::BEGIN@3 which was called
# once (16µs+3µs) by LWP::UserAgent::BEGIN@10 at line 3 # spent 19µs making 1 call to HTTP::Message::BEGIN@3
# spent 3µs making 1 call to strict::import |
4 | 3 | 2.57ms | 2 | 60µs | # spent 33µs (5+27) within HTTP::Message::BEGIN@4 which was called
# once (5µs+27µs) by LWP::UserAgent::BEGIN@10 at line 4 # spent 33µs making 1 call to HTTP::Message::BEGIN@4
# spent 27µs making 1 call to vars::import |
5 | 1 | 600ns | $VERSION = "5.834"; | ||
6 | |||||
7 | 1 | 84µs | require HTTP::Headers; | ||
8 | 1 | 300ns | require Carp; | ||
9 | |||||
10 | 1 | 400ns | my $CRLF = "\015\012"; # "\r\n" is not portable | ||
11 | 1 | 1µ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 712µs (558+154) within HTTP::Message::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm:18] which was called 98 times, avg 7µs/call:
# 57 times (365µs+104µs) by HTTP::Message::add_content at line 156, avg 8µs/call
# 41 times (193µs+51µs) by HTTP::Message::_set_content at line 136, avg 6µs/call | ||||
16 | 98 | 755µs | 98 | 154µs | utf8::downgrade($_[0], 1) or # spent 154µs making 98 calls to utf8::downgrade, avg 2µs/call |
17 | Carp::croak("HTTP::Message content must be bytes") | ||||
18 | } | ||||
19 | : | ||||
20 | sub { | ||||
21 | 1 | 4µs | }; | ||
22 | |||||
23 | sub new | ||||
24 | # spent 1.78ms (1.26+512µs) within HTTP::Message::new which was called 82 times, avg 22µs/call:
# 41 times (800µs+344µs) by HTTP::Response::new at line 15 of HTTP/Response.pm, avg 28µs/call
# 41 times (464µs+167µs) by HTTP::Request::new at line 14 of HTTP/Request.pm, avg 15µs/call | ||||
25 | 492 | 1.10ms | 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 512µs making 82 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 429µs (255+174) within HTTP::Message::protocol which was called 41 times, avg 10µs/call:
# 41 times (255µs+174µs) by LWP::Protocol::http::request at line 359 of LWP/Protocol/http.pm, avg 10µs/call | ||||
96 | 41 | 218µs | 41 | 174µs | shift->_elem('_protocol', @_); # spent 174µs making 41 calls to HTTP::Message::_elem, avg 4µs/call |
97 | } | ||||
98 | |||||
99 | # spent 1.42ms within HTTP::Message::headers which was called 573 times, avg 2µs/call:
# 532 times (1.33ms+0s) by HTTP::Message::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm:622] at line 622, avg 2µs/call
# 41 times (94µs+0s) by LWP::Protocol::http::request at line 159 of LWP/Protocol/http.pm, avg 2µs/call | ||||
100 | 1719 | 2.18ms | 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 1.25ms (557µs+690µs) within HTTP::Message::content which was called 82 times, avg 15µs/call:
# 41 times (223µs+690µs) by SimpleDB::Client::construct_request at line 183 of SimpleDB/Client.pm, avg 22µs/call
# 41 times (334µs+0s) by SimpleDB::Client::handle_response at line 250 of SimpleDB/Client.pm, avg 8µs/call | ||||
115 | |||||
116 | 410 | 556µ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 690µs making 41 calls to HTTP::Message::_set_content, avg 17µ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 690µs (447+243) within HTTP::Message::_set_content which was called 41 times, avg 17µs/call:
# 41 times (447µs+243µs) by HTTP::Message::content at line 125, avg 17µs/call | ||||
135 | 287 | 427µs | my $self = $_[0]; | ||
136 | _utf8_downgrade($_[1]); # spent 243µs making 41 calls to HTTP::Message::__ANON__[HTTP/Message.pm:18], avg 6µ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 1.20ms (728µs+469µs) within HTTP::Message::add_content which was called 57 times, avg 21µs/call:
# 57 times (728µs+469µ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 21µs/call | ||||
151 | 456 | 715µ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 469µs making 57 calls to HTTP::Message::__ANON__[HTTP/Message.pm:18], avg 8µ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 333µs within HTTP::Message::content_ref which was called 41 times, avg 8µs/call:
# 41 times (333µs+0s) by LWP::Protocol::http::request at line 169 of LWP/Protocol/http.pm, avg 8µs/call | ||||
180 | 328 | 311µ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 107µs within HTTP::Message::AUTOLOAD which was called 8 times, avg 13µs/call:
# once (22µs+0s) by LWP::Protocol::http::request at line 362 of LWP/Protocol/http.pm
# once (17µ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 (14µs+0s) by LWP::UserAgent::prepare_request at line 217 of LWP/UserAgent.pm
# once (14µs+0s) by SimpleDB::Client::construct_request at line 182 of SimpleDB/Client.pm
# once (11µs+0s) by LWP::Protocol::http::_get_sock_info at line 77 of LWP/Protocol/http.pm
# once (10µ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
# once (10µs+0s) by LWP::Protocol::http::request at line 374 of LWP/Protocol/http.pm
# once (10µs+0s) by LWP::Protocol::collect at line 145 of LWP/Protocol.pm | ||||
617 | 24 | 142µ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 | 610µs | 2 | 48µs | # spent 28µs (9+19) within HTTP::Message::BEGIN@621 which was called
# once (9µs+19µs) by LWP::UserAgent::BEGIN@10 at line 621 # spent 28µs making 1 call to HTTP::Message::BEGIN@621
# spent 19µs making 1 call to strict::unimport |
622 | 532 | 3.73ms | 1064 | 14.1ms | # spent 19.0ms (4.92+14.1) within HTTP::Message::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm:622] which was called 532 times, avg 36µs/call:
# 80 times (719µs+1.54ms) by LWP::Protocol::http::request at line 374 of LWP/Protocol/http.pm, avg 28µs/call
# 41 times (292µs+1.07ms) by LWP::UserAgent::send_request at line 196 of LWP/UserAgent.pm, avg 33µs/call
# 41 times (344µs+934µs) by LWP::Protocol::http::request at line 406 of LWP/Protocol/http.pm, avg 31µs/call
# 41 times (433µs+822µ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 31µs/call
# 41 times (319µs+693µs) by LWP::Protocol::http::request at line 377 of LWP/Protocol/http.pm, avg 25µs/call
# 40 times (537µs+2.93ms) by LWP::Protocol::http::request at line 362 of LWP/Protocol/http.pm, avg 87µs/call
# 40 times (423µs+1.61ms) by LWP::Protocol::http::_get_sock_info at line 77 of LWP/Protocol/http.pm, avg 51µs/call
# 40 times (364µs+1.61ms) 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 49µs/call
# 40 times (402µs+825µs) by LWP::Protocol::collect at line 145 of LWP/Protocol.pm, avg 31µs/call
# 40 times (327µs+838µs) by LWP::UserAgent::prepare_request at line 217 of LWP/UserAgent.pm, avg 29µs/call
# 40 times (335µs+672µ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 25µs/call
# 40 times (338µs+315µs) by SimpleDB::Client::construct_request at line 182 of SimpleDB/Client.pm, avg 16µs/call
# 8 times (83µs+262µ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 43µs/call # spent 4.08ms making 122 calls to HTTP::Headers::push_header, avg 33µs/call
# spent 3.37ms making 123 calls to HTTP::Headers::header, avg 27µs/call
# spent 1.57ms making 41 calls to HTTP::Headers::content_is_html, avg 38µs/call
# spent 1.33ms making 532 calls to HTTP::Message::headers, avg 2µs/call
# spent 918µs making 82 calls to HTTP::Headers::content_type, avg 11µs/call
# spent 781µs making 41 calls to HTTP::Headers::init_header, avg 19µs/call
# spent 757µs making 41 calls to HTTP::Headers::content_length, avg 18µs/call
# spent 711µs making 41 calls to HTTP::Headers::remove_header, avg 17µs/call
# spent 604µs making 41 calls to HTTP::Headers::content_is_xhtml, avg 15µs/call |
623 | goto &$method; # spent 345µs making 8 calls to HTTP::Message::__ANON__[HTTP/Message.pm:622], avg 43µ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 1.83ms within HTTP::Message::_elem which was called 533 times, avg 3µs/call:
# 164 times (467µs+0s) by HTTP::Request::method at line 54 of HTTP/Request.pm, avg 3µs/call
# 123 times (471µs+0s) by HTTP::Response::code at line 61 of HTTP/Response.pm, avg 4µs/call
# 123 times (431µs+0s) by HTTP::Response::request at line 64 of HTTP/Response.pm, avg 4µs/call
# 41 times (174µs+0s) by HTTP::Message::protocol at line 96, avg 4µs/call
# 41 times (162µs+0s) by HTTP::Response::message at line 62 of HTTP/Response.pm, avg 4µs/call
# 41 times (125µs+0s) by HTTP::Response::previous at line 63 of HTTP/Response.pm, avg 3µs/call | ||||
633 | 2665 | 2.37ms | 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 | 20µ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 |