home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _4200da217b6662f38f0d8b89cb7be7e2 < prev    next >
Encoding:
Text File  |  2004-06-01  |  13.0 KB  |  513 lines
  1. package HTTP::Message;
  2.  
  3. # $Id: Message.pm,v 1.42 2004/04/09 15:07:04 gisle Exp $
  4.  
  5. use strict;
  6. use vars qw($VERSION $AUTOLOAD);
  7. $VERSION = sprintf("%d.%02d", q$Revision: 1.42 $ =~ /(\d+)\.(\d+)/);
  8.  
  9. require HTTP::Headers;
  10. require Carp;
  11.  
  12. my $CRLF = "\015\012";   # "\r\n" is not portable
  13. $HTTP::URI_CLASS ||= $ENV{PERL_HTTP_URI_CLASS} || "URI";
  14. eval "require $HTTP::URI_CLASS"; die $@ if $@;
  15.  
  16.  
  17.  
  18. sub new
  19. {
  20.     my($class, $header, $content) = @_;
  21.     if (defined $header) {
  22.     Carp::croak("Bad header argument") unless ref $header;
  23.         if (ref($header) eq "ARRAY") {
  24.         $header = HTTP::Headers->new(@$header);
  25.     }
  26.     else {
  27.         $header = $header->clone;
  28.     }
  29.     }
  30.     else {
  31.     $header = HTTP::Headers->new;
  32.     }
  33.     $content = '' unless defined $content;
  34.  
  35.     bless {
  36.     '_headers' => $header,
  37.     '_content' => $content,
  38.     }, $class;
  39. }
  40.  
  41.  
  42. sub parse
  43. {
  44.     my($class, $str) = @_;
  45.  
  46.     my @hdr;
  47.     while (1) {
  48.     if ($str =~ s/^([^ \t:]+)[ \t]*: ?(.*)\n?//) {
  49.         push(@hdr, $1, $2);
  50.         $hdr[-1] =~ s/\r\z//;
  51.     }
  52.     elsif (@hdr && $str =~ s/^([ \t].*)\n?//) {
  53.         $hdr[-1] .= "\n$1";
  54.         $hdr[-1] =~ s/\r\z//;
  55.     }
  56.     else {
  57.         $str =~ s/^\r?\n//;
  58.         last;
  59.     }
  60.     }
  61.  
  62.     new($class, \@hdr, $str);
  63. }
  64.  
  65.  
  66. sub clone
  67. {
  68.     my $self  = shift;
  69.     my $clone = HTTP::Message->new($self->headers,
  70.                    $self->content);
  71.     $clone;
  72. }
  73.  
  74.  
  75. sub clear {
  76.     my $self = shift;
  77.     $self->{_headers}->clear;
  78.     $self->{_content} = "";
  79.     delete $self->{_parts};
  80.     return;
  81. }
  82.  
  83.  
  84. sub protocol { shift->_elem('_protocol',  @_); }
  85.  
  86. sub content  {
  87.     my $self = shift;
  88.     if (defined(wantarray) && !exists $self->{_content}) {
  89.     $self->_content;
  90.     }
  91.     my $old = $self->{_content};
  92.     if (@_) {
  93.     $self->{_content} = shift;
  94.     delete $self->{_parts};
  95.     }
  96.     $old;
  97. }
  98.  
  99.  
  100. sub add_content
  101. {
  102.     my $self = shift;
  103.     $self->_content unless exists $self->{_content};
  104.     if (ref($_[0])) {
  105.     $self->{'_content'} .= ${$_[0]};  # for backwards compatability
  106.     }
  107.     else {
  108.     $self->{'_content'} .= $_[0];
  109.     }
  110.     delete $self->{_parts};
  111. }
  112.  
  113.  
  114. sub content_ref
  115. {
  116.     my $self = shift;
  117.     $self->_content unless exists $self->{_content};
  118.     delete $self->{_parts};
  119.     \$self->{'_content'};
  120. }
  121.  
  122.  
  123. sub as_string
  124. {
  125.     my($self, $eol) = @_;
  126.     $eol = "\n" unless defined $eol;
  127.  
  128.     # The calculation of content might update the headers
  129.     # so we need to do that first.
  130.     my $content = $self->content;
  131.  
  132.     return join("", $self->{'_headers'}->as_string($eol),
  133.             $eol,
  134.             $content,
  135.             (@_ == 1 && length($content) &&
  136.              $content !~ /\n\z/) ? "\n" : "",
  137.         );
  138. }
  139.  
  140.  
  141. sub headers            { shift->{'_headers'};                }
  142. sub headers_as_string  { shift->{'_headers'}->as_string(@_); }
  143.  
  144.  
  145. sub parts {
  146.     my $self = shift;
  147.     if (defined(wantarray) && !exists $self->{_parts}) {
  148.     $self->_parts;
  149.     }
  150.     my $old = $self->{_parts};
  151.     if (@_) {
  152.     my @parts = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
  153.     my $ct = $self->content_type || "";
  154.     if ($ct =~ m,^message/,) {
  155.         Carp::croak("Only one part allowed for $ct content")
  156.         if @parts > 1;
  157.     }
  158.     elsif ($ct !~ m,^multipart/,) {
  159.         $self->remove_content_headers;
  160.         $self->content_type("multipart/mixed");
  161.     }
  162.     $self->{_parts} = \@parts;
  163.     delete $self->{_content};
  164.     }
  165.     return @$old if wantarray;
  166.     return $old->[0];
  167. }
  168.  
  169. sub add_part {
  170.     my $self = shift;
  171.     if (($self->content_type || "") !~ m,^multipart/,) {
  172.     my $p = HTTP::Message->new($self->remove_content_headers,
  173.                    $self->content(""));
  174.     $self->content_type("multipart/mixed");
  175.     $self->{_parts} = [$p];
  176.     }
  177.     elsif (!exists $self->{_parts}) {
  178.     $self->_parts;
  179.     }
  180.  
  181.     push(@{$self->{_parts}}, @_);
  182.     delete $self->{_content};
  183.     return;
  184. }
  185.  
  186.  
  187. # delegate all other method calls the the _headers object.
  188. sub AUTOLOAD
  189. {
  190.     my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
  191.     return if $method eq "DESTROY";
  192.  
  193.     # We create the function here so that it will not need to be
  194.     # autoloaded the next time.
  195.     no strict 'refs';
  196.     *$method = eval "sub { shift->{'_headers'}->$method(\@_) }";
  197.     goto &$method;
  198. }
  199.  
  200.  
  201. # Private method to access members in %$self
  202. sub _elem
  203. {
  204.     my $self = shift;
  205.     my $elem = shift;
  206.     my $old = $self->{$elem};
  207.     $self->{$elem} = $_[0] if @_;
  208.     return $old;
  209. }
  210.  
  211.  
  212. # Create private _parts attribute from current _content
  213. sub _parts {
  214.     my $self = shift;
  215.     my $ct = $self->content_type;
  216.     if ($ct =~ m,^multipart/,) {
  217.     require HTTP::Headers::Util;
  218.     my @h = HTTP::Headers::Util::split_header_words($self->header("Content-Type"));
  219.     die "Assert" unless @h;
  220.     my %h = @{$h[0]};
  221.     if (defined(my $b = $h{boundary})) {
  222.         my $str = $self->{_content};
  223.         $str =~ s/\r?\n--\Q$b\E--\r?\n.*//s;
  224.         if ($str =~ s/(^|.*?\r?\n)--\Q$b\E\r?\n//s) {
  225.         $self->{_parts} = [map HTTP::Message->parse($_),
  226.                    split(/\r?\n--\Q$b\E\r?\n/, $str)]
  227.         }
  228.     }
  229.     }
  230.     elsif ($ct eq "message/http") {
  231.     require HTTP::Request;
  232.     require HTTP::Response;
  233.     my $class = ($self->{_content} =~ m,^(HTTP/.*)\n,) ?
  234.         "HTTP::Response" : "HTTP::Request";
  235.     $self->{_parts} = [$class->parse($self->{_content})];
  236.     }
  237.     elsif ($ct =~ m,^message/,) {
  238.     $self->{_parts} = [ HTTP::Message->parse($self->{_content}) ];
  239.     }
  240.  
  241.     $self->{_parts} ||= [];
  242. }
  243.  
  244.  
  245. # Create private _content attribute from current _parts
  246. sub _content {
  247.     my $self = shift;
  248.     my $ct = $self->header("Content-Type") || "multipart/mixed";
  249.     if ($ct =~ m,^\s*message/,i) {
  250.     $self->{_content} = $self->{_parts}[0]->as_string($CRLF);
  251.     return;
  252.     }
  253.  
  254.     require HTTP::Headers::Util;
  255.     my @v = HTTP::Headers::Util::split_header_words($ct);
  256.     Carp::carp("Multiple Content-Type headers") if @v > 1;
  257.     @v = @{$v[0]};
  258.  
  259.     my $boundary;
  260.     my $boundary_index;
  261.     for (my @tmp = @v; @tmp;) {
  262.     my($k, $v) = splice(@tmp, 0, 2);
  263.     if (lc($k) eq "boundary") {
  264.         $boundary = $v;
  265.         $boundary_index = @v - @tmp - 1;
  266.         last;
  267.     }
  268.     }
  269.  
  270.     my @parts = map $_->as_string($CRLF), @{$self->{_parts}};
  271.  
  272.     my $bno = 0;
  273.     $boundary = _boundary() unless defined $boundary;
  274.  CHECK_BOUNDARY:
  275.     {
  276.     for (@parts) {
  277.         if (index($_, $boundary) >= 0) {
  278.         # must have a better boundary
  279.         $boundary = _boundary(++$bno);
  280.         redo CHECK_BOUNDARY;
  281.         }
  282.     }
  283.     }
  284.  
  285.     if ($boundary_index) {
  286.     $v[$boundary_index] = $boundary;
  287.     }
  288.     else {
  289.     push(@v, boundary => $boundary);
  290.     }
  291.  
  292.     $ct = HTTP::Headers::Util::join_header_words(@v);
  293.     $self->header("Content-Type", $ct);
  294.  
  295.     $self->{_content} = "--$boundary$CRLF" .
  296.                     join("$CRLF--$boundary$CRLF", @parts) .
  297.             "$CRLF--$boundary--$CRLF";
  298. }
  299.  
  300.  
  301. sub _boundary
  302. {
  303.     my $size = shift || return "xYzZY";
  304.     require MIME::Base64;
  305.     my $b = MIME::Base64::encode(join("", map chr(rand(256)), 1..$size*3), "");
  306.     $b =~ s/[\W]/X/g;  # ensure alnum only
  307.     $b;
  308. }
  309.  
  310.  
  311. 1;
  312.  
  313.  
  314. __END__
  315.  
  316. =head1 NAME
  317.  
  318. HTTP::Message - HTTP style message (base class)
  319.  
  320. =head1 SYNOPSIS
  321.  
  322.  use base 'HTTP::Message';
  323.  
  324. =head1 DESCRIPTION
  325.  
  326. An C<HTTP::Message> object contains some headers and a content body.
  327. The following methods are available:
  328.  
  329. =over 4
  330.  
  331. =item $mess = HTTP::Message->new
  332.  
  333. =item $mess = HTTP::Message->new( $headers )
  334.  
  335. =item $mess = HTTP::Message->new( $headers, $content )
  336.  
  337. This constructs a new message object.  Normally you would want
  338. construct C<HTTP::Request> or C<HTTP::Response> objects instead.
  339.  
  340. The optional $header argument should be a reference to an
  341. C<HTTP::Headers> object or a plain array reference of key/value pairs.
  342. If an C<HTTP::Headers> object is provided then a copy of it will be
  343. embedded into the constructed message, i.e. it will not be owned and
  344. can be modified afterwards without affecting the message.
  345.  
  346. The optional $content argument should be a string of bytes.
  347.  
  348. =item $mess = HTTP::Message->parse( $str )
  349.  
  350. This constructs a new message object by parsing the given string.
  351.  
  352. =item $mess->headers
  353.  
  354. Returns the embedded C<HTTP::Headers> object.
  355.  
  356. =item $mess->headers_as_string
  357.  
  358. =item $mess->headers_as_string( $eol )
  359.  
  360. Call the as_string() method for the headers in the
  361. message.  This will be the same as
  362.  
  363.     $mess->headers->as_string
  364.  
  365. but it will make your program a whole character shorter :-)
  366.  
  367. =item $mess->content
  368.  
  369. =item $mess->content( $content )
  370.  
  371. The content() method sets the content if an argument is given.  If no
  372. argument is given the content is not touched.  In either case the
  373. original content is returned.
  374.  
  375. Note that the content should be a string of bytes.  Strings in perl
  376. can contain characters outside the range of a byte.  The C<Encode>
  377. module can be used to turn such strings into a string of bytes.
  378.  
  379. =item $mess->add_content( $data )
  380.  
  381. The add_content() methods appends more data to the end of the current
  382. content buffer.
  383.  
  384. =item $mess->content_ref
  385.  
  386. The content_ref() method will return a reference to content buffer string.
  387. It can be more efficient to access the content this way if the content
  388. is huge, and it can even be used for direct manipulation of the content,
  389. for instance:
  390.  
  391.   ${$res->content_ref} =~ s/\bfoo\b/bar/g;
  392.  
  393. This example would modify the content buffer in-place.
  394.  
  395. =item $mess->parts
  396.  
  397. =item $mess->parts( @parts )
  398.  
  399. =item $mess->parts( \@parts )
  400.  
  401. Messages can be composite, i.e. contain other messages.  The composite
  402. messages have a content type of C<multipart/*> or C<message/*>.  This
  403. method give access to the contained messages.
  404.  
  405. The argumentless form will return a list of C<HTTP::Message> objects.
  406. If the content type of $msg is not C<multipart/*> or C<message/*> then
  407. this will return the empty list.  In scalar context only the first
  408. object is returned.  The returned message parts should be regarded as
  409. are read only (future versions of this library might make it possible
  410. to modify the parent by modifying the parts).
  411.  
  412. If the content type of $msg is C<message/*> then there will only be
  413. one part returned.
  414.  
  415. If the content type is C<message/http>, then the return value will be
  416. either an C<HTTP::Request> or an C<HTTP::Response> object.
  417.  
  418. If an @parts argument is given, then the content of the message will
  419. modified. The array reference form is provided so that an empty list
  420. can be provided.  The @parts array should contain C<HTTP::Message>
  421. objects.  The @parts objects are owned by $mess after this call and
  422. should not be modified or made part of other messages.
  423.  
  424. When updating the message with this method and the old content type of
  425. $mess is not C<multipart/*> or C<message/*>, then the content type is
  426. set to C<multipart/mixed> and all other content headers are cleared.
  427.  
  428. This method will croak if the content type is C<message/*> and more
  429. than one part is provided.
  430.  
  431. =item $mess->add_part( $part )
  432.  
  433. This will add a part to a message.  The $part argument should be
  434. another C<HTTP::Message> object.  If the previous content type of
  435. $mess is not C<multipart/*> then the old content (together with all
  436. content headers) will be made part #1 and the content type made
  437. C<multipart/mixed> before the new part is added.  The $part object is
  438. owned by $mess after this call and should not be modified or made part
  439. of other messages.
  440.  
  441. There is no return value.
  442.  
  443. =item $mess->clear
  444.  
  445. Will clear the headers and set the content to the empty string.  There
  446. is no return value
  447.  
  448. =item $mess->protocol
  449.  
  450. =item $mess->protocol( $proto )
  451.  
  452. Sets the HTTP protocol used for the message.  The protocol() is a string
  453. like C<HTTP/1.0> or C<HTTP/1.1>.
  454.  
  455. =item $mess->clone
  456.  
  457. Returns a copy of the message object.
  458.  
  459. =item $mess->as_string
  460.  
  461. =item $mess->as_string( $eol )
  462.  
  463. Returns the message formatted as a single string.
  464.  
  465. The optional $eol parameter specifies the line ending sequence to use.
  466. The default is "\n".  If no $eol is given then as_string will ensure
  467. that the returned string is newline terminated (even when the message
  468. content is not).  No extra newline is appended if an explicit $eol is
  469. passed.
  470.  
  471. =back
  472.  
  473. All methods unknown to C<HTTP::Message> itself are delegated to the
  474. C<HTTP::Headers> object that is part of every message.  This allows
  475. convenient access to these methods.  Refer to L<HTTP::Headers> for
  476. details of these methods:
  477.  
  478.     $mess->header( $field => $val )
  479.     $mess->push_header( $field => $val )
  480.     $mess->init_header( $field => $val )
  481.     $mess->remove_header( $field )
  482.     $mess->remove_content_headers
  483.     $mess->header_field_names
  484.     $mess->scan( \&doit )
  485.  
  486.     $mess->date
  487.     $mess->expires
  488.     $mess->if_modified_since
  489.     $mess->if_unmodified_since
  490.     $mess->last_modified
  491.     $mess->content_type
  492.     $mess->content_encoding
  493.     $mess->content_length
  494.     $mess->content_language
  495.     $mess->title
  496.     $mess->user_agent
  497.     $mess->server
  498.     $mess->from
  499.     $mess->referer
  500.     $mess->www_authenticate
  501.     $mess->authorization
  502.     $mess->proxy_authorization
  503.     $mess->authorization_basic
  504.     $mess->proxy_authorization_basic
  505.  
  506. =head1 COPYRIGHT
  507.  
  508. Copyright 1995-2004 Gisle Aas.
  509.  
  510. This library is free software; you can redistribute it and/or
  511. modify it under the same terms as Perl itself.
  512.  
  513.