File Coverage

blib/lib/HTTP/Accept.pm

Criterion	Covered	Total	%
statement	36	36	100.0
branch	17	20	85.0
condition	2	2	100.0
subroutine	3	3	100.0
pod	1	1	100.0
total	59	62	95.1

package HTTP::Accept;

# ABSTRACT: Parse the HTTP header 'Accept'

our $VERSION = '0.02';

use Moo;

has string => ( is => 'ro', required => 1 );
has values => ( is => 'ro', lazy => 1, default => \&_parse_string );

sub match {
    my ($self, @values_to_check) = @_;

    @values_to_check = grep{ defined $_ && length $_ } @values_to_check;
    return '' if !@values_to_check;

    my @accepts = @{ $self->values || [] };
    return $values_to_check[0] if !@accepts;

    @values_to_check = map { lc $_ } @values_to_check;

    ACCEPT:
    for my $accept ( @accepts ) {
        return $values_to_check[0] if $accept eq '*/*';

        my ($cat, $type) = split /\//, $accept;

        VALUE:
        for my $value ( @values_to_check ) {
            return $value if $value eq $accept;

            my ($value_cat, $value_type) = split /\//, $value;

            next VALUE if $value_cat ne $cat;

            return $value if $type eq '*';
        }
    }

    return '';
}

around BUILDARGS => sub {
  my ($orig, $class, @args) = @_;

  return { string => $args[0] }
    if @args == 1 && !ref $args[0];

  return $class->$orig(@args);
};

sub _parse_string {
    my ($self) = @_;

    my @accepts = split /\s*,\s*/, $self->string;
    my %weighted;

    for my $accept ( @accepts ) {
        my ($accept_name, $quality) = split /;/, $accept;

        $quality //= 'q=1';
        $quality   = 'q=1' if $quality !~ m{q=};

        my ($weight) = $quality =~ m{q=([^;]*)};
        push @{ $weighted{$weight} }, lc $accept_name;
    }

    my @accept_names = map{ @{ $weighted{$_} || [] } } sort { $b <=> $a }keys %weighted;

    return \@accept_names;
}

1;

__END__