Profile of /usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm

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

File | /usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm
Statements Executed | 551
Statement Execution Time | 4.82ms

Subroutines — ordered by exclusive time
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
38 | 13 | 6 | 403µs | 1.65ms | HTTP::Message::::__ANON__[:622]HTTP::Message::__ANON__[:622]
39 | 6 | 3 | 148µs | 148µs | HTTP::Message::::_elemHTTP::Message::_elem
8 | 8 | 5 | 134µs | 134µs | HTTP::Message::::AUTOLOADHTTP::Message::AUTOLOAD
41 | 2 | 2 | 115µs | 115µs | HTTP::Message::::headersHTTP::Message::headers
6 | 2 | 2 | 106µs | 141µs | HTTP::Message::::newHTTP::Message::new
4 | 1 | 1 | 58µs | 92µs | HTTP::Message::::add_contentHTTP::Message::add_content
7 | 2 | 1 | 44µs | 61µs | HTTP::Message::::__ANON__[:18]HTTP::Message::__ANON__[:18]
6 | 2 | 1 | 44µs | 108µs | HTTP::Message::::contentHTTP::Message::content
3 | 1 | 1 | 37µs | 64µs | HTTP::Message::::_set_contentHTTP::Message::_set_content
3 | 1 | 1 | 25µs | 25µs | HTTP::Message::::content_refHTTP::Message::content_ref
1 | 1 | 1 | 22µs | 29µs | HTTP::Message::::BEGIN@3HTTP::Message::BEGIN@3
3 | 1 | 1 | 19µs | 32µs | HTTP::Message::::protocolHTTP::Message::protocol
1 | 1 | 1 | 10µs | 29µs | HTTP::Message::::BEGIN@621HTTP::Message::BEGIN@621
1 | 1 | 1 | 7µs | 43µs | HTTP::Message::::BEGIN@4HTTP::Message::BEGIN@4
0 | 0 | 0 | 0s | 0s | HTTP::Message::::DESTROYHTTP::Message::DESTROY
0 | 0 | 0 | 0s | 0s | HTTP::Message::::__ANON__[:21]HTTP::Message::__ANON__[:21]
0 | 0 | 0 | 0s | 0s | HTTP::Message::::__ANON__[:262]HTTP::Message::__ANON__[:262]
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::::_partsHTTP::Message::_parts
0 | 0 | 0 | 0s | 0s | HTTP::Message::::_stale_contentHTTP::Message::_stale_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::::content_charsetHTTP::Message::content_charset
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::::headers_as_stringHTTP::Message::headers_as_string
0 | 0 | 0 | 0s | 0s | HTTP::Message::::parseHTTP::Message::parse
0 | 0 | 0 | 0s | 0s | HTTP::Message::::partsHTTP::Message::parts

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

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