Feeds:
Posts
Comments

Archive for July, 2010

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

Read Full Post »

Following Nilson’s comment, I’ve updated my perl and python method call benchmarks to (hopefully) test what I actually intended to test.

I must admit, I’m not nearly as interested in method call times as I am in vanilla subroutine call times which could be why I made such a hash of it in the first place.

And I haven’t updated the iteration method as I’m not interested in loop speed (hence why I measured the base case) and that would make pointless extra work for me to do.

Read Full Post »

I really like YAML. But I often find myself adding perl-like variables and fallbacks to defaults. Does anyone else do that? Do people still use YAML or has everybody moved on to JSON?

Anyway, there may already be a module to do this, but the more the merrier right ;)

I have to work with a lot of databases, and there is often, but not always a pattern between the database, the username and the password1

Please note I’m not advocating putting plaintext passwords in a config file – that is generally a bad idea. This is just for the purposes of the example.

---
default:
    _base: [~VAR, ~ENV]

aliases:

    db:
        _base: []

        default:
            x: y

        other:
            _base: [db/default]

    database:
        _base: [~VAR, database/default, ~ENV]

        default:
            _base: []
            server: DB_$[UC_ALIAS]_SERVER
            database: $[ALIAS]
            user: $[ALIAS]_user
            password: $[USER]_1

        # --

        saturn: 1
        neptune: 1

        mars:
            _base: [~VAR, database/default, db/other]
            password: qwerty

So basically, this config file says that there are three databases – saturn, neptune and mars. Username is (for example) saturn_user and the password would be saturn_user_1 except for mars which has a special password of qwerty.

I’ll stick to a fairly standard Object Based approach.

package MyConfig;

use strict;
use warnings;

use YAML;

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

~VAR mentioned in the YAML above can be set by a member method.

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

Now, you can probably see my intent from the yaml above, that I’m using forward-slash as my namespace seperator and variables from more global namespaces are overridden by more local namespaces. Anyway, I need some way of iterating over these namespaces – I like closures for this sort of thing.

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

Getting the base is an important task as it determines the fallbacks. This uses the iterator mentioned above.

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

I’m using a helper function here as even perl is not quite loose enough for me by default. Attempting index an undefined value as a hash reference is fatal. Anyway, that is fixable.

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

Getting the alias data also uses the iterator closure.

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

We will want to set which alias we are using before retrieving params. This will set a couple of convenience variables, ALIAS and UC_ALIAS. We’ll provide a flag parameter to avoid clearing any preset variables.

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

And after all that, we are able to retrieve the param, correctly with fallbacks.

Note: this is somewhat prone to infinite recursion if you are not careful with setting your _base parameters in the yaml. I had intended to detect this with $self->{'params'} but this overly bloats the code for the purposes of the post.

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));
            }
        }
    }
    return $retval;
}

A little test program to check it is working correctly at this stage.

my $file = shift;
my $cfg = MyConfig->new($file);

foreach my $alias (qw(database/saturn database/mars databasky/neptune)) {
    print "Alias: $alias\n";
    $cfg->set_alias($alias);
    foreach (qw(server database user password x)) {
        my $param = $cfg->param($_);
        $param = '' unless defined($param);
        print "$_: $param\n";
    }
    print "\n";
}

And the result. Looks okay to me.

$ perl MyConfig.pl db-test.yaml
Alias: database/saturn
server: DB_$[UC_ALIAS]_SERVER
database: $[ALIAS]
user: $[ALIAS]_user
password: $[USER]_1
x:

Alias: database/mars
server: DB_$[UC_ALIAS]_SERVER
database: $[ALIAS]
user: $[ALIAS]_user
password: qwerty
x: y

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

Next time, we’ll talk about substituting those variables. I was going to mention it here, but this post is long enough already.


1. Well, not really, but for the purposes of the example…

Read Full Post »

boor
n.
1. A person with rude, clumsy manners and little refinement.

A couple of surprising attacks from Zloyrusskiy on my recent posts. I’m honour-bound to respond in kind.

Your problems with Perl programs is in not so good understanding of the language[sic]. Try to understand it[sic] principles or write your programs in python if deems[sic] more appropriate.

P.P.S. Author of post, Perl is not for you, it requires a sharp mind and intellect (and knowledge of the syntax of course). Write your programs in python and everything will be fine.

Dude, as one of the rare multilingual1 Engländers, I feel fully qualified in saying this: Your English is poor and unidiomatic. Despite this, I don’t say "Stop speaking English. Try Russian mate, English clearly doesn’t suit you". No sir. I hope you’ll improve. The more people who speak English, the better [for me].

You can use your sharp mind and intellect to draw parallels with Perl.

Second example (about numbers) i never used in my life in any language =). I can not even imagine where this might come in handy, so you worry about this.

What do you mean here? You mean you have never used a language that protected you from adding a string to an integer? Python, Lisp, C++, Java (in fact any modern statically typed language) all do this automatically. Which languages have you used?

And you missed my point. I was saying that with subroutines in any languages, you can fix things about that language that you don’t like. I used Perl for the examples, but I could have easily used C or Emacs Lisp, or Python.

Maybe I should be more explicit about what I’m trying to say. Or maybe it’s just you.

I’m perfectly comfortable with the default behaviour of Perl hashes. And sometimes I’m fine with the fact that 1 + 'banana' == 1. But when I’m writing my nuclear reactor software, I like to protect against that type of error.

Thanks for the comments and for providing material for this post.


1. I can also get by in American and Australian

Read Full Post »

« Newer Posts

Follow

Get every new post delivered to your Inbox.