Fully separate parent and child resultsource metadata

[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / ResultSource.pm

diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm
index f6e3923..4ebb4c0 100644 (file)
--- a/lib/DBIx/Class/ResultSource.pm
+++ b/lib/DBIx/Class/ResultSource.pm
@@ -16,12 +16,18 @@ use DBIx::Class::ResultSet;
 
 use namespace::clean;
 
-__PACKAGE__->mk_group_accessors(simple => qw/
-  source_name name source_info
-  _ordered_columns _columns _primaries _unique_constraints
-  _relationships resultset_attributes
-  column_info_from_storage sqlt_deploy_callback
-/);
+my @hashref_attributes = qw(
+  source_info resultset_attributes
+  _columns _unique_constraints _relationships
+);
+my @arrayref_attributes = qw(
+  _ordered_columns _primaries
+);
+__PACKAGE__->mk_group_accessors(simple =>
+  @hashref_attributes,
+  @arrayref_attributes,
+  qw( source_name name column_info_from_storage sqlt_deploy_callback ),
+);
 
 __PACKAGE__->mk_group_accessors(component_class => qw/
   resultset_class
@@ -115,20 +121,73 @@ Creates a new ResultSource object.  Not normally called directly by end users.
 
 =cut
 
-sub new {
-  my ($class, $attrs) = @_;
-  $class = ref $class if ref $class;
-
-  my $new = bless { %{$attrs || {}} }, $class;
-  $new->{resultset_class} ||= 'DBIx::Class::ResultSet';
-  $new->{resultset_attributes} = { %{$new->{resultset_attributes} || {}} };
-  $new->{_ordered_columns} = [ @{$new->{_ordered_columns}||[]}];
-  $new->{_columns} = { %{$new->{_columns}||{}} };
-  $new->{_relationships} = { %{$new->{_relationships}||{}} };
-  $new->{name} ||= "!!NAME NOT SET!!";
-  $new->{_columns_info_loaded} ||= 0;
-  $new->{sqlt_deploy_callback} ||= 'default_sqlt_deploy_hook';
-  return $new;
+{
+  sub new {
+    my ($class, $attrs) = @_;
+    $class = ref $class if ref $class;
+
+    my $self = bless { %{$attrs || {}} }, $class;
+
+
+    DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
+      and
+    # a constructor with 'name' as sole arg clearly isn't "inheriting" from anything
+    ( not ( keys(%$self) == 1 and exists $self->{name} ) )
+      and
+    defined CORE::caller(1)
+      and
+    (CORE::caller(1))[3] !~ / ::new$ | ^ DBIx::Class :: (?:
+      ResultSourceProxy::Table::table
+        |
+      ResultSourceProxy::Table::_init_result_source_instance
+        |
+      ResultSource::clone
+    ) $ /x
+      and
+    local $Carp::CarpLevel = $Carp::CarpLevel + 1
+      and
+    Carp::confess("Incorrect instantiation of '$self': you almost certainly wanted to call ->clone() instead");
+
+
+    $self->{resultset_class} ||= 'DBIx::Class::ResultSet';
+    $self->{name} ||= "!!NAME NOT SET!!";
+    $self->{_columns_info_loaded} ||= 0;
+    $self->{sqlt_deploy_callback} ||= 'default_sqlt_deploy_hook';
+
+    $self->{$_} = { %{ $self->{$_} || {} } }
+      for @hashref_attributes;
+
+    $self->{$_} = [ @{ $self->{$_} || [] } ]
+      for @arrayref_attributes;
+
+    $self;
+  }
+}
+
+=head2 clone
+
+  $rsrc_instance->clone( atribute_name => overriden_value );
+
+A wrapper around L</new> inheriting any defaults from the callee. This method
+also not normally invoked directly by end users.
+
+=cut
+
+sub clone {
+  my $self = shift;
+
+  $self->new({
+    (
+      (length ref $self)
+        ? %$self
+        : ()
+    ),
+    (
+      (@_ == 1 and ref $_[0] eq 'HASH')
+        ? %{ $_[0] }
+        : @_
+    ),
+  });
 }
 
 =pod