File Coverage

blib/lib/Config/Wild.pm

Criterion	Covered	Total	%
statement	99	176	56.2
branch	40	90	44.4
condition	2	12	16.6
subroutine	13	22	59.0
pod	10	11	90.9
total	164	311	52.7

# --8<--8<--8<--8<--
#
# Copyright (C) 1998-2011 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 3 of the License, or (at
# your option) any later version.
#
# This program 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, see .
#
# -->8-->8-->8-->8--

package Config::Wild;

use strict;
use warnings;

use Carp qw( carp croak );
use FileHandle;
use Cwd qw[ getcwd ];

our $VERSION = '1.5';


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

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

    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
            dir        => '.',
            %$attr,
        },

    };

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

    my $cwd = getcwd;
    chdir( $self->{attr}{dir} ) or do {
        $self->_errmsg(
            "load: couldn't change directory to $self->{attr}{dir}" );
        return undef;
    };

    my $ret = eval {

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

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

            }

        }
        continue {
            shift @files;
        }


        return 1;
    };

    chdir( $cwd ) or do {
        $self->_errmsg( "load: error restoring directory to $cwd" );
        return undef;
    };


    return $ret;
}

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 getbool {

    require Lingua::Boolean::Tiny;

    my $self = shift;

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

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__