headers.pm

稀饭伊人相册系统继承了新天堂多用户相册系统的功能

package HTTP::Headers;

# $Id: Headers.pm,v 1.43 2001/11/15 06:19:22 gisle Exp $

=head1 NAME

HTTP::Headers - Class encapsulating HTTP Message headers

=head1 SYNOPSIS

 require HTTP::Headers;
 $h = HTTP::Headers->new;

 $h->header('Content-Type' => 'text/plain');  # set
 $ct = $h->header('Content-Type');            # get
 $h->remove_header('Content-Type');           # delete

=head1 DESCRIPTION

The C<HTTP::Headers> class encapsulates HTTP-style message headers.
The headers consist of attribute-value pairs also called fields, which
may be repeated, and which are printed in a particular order.

Instances of this class are usually created as member variables of the
C<HTTP::Request> and C<HTTP::Response> classes, internal to the
library.

The following methods are available:

=over 4

=cut

use strict;
use Carp ();

use vars qw($VERSION $TRANSLATE_UNDERSCORE);
$VERSION = sprintf("%d.%02d", q$Revision: 1.43 $ =~ /(\d+)\.(\d+)/);

# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used
# as a replacement for '-' in header field names.
$TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE;

# "Good Practice" order of HTTP message headers:
#    - General-Headers
#    - Request-Headers
#    - Response-Headers
#    - Entity-Headers

my @header_order = qw(
   Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade
   Via Warning

   Accept Accept-Charset Accept-Encoding Accept-Language
   Authorization Expect From Host
   If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
   Max-Forwards Proxy-Authorization Range Referer TE User-Agent

   Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server
   Vary WWW-Authenticate

   Allow Content-Encoding Content-Language Content-Length Content-Location
   Content-MD5 Content-Range Content-Type Expires Last-Modified
);

# Make alternative representations of @header_order.  This is used
# for sorting and case matching.
my %header_order;
my %standard_case;

{
    my $i = 0;
    for (@header_order) {
	my $lc = lc $_;
	$header_order{$lc} = ++$i;
	$standard_case{$lc} = $_;
    }
}




=item $h = HTTP::Headers->new

Constructs a new C<HTTP::Headers> object.  You might pass some initial
attribute-value pairs as parameters to the constructor.  I<E.g.>:

 $h = HTTP::Headers->new(
       Date         => 'Thu, 03 Feb 1994 00:00:00 GMT',
       Content_Type => 'text/html; version=3.2',
       Content_Base => 'http://www.perl.org/');

The constructor arguments are passed to the C<header> method which is
described below.

=cut

sub new
{
    my($class) = shift;
    my $self = bless {}, $class;
    $self->header(@_); # set up initial headers
    $self;
}


=item $h->header($field [=> $value],...)

Get or set the value of one or more header fields.  The header field name
($field) is not case sensitive.  To make the life easier for perl
users who wants to avoid quoting before the => operator, you can use
'_' as a replacement for '-' in header names (this behaviour can be
suppressed by setting the $HTTP::Headers::TRANSLATE_UNDERSCORE
variable to a FALSE value).

The header() method accepts multiple ($field => $value) pairs, which
means that you can update several fields with a single invocation.

The $value argument may be a plain string or a reference to an array
of strings for a multi-valued field. If the $value is undefined or not
given, then that header field will remain unchanged.

The old value (or values) of the last of the header fields is returned.
If no such field exists C<undef> will be returned.

A multi-valued field will be retuned as separate values in list
context and will be concatenated with ", " as separator in scalar
context.  The HTTP spec (RFC 2616) promise that joining multiple
values in this way will not change the semantic of a header field, but
in practice there are cases like old-style Netscape cookies (see
L<HTTP::Cookies>) where "," is used as part of the syntax of a single
field value.

Examples:

 $header->header(MIME_Version => '1.0',
		 User_Agent   => 'My-Web-Client/0.01');
 $header->header(Accept => "text/html, text/plain, image/*");
 $header->header(Accept => [qw(text/html text/plain image/*)]);
 @accepts = $header->header('Accept');  # get multiple values
 $accepts = $header->header('Accept');  # get values as a single string

=cut

sub header
{
    my $self = shift;
    my(@old);
    while (my($field, $val) = splice(@_, 0, 2)) {
	@old = $self->_header($field, $val);
    }
    return @old if wantarray;
    return $old[0] if @old <= 1;
    join(", ", @old);
}


=item $h->push_header($field, $value)

Add a new field value for the specified header field.  Previous values
for the same field are retained.

As for the header() method, the field name ($field) is not case
sensitive and '_' can be used as a replacement for '-'.

The $value argument may be a scalar or a reference to a list of
scalars.

 $header->push_header(Accept => 'image/jpeg');
 $header->push_header(Accept => [map "image/$_", qw(gif png tiff)]);

=cut

sub push_header
{
    Carp::croak('Usage: $h->push_header($field, $val)') if @_ != 3;
    shift->_header(@_, 'PUSH');
}

=item $h->init_header($field, $value)

Set the specified header to the given value, but only if no previous
value for that field is set.

The header field name ($field) is not case sensitive and '_'
can be used as a replacement for '-'.

The $value argument may be a scalar or a reference to a list of
scalars.

=cut

sub init_header
{
    Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3;
    shift->_header(@_, 'INIT');
}


=item $h->remove_header($field,...)

This function removes the headers fields with the specified names.

The header field names ($field) are not case sensitive and '_'
can be used as a replacement for '-'.

The return value is the values of the fields removed.  In scalar
context the number of fields removed is returned.

Note that if you pass in multiple field names then it is generally not
possible to tell which of the returned values belonged to which field.

=cut

sub remove_header
{
    my($self, @fields) = @_;
    my $field;
    my @values;
    foreach $field (@fields) {
	$field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
	my $v = delete $self->{lc $field};
	push(@values, ref($v) ? @$v : $v) if defined $v;
    }
    return @values;
}


sub _header
{
    my($self, $field, $val, $op) = @_;
    $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;

    # $push is only used interally sub push_header
    Carp::croak('Need a field name') unless length($field);

    my $lc_field = lc $field;
    unless(defined $standard_case{$lc_field}) {
	# generate a %standard_case entry for this field
	$field =~ s/\b(\w)/\u$1/g;
	$standard_case{$lc_field} = $field;
    }

    my $h = $self->{$lc_field};
    my @old = ref($h) ? @$h : (defined($h) ? ($h) : ());

    $op ||= "";
    $val = undef if $op eq 'INIT' && @old;
    if (defined($val)) {
	my @new = ($op eq 'PUSH') ? @old : ();
	if (!ref($val)) {
	    push(@new, $val);
	} elsif (ref($val) eq 'ARRAY') {
	    push(@new, @$val);
	} else {
	    Carp::croak("Unexpected field value $val");
	}
	$self->{$lc_field} = @new > 1 ? \@new : $new[0];
    }
    @old;
}


# Compare function which makes it easy to sort headers in the
# recommended "Good Practice" order.
sub _header_cmp
{
    ($header_order{$a} || 999) <=> ($header_order{$b} || 999) || $a cmp $b;
}


=item $h->scan(\&doit)

Apply a subroutine to each header field in turn.  The callback routine
is called with two parameters; the name of the field and a single
value (a string).  If a header field is multi-valued, then the
routine is called once for each value.  The field name passed to the
callback routine has case as suggested by HTTP spec, and the headers
will be visited in the recommended "Good Practice" order.

Any return values of the callback routine are ignored.  The loop can
be broken by raising an exception (C<die>).

=cut

sub scan
{
    my($self, $sub) = @_;
    my $key;
    foreach $key (sort _header_cmp keys %$self) {
        next if $key =~ /^_/;
	my $vals = $self->{$key};
	if (ref($vals)) {
	    my $val;
	    for $val (@$vals) {
		&$sub($standard_case{$key} || $key, $val);
	    }
	} else {
	    &$sub($standard_case{$key} || $key, $vals);
	}
    }
}


=item $h->as_string([$endl])

Return the header fields as a formatted MIME header.  Since it
internally uses the C<scan> method to build the string, the result