Apache2-API
view release on metacpan or search on metacpan
is available.
v0.5.2 2026-03-22T03:03:45+0900
- Upddated method reply to ensure status code is JSON encoded as an integer, and not as a string.
- Updated status_to_type() in Apache2::API::Status
v0.5.1 2026-03-19T18:11:03+0900
- Updating Apache2::API::Request to improve acceptance of application/*+json content types
v0.5.0 2025-11-01T08:58:01+0900
- Expanded and improved localised HTTP errors now covering the following locales: cs_CZ, de_DE, en_GB, es_ES, fr_FR, ga_IE, it_IT, ja_JP, ko_KR, nb_NO, nl_NL, pl_PL, pt_BR, pt_PT, ro_RO, ru_RU, sr_RS, sv_SE, tr_TR, zh_CN, zh_TW
- Added the methods allow_methods_list, method_bit, and method_name in Apache2::API::Request
- Improved the method data() in Apache2::API to be able to be called in mutator mode, and improved caching by using Apache2::RequestUtil->pnotes rather than an object property
- Changed the method length() in Apache2::API::Request from wrongly using bytes_sent() to using the incoming headers field 'Content-Length'
v0.4.1 2025-10-07T08:09:10+0900
- Corrected the key support method _try so that it honours the list call context
v0.4.0 2025-09-30T20:30:14+0900
- Adding the log method to access the Apache2::Log::Request object
- Added the methods is_initial_req and psignature to Apache2::API::Request
lib/Apache2/API.pm view on Meta::CPAN
$msg->{message} = $ex->message;
my $lang;
if( $ex->can( 'type' ) && ( my $type = $ex->type ) )
{
$msg->{type} = $type;
}
if( !$msg->{lang} && $ex->can( 'lang' ) && ( $lang = $ex->lang ) )
{
$msg->{lang} = $lang;
}
elsif( !$msg->{lang} && $ex->can( 'locale' ) && ( $lang = $ex->locale ) )
{
$msg->{lang} = $lang;
}
warn( $msg->{message} ) if( $msg->{message} );
}
else
{
$msg = { code => Apache2::Const::HTTP_INTERNAL_SERVER_ERROR };
$msg->{message} = join( '', @_ ) if( @_ );
}
lib/Apache2/API.pm view on Meta::CPAN
my $sub = CORE::index( $sub_str, '::' ) != -1 ? substr( $sub_str, rindex( $sub_str, '::' ) + 2 ) : $sub_str;
# Now we tweak the hash to send it to the client
$msg->{message} = CORE::delete( $msg->{public_message} ) || 'An unexpected server error has occurred';
# Give it a chance to be localised
$msg->{message} = $self->gettext( $msg->{message} );
# For example, if the message is a Text::PO::Gettext::String object
if( !$msg->{lang} && $self->_can( $msg->{message} => 'lang' ) )
{
$msg->{lang} = $msg->{message}->lang;
}
elsif( !$msg->{lang} && $self->_can( $msg->{message} => 'locale' ) )
{
$msg->{lang} = $msg->{message}->locale;
}
my $ctype = $self->response->content_type;
if( $ctype eq 'application/json' )
{
return( $self->reply( $msg->{code}, { error => $msg->{message} } ) );
}
else
{
# try-catch
local $@;
lib/Apache2/API.pm view on Meta::CPAN
my $use_rfc_error = $self->{use_rfc_error} // $USE_RFC_ERROR;
# rfc9457 standard for REST API error response: <https://www.rfc-editor.org/rfc/rfc9457.html>
# Legacy JSON payload like Google, Twitter, Facebook
# Modern REST APIs now uses rfc9457 with a flattened payload.
# When the use_rfc_error object property is true, we use rfc9457 flattened error, this will produce something like:
# {
# error => 'not_found',
# status => 404,
# title => 'Not found!',
# detail => q{The requested URL was not found on this server. If you entered the URL manually please check your spelling and try again.},
# locale => 'en-US',
# type => 'https://api.example.com/problems/not-found',
# }
# otherwise, the legacy approach would be:
# {
# error =>
# {
# code => 404,
# message => q{The requested URL was not found on this server. If you entered the URL manually please check your spelling and try again.},
# },
# locale => 'en-US',
# }
# $self->reply( Apache2::Const::HTTP_OK, { message => "All is well" } );
if( scalar( @_ ) == 2 )
{
( $code, $ref ) = @_;
}
elsif( scalar( @_ ) == 1 &&
$self->_can( $_[0] => 'code' ) &&
$self->_can( $_[0] => 'message' ) )
{
my $ex = shift( @_ );
$code = $ex->code;
$ref =
{
message => $ex->message,
( $ex->can( 'public_message' ) ? ( public_message => $ex->public_message ) : () ),
( $ex->can( 'locale' ) ? ( locale => $ex->locale ) : () ),
};
}
# $self->reply({ code => Apache2::Const::HTTP_OK, message => "All is well" } );
elsif( ref( $_[0] ) eq 'HASH' )
{
$ref = shift( @_ );
$code = $ref->{code} if( length( $ref->{code} ) );
}
my $r = $self->apache_request;
my $req = $self->request;
lib/Apache2/API.pm view on Meta::CPAN
$resp->rflush;
# $r->send_http_header;
$resp->print( $self->json->utf8->encode({ error => 'An unexpected server error occured', code => 500 }) );
$self->error( "Data provided to send is not a hash ref." );
return( Apache2::Const::HTTP_INTERNAL_SERVER_ERROR );
}
# Resolve whether this is an error
my $is_error = $resp->is_error( $code ) ? 1 : 0;
# NOTE: guess_preferred_locale() -> this is used to get he most appropriate locale if not defined already so we can, in turn, get the fallback description
my $guess_preferred_locale = sub
{
my $locale = shift( @_ );
if( !defined( $locale ) )
{
$locale = $req->preferred_language( Apache2::API::Status->supported_languages );
}
if( defined( $locale ) )
{
# Make sure we are dealing with unix style language code
$locale =~ tr/-/_/;
if( length( $locale ) == 2 )
{
$locale = Apache2::API::Status->convert_short_lang_to_long( $locale );
}
# We have something weird, like maybe eng?
elsif( $locale !~ /^[a-z]{2}_[A-Z]{2}$/ )
{
$locale = Apache2::API::Status->convert_short_lang_to_long( substr( $locale, 0, 2 ) );
}
}
return( $locale );
};
# NOTE: build_rfc_error() -> private subroutine to build the modern rfc9457 error payload
my $build_rfc_error = sub
{
my( $ref, $code, $msg ) = @_;
# By now, our property 'locale' has been dealt with, so we do not have to worry about it.
# It either exists or not
my $locale = exists( $ref->{locale} ) ? $ref->{locale} : undef;
# The property 'status' could exist, but be undefined, or even empty, so we check for that.
unless( exists( $ref->{status} ) &&
defined( $ref->{status} ) &&
length( $ref->{status} ) )
{
$ref->{status} = $code;
}
$ref->{status} = int( $ref->{status} ) if( $ref->{status} =~ /^\d+$/ );
lib/Apache2/API.pm view on Meta::CPAN
defined( $ref->{title} ) &&
length( $ref->{title} // '' ) )
{
if( exists( $ref->{error} ) &&
defined( $ref->{error} ) &&
ref( $ref->{error} ) eq 'HASH' &&
exists( $ref->{error}->{title} ) )
{
$ref->{title} = delete( $ref->{error}->{title} );
}
elsif( $locale )
{
$ref->{title} = Apache2::API::Status->status_message( $code => $locale );
}
else
{
$ref->{title} = Apache2::API::Status->status_message( $code );
}
}
# Detail/message precedence: explicit detail > message field > HTTP message
if( !defined( $ref->{detail} ) || $ref->{detail} eq '' )
{
lib/Apache2/API.pm view on Meta::CPAN
{
$r->log->warn( ref( $self ), ": warning only: you seem to have set the property 'details' in your error payload, but to build a rfc9457 error, you need to provide the property 'detail' instead." );
}
if( defined( $msg ) && ( !ref( $msg ) || $self->_can_overload( $msg => "''" ) ) )
{
$ref->{detail} = "$msg";
}
else
{
my $fallback = $locale
? $resp->get_http_message( $code, $locale )
: $resp->get_http_message( $code );
$ref->{detail} = $fallback // 'An error occurred';
}
}
# Clean up the 'error' property if it is a hash reference.
if( exists( $ref->{error} ) &&
defined( $ref->{error} ) &&
ref( $ref->{error} ) eq 'HASH' )
{
lib/Apache2/API.pm view on Meta::CPAN
# The rfc 9457 prefers the property 'detail'.
delete( $ref->{message} ) if( exists( $ref->{message} ) );
# The rfc 9457 prefers the property 'status'.
delete( $ref->{code} ) if( exists( $ref->{code} ) );
};
# NOTE: build_legacy_error() -> private subroutine to build the legacy error payload
my $build_legacy_error = sub
{
my( $ref, $code, $msg ) = @_;
# By now, our property 'locale' has been dealt with, so we do not have to worry about it.
# It either exists or not
my $locale = exists( $ref->{error}->{locale} ) ? $ref->{error}->{locale} : undef;
# We set the property 'error' to be an HASH if not set already.
$ref->{error} = {} unless( exists( $ref->{error} ) && ref( $ref->{error} ) eq 'HASH' );
# The property 'code' could exist, but be undefined, or even empty, so we check for that.
unless( exists( $ref->{error}->{code} ) &&
defined( $ref->{error}->{code} ) &&
length( $ref->{error}->{code} ) )
{
$ref->{error}->{code} = $code;
}
$ref->{error}->{code} = int( $ref->{error}->{code} ) if( $ref->{error}->{code} =~ /^\d+$/ );
# We try hard to get the value for the property 'message', but if $locale is undefined, it is impossible to find out the language that was used to formulate the response.
# So, ultimately, if we cannot find any value for the property 'message', we revert to guessing the HTTP caller's preferred language, which may, or may not be aligned with the content of other parts of the JSON response. Given that, in that s...
if( !exists( $ref->{error}->{message} ) ||
!defined( $ref->{error}->{message} ) ||
!length( $ref->{error}->{message} // '' ) )
{
if( defined( $msg ) &&
( !ref( $msg ) || $self->_can_overload( $msg => "''" ) ) )
{
$ref->{error}->{message} = "$msg";
}
else
lib/Apache2/API.pm view on Meta::CPAN
if( exists( $ref->{ $p } ) &&
defined( $ref->{ $p } ) &&
length( $ref->{ $p } ) )
{
$ref->{error}->{message} = delete( $ref->{ $p } );
last;
}
}
}
# Still nothing ? Get the fallback value using 'get_http_message' either using the $locale, if defined, or the HTTP caller's preferred language
if( !$ref->{error}->{message} )
{
$locale = $guess_preferred_locale->( $locale ) unless( defined( $locale ) );
my $fallback = $locale
? $resp->get_http_message( $code, $locale )
: $resp->get_http_message( $code );
$ref->{error}->{message} = $fallback // 'An error occurred';
}
}
# Build 'type' URL if not provided
unless( exists( $ref->{error}->{type} ) &&
defined( $ref->{error}->{type} ) &&
length( $ref->{error}->{type} // '' ) )
{
lib/Apache2/API.pm view on Meta::CPAN
elsif( my $t = Apache2::API::Status->status_to_type( $code ) )
{
$ref->{error}->{type} = $t;
}
}
# Collapse top-level duplicates
delete( $ref->{ $_ } ) for( qw( message code type error_description ) );
};
# NOTE: set_payload_locale() -> find out and set the 'locale' property.
my $set_payload_locale = sub
{
my( $ref, $msg ) = @_;
my $locale;
# From message object
# '$msg' might be undef, and the method _is_a knows how to handle it.
if( $self->_is_a( $msg => 'Text::PO::String' ) )
{
$locale = $msg->locale
}
# Check if the Content-Language has already been set.
elsif( my $l = $resp->headers->get( 'Content-Language' ) )
{
$locale = $l;
$locale =~ tr/_/-/;
}
if( !defined( $locale ) &&
exists( $ref->{error} ) &&
ref( $ref->{error} ) eq 'HASH' )
{
foreach my $p ( qw( locale lang ) )
{
if( exists( $ref->{error}->{ $p } ) &&
defined( $ref->{error}->{ $p } ) &&
length( $ref->{error}->{ $p } ) )
{
$locale = $ref->{error}->{ $p };
last;
}
}
}
if( !defined( $locale ) )
{
foreach my $p ( qw( locale lang ) )
{
if( exists( $ref->{ $p } ) &&
defined( $ref->{ $p } ) &&
length( $ref->{ $p } ) )
{
$locale = $ref->{ $p };
last;
}
}
}
# If we found a locale, we set it properly whether it is an error or success message.
if( defined( $locale ) )
{
if( $is_error )
{
if( $use_rfc_error )
{
$ref->{locale} = $locale;
if( exists( $ref->{error} ) &&
ref( $ref->{error} ) eq 'HASH' )
{
delete( $ref->{error}->{lang} );
delete( $ref->{error}->{locale} );
}
}
else
{
$ref->{error} //= {};
$ref->{error}->{locale} = $locale;
delete( $ref->{lang} );
delete( $ref->{locale} );
}
}
else
{
$ref->{locale} = $locale;
}
}
return( defined( $locale ) ? 1 : 0);
};
# '$msg' may possibly be a Text::PO::String, whose benefit is that it has the 'locale' method
my $msg;
if( exists( $ref->{success} ) && !exists( $ref->{message} ) )
{
$msg = $ref->{success};
}
# Maybe error is a string, or maybe it is already an error hash like { error => { message => '', code => '' } }
elsif( exists( $ref->{error} ) && $is_error )
{
# Caller gave us either a string or a hash under the property 'error'
if( ref( $ref->{error} ) eq 'HASH' )
lib/Apache2/API.pm view on Meta::CPAN
}
# Remove those properties now
delete( $ref->{error}->{ $_ } ) for( qw( code status ) );
}
else
{
$msg = $ref->{error};
$ref->{error} = {} unless( $use_rfc_error );
}
$set_payload_locale->( $ref, $msg );
if( $use_rfc_error )
{
$build_rfc_error->( $ref, $code, $msg );
}
else
{
$build_legacy_error->( $ref, $code, $msg );
}
}
lib/Apache2/API.pm view on Meta::CPAN
$build_legacy_error->( $ref, $code, $msg );
}
}
# This is a success response
else
{
$ref->{success} = \1 unless( exists( $ref->{success} ) );
$ref->{code} //= $code;
$ref->{code} = int( $ref->{code} ) if( $ref->{code} =~ /^\d+$/ );
}
$set_payload_locale->( $ref, $msg );
}
# Or we just have a code to go on with
elsif( $is_error )
{
# No message, just a code => build minimal error body
if( $use_rfc_error )
{
$build_rfc_error->( $ref, $code, undef );
}
else
lib/Apache2/API.pm view on Meta::CPAN
unless( $resp->headers->get( 'Access-Control-Allow-Origin' ) )
{
$resp->headers->set( 'Access-Control-Allow-Origin' => '*' );
}
# As an api, make sure there is no caching by default unless the field has already been set.
unless( $resp->headers->get( 'Cache-Control' ) )
{
$resp->headers->set( 'Cache-Control' => 'private, no-cache, no-store, must-revalidate' );
}
# If we have a locale set, we use it
my $locale;
if( $is_error )
{
if( $use_rfc_error )
{
$locale = $ref->{locale} if( exists( $ref->{locale} ) );
}
else
{
$locale = $ref->{error}->{locale} if( exists( $ref->{error} ) && ref( $ref->{error} ) eq 'HASH' && exists( $ref->{error}->{locale} ) );
}
}
# Success response
else
{
$locale = $ref->{locale} if( exists( $ref->{locale} ) );
}
if( $locale )
{
# Set the content language for this payload unless the user has already set it.
unless( $resp->headers->get( 'Content-Language' ) )
{
# en_GB -> en-GB
( my $hdr_locale = $locale ) =~ tr/_/-/;
$resp->headers->set( 'Content-Language' => $hdr_locale );
}
$resp->headers->merge( 'Vary' => 'Accept-Language' );
}
# Choose Content-Type
# If we use new modern error, then we set application/problem+json in line with rfc7807
my $ctype = ( $is_error && $use_rfc_error )
? 'application/problem+json; charset=utf-8'
: 'application/json; charset=utf-8';
$resp->content_type( $ctype );
lib/Apache2/API/Headers/AcceptCommon.pm view on Meta::CPAN
=head1 SYNOPSIS
use Apache2::API::Headers::Accept;
use Apache2::API::Headers::AcceptLanguage;
my $accept = Apache2::API::Headers::Accept->new( 'text/html;q=0.9,application/json' );
my $mime = $accept->match( ['text/html', 'application/json'] ); # => 'text/html'
my $al = Apache2::API::Headers::AcceptLanguage->new( 'fr-FR;q=0.9,en;q=0.8' );
my $locale = $lang->match( ['en', 'fr-FR'] ); # => 'fr-FR'
=head1 DESCRIPTION
L<Apache2::API::Headers::AcceptCommon> implements a base class for parsing, sorting, and matching rules for HTTP headers that carry I<quality values> (C<q>), such as C<Accept> and C<Accept-Language>. Subclasses provide the domain-specific details:
=over 4
=item * how to parse a token, such as C<type/subtype> vs. language tags
=item * what counts as a full match vs partial match
lib/Apache2/API/Headers/AcceptLanguage.pm view on Meta::CPAN
};
use v5.26.1;
use strict;
use warnings;
use feature 'try';
no warnings 'experimental';
# Patterns for accept language
# my $LANGUAGE_RANGE = qr/(?:[A-Za-z0-9]{1,8}(?:-[A-Za-z0-9]{1,8})*|\*)/;
# No need to re-invent the wheel, but instead of using this regular expression, best to use Locale::Unicode->matches that returns an hash reference of locale parts upon success or an empty string in scalar context, or an empty list in list context.
my $LANGUAGE_RANGE = $Locale::Unicode::LOCALE_RE;
my $QVALUE = qr/(?:0(?:\.[0-9]{0,3})?|1(?:\.0{0,3})?)/;
# Useful alias, similar to HTTP::AcceptLanguage
sub languages { return( shift->preferences ); }
sub locales { return( shift->preferences ); }
sub _full_match
{
my( $self, $their, $our ) = @_;
return( ( $their->{locale_lc} eq $our->{locale_lc} ) ? 1 : 0 );
}
sub _is_wildcard
{
my( $self, $ph ) = @_;
return( ( $ph->{locale} && $ph->{locale} eq '*' ) ? 1 : 0 );
}
sub _normalize_supported
{
my( $self, @supported ) = @_;
my @norm;
my $seen = {};
for my $token ( @supported )
{
next unless( defined( $token ) && length( $token ) );
my $hv = Module::Generic::HeaderValue->new_from_header( $token ) || next;
my $l = $hv->value->first;
unless( defined( $l ) && length( $l ) )
{
next;
}
my $locale = Locale::Unicode->new( $l );
if( !$locale )
{
warn( "Locale provided '$l' is not a valid locale." ) if( $self->_is_warnings_enabled( 'Apache2::API' ) );
}
my $base = $locale->base;
# Locale with the same base are considered identical, which means their BCP47 or Unicode CLDR extension are rightfully ignored.
next if( ++$seen->{ lc( $base ) } > 1 );
my $lang = $locale->language;
push( @norm,
{
raw => $locale,
# en-Latn-US-posix-t-de-AT-t0-und-x0-medical -> en
language => $lang,
language_lc => lc( $lang ),
# en-Latn-US-posix-t-de-AT-t0-und-x0-medical -> en-Latn-US-posix
# en-US -> en-US
locale => $base,
locale_lc => lc( $base ),
});
}
return( \@norm );
}
sub _parse
{
my $self = shift( @_ );
my $header = shift( @_ );
my $h = $header;
lib/Apache2/API/Headers/AcceptLanguage.pm view on Meta::CPAN
defined( $params->{'q'} ) &&
length( $params->{'q'} ) &&
$params->{'q'} =~ m/\A$QVALUE\z/ )
{
$q = 0 + $params->{'q'};
}
next unless( $token && $q > 0 );
# We need to clarify the vocabulary here, as per the BCP47, and the Unicode CLDR
# A language is a 2 or 3-characters code, such as fr or fra, oe en or eng
# A locale carries more information, such as, but not limited to, the country. It could also have a script, and much more information.
# For example, a valid locale: fr-BE, ja-JP, or en-Latn-AU or even ja-Kana-t-it
my $locale = Locale::Unicode->new( $token );
if( !$locale )
{
warn( "Locale provided '$token' is not a valid locale." ) if( $self->_is_warnings_enabled( 'Apache2::API' ) );
next;
}
# en-Latn-US-posix-t-de-AT-t0-und-x0-medical -> en-Latn-US
my $base = $locale->base;
# The 2 to 3-characters code
# en-Latn-US-posix-t-de-AT-t0-und-x0-medical -> en
my $lang = $locale->language;
my $locale_lc = lc( $base );
push( @$elements,
{
token => $token,
# The Locale::Unicode object
locale => $locale,
locale_lc => $locale_lc,
language_lc => lc( $lang ),
quality => $q + 0,
});
if( !exists( $best_q_for{ $locale_lc } ) || $q > $best_q_for{ $locale_lc } )
{
$best_q_for{ $locale_lc } = $q;
}
}
# Keep only the records that have the best 'q' for their exact tag.
@$elements = grep{
my $keep = 0;
if( exists( $best_q_for{ $_->{locale_lc} } ) )
{
$keep = ( $best_q_for{ $_->{locale_lc} } == $_->{quality} ) ? 1 : 0;
delete( $best_q_for{ $_->{locale_lc} } ) if( $keep );
}
$keep;
} @$elements;
return( $elements );
}
sub _partial_match
{
my( $self, $their, $our ) = @_;
# ex: "en" (language part of the locale) matches "en-GB"
return( ( $their->{language_lc} eq $our->{language_lc} ) ? 1 : 0 );
}
# For the locales, we do not use a granularity of numbered specificity;
# we return 2 for full, and 1 for partial in order to remain coherent with Accept.
sub _specificity
{
my( $self, $their, $our ) = @_;
return(2) if( $self->_full_match( $their, $our ) );
return(1) if( $self->_partial_match( $their, $our ) );
return(0);
}
1;
lib/Apache2/API/Headers/AcceptLanguage.pm view on Meta::CPAN
=encoding utf-8
=head1 NAME
Apache2::API::Headers::AcceptLanguage - Parser and matcher for HTTP Accept-Language header
=head1 SYNOPSIS
use Apache2::API::Headers::AcceptLanguage;
my $al = Apache2::API::Headers::AcceptLanguage->new( 'fr-FR;q=0.9,en;q=0.8' );
my $locale = $al->match( ['en', 'fr-FR'] ); # => 'fr-FR'
my $prefs = $al->prefs; # => ['fr-FR', 'en']
=head1 DESCRIPTION
Parses HTTP C<Accept-Language> header and provides the L<Apache2::API::Headers::AcceptCommon/match> method to match against supported locales (languages).
Full tag matches (e.g. C<fr-FR>) trump primary-language matches (e.g. C<fr> matching C<fr-CA>), with quality values (C<q>) per RFC 7231 and RFC 9110. Language/locale parsing is done with L<Locale::Unicode>.
It inherits from L<Apache2::API::Headers::AcceptCommon>.
The algorithm is as follows:
=over 4
=item * Exact C<locale> match beats primary language match at the same C<q>. For example, C<fr-CA> beats C<fr>
=item * Primary language tokens, such as C<en>, can match more specific locales, such as C<en-GB>.
=item * C<*> wildcard is a low-specificity fallback and never outranks an equal-C<q> specific match.
=item * Duplicates keep highest C<q>; C<q=0> excludes a tag.
=back
=head1 CONSTRUCTOR
=head2 new( $header )
Creates a new instance with the given C<Accept-Language> header string, and returns it.
If an error occurred, it sets an error that can be retrieved with the L<error method|Module::Generic/error>, and it returns C<undef> in scalar context, or an empty list in list context.
=head1 METHODS
=head2 languages
As per BCP47, and Unicode CLDR, a C<language> is just a 2 to 3-characters code ths is possibly part of a L<locale|Locale::Unicode>. Yet, this method is defined here for convenience.
This is an alias to L</preferences>
=head2 locales
This is an alias to L</preferences>
=head2 match( \@supported_locales )
Returns the best matching L<locale|Locale::Unicode> from the provided list of supported locales.
It returns an empty string if nothing matched, or sets an L<error|Module::Generic/error> and returns C<undef> in scalar context, or returns an empty list in list context.
=head2 preferences
Read-only.
Returns an array reference of locales, submitted by the user C<Accept-Language> header in his HTTP request, sorted by decreasing quality, with duplicates removed (keeping highest C<q>).
If an error occurred, it sets an error that can be retrieved with the L<error method|Module::Generic/error>, and it returns C<undef> in scalar context, or an empty list in list context.
=head1 EXAMPLES
=head2 1. Exact beats primary language at same q
my $al = Apache2::API::Headers::AcceptLanguage->new('fr-FR;q=0.9, fr;q=0.9');
$al->match([ 'fr-CA', 'fr-FR' ]);
# "fr-FR"
=head2 2. Primary language matches a more specific server locale
my $al = Apache2::API::Headers::AcceptLanguage->new('en;q=0.9, fr;q=0.8');
$al->match([ 'fr-FR', 'en-GB' ]);
# "en-GB"
=head2 3. Wildcard at higher q picks first supported
my $al = Apache2::API::Headers::AcceptLanguage->new('*;q=1.0, en;q=0.9');
$al->match([ 'fr-FR', 'en-GB' ]);
# "fr-FR"
=head1 LEGACY MATCH PRIORITY
Set C<$Apache2::API::Headers::AcceptLanguage::MATCH_PRIORITY_0_01_STYLE> to true to apply “offer order†tie-breaking within equal-C<q> buckets (see L<Apache2::API::Headers::AcceptCommon/"MATCH PRIORITY MODE"> for details).
=head1 NOTES ON TAGS
Tags are parsed using L<Locale::Unicode>. Invalid tags are discarded. For robust behavior, pass your supported locales in the same syntax you intend to serve, such as C<en>, C<en-GB>, C<ja-JP>.
=head1 PERFORMANCE
The matchers called with L<Apache2::API::Headers::AcceptCommon/match> loops through the array reference of supported locales times the number of parsed acceptable locales as submitted by the client.
Typical HTTP C<Accept-Language> headers are small, so the performance should be very good.
L<Apache2::API::Headers::AcceptCommon/preferences> and sorted results are cached per object.
=head1 CREDITS
Based on L<HTTP::AcceptLanguage> by Kazuhiro Osawa
=head1 AUTHOR
t/08.accept_language.t view on Meta::CPAN
my $al = Apache2::API::Headers::AcceptLanguage->new( 'en-GB, fr-FR;q=0.8', debug => $DEBUG );
isa_ok( $al, 'Apache2::API::Headers::AcceptLanguage' );
# To generate this list:
# perl -lnE '/^sub (?!init|[A-Z]|_)/ and say "can_ok( \$al, \''", [split(/\s+/, $_)]->[1], "\'' );"' ./lib/Apache2/API/Headers/AcceptCommon.pm ./lib/Apache2/API/Headers/AcceptLanguage.pm
can_ok( $al, 'header' );
can_ok( $al, 'match' );
can_ok( $al, 'preferences' );
can_ok( $al, 'languages' );
can_ok( $al, 'locales' );
sub is_match
{
my( $hdr, $offers, $expect, $name ) = @_;
my $al = Apache2::API::Headers::AcceptLanguage->new( $hdr, debug => $DEBUG );
my $got = $al->match( $offers );
is( $got, $expect, $name );
}
is( $al->header, 'en-GB, fr-FR;q=0.8', 'Header stored correctly' );
# Test preferences (locales)
my $prefs = $al->preferences;
is_deeply( $prefs, ['en-GB', 'fr-FR'], 'Preferences sorted by q descending' );
# Test aliases
is_deeply( $al->languages, $prefs, 'languages alias' );
is_deeply( $al->locales, $prefs, 'locales alias' );
# Exact tag match
is_match(
'en-GB, fr-FR;q=0.8',
[ 'fr-FR', 'en-GB' ],
'en-GB',
'Exact locale match'
);
# Primary language partial match
is_match(
'en;q=0.5, fr-FR;q=0.9',
[ 'en-GB', 'fr-FR' ],
'fr-FR',
'Higher q exact vs partial language match'
);
# Primary language matches more specific server locale
is_match(
'en;q=0.9, fr;q=0.8',
[ 'fr-FR', 'en-GB' ],
'en-GB',
'Primary language matches server locale'
);
# Wildcard => first supported
{
# The wildcard is triggering warning about illegal locale string, so we silence it.
local $SIG{__WARN__} = sub{};
is_match(
'*;q=0.2',
[ 'ja-JP', 'fr-FR' ],
'ja-JP',
'Wildcard * selects first supported'
);
}
# Test partial match (language only)
t/08.accept_language.t view on Meta::CPAN
);
# Test error handling
$al = Apache2::API::Headers::AcceptLanguage->new('en', debug => $DEBUG);
my $rv = $al->match('not array');
ok( !defined( $rv ), 'Non-array supported: error' );
like( $al->error->message, qr/not an array reference/, 'Error message correct' );
subtest 'edge cases' => sub
{
# Duplicate locales keep best q
is_match(
'fr-FR;q=0.2, fr-FR;q=0.9, en;q=0.8',
[ 'en', 'fr-FR' ],
'fr-FR',
'Duplicate locale uses highest q',
);
# q=0 excludes a tag
is_match(
'ja;q=0, en;q=0.5',
[ 'ja-JP', 'en-GB' ],
'en-GB',
'q=0 excludes language',
);
t/08.accept_language.t view on Meta::CPAN
);
# Test no header
is_match(
'',
['en'],
'en',
'No header: first supported',
);
# Test multiple same locale different q
$al = Apache2::API::Headers::AcceptLanguage->new('en;q=0.5,en;q=0.9', debug => $DEBUG);
is_deeply( $al->preferences, ['en'], 'Keeps highest q for duplicate' );
# Test invalid locale
$al = Apache2::API::Headers::AcceptLanguage->new('invalid;q=1', debug => $DEBUG);
ok( !$al->preferences->[0], 'Invalid locale ignored' );
# Test empty supported
is( $al->match([]), '', 'Empty supported: empty string' );
# Test 0.01 style priority
local $Apache2::API::Headers::AcceptLanguage::MATCH_PRIORITY_0_01_STYLE = 1;
$al = Apache2::API::Headers::AcceptLanguage->new('en;q=0.5,fr;q=0.5', debug => $DEBUG);
is( $al->match(['fr', 'en']), 'fr', '0.01 style: supported order' );
# Test complex locale
$al = Apache2::API::Headers::AcceptLanguage->new('ja-Kana-t-it;q=0.9', debug => $DEBUG);
is( $al->preferences->[0], 'ja-Kana-t-it', 'Complex locale parsed' );
};
subtest 'preferences consistency' => sub
{
$al = Apache2::API::Headers::AcceptLanguage->new( 'fr-FR;q=0.5, en-GB;q=0.8, fr;q=0.7', debug => $DEBUG );
my $prefs = $al->preferences;
isa_ok( $prefs, 'ARRAY', 'AcceptLanguage::preferences returns arrayref (first call)' );
my $prefs2 = $al->preferences;
isa_ok( $prefs2, 'ARRAY', 'AcceptLanguage::preferences returns arrayref (cached path)' );
is_deeply( $prefs2, $prefs, 'AcceptLanguage::preferences cached == initial' );
( run in 0.862 second using v1.01-cache-2.11-cpan-ceb78f64989 )