From: Peter Rabbitson Date: Thu, 7 Apr 2016 11:20:30 +0000 (+0200) Subject: Add a clone method to ResultSource, switch obvious spots to it X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=534aff612dee17fe18831e445d464d942c27c172;p=dbsrgits%2FDBIx-Class-Historic.git Add a clone method to ResultSource, switch obvious spots to it Not messing with the ::ResultSourceProxy::Table clusterfuck for now, too many things can go wrong. Instead will explicitly instrument the callsites in subsequent commits. Also add assertions this does not get routed around: such use will throw from here on out as long as one enables the necessary assert: ~$ DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE=1 perl -Ilib -MDBIx::Class -e ' bless ({}, "DBIx::Class::ResultSource") ' --- diff --git a/lib/DBIx/Class/DB.pm b/lib/DBIx/Class/DB.pm index 235b6bf..ea4a5a6 100644 --- a/lib/DBIx/Class/DB.pm +++ b/lib/DBIx/Class/DB.pm @@ -222,15 +222,14 @@ sub result_source_instance { } my($source, $result_class) = @{$class->_result_source_instance}; - return unless blessed $source; + return undef unless blessed $source; if ($result_class ne $class) { # new class # Give this new class its own source and register it. - $source = $source->new({ - %$source, + $source = $source->clone( source_name => $class, result_class => $class - } ); + ); $class->_result_source_instance([$source, $class]); $class->_maybe_attach_source_to_schema($source); } diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index f6e3923..053b398 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -115,20 +115,72 @@ 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 qw( _columns _relationships resultset_attributes ); + + $self->{_ordered_columns} = [ @{ $self->{_ordered_columns} || [] } ]; + + $self; + } +} + +=head2 clone + + $rsrc_instance->clone( atribute_name => overriden_value ); + +A wrapper around L 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 diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index f19c7bc..153d729 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -957,19 +957,12 @@ sub compose_namespace { my $target_class = "${target}::${source_name}"; $self->inject_base($target_class, $orig_source->result_class, ($base || ()) ); - # register_source examines result_class, and then returns us a clone - my $new_source = $schema->register_source($source_name, bless - { %$orig_source, result_class => $target_class }, - ref $orig_source, + $schema->register_source( + $source_name, + $orig_source->clone( + result_class => $target_class + ), ); - - if ($target_class->can('result_source_instance')) { - # give the class a schema-less source copy - $target_class->result_source_instance( bless - { %$new_source, schema => ref $new_source->{schema} || $new_source->{schema} }, - ref $new_source, - ); - } } # Legacy stuff, not inserting INDIRECT assertions @@ -979,6 +972,24 @@ sub compose_namespace { Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; + # Give each composed class yet another *schema-less* source copy + # this is used for the freeze/thaw cycle + # + # This is not covered by any tests directly, but is indirectly exercised + # in t/cdbi/sweet/08pager by re-setting the schema on an existing object + # FIXME - there is likely a much cheaper way to take care of this + for my $source_name ($self->sources) { + + my $target_class = "${target}::${source_name}"; + + $target_class->result_source_instance( + $self->source($source_name)->clone( + result_class => $target_class, + schema => ( ref $schema || $schema ), + ) + ); + } + return $schema; } @@ -1083,13 +1094,10 @@ sub _copy_state_from { $self->class_mappings({ %{$from->class_mappings} }); $self->source_registrations({ %{$from->source_registrations} }); - foreach my $source_name ($from->sources) { - my $source = $from->source($source_name); - my $new = $source->new($source); - # we use extra here as we want to leave the class_mappings as they are - # but overwrite the source_registrations entry with the new source - $self->register_extra_source($source_name => $new); - } + # we use extra here as we want to leave the class_mappings as they are + # but overwrite the source_registrations entry with the new source + $self->register_extra_source( $_ => $from->source($_) ) + for $from->sources; if ($from->storage) { $self->storage($from->storage); @@ -1448,8 +1456,7 @@ sub register_extra_source { shift->_register_source(@_, { extra => 1 }) } sub _register_source { my ($self, $source_name, $supplied_rsrc, $params) = @_; - my $derived_rsrc = $supplied_rsrc->new({ - %$supplied_rsrc, + my $derived_rsrc = $supplied_rsrc->clone({ source_name => $source_name, }); diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index f86be00..b640e76 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -49,6 +49,7 @@ BEGIN { DBIC_SHUFFLE_UNORDERED_RESULTSETS DBIC_ASSERT_NO_INTERNAL_WANTARRAY DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS + DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE ) @@ -1078,4 +1079,59 @@ sub fail_on_internal_call { } } +if (DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE) { + + no warnings 'redefine'; + + my $next_bless = defined(&CORE::GLOBAL::bless) + ? \&CORE::GLOBAL::bless + : sub { CORE::bless($_[0], $_[1]) } + ; + + *CORE::GLOBAL::bless = sub { + my $class = (@_ > 1) ? $_[1] : CORE::caller(); + + # allow for reblessing (role application) + return $next_bless->( $_[0], $class ) + if defined blessed $_[0]; + + my $obj = $next_bless->( $_[0], $class ); + + my $calling_sub = (CORE::caller(1))[3] || ''; + + ( + # before 5.18 ->isa() will choke on the "0" package + # which we test for in several obscure cases, sigh... + !( DBIx::Class::_ENV_::PERL_VERSION < 5.018 ) + or + $class + ) + and + ( + ( + $calling_sub !~ /^ (?: + DBIx::Class::Schema::clone + | + DBIx::Class::DB::setup_schema_instance + )/x + and + $class->isa("DBIx::Class::Schema") + ) + or + ( + $calling_sub ne 'DBIx::Class::ResultSource::new' + and + $class->isa("DBIx::Class::ResultSource") + ) + ) + and + local $Carp::CarpLevel = $Carp::CarpLevel + 1 + and + Carp::confess("Improper instantiation of '$obj': you *MUST* call the corresponding constructor"); + + + $obj; + }; +} + 1; diff --git a/t/zzzzzzz_perl_perf_bug.t b/t/zzzzzzz_perl_perf_bug.t index 85dd77c..a9cc07f 100644 --- a/t/zzzzzzz_perl_perf_bug.t +++ b/t/zzzzzzz_perl_perf_bug.t @@ -6,6 +6,8 @@ use Test::More; BEGIN { + delete $ENV{DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE}; + plan skip_all => 'Skipping RH perl performance bug tests as DBIC_NO_WARN_BAD_PERL set' if ( $ENV{DBIC_NO_WARN_BAD_PERL} );