App-reposdb
view release on metacpan or search on metacpan
script/_reposdb-inline view on Meta::CPAN
# }
# $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} }) {
script/_reposdb-inline view on Meta::CPAN
# #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)
script/_reposdb-inline view on Meta::CPAN
#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).
script/_reposdb-inline view on Meta::CPAN
#}
#
#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;
# }
script/_reposdb-inline view on Meta::CPAN
## 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];
script/_reposdb-inline view on Meta::CPAN
# 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) {
script/_reposdb-inline view on Meta::CPAN
# {
# 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;
script/_reposdb-inline view on Meta::CPAN
# }
# 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 {
script/_reposdb-inline view on Meta::CPAN
# $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
script/_reposdb-inline view on Meta::CPAN
#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 1.775 second using v1.01-cache-2.11-cpan-49f99fa48dc )