Standardize the struct-cloning interface throughout the codebase

diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
index d804d02..f4c8ac8 100644 (file)
--- a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
+++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
@@ -4,7 +4,6 @@ package # hide from PAUSE
 use strict;
 use warnings;
 use Sub::Name ();
-use Storable 'dclone';
 use List::Util ();
 
 use base qw/DBIx::Class::Row/;
@@ -43,7 +42,7 @@ sub _register_column_group {
 
   # Must do a complete deep copy else column groups
   # might accidentally be shared.
-  my $groups = dclone $class->_column_groups;
+  my $groups = DBIx::Class::_Util::deep_clone( $class->_column_groups );
 
   if ($group eq 'Primary') {
     $class->set_primary_key(@cols);

diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm
index be7b5bf..05afe74 100644 (file)
--- a/lib/DBIx/Class/CDBICompat/Relationships.pm
+++ b/lib/DBIx/Class/CDBICompat/Relationships.pm
@@ -162,14 +162,19 @@ sub might_have {
 
 sub _extend_meta {
     my ($class, $type, $rel, $val) = @_;
-    my %hash = %{ Clone::clone($class->__meta_info || {}) };
+
+### Explicitly not using the deep cloner as Clone exhibits specific behavior
+### wrt CODE references - it simply passes them as-is to the new structure
+### (without deparse/eval cycles). There likely is code that relies on this
+### so we just let sleeping dogs lie.
+    my $hash = Clone::clone($class->__meta_info || {});
 
     $val->{self_class} = $class;
     $val->{type}       = $type;
     $val->{accessor}   = $rel;
 
-    $hash{$type}{$rel} = DBIx::Class::CDBICompat::Relationship->new($val);
-    $class->__meta_info(\%hash);
+    $hash->{$type}{$rel} = DBIx::Class::CDBICompat::Relationship->new($val);
+    $class->__meta_info($hash);
 }
 
 

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index f90c998..56bcbd6 100644 (file)
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -80,12 +80,15 @@ BEGIN {
 sub qsub ($) { goto &quote_sub }  # no point depping on new Moo just for this
 # END pre-Moo2 import block
 
+# Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone'
+BEGIN { *deep_clone = \&Storable::dclone }
+
 use base 'Exporter';
 our @EXPORT_OK = qw(
   sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt
   fail_on_internal_wantarray fail_on_internal_call
   refdesc refcount hrefaddr is_exception
-  quote_sub qsub perlstring serialize
+  quote_sub qsub perlstring serialize deep_clone
   UNRESOLVABLE_CONDITION
 );
 

diff --git a/t/100populate.t b/t/100populate.t
index fa07ba5..7324bce 100644 (file)
--- a/t/100populate.t
+++ b/t/100populate.t
@@ -6,11 +6,10 @@ use Test::Exception;
 use Test::Warn;
 use lib qw(t/lib);
 use DBICTest;
-use DBIx::Class::_Util 'sigwarn_silencer';
+use DBIx::Class::_Util qw(sigwarn_silencer serialize);
 use Path::Class::File ();
 use Math::BigInt;
 use List::Util qw/shuffle/;
-use Storable qw/nfreeze dclone/;
 
 my $schema = DBICTest->init_schema();
 
@@ -456,7 +455,7 @@ warnings_like {
   }
 
   local $Storable::canonical = 1;
-  my $preimage = nfreeze($args);
+  my $preimage = serialize($args);
 
 
   for my $tst (keys %$args) {
@@ -502,7 +501,7 @@ warnings_like {
   }
 
   ok (
-    ($preimage eq nfreeze($args)),
+    ($preimage eq serialize($args)),
     'Arguments fed to populate()/create() unchanged'
   );
 

diff --git a/t/67pager.t b/t/67pager.t
index f768549..2463369 100644 (file)
--- a/t/67pager.t
+++ b/t/67pager.t
@@ -4,7 +4,6 @@ use warnings;
 use Test::More;
 use lib qw(t/lib);
 use DBICTest;
-use Storable qw/dclone/;
 
 my $schema = DBICTest->init_schema();
 
@@ -197,7 +196,11 @@ $it = $rs->search(
 $pager = $it->pager;
 is ($qcnt, 0, 'No queries on rs/pager creation');
 
-$it = do { local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema; dclone ($it) };
+# test *requires* it to be Storable
+$it = do {
+  local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema;
+  Storable::dclone ($it);
+};
 is ($qcnt, 0, 'No queries on rs/pager freeze/thaw');
 
 is( $it->pager->entries_on_this_page, 1, "entries_on_this_page ok for page 2" );
@@ -207,7 +210,11 @@ is ($qcnt, 1, 'Count fired to get pager page entries');
 $rs->create({ title => 'bah', artist => 1, year => 2011 });
 
 $qcnt = 0;
-$it = do { local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema; dclone ($it) };
+# test *requires* it to be Storable
+$it = do {
+  local $DBIx::Class::ResultSourceHandle::thaw_schema = $schema;
+  Storable::dclone ($it);
+};
 is ($qcnt, 0, 'No queries on rs/pager freeze/thaw');
 
 is( $it->pager->entries_on_this_page, 1, "entries_on_this_page ok for page 2, even though underlying count changed" );

diff --git a/t/search/preserve_original_rs.t b/t/search/preserve_original_rs.t
index abb6544..9f6704f 100644 (file)
--- a/t/search/preserve_original_rs.t
+++ b/t/search/preserve_original_rs.t
@@ -6,50 +6,49 @@ use Test::Exception;
 
 use lib qw(t/lib);
 use DBICTest ':DiffSQL';
-
-use Storable 'dclone';
+use DBIx::Class::_Util 'serialize';
 
 my $schema = DBICTest->init_schema();
 
 # A search() with prefetch seems to pollute an already joined resultset
 # in a way that offsets future joins (adapted from a test case by Debolaz)
 {
-  my ($cd_rs, $attrs);
+  my ($cd_rs, $preimage);
 
   # test a real-life case - rs is obtained by an implicit m2m join
   $cd_rs = $schema->resultset ('Producer')->first->cds;
-  $attrs = dclone( $cd_rs->{attrs} );
+  $preimage = serialize $cd_rs->{attrs};
 
   $cd_rs->search ({})->all;
-  is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after a simple search');
+  is ( serialize $cd_rs->{attrs}, $preimage, 'Resultset attributes preserved after a simple search');
 
   lives_ok (sub {
     $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
-    is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after search with prefetch');
+    is ( serialize $cd_rs->{attrs}, $preimage, 'Resultset attributes preserved after search with prefetch');
   }, 'first prefetching search ok');
 
   lives_ok (sub {
     $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
-    is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after another search with prefetch')
+    is ( serialize $cd_rs->{attrs}, $preimage, 'Resultset attributes preserved after another search with prefetch')
   }, 'second prefetching search ok');
 
 
   # test a regular rs with an empty seen_join injected - it should still work!
   $cd_rs = $schema->resultset ('CD');
   $cd_rs->{attrs}{seen_join}  = {};
-  $attrs = dclone( $cd_rs->{attrs} );
+  $preimage = serialize $cd_rs->{attrs};
 
   $cd_rs->search ({})->all;
-  is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after a simple search');
+  is ( serialize $cd_rs->{attrs}, $preimage, 'Resultset attributes preserved after a simple search');
 
   lives_ok (sub {
     $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
-    is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after search with prefetch');
+    is ( serialize $cd_rs->{attrs}, $preimage, 'Resultset attributes preserved after search with prefetch');
   }, 'first prefetching search ok');
 
   lives_ok (sub {
     $cd_rs->search ({'artist.artistid' => 1}, { prefetch => 'artist' })->all;
-    is_deeply (dclone($cd_rs->{attrs}), $attrs, 'Resultset attributes preserved after another search with prefetch')
+    is ( serialize $cd_rs->{attrs}, $preimage, 'Resultset attributes preserved after another search with prefetch')
   }, 'second prefetching search ok');
 }
 

diff --git a/t/sqlmaker/limit_dialects/torture.t b/t/sqlmaker/limit_dialects/torture.t
index 9d8d23d..4dac672 100644 (file)
--- a/t/sqlmaker/limit_dialects/torture.t
+++ b/t/sqlmaker/limit_dialects/torture.t
@@ -3,9 +3,9 @@ use warnings;
 
 use Test::More;
 use Test::Exception;
-use Storable 'dclone';
 use lib qw(t/lib);
 use DBICTest ':DiffSQL';
+use DBIx::Class::_Util 'deep_clone';
 
 my $schema = DBICTest->init_schema;
 my $native_limit_dialect = $schema->storage->sql_maker->{limit_dialect};
@@ -626,7 +626,7 @@ my $tests = {
         @where_bind,
         @group_bind,
         @having_bind,
-        @{ dclone \@order_bind },  # without this is_deeply throws a fit
+        @{ deep_clone \@order_bind },  # without this is_deeply throws a fit
       ],
     ],
     limit_offset_prefetch => [
@@ -738,7 +738,7 @@ my $tests = {
         @where_bind,
         @group_bind,
         @having_bind,
-        @{ dclone \@order_bind },  # without this is_deeply throws a fit
+        @{ deep_clone \@order_bind },  # without this is_deeply throws a fit
       ],
     ],
     limit_offset_prefetch => [