1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177
|
# -*- cperl -*-
use warnings;
use Test::More;
use Test::Memory::Cycle;
use Config::Model;
use Config::Model::Value;
use Config::Model::Tester::Setup qw/init_test/;
use Data::Dumper;
use Test::Log::Log4perl;
use Test::Differences;
use strict;
use 5.10.1;
Test::Log::Log4perl->ignore_priority("info");
my ($model, $trace) = init_test();
# minimal set up to get things working
$model->create_config_class(
name => "NodeFix",
element => [
'fix-gnu' => {
type => 'leaf',
value_type => 'uniline',
'warn_if_match' => {
'Debian GNU/Linux' => {
'msg' => 'deprecated in favor of Debian GNU',
'fix' => 's!Debian GNU/Linux!Debian GNU!g;'
},
},
},
'fix-long' => {
type => 'leaf',
value_type => 'uniline',
'warn_if_match' => {
'[^\\n]{10,}' => {
'msg' => 'Line too long',
'fix' => '$_ = substr $_,0,8;'
},
},
},
# test data deletion from Dpkg/Copyright Disclaimer
# using undef
disclaimer_fix_with_undef => {
type => 'leaf',
value_type => 'string',
warn_if_match => {
'dh-make-perl' => {
fix => '$_ = undef ;',
msg => 'Disclaimer contains dh-make-perl boilerplate'
}
}
},
# same test as above using _store method
disclaimer_fix_with_delete => {
type => 'leaf',
value_type => 'string',
warn_if_match => {
'dh-make-perl' => {
fix => '$self->store(undef) ;',
msg => 'Disclaimer contains dh-make-perl boilerplate'
}
}
},
'chained-fix' => {
type => 'leaf',
value_type => 'uniline',
'warn_if_match' => {
'^\s' => {
'msg' => 'leading white space',
'fix' => 's/^\s+//;'
},
},
warn_unless_match => {
'^https://' => {
msg => 'secure http',
fix => 's!^http://!https://!'
},
'^https?://bugs\.debian\.org/' => {
msg => 'unknown host',
fix => 's!https?://[^/]*!https://bugs.debian.org!'
}
},
},
]
);
$model->create_config_class(
name => "Master",
element => [
[ map { "my_broken_node_$_" } (qw/a b c/) ] => {
type => 'node',
config_class_name => 'NodeFix',
}
]
);
my $inst = $model->instance(
root_class_name => 'Master',
instance_name => 'test1'
);
ok( $inst, "created dummy instance" );
my $root = $inst->config_root;
my %expected_changes = (
long => [],
with_delete => [],
with_undef => [] );
foreach my $w (qw/a b c/) {
my $foo = Test::Log::Log4perl->expect(
ignore_priority => info => [
'User',
warn => qr/deprecated in favor of Debian GNU/,
warn => qr/Line too long/,
warn => qr/leading white space/,
warn => qr/secure http/,
warn => qr/unknown host/,
( warn => qr/dh-make-perl/) x 2 # 2 disclaimer parameters
]
);
$root->load (qq!my_broken_node_$w fix-gnu="Debian GNU/Linux for $w"!
. qq! fix-long="$w is way too long"!
. qq! chained-fix=" http://floc/$w$w$w"!
. qq! disclaimer_fix_with_undef="blah dh-make-perl blah"!
. qq! disclaimer_fix_with_delete="blah dh-make-perl blah"!
);
push @{$expected_changes{long}}, "my_broken_node_$w fix-long: '$w is way too long' -> '$w is way' # applied fix for :Line too long";
push @{$expected_changes{with_delete}}, "my_broken_node_$w disclaimer_fix_with_delete deleted value: \'blah dh-make-perl blah\'";
push @{$expected_changes{with_undef}}, "my_broken_node_$w disclaimer_fix_with_undef deleted value: \'blah dh-make-perl blah\' # applied fix for :Disclaimer contains dh-make-perl boilerplate";
}
print $root->dump_tree if $trace;
foreach my $filter (sort keys %expected_changes) {
$inst->clear_changes;
$root->apply_fixes($filter);
eq_or_diff([$inst->list_changes], $expected_changes{$filter}, qq!change list for $filter apply_fix! );
}
foreach (qw/a b c/) {
is( $root->grab_value("my_broken_node_$_ fix-long"),
"$_ is way", "check that '$_' long stuff was fixed" );
is( $root->grab_value("my_broken_node_$_ disclaimer_fix_with_undef"),
undef, "check that '$_ disclaimer_fix_with_undef' was fixed" );
is( $root->grab_value("my_broken_node_$_ disclaimer_fix_with_delete"),
undef, "check that '$_ disclaimer_fix_with_delete' was fixed" );
is(
$root->grab_value("my_broken_node_$_ fix-gnu"),
"Debian GNU/Linux for $_",
"check that '$_' gnu stuff was NOT fixed"
);
}
$inst->clear_changes;
$root -> apply_fixes;
foreach (qw/a b c/) {
is( $root->grab_value("my_broken_node_$_ chained-fix"),
"https://bugs.debian.org/$_$_$_", "check that $_ secure url was fixed" );
}
my @changes = $inst->list_changes;
is(scalar @changes, 3 * 4 , qq!number of changes applied for chained-fix apply_fix! );
print $root->dump_tree if $trace;
memory_cycle_ok($model, "memory cycle");
done_testing;
|