File Coverage

blib/lib/HTTP/UserAgentClientHints.pm

Criterion	Covered	Total	%
statement	55	55	100.0
branch	19	20	95.0
condition	7	8	87.5
subroutine	13	13	100.0
pod	2	2	100.0
total	96	98	97.9

package HTTP::UserAgentClientHints;
use strict;
use warnings;
use HTTP::UserAgentClientHints::BrandVersion;
use HTTP::UserAgentClientHints::Util;

our $VERSION = '0.04';

my $HTTP_HEADER_PREFIX = 'Sec-CH-UA';

my @FIELDS = qw/
    UA
    Mobile
    Platform
    Arch
    Bitness
    Model
    Full-Version-List
    Full-Version
/;

# Build getters
for my $field (@FIELDS) {
    my $method = __PACKAGE__->_as_method($field);
    no strict 'refs'; ## no critic
    *{__PACKAGE__ . '::' . $method} = sub {
        my $self = shift;
        if (exists $self->{_value}{$method}) {
            return $self->{_value}{$method};
        }
        my $raw_value = $self->{_headers}->header($self->_as_http_header_key($field));
        return $self->{_value}{$method} = $self->_normalize($raw_value, $field);
    };
    *{__PACKAGE__ . '::' . $method . '_raw'} = sub {
        my $self = shift;
        if (exists $self->{_value_raw}{$method}) {
            return $self->{_value_raw}{$method};
        }
        return $self->{_value_raw}{$method} = $self->{_headers}->header($self->_as_http_header_key($field));
    };
}

my $FULL_ACCEPT_CH = __PACKAGE__->_accept_ch;

sub _as_method {
    my ($self, $field) = @_;

    $field =~ s/-/_/g;
    $field = lc $field;

    return $field;
}

sub _as_http_header_key {
    my ($self, $field) = @_;

    return $HTTP_HEADER_PREFIX . (!$field || $field eq 'UA' ? '' : "-$field");
}

sub _normalize {
    my ($self, $value, $field) = @_;

    return $value unless defined $value;

    if ($field eq 'UA' || $field eq 'Full-Version-List') {
        $value = HTTP::UserAgentClientHints::BrandVersion->new($value);
    }
    elsif ($field =~ m!^(?:Platform|Arch|Bitness|Model|Full-Version)$!) {
        $value = HTTP::UserAgentClientHints::Util->strip_quote($value);
    }
    elsif ($field eq 'Mobile') {
        $value =~ s/^\?//;
    }

    return $value;
}

sub new {
    my ($class, $http_headers_obj) = @_;

    unless ($http_headers_obj->can('header')) {
        die q|Argument object:| . ref($http_headers_obj) . q| doesn't have "header" method to get HTTP header value.|;
    }

    bless {
        _headers   => $http_headers_obj,
        _value_raw => {},
        _value     => {},
    }, $class;
}

sub accept_ch {
    return $FULL_ACCEPT_CH unless $_[1];

    return _accept_ch(@_);
}

sub _accept_ch {
    my ($self, $excepts) = @_;

    $excepts ||= [];

    unshift @{$excepts}, 'Sec-CH-UA', 'Sec-CH-UA-Mobile', 'Sec-CH-UA-Platform'; # Default fields

    my @accept_ch;
    for my $field (@FIELDS) {
        my $f = $self->_as_http_header_key($field);
        next if grep { lc($f) eq lc($_) } @{$excepts};
        push @accept_ch, $f;
    }

    return join(', ', @accept_ch);
}

1;

__END__