File Coverage

blib/lib/HTTP/XSHeaders.pm

Criterion	Covered	Total	%
statement	115	124	92.7
branch	48	62	77.4
condition	12	18	66.6
subroutine	24	27	88.8
pod	13	14	92.8
total	212	245	86.5

package HTTP::XSHeaders;
use strict;
use warnings;
use XSLoader;

our $VERSION = '0.400003';

eval {
    require HTTP::Headers::Fast;

    # HTTP::Headers::Fast
    *HTTP::Headers::Fast::new                    = *HTTP::XSHeaders::new;
    *HTTP::Headers::Fast::DESTROY                = *HTTP::XSHeaders::DESTROY;
    *HTTP::Headers::Fast::clone                  = *HTTP::XSHeaders::clone;
    *HTTP::Headers::Fast::header                 = *HTTP::XSHeaders::header;
    *HTTP::Headers::Fast::_header                = *HTTP::XSHeaders::_header;
    *HTTP::Headers::Fast::clear                  = *HTTP::XSHeaders::clear;
    *HTTP::Headers::Fast::push_header            = *HTTP::XSHeaders::push_header;
    *HTTP::Headers::Fast::init_header            = *HTTP::XSHeaders::init_header;
    *HTTP::Headers::Fast::remove_header          = *HTTP::XSHeaders::remove_header;
    *HTTP::Headers::Fast::remove_content_headers = *HTTP::XSHeaders::remove_content_headers;
    *HTTP::Headers::Fast::as_string              = *HTTP::XSHeaders::as_string;
    *HTTP::Headers::Fast::as_string_without_sort = *HTTP::XSHeaders::as_string_without_sort;
    *HTTP::Headers::Fast::header_field_names     = *HTTP::XSHeaders::header_field_names;
    *HTTP::Headers::Fast::scan                   = *HTTP::XSHeaders::scan;

    # Implemented in Pure-Perl
    # (candidates to move to XS)
    *HTTP::Headers::Fast::_date_header          = *HTTP::XSHeaders::_date_header;
    *HTTP::Headers::Fast::content_type          = *HTTP::XSHeaders::content_type;
    *HTTP::Headers::Fast::content_type_charset  = *HTTP::XSHeaders::content_type_charset;
    *HTTP::Headers::Fast::referer               = *HTTP::XSHeaders::referer;
    *HTTP::Headers::Fast::referrer              = *HTTP::XSHeaders::referer;
    *HTTP::Headers::Fast::_basic_auth           = *HTTP::XSHeaders::_basic_auth;
};

eval {
    require HTTP::Headers;

    # HTTP::Headers
    *HTTP::Headers::new                    = *HTTP::XSHeaders::new;
    *HTTP::Headers::clone                  = *HTTP::XSHeaders::clone;
    *HTTP::Headers::header                 = *HTTP::XSHeaders::header;
    *HTTP::Headers::_header                = *HTTP::XSHeaders::_header;
    *HTTP::Headers::clear                  = *HTTP::XSHeaders::clear;
    *HTTP::Headers::push_header            = *HTTP::XSHeaders::push_header;
    *HTTP::Headers::init_header            = *HTTP::XSHeaders::init_header;
    *HTTP::Headers::remove_header          = *HTTP::XSHeaders::remove_header;
    *HTTP::Headers::remove_content_headers = *HTTP::XSHeaders::remove_content_headers;
    *HTTP::Headers::as_string              = *HTTP::XSHeaders::as_string;
    *HTTP::Headers::header_field_names     = *HTTP::XSHeaders::header_field_names;
    *HTTP::Headers::scan                   = *HTTP::XSHeaders::scan;

    # Implemented in Pure-Perl
    *HTTP::Headers::_date_header           = *HTTP::XSHeaders::_date_header;
    *HTTP::Headers::content_type           = *HTTP::XSHeaders::content_type;
    *HTTP::Headers::content_type_charset   = *HTTP::XSHeaders::content_type_charset;
    *HTTP::Headers::referer                = *HTTP::XSHeaders::referer;
    *HTTP::Headers::referrer               = *HTTP::XSHeaders::referer;
    *HTTP::Headers::_basic_auth            = *HTTP::XSHeaders::_basic_auth;
};

XSLoader::load( 'HTTP::XSHeaders', $VERSION );

{
    no warnings qw;
    for my $key (qw/content-length content-language content-encoding title user-agent server from warnings www-authenticate authorization proxy-authenticate proxy-authorization/) {
      (my $meth = $key) =~ s/-/_/g;
      no strict 'refs'; ## no critic
      *{$meth} = sub { (shift->header($key, @_))[0] };

      *{ "HTTP::Headers::$meth" } = sub {
          (shift->header($key, @_))[0];
      };

      *{ "HTTP::Headers::Fast::$meth" } = sub {
          (shift->header($key, @_))[0];
      };
    }
}

use 5.00800;
use Carp ();

sub _date_header {
    require HTTP::Date;
    my ( $self, $header, $time ) = @_;
    my $old;
    if ( defined $time ) {
        ($old) = $self->header($header, HTTP::Date::time2str($time));
    } else {
        ($old) = $self->header($header);
    }
    $old =~ s/;.*// if defined($old);
    HTTP::Date::str2time($old);
}

sub content_type {
    my $self = shift;
    my $ct   = $self->header('content-type');
    $self->header('content-type', shift) if @_;
    $ct = $ct->[0] if ref($ct) eq 'ARRAY';
    return '' unless defined($ct) && length($ct);
    my @ct = split( /;\s*/, $ct, 2 );
    for ( $ct[0] ) {
        s/\s+//g;
        $_ = lc($_);
    }
    wantarray ? @ct : $ct[0];
}

# This is copied here because it is not a method
sub _split_header_words
{
    my(@val) = @_;
    my @res;
    for (@val) {
	my @cur;
	while (length) {
	    if (s/^\s*(=*[^\s=;,]+)//) {  # 'token' or parameter 'attribute'
		push(@cur, $1);
		# a quoted value
		if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) {
		    my $val = $1;
		    $val =~ s/\\(.)/$1/g;
		    push(@cur, $val);
		# some unquoted value
		}
		elsif (s/^\s*=\s*([^;,\s]*)//) {
		    my $val = $1;
		    $val =~ s/\s+$//;
		    push(@cur, $val);
		# no value, a lone token
		}
		else {
		    push(@cur, undef);
		}
	    }
	    elsif (s/^\s*,//) {
		push(@res, [@cur]) if @cur;
		@cur = ();
	    }
	    elsif (s/^\s*;// || s/^\s+//) {
		# continue
	    }
	    else {
		die "This should not happen: '$_'";
	    }
	}
	push(@res, \@cur) if @cur;
    }

    for my $arr (@res) {
	for (my $i = @$arr - 2; $i >= 0; $i -= 2) {
	    $arr->[$i] = lc($arr->[$i]);
	}
    }
    return @res;
}

sub content_type_charset {
    my $self = shift;
    my $h = $self->header('content-type');
    $h = $h->[0] if ref($h);
    $h = "" unless defined $h;
    my @v = _split_header_words($h);
    if (@v) {
        my($ct, undef, %ct_param) = @{$v[0]};
        my $charset = $ct_param{charset};
        if ($ct) {
            $ct = lc($ct);
            $ct =~ s/\s+//;
        }
        if ($charset) {
            $charset = uc($charset);
            $charset =~ s/^\s+//;  $charset =~ s/\s+\z//;
            undef($charset) if $charset eq "";
        }
        return $ct, $charset if wantarray;
        return $charset;
    }
    return undef, undef if wantarray; ## no critic
    return undef; ## no critic
}

sub referer {
    my $self = shift;
    if ( @_ && $_[0] =~ /#/ ) {

        # Strip fragment per RFC 2616, section 14.36.
        my $uri = shift;
        if ( ref($uri) ) {
            require URI;
            $uri = $uri->clone;
            $uri->fragment(undef);
        }
        else {
            $uri =~ s/\#.*//;
        }
        unshift @_, $uri;
    }
    ( $self->header( 'Referer', @_ ) )[0];
}

*referrer = \&referer;

sub authorization_basic { shift->_basic_auth( "Authorization", @_ ) }
sub proxy_authorization_basic {
    shift->_basic_auth( "Proxy-Authorization", @_ );
}

sub _basic_auth {
    require MIME::Base64;
    my ( $self, $h, $user, $passwd ) = @_;
    my ($old) = $self->header($h);
    if ( defined $user ) {
        Carp::croak("Basic authorization user name can't contain ':'")
          if $user =~ /:/;
        $passwd = '' unless defined $passwd;
        $self->header(
            $h => 'Basic ' . MIME::Base64::encode( "$user:$passwd", '' ) );
    }
    if ( defined $old && $old =~ s/^\s*Basic\s+// ) {
        my $val = MIME::Base64::decode($old);
        return $val unless wantarray;
        return split( /:/, $val, 2 );
    }
    return;
}

sub date                { shift->_date_header( 'date',                @_ ); }
sub expires             { shift->_date_header( 'expires',             @_ ); }
sub if_modified_since   { shift->_date_header( 'if-modified-since',   @_ ); }
sub if_unmodified_since { shift->_date_header( 'if-unmodified-since', @_ ); }
sub last_modified       { shift->_date_header( 'last-modified',       @_ ); }

# This is used as a private LWP extension.  The Client-Date header is
# added as a timestamp to a response when it has been received.
sub client_date { shift->_date_header( 'client-date', @_ ); }

sub content_is_html {
    my $self = shift;
    return $self->content_type eq 'text/html' || $self->content_is_xhtml;
}

sub content_is_xhtml {
    my $ct = shift->content_type;
    return $ct eq "application/xhtml+xml"
      || $ct   eq "application/vnd.wap.xhtml+xml";
}

sub content_is_xml {
    my $ct = shift->content_type;
    return 1 if $ct eq "text/xml";
    return 1 if $ct eq "application/xml";
    return 1 if $ct =~ /\+xml$/;
    return 0;
}

1;

__END__