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