view release on metacpan or  search on metacpan

lib/Config/XrmDatabase.pm  view on Meta::CPAN

package Config::XrmDatabase;

# ABSTRACT: Pure Perl X Resource Manager Database

use v5.26;
use warnings;

our $VERSION = '0.08';

use Feature::Compat::Try;

use Config::XrmDatabase::Failure ':all';
use Config::XrmDatabase::Util ':all';
use Config::XrmDatabase::Types -all;
use Types::Standard qw( Object Str Optional HashRef );
use Type::Params    qw( compile_named );
use Ref::Util;

use Moo;

use namespace::clean;

use MooX::StrictConstructor;

use experimental qw( signatures postderef declared_refs refaliasing );
use if $] >= 5.034, 'experimental', 'try';

has _db => (
    is       => 'rwp',
    init_arg => undef,
    default  => sub { {} },
);

has _query_return_value => (
    is       => 'ro',
    isa      => QueryReturnValue,
    init_arg => 'query_return_value',
    coerce   => 1,
    default  => 'value',
);

has _query_on_failure => (
    is       => 'ro',
    isa      => OnQueryFailure,
    init_arg => 'query_on_failure',
    coerce   => 1,
    default  => 'undef',
);

# fake attribute so we can use MooX::StrictConstructor
has _insert => (
    is        => 'ro',
    isa       => HashRef,
    init_arg  => 'insert',
    predicate => 1,
    clearer   => 1,
);

lib/Config/XrmDatabase.pm  view on Meta::CPAN

no namespace::clean;
use constant {
    QUERY_RETURN_VALUE     => 'value',
    QUERY_RETURN_REFERENCE => 'reference',
    QUERY_RETURN_ALL       => 'all',
    QUERY_ON_FAILURE_THROW => 'throw',
    QUERY_ON_FAILURE_UNDEF => 'undef',
};
use namespace::clean;

sub query ( $self, $class, $name, %iopt ) {

    state $check = compile_named(
        { head => [ Str, Str ] },
        return_value => Optional [QueryReturnValue],
        on_failure   => Optional [OnQueryFailure],
    );

    ( $class, $name, my \%opt ) = $check->( $class, $name, %iopt );

    $opt{on_failure}   //= $self->_query_on_failure;
    $opt{return_value} //= $self->_query_return_value;

    ( $class, $name ) = map { parse_fq_resource_name( $_ ) } $class, $name;

    components_failure->throw( 'class and name must have the same number of components' )
      if @$class != @$name;

    my $return_all = $opt{return_value} eq QUERY_RETURN_ALL;

    my $match  = [];
    my @qargs  = ( $class, $name, $return_all, $match );
    my $retval = $self->_query( $self->_db, 0, \@qargs );

    if ( !defined $retval ) {
        return $opt{on_failure}->( $name, $class )
          if Ref::Util::is_coderef( $opt{on_failure} );

        query_failure->throw(
            "unable to match name: '@{[ name_arr_to_str($name) ]} '; class : '@{[ name_arr_to_str($class) ]}'" )
          if $opt{on_failure} eq QUERY_ON_FAILURE_THROW;

        return undef;
    }

    return $opt{return_value} eq QUERY_RETURN_VALUE ? $$retval : $retval;
}

sub _query ( $self, $db, $idx, $args ) {

    my ( \$class, \$name, \$return_all, \$match ) = map { \$_ } $args->@*;

    my $_query = __SUB__;

    # things are simple if we're looking for the last component; it must
    # match exactly.  this might be able to be inlined in the exact match
    # checks below to avoid a recursive call, but this is clearer.
    if ( $idx + 1 == @$name ) {
        for my $component ( $name->[$idx], $class->[$idx] ) {
            if (   exists $db->{$component}
                && exists $db->{$component}{ +VALUE } )
            {
                push $match->@*, $component;
                my $entry = $db->{$component};
                ++$entry->{ +MATCH_COUNT };
                my $value = $entry->{ +VALUE };
                return $return_all
                  ? {
                    value       => $value,
                    match_count => $entry->{ +MATCH_COUNT },
                    key         => $match,
                  }
                  : \$value;
            }
        }
        return undef;
    }

    # otherwise need to possibly check lower level components

    # exactly named components
    for my $component ( $name->[$idx], $class->[$idx] ) {
        if ( my $subdb = $db->{$component} ) {
            push $match->@*, $component;
            my $res = $self->$_query( $subdb, $idx + 1, $args );
            return $res if defined $res;
            pop $match->@*;
        }
    }

    # single wildcard
    if ( my $subdb = $db->{ +SINGLE } ) {
        push $match->@*, SINGLE;
        my $res = $self->$_query( $subdb, $idx + 1, $args );
        return $res if defined $res;
        pop $match->@*;
    }