File Coverage

blib/lib/Config/XrmDatabase/Util.pm

Criterion	Covered	Total	%
statement	60	64	93.7
branch	11	12	91.6
condition	9	12	75.0
subroutine	14	15	93.3
pod	5	5	100.0
total	99	108	91.6

package Config::XrmDatabase::Util;

# ABSTRACT: Constants that won't change, and other utilitarian things.

use v5.26;
use warnings;

our $VERSION = '0.08';

use Config::XrmDatabase::Failure ':all';

use namespace::clean;

use Exporter 'import';

use experimental qw( signatures postderef );

my %CONSTANTS;
our ( %META, %RMETA );    # these get exported

BEGIN {
    %CONSTANTS = (
        TIGHT       => q{.},
        SINGLE      => q{?},
        LOOSE       => q{*},
        VALUE       => '!!VALUE',
        MATCH_COUNT => '!!MATCH_COUNT',
    );

    %META = (
        $CONSTANTS{VALUE}       => 'value',
        $CONSTANTS{MATCH_COUNT} => 'match_count',
    );
    %RMETA = reverse %META;

    $CONSTANTS{META_QR} = qr/@{[ join '|', map { quotemeta } keys %META ]}/i;
}

# so we can use the scalars here without complaints
use vars map { q{$} . $_ } keys %CONSTANTS;
{
    no strict 'refs';    ## no critic(ProhibitNoStrict)
    *{$_} = \( $CONSTANTS{$_} ) for keys %CONSTANTS;
}

use constant \%CONSTANTS;

our %EXPORT_TAGS = (
    scalar    => [ map "\$$_", keys( %CONSTANTS ) ],
    constants => [ keys( %CONSTANTS ) ],
    hashes    => [qw( %META %RMETA )],
    funcs     => [
        qw( parse_resource_name parse_fq_resource_name
          normalize_key name_arr_to_str is_wildcard ),
    ],
);


our @EXPORT_OK = ( map { @$_ } values %EXPORT_TAGS );

$EXPORT_TAGS{all} = \@EXPORT_OK;











sub parse_resource_name ( $name ) {

    {
        ## no critic (AmbiguousNames)
        my $last = substr( $name, -1 );
        key_failure->throw( "last component of name may not be a binding operator: $name" )
          if $last eq TIGHT || $last eq SINGLE || $last eq LOOSE;
    }

    # all consecutive '.' characters are replaced with a single one.
    $name =~ s/[$TIGHT]+/$TIGHT/g;

    # any combination of '.' and '*' is replaced with a '*'
    $name =~ s/[${TIGHT}${LOOSE}]{2,}/$LOOSE/g;

    # toss out fields:
    #   - the tight binding operator; that is the default.
    #   - empty fields correspond to two sequential binding operators
    #     or a leading binding operator

    return [
        grep { $_ ne TIGHT && $_ ne q{} }
          split( /([${TIGHT}${SINGLE}${LOOSE}])/, $name ) ];
}











sub parse_fq_resource_name ( $name ) {

    key_failure->throw(
        "cannot have '$LOOSE' or '$SINGLE' binding operators in a fully qualified name: $name", )
      if index( $name, SINGLE ) != -1
      or index( $name, LOOSE ) != -1;

    key_failure->throw(
        "cannot have multiple sequential '$TIGHT' binding operators in a fully qualified name: $name", )
      if $name =~ /[$TIGHT]{2,}/;

    key_failure->throw(
        "last component of a fully qualified name must not be a binding operator: $name", )
      if substr( $name, -1 ) eq TIGHT;

    key_failure->throw(
        "first component of a fully qualified name must not be a binding operator: $name", )
      if substr( $name, 0, 1 ) eq TIGHT;

    return [ split( /[$TIGHT]/, $name ) ];
}











sub normalize_key( $key ) {
    $key =~ s/[$TIGHT]?[$LOOSE][$TIGHT]?/$LOOSE/g;
    return $key;
}









sub name_arr_to_str ( $name_arr ) {
    return normalize_key( join( +TIGHT, @$name_arr ) );
}










sub is_wildcard( $string ) {
    return $string eq TIGHT || $string eq LOOSE;
}


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__