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