home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / perl5 / HTTP / Message.pm < prev    next >
Encoding:
Perl POD Document  |  2010-05-05  |  29.2 KB  |  1,103 lines
  1. package HTTP::Message;
  2.  
  3. use strict;
  4. use vars qw($VERSION $AUTOLOAD);
  5. $VERSION = "5.835";
  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.     for ($$cref) {
  209.     return "UTF-8"     if /^\xEF\xBB\xBF/;
  210.     return "UTF-32-LE" if /^\xFF\xFE\x00\x00/;
  211.     return "UTF-32-BE" if /^\x00\x00\xFE\xFF/;
  212.     return "UTF-16-LE" if /^\xFF\xFE/;
  213.     return "UTF-16-BE" if /^\xFE\xFF/;
  214.     }
  215.  
  216.     if ($self->content_is_xml) {
  217.     # http://www.w3.org/TR/2006/REC-xml-20060816/#sec-guessing
  218.     # XML entity not accompanied by external encoding information and not
  219.     # in UTF-8 or UTF-16 encoding must begin with an XML encoding declaration,
  220.     # in which the first characters must be '<?xml'
  221.     for ($$cref) {
  222.         return "UTF-32-BE" if /^\x00\x00\x00</;
  223.         return "UTF-32-LE" if /^<\x00\x00\x00/;
  224.         return "UTF-16-BE" if /^(?:\x00\s)*\x00</;
  225.         return "UTF-16-LE" if /^(?:\s\x00)*<\x00/;
  226.         if (/^\s*(<\?xml[^\x00]*?\?>)/) {
  227.         if ($1 =~ /\sencoding\s*=\s*(["'])(.*?)\1/) {
  228.             my $enc = $2;
  229.             $enc =~ s/^\s+//; $enc =~ s/\s+\z//;
  230.             return $enc if $enc;
  231.         }
  232.         }
  233.     }
  234.     return "UTF-8";
  235.     }
  236.     elsif ($self->content_is_html) {
  237.     # look for <META charset="..."> or <META content="...">
  238.     # http://dev.w3.org/html5/spec/Overview.html#determining-the-character-encoding
  239.     my $charset;
  240.     require HTML::Parser;
  241.     my $p = HTML::Parser->new(
  242.         start_h => [sub {
  243.         my($tag, $attr, $self) = @_;
  244.         $charset = $attr->{charset};
  245.         unless ($charset) {
  246.             # look at $attr->{content} ...
  247.             if (my $c = $attr->{content}) {
  248.             require HTTP::Headers::Util;
  249.             my @v = HTTP::Headers::Util::split_header_words($c);
  250.             return unless @v;
  251.             my($ct, undef, %ct_param) = @{$v[0]};
  252.             $charset = $ct_param{charset};
  253.             }
  254.             return unless $charset;
  255.         }
  256.         if ($charset =~ /^utf-?16/i) {
  257.             # converted document, assume UTF-8
  258.             $charset = "UTF-8";
  259.         }
  260.         $self->eof;
  261.         }, "tagname, attr, self"],
  262.         report_tags => [qw(meta)],
  263.         utf8_mode => 1,
  264.     );
  265.     $p->parse($$cref);
  266.     return $charset if $charset;
  267.     }
  268.     if ($self->content_type =~ /^text\//) {
  269.     for ($$cref) {
  270.         if (length) {
  271.         return "US-ASCII" unless /[\x80-\xFF]/;
  272.         require Encode;
  273.         eval {
  274.             Encode::decode_utf8($_, Encode::FB_CROAK());
  275.         };
  276.         return "UTF-8" unless $@;
  277.         return "ISO-8859-1";
  278.         }
  279.     }
  280.     }
  281.  
  282.     return undef;
  283. }
  284.  
  285.  
  286. sub decoded_content
  287. {
  288.     my($self, %opt) = @_;
  289.     my $content_ref;
  290.     my $content_ref_iscopy;
  291.  
  292.     eval {
  293.     $content_ref = $self->content_ref;
  294.     die "Can't decode ref content" if ref($content_ref) ne "SCALAR";
  295.  
  296.     if (my $h = $self->header("Content-Encoding")) {
  297.         $h =~ s/^\s+//;
  298.         $h =~ s/\s+$//;
  299.         for my $ce (reverse split(/\s*,\s*/, lc($h))) {
  300.         next unless $ce;
  301.         next if $ce eq "identity";
  302.         if ($ce eq "gzip" || $ce eq "x-gzip") {
  303.             require IO::Uncompress::Gunzip;
  304.             my $output;
  305.             IO::Uncompress::Gunzip::gunzip($content_ref, \$output, Transparent => 0)
  306.             or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError";
  307.             $content_ref = \$output;
  308.             $content_ref_iscopy++;
  309.         }
  310.         elsif ($ce eq "x-bzip2") {
  311.             require IO::Uncompress::Bunzip2;
  312.             my $output;
  313.             IO::Uncompress::Bunzip2::bunzip2($content_ref, \$output, Transparent => 0)
  314.             or die "Can't bunzip content: $IO::Uncompress::Bunzip2::Bunzip2Error";
  315.             $content_ref = \$output;
  316.             $content_ref_iscopy++;
  317.         }
  318.         elsif ($ce eq "deflate") {
  319.             require IO::Uncompress::Inflate;
  320.             my $output;
  321.             my $status = IO::Uncompress::Inflate::inflate($content_ref, \$output, Transparent => 0);
  322.             my $error = $IO::Uncompress::Inflate::InflateError;
  323.             unless ($status) {
  324.             # "Content-Encoding: deflate" is supposed to mean the
  325.             # "zlib" format of RFC 1950, but Microsoft got that
  326.             # wrong, so some servers sends the raw compressed
  327.             # "deflate" data.  This tries to inflate this format.
  328.             $output = undef;
  329.             require IO::Uncompress::RawInflate;
  330.             unless (IO::Uncompress::RawInflate::rawinflate($content_ref, \$output)) {
  331.                 $self->push_header("Client-Warning" =>
  332.                 "Could not raw inflate content: $IO::Uncompress::RawInflate::RawInflateError");
  333.                 $output = undef;
  334.             }
  335.             }
  336.             die "Can't inflate content: $error" unless defined $output;
  337.             $content_ref = \$output;
  338.             $content_ref_iscopy++;
  339.         }
  340.         elsif ($ce eq "compress" || $ce eq "x-compress") {
  341.             die "Can't uncompress content";
  342.         }
  343.         elsif ($ce eq "base64") {  # not really C-T-E, but should be harmless
  344.             require MIME::Base64;
  345.             $content_ref = \MIME::Base64::decode($$content_ref);
  346.             $content_ref_iscopy++;
  347.         }
  348.         elsif ($ce eq "quoted-printable") { # not really C-T-E, but should be harmless
  349.             require MIME::QuotedPrint;
  350.             $content_ref = \MIME::QuotedPrint::decode($$content_ref);
  351.             $content_ref_iscopy++;
  352.         }
  353.         else {
  354.             die "Don't know how to decode Content-Encoding '$ce'";
  355.         }
  356.         }
  357.     }
  358.  
  359.     if ($self->content_is_text || (my $is_xml = $self->content_is_xml)) {
  360.         my $charset = lc(
  361.             $opt{charset} ||
  362.         $self->content_type_charset ||
  363.         $opt{default_charset} ||
  364.         $self->content_charset ||
  365.         "ISO-8859-1"
  366.         );
  367.         unless ($charset =~ /^(?:none|us-ascii|iso-8859-1)\z/) {
  368.         require Encode;
  369.         if (do{my $v = $Encode::VERSION; $v =~ s/_//g; $v} < 2.0901 &&
  370.             !$content_ref_iscopy)
  371.         {
  372.             # LEAVE_SRC did not work before Encode-2.0901
  373.             my $copy = $$content_ref;
  374.             $content_ref = \$copy;
  375.             $content_ref_iscopy++;
  376.         }
  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 =~ /^(?:none|us-ascii|iso-8859-1)\z/;
  390.                 $retried++;
  391.             }
  392.             }
  393.             die unless $retried;
  394.         }
  395.         die "Encode::decode() returned undef improperly" unless defined $$content_ref;
  396.         if ($is_xml) {
  397.             # Get rid of the XML encoding declaration if present
  398.             $$content_ref =~ s/^\x{FEFF}//;
  399.             if ($$content_ref =~ /^(\s*<\?xml[^\x00]*?\?>)/) {
  400.             substr($$content_ref, 0, length($1)) =~ s/\sencoding\s*=\s*(["']).*?\1//;
  401.             }
  402.         }
  403.         }
  404.     }
  405.     };
  406.     if ($@) {
  407.     Carp::croak($@) if $opt{raise_error};
  408.     return undef;
  409.     }
  410.  
  411.     return $opt{ref} ? $content_ref : $$content_ref;
  412. }
  413.  
  414.  
  415. sub decodable
  416. {
  417.     # should match the Content-Encoding values that decoded_content can deal with
  418.     my $self = shift;
  419.     my @enc;
  420.     # XXX preferably we should determine if the modules are available without loading
  421.     # them here
  422.     eval {
  423.         require IO::Uncompress::Gunzip;
  424.         push(@enc, "gzip", "x-gzip");
  425.     };
  426.     eval {
  427.         require IO::Uncompress::Inflate;
  428.         require IO::Uncompress::RawInflate;
  429.         push(@enc, "deflate");
  430.     };
  431.     eval {
  432.         require IO::Uncompress::Bunzip2;
  433.         push(@enc, "x-bzip2");
  434.     };
  435.     # we don't care about announcing the 'identity', 'base64' and
  436.     # 'quoted-printable' stuff
  437.     return wantarray ? @enc : join(", ", @enc);
  438. }
  439.  
  440.  
  441. sub decode
  442. {
  443.     my $self = shift;
  444.     return 1 unless $self->header("Content-Encoding");
  445.     if (defined(my $content = $self->decoded_content(charset => "none"))) {
  446.     $self->remove_header("Content-Encoding", "Content-Length", "Content-MD5");
  447.     $self->content($content);
  448.     return 1;
  449.     }
  450.     return 0;
  451. }
  452.  
  453.  
  454. sub encode
  455. {
  456.     my($self, @enc) = @_;
  457.  
  458.     Carp::croak("Can't encode multipart/* messages") if $self->content_type =~ m,^multipart/,;
  459.     Carp::croak("Can't encode message/* messages") if $self->content_type =~ m,^message/,;
  460.  
  461.     return 1 unless @enc;  # nothing to do
  462.  
  463.     my $content = $self->content;
  464.     for my $encoding (@enc) {
  465.     if ($encoding eq "identity") {
  466.         # nothing to do
  467.     }
  468.     elsif ($encoding eq "base64") {
  469.         require MIME::Base64;
  470.         $content = MIME::Base64::encode($content);
  471.     }
  472.     elsif ($encoding eq "gzip" || $encoding eq "x-gzip") {
  473.         require IO::Compress::Gzip;
  474.         my $output;
  475.         IO::Compress::Gzip::gzip(\$content, \$output, Minimal => 1)
  476.         or die "Can't gzip content: $IO::Compress::Gzip::GzipError";
  477.         $content = $output;
  478.     }
  479.     elsif ($encoding eq "deflate") {
  480.         require IO::Compress::Deflate;
  481.         my $output;
  482.         IO::Compress::Deflate::deflate(\$content, \$output)
  483.         or die "Can't deflate content: $IO::Compress::Deflate::DeflateError";
  484.         $content = $output;
  485.     }
  486.     elsif ($encoding eq "x-bzip2") {
  487.         require IO::Compress::Bzip2;
  488.         my $output;
  489.         IO::Compress::Bzip2::bzip2(\$content, \$output)
  490.         or die "Can't bzip2 content: $IO::Compress::Bzip2::Bzip2Error";
  491.         $content = $output;
  492.     }
  493.     elsif ($encoding eq "rot13") {  # for the fun of it
  494.         $content =~ tr/A-Za-z/N-ZA-Mn-za-m/;
  495.     }
  496.     else {
  497.         return 0;
  498.     }
  499.     }
  500.     my $h = $self->header("Content-Encoding");
  501.     unshift(@enc, $h) if $h;
  502.     $self->header("Content-Encoding", join(", ", @enc));
  503.     $self->remove_header("Content-Length", "Content-MD5");
  504.     $self->content($content);
  505.     return 1;
  506. }
  507.  
  508.  
  509. sub as_string
  510. {
  511.     my($self, $eol) = @_;
  512.     $eol = "\n" unless defined $eol;
  513.  
  514.     # The calculation of content might update the headers
  515.     # so we need to do that first.
  516.     my $content = $self->content;
  517.  
  518.     return join("", $self->{'_headers'}->as_string($eol),
  519.             $eol,
  520.             $content,
  521.             (@_ == 1 && length($content) &&
  522.              $content !~ /\n\z/) ? "\n" : "",
  523.         );
  524. }
  525.  
  526.  
  527. sub dump
  528. {
  529.     my($self, %opt) = @_;
  530.     my $content = $self->content;
  531.     my $chopped = 0;
  532.     if (!ref($content)) {
  533.     my $maxlen = $opt{maxlength};
  534.     $maxlen = 512 unless defined($maxlen);
  535.     if ($maxlen && length($content) > $maxlen * 1.1 + 3) {
  536.         $chopped = length($content) - $maxlen;
  537.         $content = substr($content, 0, $maxlen) . "...";
  538.     }
  539.  
  540.     $content =~ s/\\/\\\\/g;
  541.     $content =~ s/\t/\\t/g;
  542.     $content =~ s/\r/\\r/g;
  543.  
  544.     # no need for 3 digits in escape for these
  545.     $content =~ s/([\0-\11\13-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
  546.  
  547.     $content =~ s/([\0-\11\13-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
  548.     $content =~ s/([^\12\040-\176])/sprintf('\\x{%X}',ord($1))/eg;
  549.  
  550.     # remaining whitespace
  551.     $content =~ s/( +)\n/("\\40" x length($1)) . "\n"/eg;
  552.     $content =~ s/(\n+)\n/("\\n" x length($1)) . "\n"/eg;
  553.     $content =~ s/\n\z/\\n/;
  554.  
  555.     my $no_content = "(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 { 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--\r?\n.*//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 the raw
  873. 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
  875. returning 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 an @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 prefix => $str
  1056.  
  1057. A string that will be prefixed to each line of the dump.
  1058.  
  1059. =back
  1060.  
  1061. =back
  1062.  
  1063. All methods unknown to C<HTTP::Message> itself are delegated to the
  1064. C<HTTP::Headers> object that is part of every message.  This allows
  1065. convenient access to these methods.  Refer to L<HTTP::Headers> for
  1066. details of these methods:
  1067.  
  1068.     $mess->header( $field => $val )
  1069.     $mess->push_header( $field => $val )
  1070.     $mess->init_header( $field => $val )
  1071.     $mess->remove_header( $field )
  1072.     $mess->remove_content_headers
  1073.     $mess->header_field_names
  1074.     $mess->scan( \&doit )
  1075.  
  1076.     $mess->date
  1077.     $mess->expires
  1078.     $mess->if_modified_since
  1079.     $mess->if_unmodified_since
  1080.     $mess->last_modified
  1081.     $mess->content_type
  1082.     $mess->content_encoding
  1083.     $mess->content_length
  1084.     $mess->content_language
  1085.     $mess->title
  1086.     $mess->user_agent
  1087.     $mess->server
  1088.     $mess->from
  1089.     $mess->referer
  1090.     $mess->www_authenticate
  1091.     $mess->authorization
  1092.     $mess->proxy_authorization
  1093.     $mess->authorization_basic
  1094.     $mess->proxy_authorization_basic
  1095.  
  1096. =head1 COPYRIGHT
  1097.  
  1098. Copyright 1995-2004 Gisle Aas.
  1099.  
  1100. This library is free software; you can redistribute it and/or
  1101. modify it under the same terms as Perl itself.
  1102.  
  1103.