Profile of HTTP/Message.pm

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

Filename | /usr/local/share/perl/5.18.2/HTTP/Message.pm
Statements | Executed 18 statements in 5.18ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 16µs | 39µs | HTTP::Message::::BEGIN@3HTTP::Message::BEGIN@3
1 | 1 | 1 | 12µs | 21µs | HTTP::Message::::BEGIN@4HTTP::Message::BEGIN@4
1 | 1 | 1 | 12µs | 33µs | HTTP::Message::::BEGIN@651HTTP::Message::BEGIN@651
0 | 0 | 0 | 0s | 0s | HTTP::Message::::AUTOLOADHTTP::Message::AUTOLOAD
0 | 0 | 0 | 0s | 0s | HTTP::Message::::DESTROYHTTP::Message::DESTROY
0 | 0 | 0 | 0s | 0s | HTTP::Message::::__ANON__[:26]HTTP::Message::__ANON__[:26]
0 | 0 | 0 | 0s | 0s | HTTP::Message::::__ANON__[:29]HTTP::Message::__ANON__[:29]
0 | 0 | 0 | 0s | 0s | HTTP::Message::::__ANON__[:652]HTTP::Message::__ANON__[:652]
0 | 0 | 0 | 0s | 0s | HTTP::Message::::_boundaryHTTP::Message::_boundary
0 | 0 | 0 | 0s | 0s | HTTP::Message::::_contentHTTP::Message::_content
0 | 0 | 0 | 0s | 0s | HTTP::Message::::_elemHTTP::Message::_elem
0 | 0 | 0 | 0s | 0s | HTTP::Message::::_part_classHTTP::Message::_part_class
0 | 0 | 0 | 0s | 0s | HTTP::Message::::_partsHTTP::Message::_parts
0 | 0 | 0 | 0s | 0s | HTTP::Message::::_set_contentHTTP::Message::_set_content
0 | 0 | 0 | 0s | 0s | HTTP::Message::::_stale_contentHTTP::Message::_stale_content
0 | 0 | 0 | 0s | 0s | HTTP::Message::::add_contentHTTP::Message::add_content
0 | 0 | 0 | 0s | 0s | HTTP::Message::::add_content_utf8HTTP::Message::add_content_utf8
0 | 0 | 0 | 0s | 0s | HTTP::Message::::add_partHTTP::Message::add_part
0 | 0 | 0 | 0s | 0s | HTTP::Message::::as_stringHTTP::Message::as_string
0 | 0 | 0 | 0s | 0s | HTTP::Message::::clearHTTP::Message::clear
0 | 0 | 0 | 0s | 0s | HTTP::Message::::cloneHTTP::Message::clone
0 | 0 | 0 | 0s | 0s | HTTP::Message::::contentHTTP::Message::content
0 | 0 | 0 | 0s | 0s | HTTP::Message::::content_charsetHTTP::Message::content_charset
0 | 0 | 0 | 0s | 0s | HTTP::Message::::content_refHTTP::Message::content_ref
0 | 0 | 0 | 0s | 0s | HTTP::Message::::decodableHTTP::Message::decodable
0 | 0 | 0 | 0s | 0s | HTTP::Message::::decodeHTTP::Message::decode
0 | 0 | 0 | 0s | 0s | HTTP::Message::::decoded_contentHTTP::Message::decoded_content
0 | 0 | 0 | 0s | 0s | HTTP::Message::::dumpHTTP::Message::dump
0 | 0 | 0 | 0s | 0s | HTTP::Message::::encodeHTTP::Message::encode
0 | 0 | 0 | 0s | 0s | HTTP::Message::::headersHTTP::Message::headers
0 | 0 | 0 | 0s | 0s | HTTP::Message::::headers_as_stringHTTP::Message::headers_as_string
0 | 0 | 0 | 0s | 0s | HTTP::Message::::newHTTP::Message::new
0 | 0 | 0 | 0s | 0s | HTTP::Message::::parseHTTP::Message::parse
0 | 0 | 0 | 0s | 0s | HTTP::Message::::partsHTTP::Message::parts
0 | 0 | 0 | 0s | 0s | HTTP::Message::::protocolHTTP::Message::protocol

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
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 use strict; # 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 use warnings; # 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 no strict 'refs'; # spent 33µs making 1 call to HTTP::Message::BEGIN@651 # spent 22µs making 1 call to strict::unimport
652 |  |  |  |  | *$method = sub { local $Carp::Internal{+__PACKAGE__} = 1; shift->headers->$method(@_) };
653 |  |  |  |  | goto &$method;
654 |  |  |  |  | }
655 |  |  |  |  |
656 |  |  |  |  |
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__