view release on metacpan or  search on metacpan

t/smooth_upgrade.t  view on Meta::CPAN

# -*- cperl -*-

use ExtUtils::testlib;
use Test::More;
use Test::Exception;
use Test::Memory::Cycle;
use Test::Log::Log4perl;
use Config::Model;
use Config::Model::Tester::Setup qw/init_test/;
use Config::Model::Value;

use strict;
use warnings;

Test::Log::Log4perl->ignore_priority("info");

my ($model, $trace) = init_test();

$model->create_config_class(
    name      => "Master",
    'element' => [

        # obsolete element cannot be used at all
        'obsolete_p' => {
            type        => 'leaf',
            value_type  => 'enum',
            choice      => [qw/cds perl ini custom/],
            status      => 'obsolete',
            description => 'obsolete_p is replaced by non_obso',
        },

        'deprecated_p' => {
            type        => 'leaf',
            value_type  => 'enum',
            choice      => [qw/cds perl ini custom/],
            status      => 'deprecated',
            description => 'deprecated_p is replaced by new_from_deprecated',
        },

        'new_from_deprecated' => {
            type         => 'leaf',
            value_type   => 'enum',
            choice       => [qw/cds_file perl_file ini_file augeas custom/],
            migrate_from => {
                formula   => '$replace{$old}',
                variables => { old => '- deprecated_p' },
                replace   => {
                    perl => 'perl_file',
                    ini  => 'ini_file',
                    cds  => 'cds_file',
                },
            },
        },

        'hidden_p' => {
            type        => 'leaf',
            value_type  => 'enum',
            choice      => [qw/cds perl ini custom/],
            level       => 'hidden',
            description => 'hidden_p is replaced by new_from_hidden',
        },
    ] );

$model->create_config_class(
    name      => "UrlMigration",
    'element' => [
        'old_url' => {
            type       => 'leaf',
            value_type => 'uniline',
            status     => 'deprecated',
        },
        'host' => {
            type         => 'leaf',
            value_type   => 'uniline',
            mandatory    => 1,
            migrate_from => {
                formula   => '$old =~ m!http://([\w\.]+)!; $1 ;',
                variables => { old => '- old_url' },
                use_eval  => 1,
            },
        },
        'port' => {
            type         => 'leaf',
            value_type   => 'uniline',
            migrate_from => {
                formula   => '$old =~ m!http://[\w\.]+:(\d+)!; $1 ;',
                variables => { old => '- old_url' },
                use_eval  => 1,
            },
        },
        'path' => {
            type         => 'leaf',
            value_type   => 'uniline',
            migrate_from => {
                formula   => '$old =~ m!http://[\w\.]+(?::\d+)?(/.*)!; $1 ;',
                variables => { old => '- old_url' },
                use_eval  => 1,
            },
        },

    ],
);

my $inst = $model->instance(
    root_class_name => 'Master',
    instance_name   => 'test1'
);
ok( $inst, "created dummy instance" );

my $root = $inst->config_root;

# emulate start of file read
$inst->initial_load_start;

throws_ok { $root->fetch_element('obsolete_p'); }
'Config::Model::Exception::ObsoleteElement',
    'tried to fetch obsolete element';

my $dp;
{
    my $foo = Test::Log::Log4perl->expect([
        User => warn => qr/Element 'deprecated_p' of node 'Master' is deprecated/
    ]);
    $dp = $root->fetch_element('deprecated_p');
}

my $nfd = $root->fetch_element('new_from_deprecated');

is( $nfd->fetch, undef, "undef old and undef new" );

# does not generate a warning
$dp->store('ini');

$inst->initial_load_stop;

is( $nfd->fetch, 'ini_file', "old is 'ini' and new is 'ini_file'" );

is( $nfd->fetch_custom, 'ini_file', "likewise for custom_value" );

is( $nfd->fetch('non_upstream_default'), 'ini_file', "likewise for non_builtin_default" );

is( $nfd->fetch_standard, undef, "but standard value is undef" );

# check element list
is_deeply( [ $root->get_element_name ],
    [qw/new_from_deprecated/], "check that deprecated and obsolete parameters are hidden" );

is( $root->dump_tree, "new_from_deprecated=ini_file -\n", "check dump tree" );

# now override the migrated value
$nfd->store('perl_file');

is( $nfd->fetch, 'perl_file', "overridden value is 'perl_file'" );

is( $nfd->fetch_custom, 'perl_file', "likewise for custom_value" );