local-lib5/lib/perl5/HTTP/Message.pm

   1 package HTTP::Message;
   2
   3 use strict;
   4 use vars qw($VERSION $AUTOLOAD);
   5 $VERSION = "5.834";
   6
   7 require HTTP::Headers;
   8 require Carp;
   9
  10 my $CRLF = "\015\012";   # "\r\n" is not portable
  11 $HTTP::URI_CLASS ||= $ENV{PERL_HTTP_URI_CLASS} || "URI";
  12 eval "require $HTTP::URI_CLASS"; die $@ if $@;
  13
  14 *_utf8_downgrade = defined(&utf8::downgrade) ?
  15     sub {
  16         utf8::downgrade($_[0], 1) or
  17             Carp::croak("HTTP::Message content must be bytes")
  18     }
  19     :
  20     sub {
  21     };
  22
  23 sub new
  24 {
  25     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;
  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 sub protocol {
  96     shift->_elem('_protocol',  @_);
  97 }
  98
  99 sub headers {
 100     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 sub content  {
 115
 116     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) {
 126         &_set_content;
 127     }
 128     else {
 129         Carp::carp("Useless content call in void context") if $^W;
 130     }
 131 }
 132
 133
 134 sub _set_content {
 135     my $self = $_[0];
 136     _utf8_downgrade($_[1]);
 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 {
 151     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);
 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 {
 180     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 {
 617     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     no strict 'refs';
 622     *$method = sub { shift->headers->$method(@_) };
 623     goto &$method;
 624 }
 625
 626
 627 sub DESTROY {}  # avoid AUTOLOADing it
 628
 629
 630 # Private method to access members in %$self
 631 sub _elem
 632 {
 633     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;
 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