File Coverage

blib/lib/HTTP/Headers/ActionPack.pm

Criterion	Covered	Total	%
statement	43	49	87.7
branch	14	22	63.6
condition	4	9	44.4
subroutine	13	16	81.2
pod	6	8	75.0
total	80	104	76.9

package HTTP::Headers::ActionPack;
BEGIN {
  $HTTP::Headers::ActionPack::AUTHORITY = 'cpan:STEVAN';
}
{
  $HTTP::Headers::ActionPack::VERSION = '0.09';
}
# ABSTRACT: HTTP Action, Adventure and Excitement

use strict;
use warnings;

use Scalar::Util    qw[ blessed ];
use Carp            qw[ confess ];
use Module::Runtime qw[ use_module ];

my @DEFAULT_CLASSES = qw[
    HTTP::Headers::ActionPack::AcceptCharset
    HTTP::Headers::ActionPack::AcceptLanguage
    HTTP::Headers::ActionPack::AuthenticationInfo
    HTTP::Headers::ActionPack::Authorization
    HTTP::Headers::ActionPack::Authorization::Basic
    HTTP::Headers::ActionPack::Authorization::Digest
    HTTP::Headers::ActionPack::DateHeader
    HTTP::Headers::ActionPack::LinkHeader
    HTTP::Headers::ActionPack::LinkList
    HTTP::Headers::ActionPack::MediaType
    HTTP::Headers::ActionPack::MediaTypeList
    HTTP::Headers::ActionPack::PriorityList
    HTTP::Headers::ActionPack::WWWAuthenticate
];

my %DEFAULT_MAPPINGS = (
    'link'                => 'HTTP::Headers::ActionPack::LinkList',
    'content-type'        => 'HTTP::Headers::ActionPack::MediaType',
    'accept'              => 'HTTP::Headers::ActionPack::MediaTypeList',
    'accept-charset'      => 'HTTP::Headers::ActionPack::AcceptCharset',
    'accept-encoding'     => 'HTTP::Headers::ActionPack::PriorityList',
    'accept-language'     => 'HTTP::Headers::ActionPack::AcceptLanguage',
    'date'                => 'HTTP::Headers::ActionPack::DateHeader',
    'client-date'         => 'HTTP::Headers::ActionPack::DateHeader', # added by LWP
    'expires'             => 'HTTP::Headers::ActionPack::DateHeader',
    'last-modified'       => 'HTTP::Headers::ActionPack::DateHeader',
    'if-unmodified-since' => 'HTTP::Headers::ActionPack::DateHeader',
    'if-modified-since'   => 'HTTP::Headers::ActionPack::DateHeader',
    'www-authenticate'    => 'HTTP::Headers::ActionPack::WWWAuthenticate',
    'authentication-info' => 'HTTP::Headers::ActionPack::AuthenticationInfo',
    'authorization'       => 'HTTP::Headers::ActionPack::Authorization',
);

sub new {
    my $class      = shift;
    my %additional = @_;
    my %mappings   = ( %DEFAULT_MAPPINGS, %additional );
    my %classes    = map { $_ => undef } ( @DEFAULT_CLASSES, values %additional );

    bless {
        mappings => \%mappings,
        classes  => \%classes
    } => $class;
}

sub mappings { (shift)->{'mappings'} }
sub classes  { keys %{ (shift)->{'classes'} } }

sub has_mapping {
    my ($self, $header_name) = @_;
    exists $self->{'mappings'}->{ lc $header_name } ? 1 : 0
}

sub get_content_negotiator {
    use_module('HTTP::Headers::ActionPack::ContentNegotiation')->new( shift );
}

sub create {
    my ($self, $class_name, $args) = @_;

    my $class = exists $self->{'classes'}->{ $class_name }
        ? $class_name
        : exists $self->{'classes'}->{ __PACKAGE__ . '::' . $class_name }
            ? __PACKAGE__ . '::' . $class_name
            : undef;

    (defined $class)
        || confess "Could not find class '$class_name' (or 'HTTP::Headers::ActionPack::$class_name')";

    ref $args
        ? use_module( $class )->new( @$args )
        : use_module( $class )->new_from_string( $args );
}

sub create_header {
    my ($self, $header_name, $header_value) = @_;

    my $class = $self->{'mappings'}->{ lc $header_name };

    (defined $class)
        || confess "Could not find mapping for '$header_name'";

    ref $header_value
        ? use_module( $class )->new( @$header_value )
        : use_module( $class )->new_from_string( $header_value );
}

sub inflate {
    my $self = shift;
    return $self->_inflate_http_headers( @_ )
        if $_[0]->isa('HTTP::Headers');
    return $self->_inflate_generic_request( @_ )
        if $_[0]->isa('HTTP::Request')
        || $_[0]->isa('Plack::Request')
        || $_[0]->isa('Web::Request');
    confess "I don't know how to inflate '$_[0]'";
}

sub _inflate_http_headers {
    my ($self, $http_headers) = @_;
    foreach my $header ( keys %{ $self->{'mappings'} } ) {
        if ( my $old = $http_headers->header( $header ) ) {
            $http_headers->header( $header => $self->create_header( $header, $old ) )
                unless blessed $old && $old->isa('HTTP::Headers::ActionPack::Core::Base');
        }
    }
    return $http_headers;
}

sub _inflate_generic_request {
    my ($self, $request) = @_;
    $self->_inflate_http_headers( $request->headers );
    return $request;
}

1;

__END__