File Coverage

blib/lib/Data/ModeMerge.pm
Criterion Covered Total %
statement 180 197 91.3
branch 103 126 81.7
condition 55 67 82.0
subroutine 19 19 100.0
pod 9 10 90.0
total 366 419 87.3


line stmt bran cond sub pod time code
1             package Data::ModeMerge;
2              
3             our $DATE = '2016-02-25'; # DATE
4             our $VERSION = '0.33'; # VERSION
5              
6 31     31   701539 use 5.010001;
  31         99  
7 31     31   154 use strict;
  31         42  
  31         779  
8 31     31   130 use warnings;
  31         41  
  31         1024  
9              
10 31     31   15960 use Data::Dmp;
  31         49173  
  31         2205  
11              
12 31     31   14905 use Mo qw(build default);
  31         14629  
  31         187  
13              
14             require Exporter;
15             our @ISA = qw(Exporter);
16             our @EXPORT = qw(mode_merge);
17              
18             sub mode_merge {
19 133     133 1 65231 my ($l, $r, $config_vars) = @_;
20 133         525 my $mm = __PACKAGE__->new(config => $config_vars);
21 133         935 $mm->merge($l, $r);
22             }
23              
24             has config => (is => "rw");
25              
26             # hash of modename => handler
27             has modes => (is => 'rw', default => sub { {} });
28              
29             has combine_rules => (is => 'rw');
30              
31             # merging process state
32             has path => (is => "rw", default => sub { [] });
33             has errors => (is => "rw", default => sub { [] });
34             has mem => (is => "rw", default => sub { {} }); # for handling circular refs. {key=>{res=>[...], todo=>[sub1, ...]}, ...}
35             has cur_mem_key => (is => "rw"); # for handling circular refs. instead of passing around this as argument, we put it here.
36              
37             sub _in($$) {
38 1686     1686   1454 my ($self, $needle, $haystack) = @_;
39 1686 100       2111 return 0 unless defined($needle);
40 1685         1258 my $r1 = ref($needle);
41 1685 100       1744 my $f1 = $r1 ? dmp($needle) : undef;
42 1685         2116 for (@$haystack) {
43 2583         1757 my $r2 = ref($_);
44 2583 100 100     6456 next if $r1 xor $r2;
45 2578 100 100     3706 return 1 if $r2 && $f1 eq dmp($_);
46 2573 100 100     8288 return 1 if !$r2 && $needle eq $_;
47             }
48 1323         3654 0;
49             }
50              
51             sub BUILD {
52 330     330 0 155529 require Data::ModeMerge::Config;
53              
54 330         642 my ($self, $args) = @_;
55              
56 330 100       807 if ($self->config) {
57             # some sanity checks
58 107         523 my $is_hashref = ref($self->config) eq 'HASH';
59 107 50 33     531 die "config must be a hashref or a Data::ModeMerge::Config" unless
60             $is_hashref || UNIVERSAL::isa($self->config, "Data::ModeMerge::Config");
61 107 50       221 $self->config(Data::ModeMerge::Config->new(%{ $self->config })) if $is_hashref;
  107         179  
62             } else {
63 223         2406 $self->config(Data::ModeMerge::Config->new);
64             }
65              
66 330         9815 for (qw(NORMAL KEEP ADD CONCAT SUBTRACT DELETE)) {
67 1980         16813 $self->register_mode($_);
68             }
69              
70 330 50       2098 if (!$self->combine_rules) {
71 330         10079 $self->combine_rules({
72             # "left + right" => [which mode to use, which mode after merge]
73             'ADD+ADD' => ['ADD' , 'ADD' ],
74             #'ADD+CONCAT' => undef,
75             'ADD+DELETE' => ['DELETE' , 'DELETE'],
76             #'ADD+KEEP' => undef,
77             'ADD+NORMAL' => ['NORMAL' , 'NORMAL'],
78             'ADD+SUBTRACT' => ['SUBTRACT', 'ADD' ],
79              
80             #'CONCAT+ADD' => undef,
81             'CONCAT+CONCAT' => ['CONCAT' , 'CONCAT'],
82             'CONCAT+DELETE' => ['DELETE' , 'DELETE'],
83             #'CONCAT+KEEP' => undef,
84             'CONCAT+NORMAL' => ['NORMAL' , 'NORMAL'],
85             #'CONCAT+SUBTRACT' => undef,
86              
87             'DELETE+ADD' => ['NORMAL' , 'ADD' ],
88             'DELETE+CONCAT' => ['NORMAL' , 'CONCAT' ],
89             'DELETE+DELETE' => ['DELETE' , 'DELETE' ],
90             'DELETE+KEEP' => ['NORMAL' , 'KEEP' ],
91             'DELETE+NORMAL' => ['NORMAL' , 'NORMAL' ],
92             'DELETE+SUBTRACT' => ['NORMAL' , 'SUBTRACT'],
93              
94             'KEEP+ADD' => ['KEEP', 'KEEP'],
95             'KEEP+CONCAT' => ['KEEP', 'KEEP'],
96             'KEEP+DELETE' => ['KEEP', 'KEEP'],
97             'KEEP+KEEP' => ['KEEP', 'KEEP'],
98             'KEEP+NORMAL' => ['KEEP', 'KEEP'],
99             'KEEP+SUBTRACT' => ['KEEP', 'KEEP'],
100              
101             'NORMAL+ADD' => ['ADD' , 'NORMAL'],
102             'NORMAL+CONCAT' => ['CONCAT' , 'NORMAL'],
103             'NORMAL+DELETE' => ['DELETE' , 'NORMAL'],
104             'NORMAL+KEEP' => ['NORMAL' , 'KEEP' ],
105             'NORMAL+NORMAL' => ['NORMAL' , 'NORMAL'],
106             'NORMAL+SUBTRACT' => ['SUBTRACT', 'NORMAL'],
107              
108             'SUBTRACT+ADD' => ['SUBTRACT', 'SUBTRACT'],
109             #'SUBTRACT+CONCAT' => undef,
110             'SUBTRACT+DELETE' => ['DELETE' , 'DELETE' ],
111             #'SUBTRACT+KEEP' => undef,
112             'SUBTRACT+NORMAL' => ['NORMAL' , 'NORMAL' ],
113             'SUBTRACT+SUBTRACT' => ['ADD' , 'SUBTRACT'],
114             });
115             }
116             }
117              
118             sub push_error {
119 89     89 1 196 my ($self, $errmsg) = @_;
120 89         89 push @{ $self->errors }, [[@{ $self->path }], $errmsg];
  89         163  
  89         473  
121 89         570 return;
122             }
123              
124             sub register_mode {
125 1980     1980 1 2289 my ($self, $name0) = @_;
126 1980         1577 my $obj;
127 1980 50       9446 if (ref($name0)) {
    50          
    50          
128 0         0 my $obj = $name0;
129             } elsif ($name0 =~ /^\w+(::\w+)+$/) {
130 0         0 eval "require $name0; \$obj = $name0->new";
131 0 0       0 die "Can't load module $name0: $@" if $@;
132             } elsif ($name0 =~ /^\w+$/) {
133 1980         2823 my $modname = "Data::ModeMerge::Mode::$name0";
134 1980         120591 eval "require $modname; \$obj = $modname->new";
135 1980 50       30519 die "Can't load module $modname: $@" if $@;
136             } else {
137 0         0 die "Invalid mode name $name0";
138             }
139 1980         4331 my $name = $obj->name;
140 1980 50       4040 die "Mode $name already registered" if $self->modes->{$name};
141 1980         12219 $obj->merger($self);
142 1980         6302 $self->modes->{$name} = $obj;
143             }
144              
145             sub check_prefix {
146 19     19 1 1229 my ($self, $hash_key) = @_;
147 19 100       59 die "Hash key not a string" if ref($hash_key);
148 17         38 my $dis = $self->config->disable_modes;
149 17 50 66     131 if (defined($dis) && ref($dis) ne 'ARRAY') {
150 0         0 $self->push_error("Invalid config value `disable_modes`: must be an array");
151 0         0 return;
152             }
153 17         22 for my $mh (sort { $b->precedence_level <=> $a->precedence_level }
  136         232  
154 102   100     341 grep { !$dis || !$self->_in($_->name, $dis) }
155 17         36 values %{ $self->modes }) {
156 86 100       531 if ($mh->check_prefix($hash_key)) {
157 5         42 return $mh->name;
158             }
159             }
160 12         100 return;
161             }
162              
163             sub check_prefix_on_hash {
164 7     7 1 55 my ($self, $hash) = @_;
165 7 100       42 die "Not a hash" unless ref($hash) eq 'HASH';
166 5         6 my $res = 0;
167 5         19 for (keys %$hash) {
168 8 100       14 do { $res++; last } if $self->check_prefix($_);
  2         3  
  2         3  
169             }
170 5         20 $res;
171             }
172              
173             sub add_prefix {
174 36     36 1 10794 my ($self, $hash_key, $mode) = @_;
175 36 100       115 die "Hash key not a string" if ref($hash_key);
176 34         110 my $dis = $self->config->disable_modes;
177 34 50 33     277 if (defined($dis) && ref($dis) ne 'ARRAY') {
178 0         0 die "Invalid config value `disable_modes`: must be an array";
179             }
180 34 50 33     92 if ($dis && $self->_in($mode, $dis)) {
181 0         0 $self->push_error("Can't add prefix for currently disabled mode `$mode`");
182 0         0 return $hash_key;
183             }
184 34 50       99 my $mh = $self->modes->{$mode} or die "Unknown mode: $mode";
185 34         367 $mh->add_prefix($hash_key);
186             }
187              
188             sub remove_prefix {
189 2293     2293 1 3565 my ($self, $hash_key) = @_;
190 2293 100       3131 die "Hash key not a string" if ref($hash_key);
191 2291         3250 my $dis = $self->config->disable_modes;
192 2291 100 100     14847 if (defined($dis) && ref($dis) ne 'ARRAY') {
193 1         18 die "Invalid config value `disable_modes`: must be an array";
194             }
195 2290         1709 for my $mh (sort { $b->precedence_level <=> $a->precedence_level }
  22763         33301  
196 13740   100     33293 grep { !$dis || !$self->_in($_->name, $dis) }
197 2290         3432 values %{ $self->modes }) {
198 11372 100       53236 if ($mh->check_prefix($hash_key)) {
199 912         6743 my $r = $mh->remove_prefix($hash_key);
200 912 100       1537 if (wantarray) { return ($r, $mh->name) }
  909         1875  
201 3         9 else { return $r }
202             }
203             }
204 1378 100       6720 if (wantarray) { return ($hash_key, $self->config->default_mode) }
  1377         2205  
205 1         3 else { return $hash_key }
206             }
207              
208             sub remove_prefix_on_hash {
209 3     3 1 57 my ($self, $hash) = @_;
210 3 100       28 die "Not a hash" unless ref($hash) eq 'HASH';
211 1         10 for (keys %$hash) {
212 4         6 my $old = $_;
213 4         8 $_ = $self->remove_prefix($_);
214 4 100       12 next unless $old ne $_;
215             die "Conflict when removing prefix on hash: $old -> $_ but $_ already exists"
216 3 50       9 if exists $hash->{$_};
217 3         6 $hash->{$_} = $hash->{$old};
218 3         7 delete $hash->{$old};
219             }
220 1         9 $hash;
221             }
222              
223             sub merge {
224 323     323 1 3659 my ($self, $l, $r) = @_;
225 323         759 $self->path([]);
226 323         1965 $self->errors([]);
227 323         1661 $self->mem({});
228 323         1590 $self->cur_mem_key(undef);
229 323         1197 my ($key, $res, $backup) = $self->_merge(undef, $l, $r);
230             {
231 322         755 success => !@{ $self->errors },
232 322         1654 error => (@{ $self->errors } ?
233             join(", ",
234 89         391 map { sprintf("/%s: %s", join("/", @{ $_->[0] }), $_->[1]) }
  89         791  
235 322 100       403 @{ $self->errors }) : ''),
  89         484  
236             result => $res,
237             backup => $backup,
238             };
239             }
240              
241             # handle circular refs: process todo's
242             sub _process_todo {
243 755     755   764 my ($self) = @_;
244 755 100       1222 if ($self->cur_mem_key) {
245 746         2401 for my $mk (keys %{ $self->mem }) {
  746         1213  
246 1036         5663 my $res = $self->mem->{$mk}{res};
247 1036 100 100     5767 if (defined($res) && @{ $self->mem->{$mk}{todo} }) {
  548         817  
248             #print "DEBUG: processing todo for mem<$mk>\n";
249 2         11 for (@{ $self->mem->{$mk}{todo} }) {
  2         4  
250 2         11 $_->(@$res);
251 2 50       2 return if @{ $self->errors };
  2         4  
252             }
253 2         13 $self->mem->{$mk}{todo} = [];
254             }
255             }
256             }
257             }
258              
259             sub _merge {
260 776     776   1041 my ($self, $key, $l, $r, $mode) = @_;
261 776         1234 my $c = $self->config;
262 776   66     3041 $mode //= $c->default_mode;
263              
264 776         1508 my $mh = $self->modes->{$mode};
265 776 50       3953 die "Can't find handler for mode $mode" unless $mh;
266              
267             # determine which merge method we will call
268 776         900 my $rl = ref($l);
269 776         687 my $rr = ref($r);
270 776 50       1906 my $tl = $rl eq 'HASH' ? 'HASH' : $rl eq 'ARRAY' ? 'ARRAY' : $rl eq 'CODE' ? 'CODE' : !$rl ? 'SCALAR' : '';
    100          
    100          
    100          
271 776 50       1657 my $tr = $rr eq 'HASH' ? 'HASH' : $rr eq 'ARRAY' ? 'ARRAY' : $rr eq 'CODE' ? 'CODE' : !$rr ? 'SCALAR' : '';
    100          
    100          
    100          
272 776 50       1088 if (!$tl) { $self->push_error("Unknown type in left side: $rl"); return }
  0         0  
  0         0  
273 776 50       1231 if (!$tr) { $self->push_error("Unknown type in right side: $rr"); return }
  0         0  
  0         0  
274 776 100 100     1349 if (!$c->allow_create_array && $tl ne 'ARRAY' && $tr eq 'ARRAY') {
      66        
275 5         53 $self->push_error("Not allowed to create array"); return;
  5         8  
276             }
277 771 100 100     3327 if (!$c->allow_create_hash && $tl ne 'HASH' && $tr eq 'HASH') {
      66        
278 5         53 $self->push_error("Not allowed to create hash"); return;
  5         10  
279             }
280 766 100 100     3116 if (!$c->allow_destroy_array && $tl eq 'ARRAY' && $tr ne 'ARRAY') {
      100        
281 5         57 $self->push_error("Not allowed to destroy array"); return;
  5         11  
282             }
283 761 100 66     3053 if (!$c->allow_destroy_hash && $tl eq 'HASH' && $tr ne 'HASH') {
      100        
284 5         61 $self->push_error("Not allowed to destroy hash"); return;
  5         11  
285             }
286 756         2962 my $meth = "merge_${tl}_${tr}";
287 756 50       2870 if (!$mh->can($meth)) { $self->push_error("No merge method found for $tl + $tr (mode $mode)"); return }
  0         0  
  0         0  
288              
289             #$self->_process_todo;
290             # handle circular refs: add to todo if necessary
291 756         632 my $memkey;
292 756 100 100     2062 if ($rl || $rr) {
293 406 100       2626 $memkey = sprintf "%s%s %s%s %s %s",
    100          
    100          
    100          
    100          
    100          
294             (defined($l) ? ($rl ? 2 : 1) : 0),
295             (defined($l) ? "$l" : ''),
296             (defined($r) ? ($rr ? 2 : 1) : 0),
297             (defined($r) ? "$r" : ''),
298             $mode,
299             $self->config;
300             #print "DEBUG: number of keys in mem = ".scalar(keys %{ $self->mem })."\n";
301             #print "DEBUG: mem keys = \n".join("", map { " $_\n" } keys %{ $self->mem }) if keys %{ $self->mem };
302             #print "DEBUG: calculating memkey = <$memkey>\n";
303             }
304 756 100       3402 if ($memkey) {
305 406 100       718 if (exists $self->mem->{$memkey}) {
306 3         16 $self->_process_todo;
307 3 50       8 if (defined $self->mem->{$memkey}{res}) {
308             #print "DEBUG: already calculated, using cached result\n";
309 0         0 return @{ $self->mem->{$memkey}{res} };
  0         0  
310             } else {
311             #print "DEBUG: detecting circular\n";
312 3         30 return ($key, undef, undef, 1);
313             }
314             } else {
315 403         3073 $self->mem->{$memkey} = {res=>undef, todo=>[]};
316 403         2432 $self->cur_mem_key($memkey);
317             #print "DEBUG: invoking ".$mh->name."'s $meth(".dmp($key).", ".dmp($l).", ".dmp($r).")\n";
318 403         2023 my ($newkey, $res, $backup) = $mh->$meth($key, $l, $r);
319             #print "DEBUG: setting res for mem<$memkey>\n";
320 402         1453 $self->mem->{$memkey}{res} = [$newkey, $res, $backup];
321 402         2247 $self->_process_todo;
322 402         3209 return ($newkey, $res, $backup);
323             }
324             } else {
325 350         608 $self->_process_todo;
326             #print "DEBUG: invoking ".$mh->name."'s $meth(".dmp($key).", ".dmp($l).", ".dmp($r).")\n";
327 350         1156 return $mh->$meth($key, $l, $r);
328             }
329             }
330              
331             # returns 1 if a is included in b (e.g. [user => "jajang"] in included in [user
332             # => jajang => "quota"], but [user => "paijo"] is not)
333             sub _path_is_included {
334 5     5   40 my ($self, $p1, $p2) = @_;
335 5         6 my $res = 1;
336 5         9 for my $i (0..@$p1-1) {
337 6 100 66     29 do { $res = 0; last } if !defined($p2->[$i]) || $p1->[$i] ne $p2->[$i];
  2         1  
  2         4  
338             }
339             #print "_path_is_included([".join(", ", @$p1)."], [".join(", ", @$p2)."])? $res\n";
340 5         18 $res;
341             }
342              
343             1;
344             # ABSTRACT: Merge two nested data structures, with merging modes and options
345              
346             __END__
347              
348             =pod
349              
350             =encoding UTF-8
351              
352             =head1 NAME
353              
354             Data::ModeMerge - Merge two nested data structures, with merging modes and options
355              
356             =head1 VERSION
357              
358             This document describes version 0.33 of Data::ModeMerge (from Perl distribution Data-ModeMerge), released on 2016-02-25.
359              
360             =head1 SYNOPSIS
361              
362             use Data::ModeMerge;
363              
364             my $hash1 = { a=>1, c=>1, d=>{ da =>[1]} };
365             my $hash2 = { a=>2, "-c"=>2, d=>{"+da"=>[2]} };
366              
367              
368             # if you want Data::ModeMerge to behave like many other merging
369             # modules (e.g. Hash::Merge or Data::Merger), turn off modes
370             # (prefix) parsing and options key parsing.
371              
372             my $mm = Data::ModeMerge->new(config => {parse_prefix=>0, options_key=>undef});
373             my $res = $mm->merge($hash1, $hash2);
374             die $res->{error} if $res->{error};
375             # $res->{result} -> { a=>2, c=>1, "-c"=>2, d=>{da=>[1], "+da"=>[2]} }
376              
377              
378             # otherwise Data::ModeMerge will parse prefix as well as options
379             # key
380              
381             my $res = $mm->merge($hash1, $hash2);
382             die $res->{error} if $res->{error};
383             # $res->{result} -> { a=>2, c=>-1, d=>{da=>[1,2]} }
384              
385             $res = $merge({ a =>1, { a2 =>1, ""=>{parse_prefix=>0}},
386             {".a"=>2, {".a2"=>2 }});
387             # $res->{result} -> { a=>12, {a2=>1, ".a2"=>2} }, parse_prefix is turned off in just the subhash
388              
389              
390             # procedural interface
391              
392             my $res = mode_merge($hash1, $hash2, {allow_destroy_hash=>0});
393              
394             =head1 DESCRIPTION
395              
396             There are already several modules on CPAN to do recursive data
397             structure merging, like L<Data::Merger> and
398             L<Hash::Merge>. C<Data::ModeMerge> differs in that it offers merging
399             "modes" and "options". It provides greater flexibility on what the
400             result of a merge between two data should/can be. This module may or
401             may not be what you need.
402              
403             One application of this module is in handling configuration. Often
404             there are multiple levels of configuration, e.g. in your typical Unix
405             command-line program there are system-wide config file in /etc,
406             per-user config file under ~/, and command-line options. It's
407             convenient programatically to load each of those in a hash and then
408             merge system-wide hash with the per-user hash, and then merge the
409             result with the command-line hash to get the a single hash as the
410             final configuration. Your program can from there on deal with this
411             just one hash instead of three.
412              
413             In a typical merging process between two hashes (left-side and
414             right-side), when there is a conflicting key, then the right-side key
415             will override the left-side. This is usually the desired behaviour in
416             our said program as the system-wide config is there to provide
417             defaults, and the per-user config (and the command-line arguments)
418             allow a user to override those defaults.
419              
420             But suppose that the user wants to I<unset> a certain configuration
421             setting that is defined by the system-wide config? She can't do that
422             unless she edits the system-wide config (in which she might need admin
423             rights), or the program allows the user to disregard the system-wide
424             config. The latter is usually what's implemented by many Unix
425             programs, e.g. the C<-noconfig> command-line option in C<mplayer>. But
426             this has two drawbacks: a slightly added complexity in the program
427             (need to provide a special, extra comand-line option) and the user
428             loses all the default settings in the system-wide config. What she
429             needed in the first place was to just unset I<a single setting> (a
430             single key-value pair of the hash).
431              
432             L<Data::ModeMerge> comes to the rescue. It provides a so-called
433             C<DELETE mode>.
434              
435             mode_merge({foo=>1, bar=>2}, {"!foo"=>undef, bar=>3, baz=>1});
436              
437             will result ini:
438              
439             {bar=>3, baz=>1}
440              
441             The C<!> prefix tells Data::ModeMerge to do a DELETE mode merging. So
442             the final result will lack the C<foo> key.
443              
444             On the other hand, what if the system admin wants to I<protect> a
445             certain configuration setting from being overriden by the user or the
446             command-line? This is useful in a hosting or other retrictive
447             environment where we want to limit users' freedom to some levels. This
448             is possible via the KEEP mode merging.
449              
450             mode_merge({"^bar"=>2, "^baz"=>1}, {bar=>3, "!baz"=>0, qux=>7});
451              
452             will result in:
453              
454             {"^bar"=>2, "^baz"=>1, qux=>7}
455              
456             effectively protecting C<bar> and C<baz> from being
457             overriden/deleted/etc.
458              
459             Aside from the two mentioned modes, there are also a few others
460             available by default: ADD (prefix C<+>), CONCAT (prefix C<.>),
461             SUBTRACT (prefix C<->), as well as the plain ol' NORMAL/override
462             (optional prefix C<*>).
463              
464             You can add other modes by writing a mode handler module.
465              
466             You can change the default prefixes for each mode if you want. You can
467             disable each mode individually.
468              
469             You can default to always using a certain mode, like the NORMAL mode,
470             and ignore all the prefixes, in which case Data::ModeMerge will behave
471             like most other merge modules.
472              
473             There are a few other options like whether or not the right side is
474             allowed a "change the structure" of the left side (e.g. replacing a
475             scalar with an array/hash, destroying an existing array/hash with
476             scalar), maximum length of scalar/array/hash, etc.
477              
478             You can change default mode, prefixes, disable/enable modes, etc on a
479             per-hash basis using the so-called B<options key>. See the B<OPTIONS
480             KEY> section for more details.
481              
482             This module can handle (though not all possible cases)
483             circular/recursive references.
484              
485             =for Pod::Coverage ^(BUILD)$
486              
487             =head1 MERGING PREFIXES AND YOUR DATA
488              
489             Merging with this module means you need to be careful when your hash
490             keys might contain one of the mode prefixes characters by accident,
491             because it will trigger the wrong merge mode and moreover the prefix
492             characters will be B<stripped> from the final result (unless you
493             configure the module not to do so).
494              
495             A rather common case is when you have regexes in your hash
496             keys. Regexes often begins with C<^>, which coincidentally is a prefix
497             for the KEEP mode. Or perhaps you have dot filenames as hash keys,
498             where it clashes with the CONCAT mode. Or perhaps shell wildcards,
499             where C<*> is also used as the prefix for NORMAL mode.
500              
501             To avoid clashes, you can either:
502              
503             =over 4
504              
505             =item * exclude the keys using
506             C<exclude_merge>/C<include_merge>/C<exclude_parse>/C<include_parse>
507             config settings
508              
509             =item * turn off some modes which you don't want via the
510             C<disable_modes> config
511              
512             =item * change the prefix for that mode so that it doesn't clash with
513             your data via the C<set_prefix> config
514              
515             =item * disable prefix parsing altogether via setting C<parse_prefix>
516             config to 0
517              
518             =back
519              
520             You can do this via the configuration, or on a per-hash basis, using
521             the options key.
522              
523             See L<Data::ModeMerge::Config> for more details on configuration.
524              
525             =head1 OPTIONS KEY
526              
527             Aside from merging mode prefixes, you also need to watch out if your
528             hash contains a "" (empty string) key, because by default this is the
529             key used for options key.
530              
531             Options key are used to specify configuration on a per-hash basis.
532              
533             If your hash keys might contain "" keys which are not meant to be an
534             options key, you can either:
535              
536             =over 4
537              
538             =item * change the name of the key for options key, via setting
539             C<options_key> config to another string.
540              
541             =item * turn off options key mechanism,
542             by setting C<options_key> config to undef.
543              
544             =back
545              
546             See L<Data::ModeMerge::Config> for more details about options key.
547              
548             =head1 MERGING MODES
549              
550             =head2 NORMAL (optional '*' prefix on left/right side)
551              
552             mode_merge({ a =>11, b=>12}, { b =>22, c=>23}); # {a=>11, b=>22, c=>23}
553             mode_merge({"*a"=>11, b=>12}, {"*b"=>22, c=>23}); # {a=>11, b=>22, c=>23}
554              
555             =head2 ADD ('+' prefix on the right side)
556              
557             mode_merge({i=>3}, {"+i"=>4, "+j"=>1}); # {i=>7, j=>1}
558             mode_merge({a=>[1]}, {"+a"=>[2, 3]}); # {a=>[1, 2, 3]}
559              
560             Additive merge on hashes will be treated like a normal merge.
561              
562             =head2 CONCAT ('.' prefix on the right side)
563              
564             mode_merge({i=>3}, {".i"=>4, ".j"=>1}); # {i=>34, j=>1}
565              
566             Concative merge on arrays will be treated like additive merge.
567              
568             =head2 SUBTRACT ('-' prefix on the right side)
569              
570             mode_merge({i=>3}, {"-i"=>4}); # {i=>-1}
571             mode_merge({a=>["a","b","c"]}, {"-a"=>["b"]}); # {a=>["a","c"]}
572              
573             Subtractive merge on hashes behaves like a normal merge, except that
574             each key on the right-side hash without any prefix will be assumed to
575             have a DELETE prefix, i.e.:
576              
577             mode_merge({h=>{a=>1, b=>1}}, {-h=>{a=>2, "+b"=>2, c=>2}})
578              
579             is equivalent to:
580              
581             mode_merge({h=>{a=>1, b=>1}}, {h=>{"!a"=>2, "+b"=>2, "!c"=>2}})
582              
583             and will merge to become:
584              
585             {h=>{b=>3}}
586              
587             =head2 DELETE ('!' prefix on the right side)
588              
589             mode_merge({x=>WHATEVER}, {"!x"=>WHATEVER}); # {}
590              
591             =head2 KEEP ('^' prefix on the left/right side)
592              
593             If you add '^' prefix on the left side, it will be protected from
594             being replaced/deleted/etc.
595              
596             mode_merge({'^x'=>WHATEVER1}, {"x"=>WHATEVER2}); # {x=>WHATEVER1}
597              
598             For hashes, KEEP mode means that all keys on the left side will not be
599             replaced/modified/deleted, *but* you can still add more keys from the
600             right side hash.
601              
602             mode_merge({a=>1, b=>2, c=>3},
603             {a=>4, '^c'=>1, d=>5},
604             {default_mode=>'KEEP'});
605             # {a=>1, b=>2, c=>3, d=>5}
606              
607             Multiple prefixes on the right side is allowed, where the merging will
608             be done by precedence level (highest first):
609              
610             mode_merge({a=>[1,2]}, {'-a'=>[1], '+a'=>[10]}); # {a=>[2,10]}
611              
612             but not on the left side:
613              
614             mode_merge({a=>1, '^a'=>2}, {a=>3}); # error!
615              
616             Precedence levels (from highest to lowest):
617              
618             KEEP
619             NORMAL
620             SUBTRACT
621             CONCAT ADD
622             DELETE
623              
624             =head1 CREATING AND USING YOUR OWN MODE
625              
626             Let's say you want to add a mode named C<FOO>. It will have the prefix
627             '?'.
628              
629             Create the mode handler class,
630             e.g. C<Data::ModeMerge::Mode::FOO>. It's probably best to subclass
631             from L<Data::ModeMerge::Mode::Base>. The class must implement name(),
632             precedence_level(), default_prefix(), default_prefix_re(), and
633             merge_{SCALAR,ARRAY,HASH}_{SCALAR,ARRAY,HASH}(). For more details, see
634             the source code of Base.pm and one of the mode handlers
635             (e.g. NORMAL.pm).
636              
637             To use the mode, register it:
638              
639             my $mm = Data::ModeMerge->new;
640             $mm->register_mode('FOO');
641              
642             This will require C<Data::ModeMerge::Mode::FOO>. After that, define
643             the operations against other modes:
644              
645             # if there's FOO on the left and NORMAL on the right, what mode
646             # should the merge be done in (FOO), and what the mode should be
647             # after the merge? (NORMAL)
648             $mm->combine_rules->{"FOO+NORMAL"} = ["FOO", "NORMAL"];
649              
650             # we don't define FOO+ADD
651              
652             $mm->combine_rules->{"FOO+KEEP"} = ["KEEP", "KEEP"];
653              
654             # and so on
655              
656             =head1 FUNCTIONS
657              
658             =head2 mode_merge($l, $r[, $config_vars])
659              
660             A non-OO wrapper for merge() method. Exported by default. See C<merge>
661             method for more details.
662              
663             =head1 ATTRIBUTES
664              
665             =head2 config
666              
667             A hashref for config. See L<Data::ModeMerge::Config>.
668              
669             =head2 modes
670              
671             =head2 combine_rules
672              
673             =head2 path
674              
675             =head2 errors
676              
677             =head2 mem
678              
679             =head2 cur_mem_key
680              
681             =head1 METHODS
682              
683             For typical usage, you only need merge().
684              
685             =head2 push_error($errmsg)
686              
687             Used by mode handlers to push error when doing merge. End users
688             normally should not need this.
689              
690             =head2 register_mode($name_or_package_or_obj)
691              
692             Register a mode. Will die if mode with the same name already exists.
693              
694             =head2 check_prefix($hash_key)
695              
696             Check whether hash key has prefix for certain mode. Return the name of
697             the mode, or undef if no prefix is detected.
698              
699             =head2 check_prefix_on_hash($hash)
700              
701             This is like C<check_prefix> but performed on every key of the
702             specified hash. Return true if any of the key contain a merge prefix.
703              
704             =head2 add_prefix($hash_key, $mode)
705              
706             Return hash key with added prefix with specified mode. Log merge error
707             if mode is unknown or is disabled.
708              
709             =head2 remove_prefix($hash_key)
710              
711             Return hash key will any prefix removed.
712              
713             =head2 remove_prefix_on_hash($hash)
714              
715             This is like C<remove_prefix> but performed on every key of the
716             specified hash. Return the same hash but with prefixes removed.
717              
718             =head2 merge($l, $r)
719              
720             Merge two nested data structures. Returns the result hash: {
721             success=>0|1, error=>'...', result=>..., backup=>... }. The 'error'
722             key is set to contain an error message if there is an error. The merge
723             result is in the 'result' key. The 'backup' key contains replaced
724             elements from the original hash/array.
725              
726             =head1 FAQ
727              
728             =head2 What is this module good for? Why would I want to use this module instead of the other hash merge modules?
729              
730             If you just need to (deeply) merge two hashes, chances are you do not
731             need this module. Use, for example, L<Hash::Merge>, which is also
732             flexible enough because it allows you to set merging behaviour for
733             merging different types (e.g. SCALAR vs ARRAY).
734              
735             You might need this module if your data is recursive/self-referencing
736             (which, last time I checked, is not handled well by Hash::Merge), or
737             if you want to be able to merge differently (i.e. apply different
738             merging B<modes>) according to different prefixes on the key, or
739             through special key. In other words, you specify merging modes from
740             inside the hash itself.
741              
742             I originally wrote Data::ModeMerge this for L<Data::Schema> and
743             L<Config::Tree>. I want to reuse the "parent" schema (or
744             configuration) in more ways other than just override conflicting
745             keys. I also want to be able to allow the parent to protect certain
746             keys from being overriden. I found these two features lacking in all
747             merging modules that I've evaluated prior to writing Data::ModeMerge.
748              
749             =head1 HOMEPAGE
750              
751             Please visit the project's homepage at L<https://metacpan.org/release/Data-ModeMerge>.
752              
753             =head1 SOURCE
754              
755             Source repository is at L<https://github.com/perlancar/perl-Data-ModeMerge>.
756              
757             =head1 BUGS
758              
759             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Data-ModeMerge>
760              
761             When submitting a bug or request, please include a test-file or a
762             patch to an existing test-file that illustrates the bug or desired
763             feature.
764              
765             =head1 SEE ALSO
766              
767             L<Data::ModeMerge::Config>
768              
769             Other merging modules on CPAN: L<Data::Merger> (from Data-Utilities),
770             L<Hash::Merge>, L<Hash::Merge::Simple>
771              
772             L<Data::Schema> and L<Config::Tree> (among others, two modules which
773             use Data::ModeMerge)
774              
775             =head1 AUTHOR
776              
777             perlancar <perlancar@cpan.org>
778              
779             =head1 COPYRIGHT AND LICENSE
780              
781             This software is copyright (c) 2016 by perlancar@cpan.org.
782              
783             This is free software; you can redistribute it and/or modify it under
784             the same terms as the Perl 5 programming language system itself.
785              
786             =cut