[1980] | 1 | #!/usr/bin/perl |
---|
| 2 | # ------------------------------------------------------------------------------ |
---|
| 3 | # (C) Crown copyright Met Office. All rights reserved. |
---|
| 4 | # For further details please refer to the file COPYRIGHT.txt |
---|
| 5 | # which you should have received as part of this distribution. |
---|
| 6 | # ------------------------------------------------------------------------------ |
---|
| 7 | |
---|
| 8 | use strict; |
---|
| 9 | use warnings; |
---|
| 10 | |
---|
| 11 | use Fcm::CfgLine; |
---|
| 12 | use Fcm::Config; |
---|
| 13 | use Scalar::Util qw{reftype}; |
---|
| 14 | use Test::More (tests => 90); |
---|
| 15 | |
---|
| 16 | BEGIN: { |
---|
| 17 | use_ok('Fcm::ConfigSystem'); |
---|
| 18 | } |
---|
| 19 | |
---|
| 20 | my $CONFIG = undef; |
---|
| 21 | |
---|
| 22 | # ------------------------------------------------------------------------------ |
---|
| 23 | if (!caller()) { |
---|
| 24 | main(@ARGV); |
---|
| 25 | } |
---|
| 26 | |
---|
| 27 | # ------------------------------------------------------------------------------ |
---|
| 28 | sub main { |
---|
| 29 | local @ARGV = @_; |
---|
| 30 | test_compare_setting_in_config(); |
---|
| 31 | } |
---|
| 32 | |
---|
| 33 | # ------------------------------------------------------------------------------ |
---|
| 34 | # Tests "compare_setting_in_config". |
---|
| 35 | sub test_compare_setting_in_config { |
---|
| 36 | my $PREFIX = 'TEST'; |
---|
| 37 | my %S = (egg => [qw{boiled poached}], ham => 'roasted', bacon => 'fried'); |
---|
| 38 | my %S_MOD = (ham => 'boiled'); |
---|
| 39 | my %S_MOD_ARRAY = (egg => [qw{scrambled omelette}]); |
---|
| 40 | my %S_ADD = (mushroom => 'sauteed'); |
---|
| 41 | my %S_DEL = (bacon => undef); |
---|
| 42 | |
---|
| 43 | my @ITEMS = ( |
---|
| 44 | { |
---|
| 45 | name => 'empty', |
---|
| 46 | original => {}, |
---|
| 47 | added => {}, |
---|
| 48 | removed => {}, |
---|
| 49 | modified => {}, |
---|
| 50 | }, |
---|
| 51 | { |
---|
| 52 | name => 'add keys to empty', |
---|
| 53 | original => {}, |
---|
| 54 | added => {%S}, |
---|
| 55 | removed => {}, |
---|
| 56 | modified => {%S}, |
---|
| 57 | }, |
---|
| 58 | { |
---|
| 59 | name => 'remove all', |
---|
| 60 | original => {%S}, |
---|
| 61 | added => {}, |
---|
| 62 | removed => {}, |
---|
| 63 | modified => {map {($_, undef)} keys(%S)}, |
---|
| 64 | }, |
---|
| 65 | { |
---|
| 66 | name => 'no change', |
---|
| 67 | original => {%S}, |
---|
| 68 | added => {%S}, |
---|
| 69 | removed => {}, |
---|
| 70 | modified => {}, |
---|
| 71 | }, |
---|
| 72 | { |
---|
| 73 | name => 'modify key', |
---|
| 74 | original => {%S}, |
---|
| 75 | added => {%S, %S_MOD}, |
---|
| 76 | removed => {}, |
---|
| 77 | modified => {%S_MOD}, |
---|
| 78 | }, |
---|
| 79 | { |
---|
| 80 | name => 'modify an array key', |
---|
| 81 | original => {%S}, |
---|
| 82 | added => {%S, %S_MOD_ARRAY}, |
---|
| 83 | removed => {}, |
---|
| 84 | modified => {%S_MOD_ARRAY}, |
---|
| 85 | }, |
---|
| 86 | { |
---|
| 87 | name => 'add a key', |
---|
| 88 | original => {%S}, |
---|
| 89 | added => {%S, %S_ADD}, |
---|
| 90 | removed => {}, |
---|
| 91 | modified => {%S_ADD}, |
---|
| 92 | }, |
---|
| 93 | { |
---|
| 94 | name => 'delete a key', |
---|
| 95 | original => {%S}, |
---|
| 96 | added => {%S}, |
---|
| 97 | removed => {%S_DEL}, |
---|
| 98 | modified => {%S_DEL}, |
---|
| 99 | }, |
---|
| 100 | { |
---|
| 101 | name => 'modify a key and delete a key', |
---|
| 102 | original => {%S}, |
---|
| 103 | added => {%S, %S_MOD}, |
---|
| 104 | removed => {%S_DEL}, |
---|
| 105 | modified => {%S_MOD, %S_DEL}, |
---|
| 106 | }, |
---|
| 107 | { |
---|
| 108 | name => 'add a key and delete a key', |
---|
| 109 | original => {%S}, |
---|
| 110 | added => {%S, %S_ADD}, |
---|
| 111 | removed => {%S_DEL}, |
---|
| 112 | modified => {%S_ADD, %S_DEL}, |
---|
| 113 | }, |
---|
| 114 | ); |
---|
| 115 | |
---|
| 116 | # A naive function to serialise an array reference |
---|
| 117 | my $flatten = sub { |
---|
| 118 | if (ref($_[0]) && reftype($_[0]) eq 'ARRAY') { |
---|
| 119 | join(q{ }, sort(@{$_[0]})) |
---|
| 120 | } |
---|
| 121 | else { |
---|
| 122 | $_[0]; |
---|
| 123 | } |
---|
| 124 | }; |
---|
| 125 | |
---|
| 126 | my $CONFIG = Fcm::Config->instance(); |
---|
| 127 | for my $item (@ITEMS) { |
---|
| 128 | # New settings |
---|
| 129 | $CONFIG->{setting}{$PREFIX} = {%{$item->{added}}}; |
---|
| 130 | for my $key (keys(%{$item->{removed}})) { |
---|
| 131 | delete($CONFIG->{setting}{$PREFIX}{$key}); |
---|
| 132 | } |
---|
| 133 | |
---|
| 134 | # Old lines |
---|
| 135 | my @old_lines = map { |
---|
| 136 | Fcm::CfgLine->new( |
---|
| 137 | LABEL => $PREFIX . $Fcm::Config::DELIMITER . $_, |
---|
| 138 | VALUE => $flatten->($item->{original}{$_}), |
---|
| 139 | ) |
---|
| 140 | } keys(%{$item->{original}}); |
---|
| 141 | |
---|
| 142 | # Invokes the method |
---|
| 143 | my $system = Fcm::ConfigSystem->new(); |
---|
| 144 | my ($changed_hash_ref, $new_cfg_lines_ref) |
---|
| 145 | = $system->compare_setting_in_config($PREFIX, \@old_lines); |
---|
| 146 | |
---|
| 147 | # Tests the return values |
---|
| 148 | my $T = $item->{name}; |
---|
| 149 | is_deeply( |
---|
| 150 | $changed_hash_ref, $item->{modified}, |
---|
| 151 | "$T: \$changed_hash_ref content", |
---|
| 152 | ); |
---|
| 153 | is( |
---|
| 154 | scalar(@{$new_cfg_lines_ref}), |
---|
| 155 | scalar(keys(%{$item->{added}})) - scalar(keys(%{$item->{removed}})), |
---|
| 156 | "$T: \$new_cfg_lines_ref length", |
---|
| 157 | ); |
---|
| 158 | for my $line (@{$new_cfg_lines_ref}) { |
---|
| 159 | my $key = $line->label_from_field(1); |
---|
| 160 | ok(exists($item->{added}{$key}), "$T: expected label $key"); |
---|
| 161 | ok(!exists($item->{removed}{$key}), "$T: unexpected label $key"); |
---|
| 162 | is( |
---|
| 163 | $line->value(), $flatten->($item->{added}{$key}), |
---|
| 164 | "$T: line content $key", |
---|
| 165 | ); |
---|
| 166 | } |
---|
| 167 | } |
---|
| 168 | } |
---|
| 169 | |
---|
| 170 | __END__ |
---|