File Coverage

blib/lib/Config/XrmDatabase.pm

Criterion	Covered	Total	%
statement	228	240	95.0
branch	45	56	80.3
condition	11	16	68.7
subroutine	32	33	96.9
pod	10	11	90.9
total	326	356	91.5

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,
);




































sub BUILD ( $self, $ ) {
    if ( $self->_has_insert ) {
        my $kv = $self->_insert;
        $self->insert( $_, $kv->{$_} ) for keys %$kv;
        $self->_clear_insert;
    }
}











sub insert ( $self, $name, $value ) {

    $name = parse_resource_name( $name );
    my $db = $self->_db;
    $db                   = $db->{$_} //= {} for $name->@*;
    $db->{ +VALUE }       = $value;
    $db->{ +MATCH_COUNT } = 0;
}


























































































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->@*;
    }

    if ( my $subdb = $db->{ +LOOSE } ) {
        my $max = @$name;
        push $match->@*, LOOSE;
        while ( $idx < $max ) {
            my $res = $self->$_query( $subdb, $idx, $args );
            return $res if defined $res;
            ++$idx;
        }
        pop $match->@*;
    }

    return undef;
}
















sub read_file ( $class, $file, %opts ) {

    my $self = $class->new( %opts );

    require File::Slurper;

    my @lines;

    try {
        @lines = File::Slurper::read_lines( $file );
    }
    catch ( $e ) {
        file_failure->throw( "$e: error opening $file: $!" );
    }

    my $idx = 0;
    for my $line ( @lines ) {
        ++$idx;
        my ( $var, $value ) = $line =~ /^\s*([^:]+?)\s*:\s*(.*?)\s*$/;
        file_failure->throw( sprintf( '%s:%d: unable to parse line', $file, $idx ) )
          unless defined $var and defined $value;
        $self->insert( $var, $value );
    }

    return $self;
}










sub write_file ( $self, $file ) {
    require File::Slurper;
    File::Slurper::write_text( $file, $self->to_string );
}















sub to_string ( $self ) {

    my $folded = $self->_folded;
    my @records;

    for my $key ( keys $folded->%* ) {
        my $value = $folded->{$key};

        if ( $key =~ /^(?.*)[.](?${META_QR})$/ ) {
            next unless $+{component} eq VALUE;
            $key = $+{key};
        }

        push @records, "$key : $value";
    }

    return @records ? join( "\n", @records, q{} ) : q{};
}











sub merge ( $self, $other ) {

    require Hash::Merge;
    my $merger = Hash::Merge->new( 'RIGHT_PRECEDENT' );

    $self->_db->%* = $merger->merge( $self->TO_HASH->{db}, $other->TO_HASH->{db} )->%*;

    return $self;
}










sub clone ( $self ) {
    require Scalar::Util;

    my \%args = $self->TO_HASH;
    my $db    = delete $args{db};                                # this isn't a constructor argument.
    my $clone = Scalar::Util::blessed( $self )->new( \%args );
    $clone->_set__db( $db );
    return $clone;
}




























































my %KV_CONSTANTS;
BEGIN {
    %KV_CONSTANTS = ( map { uc( "KV_$_" ) => $_ } qw( all string array value match_count ) );

}
use constant \%KV_CONSTANTS;


sub _to_kv_xx ( $self, %iopt ) {
    %iopt = ( key => KV_STRING, value => KV_VALUE, %iopt );

    state $match = {
        ## no critic (ComplexRegexes)
        value => qr/^(? @{[ join '|', KV_VALUE, KV_MATCH_COUNT, KV_ALL ]} )$/xi,
        key   => qr/^(? @{[ join '|', KV_STRING, KV_ARRAY ]} )$/xi,
    };

    ## no critic (ComplexMappings)
    my %opt = map {
        parameter_failure->throw( "illegal value for '$_' option: $iopt{$_}" )
          unless $iopt{$_} =~ $match->{$_};
        $_ => $+{match};
    } qw( key value );

    parameter_failure->throw( "illegal option: $_" ) for grep !defined $opt{$_}, keys %iopt;

    # don't clean out excess TIGHT characters if we'll need to later
    # split it into components.  otherwise we'd have to run
    # parse_resource_name all over again.
    my $normalize_keys = $opt{key} eq KV_STRING;
    my $folded         = $self->_folded( $normalize_keys );

    # first get values
    # return single requested value
    if ( my $component = $RMETA{ $opt{value} } ) {

        for my $key ( keys $folded->%* ) {
            if ( $key =~ /^(?.*)[.](?${META_QR})$/ ) {
                # only allow the requested data out
                my $value = delete $folded->{$key};
                $folded->{ $+{key} } = $value
                  if $+{component} eq $component;
            }
        }
    }

    elsif ( $opt{value} eq KV_ALL ) {

        for my $key ( keys $folded->%* ) {
            if ( $key =~ /^(?.*)[.](?${META_QR})$/ ) {
                ( $folded->{ $+{key} } //= {} )->{ $META{ $+{component} } }
                  = delete $folded->{$key};
            }
        }
    }

    # shouldn't get here
    else {
        internal_failure->throw( "internal error: unexpected value for 'value': $iopt{value}" );
    }

    return $folded
      if $opt{key} eq KV_STRING;

    return [ map { [ [ split( /[.]/ ) ], $folded->{$_} ] } keys $folded->%* ]
      if $opt{key} eq KV_ARRAY;

    internal_failure->throw( "internal error: unexpected value for 'key': $iopt{key}" );
}











































sub to_kv ( $self, %opt ) {
    $self->_to_kv_xx( %opt, key => 'string' );
}














































sub to_kv_arr ( $self, %opt ) {
    $self->_to_kv_xx( %opt, key => 'array' );
}











sub TO_HASH ( $self ) {
    require Storable;

    {
        query_return_value => $self->_query_return_value,
        query_on_failure   => $self->_query_on_failure,
        db                 => Storable::dclone( $self->_db ),
    };
}









sub _folded ( $self, $normalize_names = 1 ) {

    # Hash::Fold is overkill
    require Hash::Fold;
    my $folded = Hash::Fold->new( delimiter => q{.} )->fold( $self->TO_HASH->{db} );

    return $folded unless $normalize_names;

    for my $key ( keys %$folded ) {
        my $nkey = normalize_key( $key );
        $folded->{$nkey} = delete $folded->{$key};
    }

    return $folded;
}






1;

#
# This file is part of Config-XrmDatabase
#
# This software is Copyright (c) 2021 by Smithsonian Astrophysical Observatory.
#
# This is free software, licensed under:
#
#   The GNU General Public License, Version 3, June 2007
#

__END__