File Coverage

blib/lib/Config/Wild.pm

Criterion	Covered	Total	%
statement	132	175	75.4
branch	58	96	60.4
condition	14	24	58.3
subroutine	24	31	77.4
pod	9	9	100.0
total	237	335	70.7

package Config::Wild;

# ABSTRACT: parse an application configuration file with wildcard keywords

use strict;
use warnings;

our $VERSION = '2.02';

use custom::failures __PACKAGE__ . '::Error' => [ 'exists', 'read', 'parse' ];

use Carp;

use List::Util qw[ first ];
use File::pushd;
use Path::Tiny qw[ path cwd ];

use Try::Tiny;

use Log::Any '$log';

use namespace::clean;

sub new {
    my $this = shift;
    my $class = ref( $this ) || $this;

    my %attr = (
        UNDEF      => undef,    # function to call from value when
                                # keyword not defined
        dir        => undef,
        path       => undef,
        ExpandWild => 0,        # match wildcards when expanding
    );

    my $attr = ref $_[-1] eq 'HASH' ? pop @_ : {};

    ## no critic (ProhibitAccessOfPrivateData)
    $attr{$_} = $attr->{$_}
      for
      grep { CORE::exists( $attr{$_} ) or croak( "unknown attribute: $_\n" ) }
      keys %$attr;

    croak( "options dir and path may not both be specified\n" )
      if defined $attr{dir} && defined $attr{path};

    my $self = {
        wild => [],       # regular expression keywords
        abs  => {},       # absolute keywords
        attr => \%attr,
    };

    bless $self, $class;

    my $file = shift;

    croak( "extra arguments passed to new. forgot a hashref?\n" )
      if @_;

    $self->load( $file )
      if $file;

    return $self;
}

sub load {
    my ( $self, $file ) = @_;

    croak( 'no file specified' )
      if !defined $file;

    my $cwd
      = defined $self->{attr}{dir}
      ? pushd( $self->{attr}{dir} )
      : cwd;

    $self->_read_config( $file, path( $cwd ) );

}

# note that Path::Tiny::path will strip ./ from ./file, so
# don't convert file to a P::T object until after
# checking for ./
sub _read_config {

    my $self = shift;

    my ( $file, $cwd ) = @_;

    my $file_p = path( $file );


    # relative to current dir or parent
    if ( !defined $self->{attr}{dir} && $file =~ m|^[.]{1,2}/| ) {

        $file_p = $cwd->child( $file );

    }

    elsif ( $self->{attr}{path} && !$file_p->is_absolute ) {

      SEARCH: {
            $log->info( "Searching for configuration file $file_p" );

            for my $path ( @{ $self->{attr}{path} } ) {

                $file_p = path( $path, $file );
                last SEARCH if $file_p->is_file;

            }

            _log_fatal( 'Config::Wild::Error::exists', $file, "unable to find file in "
                        . join( ':', @{ $self->{attr}{path} } ) );

        }

    }

    _log_fatal( 'Config::Wild::Error::exists', $file_p, 'unable to find file' )
      unless $file_p->is_file;

    $log->info( "Reading configuration file ", $file_p->absolute->canonpath )
      if $log->is_info;

    my @lines;

    local $! = 0;
    try {
        @lines = $file_p->lines( { chomp => 1 } );
    }
    catch {
        _log_fatal( 'Config::Wild::Error::read', $file_p, $_ );
    };

    try {

        my $line_idx = 1;
        for my $line ( @lines ) {

            # ignore comment lines or empty lines
            next if $line =~ /^\s*\#|^\s*$/;

            if ( $line =~ /^\s*%include\s+(.*)/ ) {

                $self->_read_config( $1, $file_p->parent );

            }

            else {

                $self->_parsepair( $line )
                  or die( "can't parse line $line_idx" );
            }

        }
        continue {
            ++$line_idx;
        }

    }
    catch {
        _log_fatal( 'Config::Wild::Error::parse', $file_p, $_ );
    };

}

sub load_cmd {
    my ( $self, $argv, $attr ) = @_;
    my $keyword;

    $attr = {} unless defined $attr;

    foreach ( @$argv ) {
        if (   $$attr{Exists}
            && ( $keyword = ( $self->_splitpair( $_ ) )[0] )
            && !$self->_exists( $keyword ) )
        {
            croak( "keyword `$keyword' doesn't exist" );
        }

        $self->_parsepair( $_ ) or croak( "can't parse line $_" );
    }

    return;
}


sub set {
    my ( $self, $keyword, $value ) = @_;

    die unless defined( $keyword ) and defined( $value );
    # so, is it a regular expression or not?
    if ( $keyword =~ /\{/ ) {
        # quote all characters outside of curly brackets.
        $keyword = join(
            '',
            map {
                substr( $_, 0, 1 ) ne '{'
                  ? quotemeta( $_ )
                  : substr( $_, 1, -1 )
            } $keyword =~ /( [^{}]+ | {[^\}]*} )/gx
        );

        unshift @{ $self->{wild} }, [ $keyword, $value ];
    }
    else {
        $self->{abs}->{$keyword} = $value;
    }
}

# for backwards compatibility
#pod =pod
#pod
#pod =begin pod_coverage
#pod
#pod =head3 value
#pod
#pod =end pod_coverage
#pod
#pod =cut

*value = \&get;

sub get {
    my ( $self, $keyword ) = @_;

    croak( 'no keyword specified' )
      if !defined $keyword;


    return $self->_expand( $self->{abs}->{$keyword} )
      if CORE::exists( $self->{abs}->{$keyword} );

    foreach ( @{ $self->{wild} } ) {
        ## no critic (ProhibitAccessOfPrivateData)
        return $self->_expand( $_->[1] ) if $keyword =~ /$_->[0]/;
    }

    return $self->{attr}{UNDEF}->( $keyword )
      if defined $self->{attr}{UNDEF};

    return;
}

sub getbool {

    require Lingua::Boolean::Tiny;

    my $self = shift;

    return Lingua::Boolean::Tiny::boolean( $self->get( @_ ) );
}

sub delete {
    my ( $self, $keyword ) = @_;

    croak( 'no keyword specified' )
      if !defined $keyword;

    if ( CORE::exists $self->{abs}->{$keyword} ) {
        delete $self->{abs}->{$keyword};
    }
    else {
        ## no critic (ProhibitAccessOfPrivateData)
        $self->{wild} = grep( $_->[0] ne $keyword, @{ $self->{wild} } );
    }
    1;
}

sub exists {
    my ( $self, $keyword ) = @_;

    croak( 'no keyword specified' )
      if !defined $keyword;

    return $self->_exists( $keyword );
}

sub _exists {
    my ( $self, $keyword ) = @_;

    return 1 if CORE::exists( $self->{abs}->{$keyword} );

    foreach ( @{ $self->{wild} } ) {
        return 1 if $keyword =~ /$_->[0]/;
    }

    undef;

}


sub set_attr {
    my ( $self, $attr ) = @_;
    my ( $key, $value );

    while ( ( $key, $value ) = each %{$attr} ) {

        croak( "unknown attribute: `$key'" )
          unless CORE::exists $self->{attr}{$key};


        $self->{attr}{$key} = $value;
    }

}

#========================================================================
#
# AUTOLOAD
#
# Autoload function called whenever an unresolved object method is
# called.  If the method name relates to a defined VARIABLE, we patch
# in $self->get() and $self->set() to magically update the varaiable
# (if a parameter is supplied) and return the previous value.
#
# Thus the function can be used in the folowing ways:
#    $cfg->variable(123);     # set a new value
#    $foo = $cfg->variable(); # get the current value
#
# Returns the current value of the variable, taken before any new value
# is set.  Throws an exception if the variable isn't defined (i.e. doesn't
# exist rather than exists with an undef value) and returns undef.
#
#========================================================================

our $AUTOLOAD;
sub AUTOLOAD {
    my $self = shift;
    my $keyword;
    my ( $oldval, $newval );


    # splat the leading package name
    ( $keyword = $AUTOLOAD ) =~ s/.*:://;

    # ignore destructor
    $keyword eq 'DESTROY' && return;

    if ( CORE::exists( $self->{abs}->{$keyword} ) ) {
        $oldval = $self->_expand( $self->{abs}->{$keyword} );
    }
    else {
        my $found = 0;
        foreach ( @{ $self->{wild} } ) {
            ## no critic (ProhibitAccessOfPrivateData)
            $oldval = $self->_expand( $_->[1] ), $found++, last
              if $keyword =~ /$_->[0]/;
        }
        if ( !$found ) {
            return $self->{attr}{UNDEF}->( $keyword )
              if defined( $self->{attr}{UNDEF} );

            croak( "$keyword doesn't exist" );
        }
    }

    # set a new value if a parameter was supplied
    $self->set( $keyword, $newval )
      if defined( $newval = shift );

    # return old value
    return $oldval;
}

sub _expand {
    my ( $self, $value ) = @_;

    my $stop = 0;
    until ( $stop ) {
        $stop = 1;

        # expand ${VAR} as environment variables
        $value =~ s/\$\{(\w+)\}/defined $ENV{$1} ? $ENV{$1} : ''/ge
          and $stop = 0;

        # expand $(VAR) as a ConfigWild variable
        $value =~ s{\$\((\w+)\)} {
            my $var = $1;
            if ( defined $self->{abs}->{$var} ) {
                 $self->{abs}->{$var};
            }

            elsif ( $self->{attr}{ExpandWild}
                    && (my $kwd = first { $var =~ $_->[0] } @{ $self->{wild} } )
                  ) {

                $kwd->[1];

            }

            else {

                ''
            }

        }gex
          and $stop = 0;

        # expand any unparenthesised/braced variables,
        # e.g. "$var", as ConfigWild vars or environment variables.
        # leave untouched if not
        $value =~ s{\$(\w+)} {
            defined $self->{abs}->{$1} ? $self->{abs}->{$1} :
              defined $ENV{$1} ? $ENV{$1} :
                "\$$1"
            }gex
          and $stop = 0;
    }
    # return the value
    $value;
}

sub _splitpair {
    my ( $self, $pair ) = @_;
    my ( $keyword, $value );

    $pair =~ s/^\s+//;
    $pair =~ s/\s+$//;

    return 2 != ( ( $keyword, $value ) = $pair =~ /([^=\s]*)\s*=\s*(.*)/ )
      ? ()
      : ( $keyword, $value );
}

sub _parsepair {
    my ( $self, $pair ) = @_;

    my ( $keyword, $value );

    $pair =~ s/^\s+//;
    $pair =~ s/\s+$//;

    return
      if 2 != ( ( $keyword, $value ) = $pair =~ /([^=\s]*)\s*=\s*(.*)/ );

    $self->set( $keyword, $value );
    1;
}


sub _log_fatal {

    my ( $package, $file, @err )  = @_;

    $file = $file->absolute->canonpath if ref $file;

    my $err = join( '', $file, ': ', @err );

    $log->error( $err );
    $package->throw( $err );

}

1;

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

=pod

=head1 NAME

Config::Wild - parse an application configuration file with wildcard keywords

=head1 VERSION

version 2.02

=head1 SYNOPSIS

  use Config::Wild;
  $cfg = Config::Wild->new();
  $cfg = Config::Wild->new( $configfile, \%attr );

=head1 DESCRIPTION

This module reads I data pairs from a file.  What sets
it apart from other configuration systems is that keys may contain
Perl regular expressions, allowing one entry to match multiple
requested keys.

Configuration information in the file has the form

  key = value

where I is a token which may contain Perl regular expressions
surrounded by curly brackets, e.g.

  foobar.{\d+}.name = goo

and I is the remainder of the line after any whitespace following
the C<=> character is removed.

Keys which contain regular expressions are termed I
keys; those without are called I keys.  Wildcard
keys serve as templates to allow grouping of keys which have
the same value.  For instance, say you've got a set of keys which
normally have the same value, but where on occasion you'd like to
override the default:

  p.{\d+}.foo = goo
  p.99.foo = flabber

I may reference environment variables or other B
variables via the following expressions:

=over 4

=item *

Environment variables may be accessed via C<${var}>:

  foo = ${HOME}/foo

If the variable doesn't exist, the expression is replaced with
an empty string.

=item *

Other B variables may be accessed via C<$(var)>.

  root = ${HOME}
  foo = $(root)/foo

If the variable doesn't exist, the expression is replaced with
an empty string.  Variable expansions can be nested, as in

  root = /root
  branch = $(root)/branch
  tree = $(branch)/tree

C will evaluate to C.

=item *

I type of variable may be accessed via C<$var>.
In this case, if I is not a B variable, it is
assumed to be an environment variable.
If the variable doesn't exist, the expression is left as is.

=back

Substitutions are made when the B method is called, not when
the values are first read in.

Lines which begin with the C<#> character are ignored.  There is also a
set of directives which alter where and how B reads
configuration information.  Each directive begins with the C<%> character
and appears alone on a line in the config file:

=over 4

=item B<%include> F

Temporarily interrupt parsing of the current configuration file, and
switch the input stream to the file specified via I.
See L.

=back

=head2 Finding Configuration Files

The C and C options to the constructor determine where
configuration files are searched for.  They are optional and may not be
specified in combination.

In the following tables:

=over

=item *

C is the provided path to the configuration file.

=item *

C indicates that neither C nor C
has been specified.

=item *

The file patterns are,

  /*         absolute path
  ./* ../*   paths relative to the current directory
  *          all other paths

=item *

In the results,

  cwd        the current working directory
  path       an entry in the path option array

=back

=head3 Files loaded via B and B

  +==========================================+
  |         |            file                |
  |---------+--------------------------------|
  | option  |  /*  |  ./* ../*   |  *        |
  |==========================================|
  | default | file | cwd/file    | cwd/file  |
  | path    | file | cwd/file    | path/file |
  | dir     | file | dir/file    | dir/file  |
  +---------+------+-------------+-----------+

=head3 Files included from other files

C is the directory containing the file including the new
configuration file, e.g. the one with the C<%include> directive.

  +==========================================+
  |         |            file                |
  |---------+--------------------------------|
  | option  |  /*  |  ./* ../*   |  *        |
  |==========================================|
  | default | file | incdir/file | cwd/file  |
  | path    | file | incdir/file | path/file |
  | dir     | file | dir/file    | dir/file  |
  +---------+------+-------------+-----------+

=begin pod_coverage

=head3 value

=end pod_coverage

=head1 METHODS

=head2 Constructor

=head3 new

  $cfg = Config::Wild->new( \%attr );
  $cfg = Config::Wild->new( $config_file, \%attr );

Create a new B object, optionally loading configuration
information from a file.

See L for more information on how
configuration files are found.

Additional attributes which modify the behavior of the object may be
specified in the passed C<%attr> hash. They may also be specified or modified after
object creation using the C method.

The following attributes are available:

=over

=item C I

This specifies a subroutine to be called when the value of an undefined
key is requested.  The subroutine is passed the name of the key.
It should return a value, which will be returned as the value of the
key.

For example,

  $cfg = Config::Wild->new( "foo.cnf", { UNDEF => \&undefined_key } );

  sub undefined_key
  {
    my $key = shift;
    return 33;
  }

You may also use this to centralize error messages:

  sub undefined_key
  {
    my $key = shift;
    die("undefined key requested: $key\n");
  }

To reset this to the default behavior, set C to C:

  $cfg->set_attr( UNDEF => undef );

=item C F

If specified, the current working directory will be changed to the
specified directory before a configuration file is loaded.

See L.

This option may not be combined with the C option.

=item C I

An array of paths to search for configuration files.

See L.

This option may not be combined with the C option.

=item C I

If set, when expanding C<$(var)> in key values, C will be
matched first against absolute keys, then against wildcard
keys.  If not set (the default), C is matched only against the
absolute keys.

=back

=head3 load

  $cfg->load( $file );

Load information from a configuration file into the current object.
New configuration values will supersede previous ones, in the
following complicated fashion.  Absolutely specified keys will
overwrite previously absolutely specified values.  Since it is
difficult to determine whether the set of keys matched by two
regular expressions overlap, wildcard keys are pushed onto a
last-in first-out (LIFO) list, so that when the application requests a
value, it will use search the wildcard keys in reverse order that
they were specified.

It throws an exception (as a string) if an error occurred.

See L for more information on how
configuration files are found.

=head3 load_cmd

  $cfg->load_cmd( \@ARGV );
  $cfg->load_cmd( \@ARGV,\%attr );

Parse an array of key-value pairs (possibly command line
arguments), and insert them into the list of keys.  It can take an
optional hash of attributes with the following values:

=over 8

=item C

If true, the keys must already exist. An error will be returned if
the key isn't in the absolute list, or doesn't match against the
wildcards.

=back

It throws an exception (as a string) if an error occurred.

=head3 set

  $cfg->set( $key, $value );

Explicitly set a key to a value.  Useful to specify keys that
should be available before parsing the configuration file.

=head3 get

  $value = $cfg->get( $key );

Return the value associated with a given key.  B<$key> is
first matched against the absolute keys, then against the
wildcards.  If no match is made, C is returned.

=head3 getbool

  $value = $cfg->getbool( $key );

Convert the value associated with a given key to a true or false value
using B>.  B<$key> is first matched against
the absolute keys, then against the wildcards.  If no match is made,
or the value could not be converted to a truth value, C is
returned.

=head3 delete

  $cfg->delete( $key );

Delete C<$key> from the list of keys (either absolute or wild)
stored in the object.  The key must be an exact match.  It is not
an error to delete a key which doesn't exist.

=head3 exists

  $exists = $cfg->exists( $key );

Returns non-zero if the given key matches against the list of
keys in the object, C if not.

=head3 set_attr

  $cfg->set_attr( \%attr );

Set object attribute. See  for a list of attributes.

=head2 Keyword-named Accessors Methods

You may access a value by specifying the keyword as the method,
instead of using the B method.  The following are equivalent:

   # keyword is foo
   $foo = $cfg->get( 'foo' );
   $foo = $cfg->foo;

If C doesn't exist, it returns C.

You can set a value using a similar syntax.  The following are
equivalent, if the key already exists:

   $cfg->set( 'key', $value );
   $cfg->key( $value );

If the key doesn't exist, the second statement does nothing.

It is a bit more time consuming to use these methods rather than using
B and B.

=head1 LOGGING

B uses L to log C level messages during
searching and reading configuration files.  In the event of an error
during searching, reading, and parsing files, it will log C
level messages.

=head1 ERRORS AND EXCEPTIONS

For most errors, B will croak.

If an error occurs during searching for, reading, or parsing a
configuration file, objects in the following classes will be thrown:

=over

=item *

Config::Wild::Error::exists

=item *

Config::Wild::Error::read

=item *

Config::Wild::Error::parse

=back

They stringify into an appropriate error message.

=head1 BUGS AND LIMITATIONS

You can make new bug reports, and view existing ones, through the
web interface at L.

=head1 AUTHOR

Diab Jerius

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2017 by Smithsonian Astrophysical Observatory.

This is free software, licensed under:

  The GNU General Public License, Version 3, June 2007

=cut

__END__