Extended Configuration Files - Substituting Variables

Last time, I left you with a bit of a cliffhanger. I’d implemented fallbacks but I still wasn’t substituting variables which I promised for this time. It turns out that the solution is really simple.

my %matching_bracket = qw#{ } ( ) [ ]#;

sub param
{
    my ($self, $param, $full_alias, $base_ref) = @_;
    $full_alias = $self->{'full_alias'} if (! defined($full_alias));
    $base_ref = $self->{'base'} if (! defined($base_ref));
    my $alias_data = $self->get_alias_data($full_alias);

    my $retval = get_if_hash($alias_data, $param);
    if (! defined($retval)) {
        foreach my $fallback (@$base_ref) {
            if ($fallback eq '~VAR') {
                if (exists($self->{'vars'}{$param})) {
                    $retval = $self->{'vars'}{$param};
                    last;
                }
            } elsif ($fallback eq '~ENV') {
                if (exists($ENV{$param})) {
                    $retval = $ENV{$param};
                    last;
                }
            } else {
                $retval = $self->param($param,
                                       $fallback,
                                       $self->get_base($fallback));
                last if (defined($retval));
            }
        }
    }

    if (defined($retval)) {
         # Substitute any variables which are present
         $retval =~ s/\$([{([])
                        ([^}\])]+)
                        # $matching_bracket{\1}
                        [})\]]
                    /$self->param(lc($2))/egx;
    }

    return $retval;
}

I was disappointed that I couldn’t quickly get %matching_bracket to work, but for my purposes it doesn’t matter that much.

param() is fairly complex now. It recursively calls itself a few times to get the appropriate fallback and it is important to pass the correct $full_alias and $base_ref to ensure we are making progress towards the base case.

The result is pleasing.

$ perl MyConfig.pl db-test.yaml
Alias: database/saturn
server: DB_SATURN_SERVER
database: saturn
user: saturn_user
password: saturn_user_1
x:

Alias: database/mars
server: DB_MARS_SERVER
database: mars
user: mars_user
password: qwerty
x: y

Alias: databasky/neptune
AliasError: unable to find alias databasky

A couple of things I’m not completely happy with:

• it should detect infinite recursion
• %matching_bracket doesn’t work
• the class name – would YAML::Extended be reasonable?

---

The Full Source

package MyConfig;

use strict;
use warnings;

use YAML;

sub get_if_hash
{
    my ($hash_ref, $key) = @_;
    if (defined($hash_ref) and
        ref($hash_ref) eq 'HASH' and
        exists $hash_ref->{$key})
    {
        return $hash_ref->{$key};
    }
    # Clarify that we are returning undef deliberately
    return undef;
}

sub new
{
    my ($class, $file) = @_;
    my $self = { yaml => YAML::LoadFile($file) };
    bless $self, $class;
    return $self;
}

sub alias_parts_iterator
{
    my ($self, $full_alias, $fn) = @_;

    my $partial = '';
    my $alias_data = $self->{'yaml'}{'aliases'};
    my @parts = split '/', $full_alias;
    foreach (@parts) {
        $partial .= '/' if length($partial);
        $partial .= (length($partial) ? '/' : '') . $_;
        if (! exists $alias_data->{$_}) {
            die "AliasError: unable to find alias $partial\n";
        }

        $alias_data = $alias_data->{$_};
        $fn->($self, $alias_data, $partial);
    }
}

sub get_base
{
    my ($self, $full_alias) = @_;

    my $base;
    $self->alias_parts_iterator(
        $full_alias,
        sub {
            my ($obj, $alias_data) = @_;
            my $_base = get_if_hash($alias_data, '_base');
            $base = $_base if (defined($_base));
        }
    );

    if (! defined($base)) {
        if (exists($self->{'yaml'}{'default'}{'_base'})) {
            $base = $self->{'yaml'}{'default'}{'_base'};
        } else {
            $base = [];
        }
    }

    return $base;
}

sub get_alias_data
{
    my ($self, $full_alias) = @_;

    my $alias_data;
    $self->alias_parts_iterator(
        $full_alias,
        sub {
            my ($obj, $_alias_data) = @_;
            $alias_data = $_alias_data;
        }
    );
    return $alias_data;
}

sub set_var
{
    my ($self, $var, $value) = @_;
    $self->{'vars'}{$var} = $value;
}

sub set_alias
{
    my ($self, $full_alias, $flags) = @_;

    $self->{'params'} = {};
    my $clear_flag = get_if_hash($flags, 'clear');
    $self->{'vars'} = {} unless defined($clear_flag) and $clear_flag eq 0;
    $self->{'full_alias'} = $full_alias;

    if ($full_alias =~ m{([^/]+$)}) {
        $self->set_var('alias', lc($1));
        $self->set_var('uc_alias', uc($1));
    }
    $self->{'base'} = $self->get_base($full_alias);
}

my %matching_bracket = qw#{ } ( ) [ ]#;

sub param
{
    my ($self, $param, $full_alias, $base_ref) = @_;
    $full_alias = $self->{'full_alias'} if (! defined($full_alias));
    $base_ref = $self->{'base'} if (! defined($base_ref));
    my $alias_data = $self->get_alias_data($full_alias);

    my $retval = get_if_hash($alias_data, $param);
    if (! defined($retval)) {
        foreach my $fallback (@$base_ref) {
            if ($fallback eq '~VAR') {
                if (exists($self->{'vars'}{$param})) {
                    $retval = $self->{'vars'}{$param};
                    last;
                }
            } elsif ($fallback eq '~ENV') {
                if (exists($ENV{$param})) {
                    $retval = $ENV{$param};
                    last;
                }
            } else {
                $retval = $self->param($param,
                                       $fallback,
                                       $self->get_base($fallback));
                last if (defined($retval));
            }
        }
    }

    if (defined($retval)) {
         # Substitute any variables which are present
         $retval =~ s/\$([{([])
                        ([^}\])]+)
                        # $matching_bracket{\1}
                        [})\]]
                    /$self->param(lc($2))/egx;
    }

    return $retval;
}

About these ads