File Coverage

blib/lib/Config/XrmDatabase/Util.pm

Criterion	Covered	Total	%
statement	56	64	87.5
branch	11	12	91.6
condition	9	12	75.0
subroutine	13	15	86.6
pod	5	5	100.0
total	94	108	87.0

package Config::XrmDatabase::Util;

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

use v5.26;
use warnings;

our $VERSION = '0.04';

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       => '.',
        SINGLE      => '?',
        LOOSE       => '*',
        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 { '$' . $_ } 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 ) {

    {
        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 '' }
          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;

__END__