The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
# t/04-parser.t
#
# This test script is for the optional external parsing of
# configuration files using Config::Merge.
#
# If you're supporting Config::Merge in your app, be sure to look at the
# semantics here. This implementation creates symlinks for keys that end
# with an '@' symbol.
#
# vim: syntax=perl

BEGIN {
    use vars qw( $req_cm_err );
    eval 'require Config::Merge;';
    $req_cm_err = $@;
}

use Test::More tests => 8;
use DateTime;
use Path::Class;
use Data::Dumper;
use Carp qw(confess);

my $ver1 = 'dbfc699b2bfaf60b0c62191d82a31bb57f75d282';

my $gitdb = 't/05-config-merge.git';

dir($gitdb)->rmtree;

package MyConfig;

use Moose;
extends 'Config::Versioned';

use Data::Dumper;

sub parser {
    my $self     = shift;
    my $params   = shift;
    my $filename = '';

    my $cm    = Config::Merge->new('t/05-config-merge.d');
    my $cmref = $cm->();

    my $tree = $self->cm2tree($cmref);

    $params->{comment} = 'import from ' . $filename . ' using Config::Merge';

    if ( not $self->commit( $tree, $params ) ) {
        die "Error committing import from $filename: $@";
    }
}

sub cm2tree {
    my $self = shift;
    my $cm   = shift;
    my $tree = {};
    if ( ref($cm) eq 'HASH' ) {
        my $ret = {};
        foreach my $key ( keys %{$cm} ) {

            # If the key is appended with an '@' character, treat it
            # as a symbolic link.
            if ( $key =~ m/(.+)[@]$/ ) {
                my $newkey = $1;
                my $temp   = $self->cm2tree( $cm->{$key} );
                $ret->{$newkey} = \$temp;
            }
            else {
                $ret->{$key} = $self->cm2tree( $cm->{$key} );
            }
        }
        return $ret;
    }
    elsif ( ref($cm) eq 'ARRAY' ) {
        my $ret = {};
        my $i   = 0;
        foreach my $entry ( @{$cm} ) {
            $ret->{ $i++ } = $self->cm2tree($entry);
        }
        return $ret;
    }
    else {
        return $cm;
    }
}

package main;

SKIP: {
    skip "Config::Merge not installed", 8 if $req_cm_err;
    my $cfg = MyConfig->new(
        {
            dbpath      => $gitdb,
            commit_time => DateTime->from_epoch( epoch => 1240341682 ),
            author_name => 'Test User',
            author_mail => 'test@example.com',
            autocreate  => 1,
        }
    );

    ok( $cfg, 'created MyConfig instance' );
    is( $cfg->version, $ver1, 'check version of HEAD' );

    is( $cfg->get('db.hosts.1'),    'host2', 'Check param db.hosts.1' );
    is( $cfg->get('db.port.host2'), '789',   'Check param db.hosts.1' );

    my @attrlist = sort( $cfg->listattr('db.port') );
    is_deeply(
        \@attrlist,
        [ sort(qw( host1 host2 )) ],
        'Check attr list at db.port'
    );

    my @getlist = $cfg->get('db.hosts');
    is_deeply( \@getlist, [qw( 0 1 )], 'Check that get() returns array' );
    my $sym = $cfg->get('db.symgroup.sym1');
    is( ref($sym), 'SCALAR', 'check value of symlink is anon ref to scalar' );
    is( ${$sym}, 'conn1:new.location', 'check target of symlink' );
}