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

  use Config::Wild;
  $cfg = Config::Wild->new();
  $cfg = Config::Wild->new( $configfile );

  keyword = value

  foobar.{\d+}.name = goo

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

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

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

   http://www.fsf.org/copyleft/gpl.html

# --8<--8<--8<--8<--
#
# Copyright (C) 2006 Smithsonian Astrophysical Observatory
#
# This file is part of Config-Wild
#
# Config-Wild is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# Config-Wild is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the 
#       Free Software Foundation, Inc. 
#       51 Franklin Street, Fifth Floor
#       Boston, MA  02110-1301, USA
#
# -->8-->8-->8-->8--

package Config::Wild;

use strict;
use warnings;

use Carp qw( carp croak );
use FileHandle;


our $VERSION = '1.3';


sub new
{
    my $this = shift;
    my $class = ref($this) || $this;
    my $self = {
		'wild' => [],	# regular expression keywords
		'abs' => {},	# absolute keywords
		'attr' => {
			   UNDEF => undef, # function to call from value when
					   # keyword not defined
			   PrintError => 0, # warn() on error
			  },

	       };

    bless $self, $class;

    my $file = shift;

    if ( $file )
    {
	$self->load($file) or return undef;
    }

    $self;
}

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

    unless ( $file )
    {
	$self->_errmsg('load: no file specified');
	return undef;
    }

    my %files = ();
    my @files = ( { 'file' => $file, 'pos' => 0 } );

  loop:
    while ( @files )
    {
	my $file = $files[0]->{'file'};
	my $pos  = $files[0]->{'pos'};

	# if EOF on last file, don't bother with it
	next if $files[0]->{'pos'} == -1;

	my $fh = new FileHandle $file or do
	{
	    $self->_errmsg("load: error opening file `$file'");
	    return undef;
	};

	seek( $fh, $files[0]->{'pos'}, 0 ); 

	# loop through file
	my $line = 0;
	while ( <$fh> )
	{
	    $files[0]->{'pos'} = tell;
	    $line++;

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

	    chomp;

	    if ( /^\s*%include\s+(.*)/ )
	    {
		if ( CORE::exists $files{ $1 } )
		{
		    $self->_errmsg("load: infinite loop trying to read $1");
		    return undef;
		}
		$files{ $1 }++;
		unshift @files, { 'file' => $1, 'pos' => 0 };
		$fh->close;
		redo loop;
	    }

	    $self->_parsepair( $_ ) or do 
	    {
		$self->_errmsg("load: $file: can't parse line $line");
		return undef;
	    }

	}

    }
    continue
    {
	shift @files;
    }

      1;

}

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 ) )
	{
	    $self->_errmsg("load_cmd: keyword `$keyword' doesn't exist");
	    return undef;
	}

	$self->_parsepair( $_ ) or do
	{
	    $self->_errmsg("load_cmd: can't parse line $_");
	    return undef;
	}
    }

    1;
}


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
sub value
{
    goto &get;
}

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

    unless ( $keyword )
    {
	$self->_errmsg('value: no keyword specified');
	return undef;
    }

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

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

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

    undef;
}


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

    unless ($keyword)
    {
	$self->_errmsg('delete: no keyword specified');
	return undef;
    }

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

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

    unless ($keyword)
    {
	$self->_errmsg('exists: no keyword specified');
	return undef;
    }

    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} )
    {
	unless ( CORE::exists $self->{'attr'}{$key} )
	{
	    $self->_errmsg("set_attr: unknown attribute: `$key'");
	    return undef;
	}
	$self->{'attr'}{$key} = $value;
    }

}



sub errmsg
{
    my $self = shift;
    return $self->{errmsg};
}

sub _errmsg
{
    my ( $self, $errmsg ) = @_;

    $self->{'errmsg'} = __PACKAGE__ . ': ' . $errmsg;
    if ( $self->{attr}{PrintError} )
    {
	if ( ref($self->{attr}{PrintError}) eq 'CODE' )
	{
	    &{$self->{attr}{PrintError}}($errmsg);
	}
	else
	{
	    warn $errmsg, "\n"
	}
    }
}


#========================================================================
#
# 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.  Prints a warning 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}} )
	{
	    $oldval = $self->_expand($_->[1]), $found++, last
	      if $keyword =~ /$_->[0]/;
	}
	if ( ! $found )
	{
	    return &{$self->{attr}{UNDEF}}( $keyword )
	      if defined ( $self->{attr}{UNDEF} );

	    $self->{'errmsg'} = __PACKAGE__ . ": $keyword doesn't exist";
	    return undef;
	}
    }

    # 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+)\)} {
	    	    defined $self->{'abs'}->{$1} ? $self->{'abs'}->{$1} : '';
		}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 undef
      if 2 != (($keyword, $value ) = $pair =~ /([^=\s]*)\s*=\s*(.*)/);

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


1;
__END__