view release on metacpan or  search on metacpan

lib/Apache2/API/Headers/AcceptCommon.pm  view on Meta::CPAN

##----------------------------------------------------------------------------
## Apache2 API Framework - ~/lib/Apache2/API/Headers/AcceptCommon.pm
## Version v0.1.0
## Copyright(c) 2025 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack@deguest.jp>
## Created 2025/10/14
## Modified 2025/10/15
## All rights reserved
## 
## This program is free software; you can redistribute  it  and/or  modify  it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
package Apache2::API::Headers::AcceptCommon;
BEGIN
{
    use strict;
    use warnings;
    warnings::register_categories( 'Apache2::API' );
    use parent qw( Module::Generic );
    use vars qw( $VERSION );
    our $VERSION = 'v0.1.0';
};

use v5.26.1;
use strict;
use warnings;
use feature 'try';
no warnings 'experimental';

sub init
{
    my $self = shift( @_ );
    my $header = shift( @_ );
    $self->SUPER::init( @_ ) || return( $self->pass_error );
    my $parsed = [];
    if( defined( $header ) && length( $header ) )
    {
        $parsed = $self->_parse( $header ) || return( $self->pass_error );
    }
    $self->{header} = $header;
    $self->{parsed_header}  = $parsed;
    # Cache
    $self->{_sorted} = undef;
    $self->{_prefs}  = undef;
    return( $self );
}

# Read-only
sub header { return( shift->_set_get_scalar( 'header' ) ); }

# Returns an empty string if no match, and undef upon error with the error object accessible with the 'error' method inherited from Module::Generic
sub match
{
    my $self = shift( @_ );
    my $supported = shift( @_ );
    if( !$supported )
    {
        return( $self->error( "No supported values was provided." ) );
    }
    # _is_array also returns true if this is an array object, such as Module::Generic::Array
    elsif( !$self->_is_array( $supported ) )
    {
        return( $self->error( "Value provided is not an array reference." ) );
    }
    elsif( !scalar( @$supported ) )
    {
        warn( "Warning only: no supported token were provided." ) if( $self->_is_warnings_enabled( 'Apache2::API' ) );
        return( '' );
    }

    # Si pas de header utilisable, RFC : tout est accepté => premier offert.
    # If no usable jeaders, RFC says that anything is acceptable, so we pick the first one supported
    if( !@{$self->{parsed_header}} )
    {
        return( $supported->[0] );
    }

    # Normalise les offres côté serveur (subclasses).
    my $norm = $self->_normalize_supported( @$supported ) ||
        return( $self->pass_error );
    if( !scalar( @$norm ) )
    {
        warn( "Warning only: Normalised token produced an empty list!" ) if( $self->_is_warnings_enabled( 'Apache2::API' ) );
        return( '' );
    }

    # Strategy:
    # 1) Iterate through the items sorted by q (client-side)
    # 2) For each equal 'q', two branches:
    #    - mode 0.01: we accumulate, then choose according to the order of the supported items
    #    - mode >= 0.02: we match in the order of the header (client)
    #
    # Get the symbol '$MATCH_PRIORITY_0_01_STYLE' in our object class namespace.
    # The symbol is in each respective class namespace, so the user can refer to $Apache2::API::Headers::Accept::MATCH_PRIORITY_0_01_STYLE for example, and NOT $Apache2::API::Headers::AcceptCommon::MATCH_PRIORITY_0_01_STYLE