Fix cloning bug exposed by hash randomization of 5.17.6 (RT #81807), …

…Data::Clone does not deep-copy object
perlancar · Dec 13, 2012 · 8536bb7 · 8536bb7
1 parent 5db762f
commit 8536bb7
Show file tree

Hide file tree

Showing 3 changed files with 17 additions and 35 deletions.
diff --git a/dist.ini b/dist.ini
@@ -18,4 +18,5 @@ Test::Exception=0
 
 perl=5.010000
 Data::Clone=0
+Log::Any=0
 Moo=0
diff --git a/lib/Data/ModeMerge.pm b/lib/Data/ModeMerge.pm
@@ -26,15 +26,14 @@ has modes => (is => 'rw', default => sub { {} });
 has combine_rules => (is => 'rw');
 
 # merging process state
-has config_stack => (is => "rw");
 has path => (is => "rw", default => sub { [] });
 has errors => (is => "rw", default => sub { [] });
 has mem => (is => "rw", default => sub { {} }); # for handling circular refs. {key=>{res=>[...], todo=>[sub1, ...]}, ...}
 has cur_mem_key => (is => "rw"); # for handling circular refs. instead of passing around this as argument, we put it here.
 
 sub _dump {
     my ($self, $var) = @_;
-    Data::Dumper->new([$var])->Indent(0)->Terse(1)->Dump;
+    Data::Dumper->new([$var])->Indent(0)->Terse(1)->Sortkeys(1)->Dump;
 }
 
 sub _in($$) {
@@ -221,21 +220,8 @@ sub remove_prefix_on_hash {
     $hash;
 }
 
-sub save_config {
-    my ($self) = @_;
-    my %config = %{ $self->config() };
-    push @{ $self->config_stack }, \%config;
-}
-
-sub restore_config {
-    my ($self) = @_;
-    my $config = pop @{ $self->config_stack };
-    $self->config(Data::ModeMerge::Config->new(%$config));
-}
-
 sub merge {
     my ($self, $l, $r) = @_;
-    $self->config_stack([]);
     $self->path([]);
     $self->errors([]);
     $self->mem({});
@@ -644,8 +630,6 @@ A hashref for config. See L<Data::ModeMerge::Config>.
 
 =head2 combine_rules
 
-=head2 config_stack
-
 =head2 path
 
 =head2 errors
@@ -692,17 +676,6 @@ Return hash key will any prefix removed.
 This is like C<remove_prefix> but performed on every key of the
 specified hash. Return the same hash but with prefixes removed.
 
-=head2 save_config()
-
-Called by mode handlers to save configuration before recursive
-merge. This is because many configuration settings can be overriden by
-options key.
-
-=head2 restore_config()
-
-Called by mode handlers to restore configuration saved by
-save_config().
-
 =head2 merge($l, $r)
 
 Merge two nested data structures. Returns the result hash: {

diff --git a/lib/Data/ModeMerge/Mode/Base.pm b/lib/Data/ModeMerge/Mode/Base.pm
@@ -1,6 +1,7 @@
 package Data::ModeMerge::Mode::Base;
 
 use 5.010;
+use Log::Any '$log';
 use Moo;
 
 use Data::Clone qw/clone/;
@@ -359,13 +360,15 @@ sub merge_HASH_HASH {
     my $mm = $self->merger;
     my $c = $mm->config;
     $mode //= $c->default_mode;
-    #print "DEBUG: entering merge_H_H(".$mm->_dump($l).", ".$mm->_dump($r).", $mode)\n";
+    #print "DEBUG: entering merge_H_H(".$mm->_dump($l).", ".$mm->_dump($r).", $mode), config=($c)=",$mm->_dump($c),"\n";
+    #$log->trace("using config($c)");
 
     return $self->merge_SCALAR_SCALAR($key, $l, $r) unless $c->recurse_hash;
     return if $c->wanted_path && !$mm->_path_is_included($mm->path, $c->wanted_path);
 
     # STEP 1. MERGE LEFT & RIGHT OPTIONS KEY
     my $config_replaced;
+    my $orig_c = $c;
     my $ok = $c->options_key;
     {
         last unless defined $ok;
@@ -393,9 +396,11 @@ sub merge_HASH_HASH {
             return;
         }
         last unless keys %$res;
-        #print "DEBUG: cloning config ...\n";
-        #my $c2 = Storable::dclone($c);
-        my $c2 = clone($c);
+        #$log->tracef("cloning config ...");
+        # Data::Clone by default does *not* deep-copy object
+        #my $c2 = clone($c);
+        my $c2 = bless({ %$c }, ref($c));
+
         for (keys %$res) {
             if ($c->allow_override) {
                 my $re = $c->allow_override;
@@ -421,11 +426,10 @@ sub merge_HASH_HASH {
             }
             $c2->$_($res->{$_}) unless $_ eq $ok;
         }
-        $mm->save_config;
         $mm->config($c2);
         $config_replaced++;
         $c = $c2;
-        #print "DEBUG: configuration now changed: ".$mm->_dump($c)."\n";
+        #$log->trace("config now changed to $c2");
     }
 
     my $sp = $c->set_prefix;
@@ -550,7 +554,11 @@ sub merge_HASH_HASH {
         }
     }
 
-    $mm->restore_config if $config_replaced;
+    # restore config
+    if ($config_replaced) {
+        $mm->config($orig_c);
+        #print "DEBUG: Restored config, config=", $mm->_dump($mm->config), "\n";
+    }
 
     #print "DEBUG: backup = ".Data::Dumper->new([$backup])->Indent(0)->Terse(1)->Dump."\n";
     #print "DEBUG: leaving merge_H_H, result = ".$mm->_dump($res)."\n";