File Coverage

blib/lib/HTTP/Headers/ActionPack/ContentNegotiation.pm

Criterion	Covered	Total	%
statement	90	90	100.0
branch	41	48	85.4
condition	12	18	66.6
subroutine	20	20	100.0
pod	4	6	66.6
total	167	182	91.7

package HTTP::Headers::ActionPack::ContentNegotiation;
BEGIN {
  $HTTP::Headers::ActionPack::ContentNegotiation::AUTHORITY = 'cpan:STEVAN';
}
{
  $HTTP::Headers::ActionPack::ContentNegotiation::VERSION = '0.09';
}
# ABSTRACT: A class to handle content negotiation

use strict;
use warnings;

use Carp         qw[ confess ];
use Scalar::Util qw[ blessed ];
use List::Util   qw[ first ];

sub new {
    my $class       = shift;
    my $action_pack = shift;

    (blessed $action_pack && $action_pack->isa('HTTP::Headers::ActionPack'))
        || confess "You must supply an instance of HTTP::Headers::ActionPack";

    bless { action_pack => $action_pack } => $class;
}

sub action_pack { (shift)->{'action_pack'} }

sub choose_media_type {
    my ($self, $provided, $header) = @_;
    my $requested       = blessed $header ? $header : $self->action_pack->create( 'MediaTypeList' => $header );
    my $parsed_provided = [ map { $self->action_pack->create( 'MediaType' => $_ ) } @$provided ];

    my $chosen;
    foreach my $request ( $requested->iterable ) {
        my $requested_type = $request->[1];
        $chosen = _media_match( $requested_type, $parsed_provided );
        return $chosen if $chosen;
    }

    return;
}

sub choose_language {
    my ($self, $provided, $header) = @_;

    return $self->_make_choice(
        choices => $provided,
        header  => $header,
        class   => 'AcceptLanguage',
        matcher => \&_language_match,
    );
}

sub choose_charset {
    my ($self, $provided, $header) = @_;

    # NOTE:
    # Making the default charset UTF-8, which
    # is maybe sensible, I dunno.
    # - SL
    return $self->_make_choice(
        choices => $provided,
        header  => $header,
        class   => 'AcceptCharset',
        default => 'UTF-8',
        matcher => \&_simple_match,
    );
}

sub choose_encoding {
    my ($self, $provided, $header) = @_;

    return $self->_make_choice(
        choices => $provided,
        header  => $header,
        class   => 'PriorityList',
        default => 'identity',
        matcher => \&_simple_match,
    );
}

sub _make_choice {
    my $self = shift;
    my %args = @_;

    my ($choices, $header, $class, $default, $matcher)
        = @args{qw( choices header class default matcher )};

    return if @$choices == 0;
    return if $header eq '';

    my $accepted         = blessed $header ? $header : $self->action_pack->create( $class => $header );
    my $star_priority    = $accepted->priority_of( '*' );

    my @canonical = map {
        my $c = $accepted->canonicalize_choice($_);
        $c ? [ $_, $c ] : ()
    } @$choices;

    my ($default_ok, $any_ok);

    if ($default) {
        $default = $accepted->canonicalize_choice($default);
        my $default_priority = $accepted->priority_of( $args{default} );

        if ( not defined $default_priority ) {
            if ( defined $star_priority && $star_priority == 0.0 ) {
                $default_ok = 0;
            }
            else {
                $default_ok = 1;
            }
        }
        elsif ( $default_priority == 0.0 ) {
            $default_ok = 0;
        }
        else {
            $default_ok = 1;
        }
    }

    if ( not defined $star_priority ) {
        $any_ok = 0;
    }
    elsif ( $star_priority == 0.0 ) {
        $any_ok = 0;
    }
    else {
        $any_ok = 1;
    }

    my $chosen;
    for my $item ($accepted->iterable) {
        my ($priority, $acceptable) = @$item;

        next if $priority == 0;

        if (my $match = first { $matcher->( $acceptable, $_->[1] ) } @canonical) {
            $chosen = $match->[0];
            last;
        }
    }

    return $chosen if $chosen;

    if ($any_ok) {
        my $match = first {
            my $priority = $accepted->priority_of( $_->[1] );
            return 1 unless defined $priority && $priority == 0;
            return 0;
        }
        @canonical;

        return $match->[0] if $match;
    }

    if ( $default && $default_ok ) {
        my $match = first { $matcher->( $default, $_->[1] ) } @canonical;
        if ($match) {
            my $priority = $accepted->priority_of( $match->[1] );
            return $match->[0] unless defined $priority && $priority == 0;
        }
    }

    return;
}

## ....

sub _media_match {
    my ($requested, $provided) = @_;
    return $provided->[0] if $requested->matches_all;
    return first { $_->match( $requested ) } @$provided;
}

sub _language_match {
    my ($range, $tag) = @_;
    ((lc $range) eq (lc $tag)) || $range eq "*" || $tag =~ /^$range\-/i;
}

sub _simple_match {
    return $_[0] eq $_[1];
}

1;

__END__