App-hr
view release on metacpan or search on metacpan
# }# $hash;#}##sub merge {# my ($self, $l, $r) = @_;# $self->path([]);# $self->errors([]);# $self->mem({});# $self->cur_mem_key(undef);# my ($key, $res, $backup) = $self->_merge(undef, $l, $r);# {# success => !@{ $self->errors },# error => (@{ $self->errors } ?# join(", ",# map { sprintf("/%s: %s", join("/", @{ $_->[0] }), $_->[1]) }# @{ $self->errors }) : ''),# result => $res,# backup => $backup,# };#}### handle circular refs: process todo's#sub _process_todo {# my ($self) = @_;# if ($self->cur_mem_key) {# for my $mk (keys %{ $self->mem }) {# my $res = $self->mem->{$mk}{res};# if (defined($res) && @{ $self->mem->{$mk}{todo} }) {
# #print "DEBUG: already calculated, using cached result\n";# return @{ $self->mem->{$memkey}{res} };# } else {# #print "DEBUG: detecting circular\n";# return ($key, undef, undef, 1);# }# } else {# $self->mem->{$memkey} = {res=>undef, todo=>[]};# $self->cur_mem_key($memkey);# #print "DEBUG: invoking ".$mh->name."'s $meth(".dmp($key).", ".dmp($l).", ".dmp($r).")\n";# my ($newkey, $res, $backup) = $mh->$meth($key, $l, $r);# #print "DEBUG: setting res for mem<$memkey>\n";# $self->mem->{$memkey}{res} = [$newkey, $res, $backup];# $self->_process_todo;# return ($newkey, $res, $backup);# }# } else {# $self->_process_todo;# #print "DEBUG: invoking ".$mh->name."'s $meth(".dmp($key).", ".dmp($l).", ".dmp($r).")\n";# return $mh->$meth($key, $l, $r);# }#}### returns 1 if a is included in b (e.g. [user => "jajang"] in included in [user## => jajang => "quota"], but [user => "paijo"] is not)
#Return hash key will any prefix removed.##=head2 remove_prefix_on_hash($hash)##This is like C<remove_prefix> but performed on every key of the#specified hash. Return the same hash but with prefixes removed.##=head2 merge($l, $r)##Merge two nested data structures. Returns the result hash: {#success=>0|1, error=>'...', result=>..., backup=>... }. The 'error'#key is set to contain an error message if there is an error. The merge#result is in the 'result' key. The 'backup' key contains replaced#elements from the original hash/array.##=head1 FAQ##=head2 What is this module good for? Why would I want to use this module instead of the other hash merge modules?##If you just need to (deeply) merge two hashes, chances are you do not#need this module. Use, for example, L<Hash::Merge>, which is also#flexible enough because it allows you to set merging behaviour for#merging different types (e.g. SCALAR vs ARRAY).
#}##sub merge_ARRAY_ARRAY {# my ($self, $key, $l, $r) = @_;# my $mm = $self->merger;# my $c = $mm->config;# return $self->merge_SCALAR_SCALAR($key, $l, $r) unless $c->recurse_array;# return if $c->wanted_path && !$mm->_path_is_included($mm->path, $c->wanted_path);## my @res;# my @backup;# my $la = @$l;# my $lb = @$r;# push @{ $mm->path }, -1;# for my $i (0..($la > $lb ? $la : $lb)-1) {# #print "DEBUG: merge_A_A: #$i: a->[$i]=".Data::Dumper->new([$l->[$i]])->Indent(0)->Terse(1)->Dump.", b->[$i]=".Data::Dumper->new([$r->[$i]])->Indent(0)->Terse(1)->Dump."\n";# $mm->path->[-1] = $i;# if ($i < $la && $i < $lb) {# push @backup, $l->[$i];# my ($subnewkey, $subres, $subbackup, $is_circular) = $mm->_merge($i, $l->[$i], $r->[$i], $c->default_mode);# last if @{ $mm->errors };# if ($is_circular) {# push @res, undef;# #print "DEBUG: pushing todo to mem<".$mm->cur_mem_key.">\n";# push @{ $mm->mem->{ $mm->cur_mem_key }{todo} }, sub {# my ($subnewkey, $subres, $subbackup) = @_;# #print "DEBUG: Entering todo subroutine (i=$i)\n";# $res[$i] = $subres;# }# } else {# push @res, $subres;# if defined($newkey); = we allow DELETE on array?# }# } elsif ($i < $la) {# push @res, $l->[$i];# } else {# push @res, $r->[$i];# }# }# pop @{ $mm->path };# ($key, \@res, \@backup);#}##sub _prefilter_hash {# my ($self, $h, $desc, $sub) = @_;# my $mm = $self->merger;## if (ref($sub) ne 'CODE') {# $mm->push_error("$desc failed: filter must be a coderef");# return;# }
## merge two hashes which have been prepared by _gen_left and## _gen_right, will result in { key => [final_mode, val], ... }#sub _merge_gen {# my ($self, $hl, $hr, $mode, $em, $im, $emr, $imr) = @_;# my $mm = $self->merger;# my $c = $mm->config;## #print "DEBUG: Entering _merge_gen(".dmp($hl).", ".dmp($hr).", $mode, ...)\n";## my $res = {};# my $backup = {};## my %k = map {$_=>1} keys(%$hl), keys(%$hr);# push @{ $mm->path }, "";# K:# for my $k (keys %k) {# my @o;# $mm->path->[-1] = $k;# my $do_merge = 1;# $do_merge = 0 if $do_merge && $em && $mm->_in($k, $em);# $do_merge = 0 if $do_merge && $im && !$mm->_in($k, $im);# $do_merge = 0 if $do_merge && $emr && $k =~ /$emr/;# $do_merge = 0 if $do_merge && $imr && $k !~ /$imr/;## if (!$do_merge) {# $res->{$k} = $hl->{$k} if $hl->{$k};# next K;# }## $backup->{$k} = $hl->{$k}[1] if $hl->{$k} && $hr->{$k};# if ($hl->{$k}) {# push @o, $hl->{$k};# }# if ($hr->{$k}) {# my %m = map {$_=>$mm->modes->{$_}->precedence_level} keys %{ $hr->{$k} };# #print "DEBUG: \\%m=".Data::Dumper->new([\%m])->Indent(0)->Terse(1)->Dump."\n";# push @o, map { [$_, $hr->{$k}{$_}] } sort { $m{$b} <=> $m{$a} } keys %m;# }# my $final_mode;# my $is_circular;# my $v;# #print "DEBUG: k=$k, o=".Data::Dumper->new([\@o])->Indent(0)->Terse(1)->Dump."\n";# for my $i (0..$#o) {# if ($i == 0) {# my $mh = $mm->modes->{$o[$i][0]};# if (@o == 1 &&# (($hl->{$k} && $mh->can("merge_left_only")) ||# ($hr->{$k} && $mh->can("merge_right_only")))) {# # there's only left-side or right-side# my $meth = $hl->{$k} ? "merge_left_only" : "merge_right_only";# my ($subnewkey, $v, $subbackup, $is_circular, $newmode) = $mh->$meth($k, $o[$i][1]); # XXX handle circular?# next K unless defined($subnewkey);# $final_mode = $newmode;# $v = $res;# } else {# $final_mode = $o[$i][0];# $v = $o[$i][1];# }# } else {# my $m = $mm->combine_rules->{"$final_mode+$o[$i][0]"}# or do {# $mm->push_error("Can't merge $final_mode + $o[$i][0]");# return;# };# #print "DEBUG: merge $final_mode+$o[$i][0] = $m->[0], $m->[1]\n";# my ($subnewkey, $subbackup);# ($subnewkey, $v, $subbackup, $is_circular) = $mm->_merge($k, $v, $o[$i][1], $m->[0]);# return if @{ $mm->errors };# if ($is_circular) {# if ($i < $#o) {# $mm->push_error("Can't handle circular at $i of $#o merges (mode $m->[0]): not the last merge");# return;# }# #print "DEBUG: pushing todo to mem<".$mm->cur_mem_key.">\n";# push @{ $mm->mem->{ $mm->cur_mem_key }{todo} }, sub {# my ($subnewkey, $subres, $subbackup) = @_;# #print "DEBUG: Entering todo subroutine (k=$k)\n";# my $final_mode = $m->[1];# #XXX return unless defined($subnewkey);# $res->{$k} = [$m->[1], $subres];# if ($c->readd_prefix) {# # XXX if there is a conflict error in# # _readd_prefix, how to adjust path?# $self->_readd_prefix($res, $k, $c->default_mode);# } else {# $res->{$k} = $res->{$k}[1];
# delete $res->{$k};# }# next K unless defined $subnewkey;# $final_mode = $m->[1];# }# }# $res->{$k} = [$final_mode, $v] unless $is_circular;# }# pop @{ $mm->path };# #print "DEBUG: Leaving _merge_gen, res = ".dmp($res)."\n";# ($res, $backup);#}### hh is {key=>[MODE, val], ...} which is the format returned by _merge_gen#sub _readd_prefix {# my ($self, $hh, $k, $defmode) = @_;# my $mm = $self->merger;# my $c = $mm->config;## my $m = $hh->{$k}[0];# if ($m eq $defmode) {
# {# last unless defined $ok;## my $okl = $self->_gen_left ($l, $mode, sub {$_[0] eq $ok});# return if @{ $mm->errors };## my $okr = $self->_gen_right($r, $mode, sub {$_[0] eq $ok});# return if @{ $mm->errors };## push @{ $mm->path }, $ok;# my ($res, $backup);# {# local $c->{readd_prefix} = 0;# ($res, $backup) = $self->_merge_gen($okl, $okr, $mode);# }# pop @{ $mm->path };# return if @{ $mm->errors };## #print "DEBUG: merge options key (".dmp($okl).", ".dmp($okr).") = ".dmp($res)."\n";## $res = $res->{$ok} ? $res->{$ok}[1] : undef;# if (defined($res) && ref($res) ne 'HASH') {# $mm->push_error("Invalid options key after merge: value must be hash");# return;
# }# if (defined($imr)) {# eval { $imr = qr/$imr/ };# if ($@) {# $mm->push_error("Invalid config value `include_merge_regex`: invalid regex: $@");# return;# }# }## # STEP 4. MERGE LEFT & RIGHT# my ($res, $backup) = $self->_merge_gen($hl, $hr, $mode, $em, $im, $emr, $imr);# return if @{ $mm->errors };## #print "DEBUG: intermediate res(5) = ".Data::Dumper->new([$res])->Indent(0)->Terse(1)->Dump."\n";## # STEP 5. TURN BACK {key=>[MODE=>val]}, ...} INTO {(prefix)key => val, ...}# if ($c->readd_prefix) {# for my $k (keys %$res) {# $self->_readd_prefix($res, $k, $c->default_mode);# }# } else {
# $mh->remove_prefix_sub($s->{remove_prefix_sub});# }# }## # restore config# if ($config_replaced) {# $mm->config($orig_c);# #print "DEBUG: Restored config, config=", dmp($mm->config), "\n";# }## #print "DEBUG: backup = ".Data::Dumper->new([$backup])->Indent(0)->Terse(1)->Dump."\n";# #print "DEBUG: leaving merge_H_H, result = ".dmp($res)."\n";# ($key, $res, $backup);#}##1;## ABSTRACT: Base class for Data::ModeMerge mode handler##__END__##=pod##=encoding UTF-8
#sub name { 'DELETE' }##sub precedence_level { 1 }##sub default_prefix { '!' }##sub default_prefix_re { qr/^!/ }### merge_left_only and merge_right_only are a bit different: they are## called with $l only or $r only instead of both, and should return an## extra argument $mode, i.e. ($key, $result, $backup, $is_circular,## $mode)#sub merge_left_only {# my ($self, $key, $l) = @_;# return;#}##sub merge_right_only {# my ($self, $key, $r) = @_;# return;#}
( run in 0.242 second using v1.01-cache-2.11-cpan-e5176c747c2 )