"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/site/lib/HTTP/Message.pm" (7 Mar 2020, 30745 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

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