X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class.git;a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSource.pm;h=0c0cb9d5ef6b5c1c7364f1826a430f081b536f10;hp=3c4566299e3d18e8eee8a8de329ea59468983920;hb=c6ec79000b160e7491d9ab9d95d6e69c473b0862;hpb=36d2ef2b8efc890a251fecb8828fa8eec5f92d99 diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 3c45662..0c0cb9d 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -1,36 +1,60 @@ package DBIx::Class::ResultSource; +### !!!NOTE!!! +# +# Some of the methods defined here will be around()-ed by code at the +# end of ::ResultSourceProxy. The reason for this strange arrangement +# is that the list of around()s of methods in this class depends +# directly on the list of may-not-be-defined-yet methods within +# ::ResultSourceProxy itself. +# If this sounds terrible - it is. But got to work with what we have. +# + use strict; use warnings; -use base qw/DBIx::Class::ResultSource::RowParser DBIx::Class/; - -use DBIx::Class::ResultSet; -use DBIx::Class::ResultSourceHandle; +use base 'DBIx::Class::ResultSource::RowParser'; use DBIx::Class::Carp; -use DBIx::Class::_Util 'UNRESOLVABLE_CONDITION'; +use DBIx::Class::_Util qw( + UNRESOLVABLE_CONDITION + dbic_internal_try fail_on_internal_call + refdesc emit_loud_diag +); +use DBIx::Class::SQLMaker::Util qw( normalize_sqla_condition extract_equality_conditions ); use SQL::Abstract 'is_literal_value'; use Devel::GlobalDestruction; -use Try::Tiny; -use List::Util 'first'; -use Scalar::Util qw/blessed weaken isweak/; +use Scalar::Util qw( blessed weaken isweak refaddr ); -use namespace::clean; +# FIXME - somehow breaks ResultSetManager, do not remove until investigated +use DBIx::Class::ResultSet; -__PACKAGE__->mk_group_accessors(simple => qw/ - source_name name source_info - _ordered_columns _columns _primaries _unique_constraints - _relationships resultset_attributes - column_info_from_storage -/); +use namespace::clean; -__PACKAGE__->mk_group_accessors(component_class => qw/ +# This global is present for the afaik nonexistent, but nevertheless possible +# case of folks using stock ::ResultSet with a completely custom Result-class +# hierarchy, not derived from DBIx::Class::Row at all +# Instead of patching stuff all over the place - this would be one convenient +# place to override things if need be +our $__expected_result_class_isa = 'DBIx::Class::Row'; + +my @hashref_attributes = qw( + source_info resultset_attributes + _columns _unique_constraints _relationships +); +my @arrayref_attributes = qw( + _ordered_columns _primaries +); +__PACKAGE__->mk_group_accessors(rsrc_instance_specific_attribute => + @hashref_attributes, + @arrayref_attributes, + qw( source_name name column_info_from_storage sqlt_deploy_callback ), +); + +__PACKAGE__->mk_group_accessors(rsrc_instance_specific_handler => qw( resultset_class result_class -/); - -__PACKAGE__->mk_classdata( sqlt_deploy_callback => 'default_sqlt_deploy_hook' ); +)); =head1 NAME @@ -58,8 +82,8 @@ DBIx::Class::ResultSource - Result source object __PACKAGE__->table_class('DBIx::Class::ResultSource::View'); __PACKAGE__->table('year2000cds'); - __PACKAGE__->result_source_instance->is_virtual(1); - __PACKAGE__->result_source_instance->view_definition( + __PACKAGE__->result_source->is_virtual(1); + __PACKAGE__->result_source->view_definition( "SELECT cdid, artist, title FROM cd WHERE year ='2000'" ); @@ -119,19 +143,350 @@ 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; - return $new; +{ + my $rsrc_registry; + + sub __derived_instances { + map { + (defined $_->{weakref}) + ? $_->{weakref} + : () + } values %{ $rsrc_registry->{ refaddr($_[0]) }{ derivatives } } + } + + sub new { + my ($class, $attrs) = @_; + $class = ref $class if ref $class; + + my $ancestor = delete $attrs->{__derived_from}; + + 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"); + + + my $own_slot = $rsrc_registry->{ + my $own_addr = refaddr $self + } = { derivatives => {} }; + + weaken( $own_slot->{weakref} = $self ); + + if( + length ref $ancestor + and + my $ancestor_slot = $rsrc_registry->{ + my $ancestor_addr = refaddr $ancestor + } + ) { + + # on ancestry recording compact registry slots, prevent unbound growth + for my $r ( $rsrc_registry, map { $_->{derivatives} } values %$rsrc_registry ) { + defined $r->{$_}{weakref} or delete $r->{$_} + for keys %$r; + } + + weaken( $_->{$own_addr} = $own_slot ) for map + { $_->{derivatives} } + ( + $ancestor_slot, + (grep + { defined $_->{derivatives}{$ancestor_addr} } + values %$rsrc_registry + ), + ) + ; + } + + + $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, '__metadata_divergencies'; + + $self->{$_} = [ @{ $self->{$_} || [] } ] + for @arrayref_attributes; + + $self; + } + + sub DBIx::Class::__Rsrc_Ancestry_iThreads_handler__::CLONE { + for my $r ( $rsrc_registry, map { $_->{derivatives} } values %$rsrc_registry ) { + %$r = map { + defined $_->{weakref} + ? ( refaddr $_->{weakref} => $_ ) + : () + } values %$r + } + } + + + # needs direct access to $rsrc_registry under an assert + # + sub set_rsrc_instance_specific_attribute { + + # only mark if we are setting something different + if ( + ( + defined( $_[2] ) + xor + defined( $_[0]->{$_[1]} ) + ) + or + ( + # both defined + defined( $_[2] ) + and + ( + # differ in ref-ness + ( + length ref( $_[2] ) + xor + length ref( $_[0]->{$_[1]} ) + ) + or + # both refs (the mark-on-same-ref is deliberate) + length ref( $_[2] ) + or + # both differing strings + $_[2] ne $_[0]->{$_[1]} + ) + ) + ) { + + my $callsite; + # need to protect $_ here + for my $derivative ( + $_[0]->__derived_instances, + + # DO NOT REMOVE - this blob is marking *ancestors* as tainted, here to + # weed out any fallout from https://github.com/dbsrgits/dbix-class/commit/9e36e3ec + # Note that there is no way to kill this warning, aside from never + # calling set_primary_key etc more than once per hierarchy + # (this is why the entire thing is guarded by an assert) + ( + ( + DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE + and + grep { $_[1] eq $_ } qw( _unique_constraints _primaries source_info ) + ) + ? ( + map + { defined($_->{weakref}) ? $_->{weakref} : () } + grep + { defined( ( $_->{derivatives}{refaddr($_[0])} || {} )->{weakref} ) } + values %$rsrc_registry + ) + : () + ), + ) { + + $derivative->{__metadata_divergencies}{$_[1]}{ $callsite ||= do { + + # + # FIXME - this is horrible, but it's the best we can do for now + # Replace when Carp::Skip is written (it *MUST* take this use-case + # into consideration) + # + my ($cs) = DBIx::Class::Carp::__find_caller(__PACKAGE__); + + my ($fr_num, @fr) = 1; + while( @fr = CORE::caller($fr_num++) ) { + $cs =~ /^ \Qat $fr[1] line $fr[2]\E (?: $ | \n )/x + and + $fr[3] =~ s/.+::// + and + last + } + + # FIXME - using refdesc here isn't great, but I can't think of anything + # better at this moment + @fr + ? "@{[ refdesc $_[0] ]}->$fr[3](...) $cs" + : "$cs" + ; + } } = 1; + } + } + + $_[0]->{$_[1]} = $_[2]; + } +} + +sub get_rsrc_instance_specific_attribute { + + $_[0]->__emit_stale_metadata_diag( $_[1] ) if ( + ! $_[0]->{__in_rsrc_setter_callstack} + and + $_[0]->{__metadata_divergencies}{$_[1]} + ); + + $_[0]->{$_[1]}; +} + + +# reuse the elaborate set logic of instance_specific_attr +sub set_rsrc_instance_specific_handler { + $_[0]->set_rsrc_instance_specific_attribute($_[1], $_[2]); + + # trigger a load for the case of $foo->handler_accessor("bar")->new + $_[0]->get_rsrc_instance_specific_handler($_[1]) + if defined wantarray; +} + +# This is essentially the same logic as get_component_class +# (in DBIC::AccessorGroup). However the latter is a grouped +# accessor type, and here we are strictly after a 'simple' +# So we go ahead and recreate the logic as found in ::AG +sub get_rsrc_instance_specific_handler { + + # emit desync warnings if any + my $val = $_[0]->get_rsrc_instance_specific_attribute( $_[1] ); + + # plain string means class - load it + no strict 'refs'; + if ( + defined $val + and + # inherited CAG can't be set to undef effectively, so people may use '' + length $val + and + ! defined blessed $val + and + ! ${"${val}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"} + ) { + $_[0]->ensure_class_loaded($val); + + ${"${val}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"} + = do { \(my $anon = 'loaded') }; + } + + $val; +} + + +sub __construct_stale_metadata_diag { + return '' unless $_[0]->{__metadata_divergencies}{$_[1]}; + + my ($fr_num, @fr); + + # find the CAG getter FIRST + # allows unlimited user-namespace overrides without screwing around with + # $LEVEL-like crap + while( + @fr = CORE::caller(++$fr_num) + and + $fr[3] ne 'DBIx::Class::ResultSource::get_rsrc_instance_specific_attribute' + ) { 1 } + + Carp::confess( "You are not supposed to call __construct_stale_metadata_diag here..." ) + unless @fr; + + # then find the first non-local, non-private reportable callsite + while ( + @fr = CORE::caller(++$fr_num) + and + ( + $fr[2] == 0 + or + $fr[3] eq '(eval)' + or + $fr[1] =~ /^\(eval \d+\)$/ + or + $fr[3] =~ /::(?: __ANON__ | _\w+ )$/x + or + $fr[0] =~ /^DBIx::Class::ResultSource/ + ) + ) { 1 } + + my $by = ( @fr and $fr[3] =~ s/.+::// ) + # FIXME - using refdesc here isn't great, but I can't think of anything + # better at this moment + ? " by 'getter' @{[ refdesc $_[0] ]}->$fr[3](...)\n within the callstack beginning" + : '' + ; + + # Given the full stacktrace combined with the really involved callstack + # there is no chance the emitter will properly deduplicate this + # Only complain once per callsite per source + return( ( $by and $_[0]->{__encountered_divergencies}{$by}++ ) + + ? '' + + : "$_[0] (the metadata instance of source '@{[ $_[0]->source_name ]}') is " + . "*OUTDATED*, and does not reflect the modifications of its " + . "*ancestors* as follows:\n" + . join( "\n", + map + { " * $_->[0]" } + sort + { $a->[1] cmp $b->[1] } + map + { [ $_, ( $_ =~ /( at .+? line \d+)/ ) ] } + keys %{ $_[0]->{__metadata_divergencies}{$_[1]} } + ) + . "\nStale metadata accessed${by}" + ); +} + +sub __emit_stale_metadata_diag { + emit_loud_diag( + msg => ( + # short circuit: no message - no diag + $_[0]->__construct_stale_metadata_diag($_[1]) + || + return 0 + ), + # the constructor already does deduplication + emit_dups => 1, + confess => DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE, + ); +} + +=head2 clone + + $rsrc_instance->clone( atribute_name => overridden_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, __derived_from => $self ) + : () + ), + ( + (@_ == 1 and ref $_[0] eq 'HASH') + ? %{ $_[0] } + : @_ + ), + }); } =pod @@ -332,15 +687,25 @@ info keys as L. sub add_columns { my ($self, @cols) = @_; + + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + $self->_ordered_columns(\@cols) unless $self->_ordered_columns; - my @added; + my ( @added, $colinfos ); my $columns = $self->_columns; + while (my $col = shift @cols) { - my $column_info = {}; - if ($col =~ s/^\+//) { - $column_info = $self->column_info($col); - } + my $column_info = + ( + $col =~ s/^\+// + and + ( $colinfos ||= $self->columns_info )->{$col} + ) + || + {} + ; # If next entry is { ... } use that for the column info, if not # use an empty hashref @@ -351,11 +716,16 @@ sub add_columns { push(@added, $col) unless exists $columns->{$col}; $columns->{$col} = $column_info; } + push @{ $self->_ordered_columns }, @added; + $self->_columns($columns); return $self; } -sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB +sub add_column :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->add_columns(@_) +} =head2 has_column @@ -396,36 +766,11 @@ contents of the hashref. =cut -sub column_info { - my ($self, $column) = @_; - $self->throw_exception("No such column $column") - unless exists $self->_columns->{$column}; - - if ( ! $self->_columns->{$column}{data_type} - and ! $self->{_columns_info_loaded} - and $self->column_info_from_storage - and my $stor = try { $self->storage } ) - { - $self->{_columns_info_loaded}++; - - # try for the case of storage without table - try { - my $info = $stor->columns_info_for( $self->from ); - my $lc_info = { map - { (lc $_) => $info->{$_} } - ( keys %$info ) - }; - - foreach my $col ( keys %{$self->_columns} ) { - $self->_columns->{$col} = { - %{ $self->_columns->{$col} }, - %{ $info->{$col} || $lc_info->{lc $col} || {} } - }; - } - }; - } +sub column_info :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; - return $self->_columns->{$column}; + #my ($self, $column) = @_; + $_[0]->columns_info([ $_[1] ])->{$_[1]}; } =head2 columns @@ -476,18 +821,18 @@ sub columns_info { my $colinfo = $self->_columns; if ( - first { ! $_->{data_type} } values %$colinfo - and ! $self->{_columns_info_loaded} and $self->column_info_from_storage and - my $stor = try { $self->storage } + grep { ! $_->{data_type} } values %$colinfo + and + my $stor = dbic_internal_try { $self->schema->storage } ) { $self->{_columns_info_loaded}++; # try for the case of storage without table - try { + dbic_internal_try { my $info = $stor->columns_info_for( $self->from ); my $lc_info = { map { (lc $_) => $info->{$_} } @@ -520,6 +865,8 @@ sub columns_info { } } else { + # the shallow copy is crucial - there are exists() checks within + # the wider codebase %ret = %$colinfo; } @@ -568,6 +915,9 @@ broken result source. sub remove_columns { my ($self, @to_remove) = @_; + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + my $columns = $self->_columns or return; @@ -580,7 +930,10 @@ sub remove_columns { $self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]); } -sub remove_column { shift->remove_columns(@_); } # DO NOT CHANGE THIS TO GLOB +sub remove_column :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->remove_columns(@_) +} =head2 set_primary_key @@ -609,6 +962,9 @@ for more info. sub set_primary_key { my ($self, @cols) = @_; + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + my $colinfo = $self->columns_info(\@cols); for my $col (@cols) { carp_unique(sprintf ( @@ -691,6 +1047,9 @@ will be applied to the L of each L sub sequence { my ($self,$seq) = @_; + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + my @pks = $self->primary_columns or return; @@ -737,6 +1096,9 @@ the result source. sub add_unique_constraint { my $self = shift; + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + if (@_ > 2) { $self->throw_exception( 'add_unique_constraint() does not accept multiple constraints, use ' @@ -799,11 +1161,13 @@ See also L. =cut -sub add_unique_constraints { +sub add_unique_constraints :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + my $self = shift; my @constraints = @_; - if ( !(@constraints % 2) && first { ref $_ ne 'ARRAY' } @constraints ) { + if ( !(@constraints % 2) && grep { ref $_ ne 'ARRAY' } @constraints ) { # with constraint name while (my ($name, $constraint) = splice @constraints, 0, 2) { $self->add_unique_constraint($name => $constraint); @@ -940,11 +1304,11 @@ sub unique_constraint_columns { =back - __PACKAGE__->sqlt_deploy_callback('mycallbackmethod'); + __PACKAGE__->result_source->sqlt_deploy_callback('mycallbackmethod'); or - __PACKAGE__->sqlt_deploy_callback(sub { + __PACKAGE__->result_source->sqlt_deploy_callback(sub { my ($source_instance, $sqlt_table) = @_; ... } ); @@ -1092,12 +1456,15 @@ Store a collection of resultset attributes, that will be set on every L produced from this result source. B: C comes with its own set of issues and -bugs! While C isn't deprecated per se, its usage is -not recommended! +bugs! Notably the contents of the attributes are B, which +greatly hinders composability (things like L can not possibly be respected). +While C isn't deprecated per se, you are strongly urged +to seek alternatives. Since relationships use attributes to link tables together, the "default" attributes you set may cause unpredictable and undesired behavior. Furthermore, -the defaults cannot be turned off, so you are stuck with them. +the defaults B, so you are stuck with them. In most cases, what you should actually be using are project-specific methods: @@ -1131,7 +1498,7 @@ sub resultset { $self->resultset_class->new( $self, { - try { %{$self->schema->default_resultset_attributes} }, + ( dbic_internal_try { %{$self->schema->default_resultset_attributes} } ), %{$self->{resultset_attributes}}, }, ); @@ -1223,10 +1590,11 @@ result source instance has been attached to. sub schema { if (@_ > 1) { - $_[0]->{schema} = $_[1]; + # invoke the mark-diverging logic + $_[0]->set_rsrc_instance_specific_attribute( schema => $_[1] ); } else { - $_[0]->{schema} || do { + $_[0]->get_rsrc_instance_specific_attribute( 'schema' ) || do { my $name = $_[0]->{source_name} || '_unnamed_'; my $err = 'Unable to perform storage-dependent operations with a detached result source ' . "(source '$name' is not associated with a schema)."; @@ -1256,7 +1624,10 @@ Returns the L for the current schema. =cut -sub storage { shift->schema->storage; } +sub storage :DBIC_method_is_indirect_sugar { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + $_[0]->schema->storage +} =head2 add_relationship @@ -1339,6 +1710,10 @@ be resolved. sub add_relationship { my ($self, $rel, $f_source_name, $cond, $attrs) = @_; + + local $self->{__in_rsrc_setter_callstack} = 1 + unless $self->{__in_rsrc_setter_callstack}; + $self->throw_exception("Can't create relationship without join condition") unless $cond; $attrs ||= {}; @@ -1360,29 +1735,6 @@ sub add_relationship { $self->_relationships(\%rels); return $self; - -# XXX disabled. doesn't work properly currently. skip in tests. - - my $f_source = $self->schema->source($f_source_name); - unless ($f_source) { - $self->ensure_class_loaded($f_source_name); - $f_source = $f_source_name->result_source; - #my $s_class = ref($self->schema); - #$f_source_name =~ m/^${s_class}::(.*)$/; - #$self->schema->register_class(($1 || $f_source_name), $f_source_name); - #$f_source = $self->schema->source($f_source_name); - } - return unless $f_source; # Can't test rel without f_source - - try { $self->_resolve_join($rel, 'me', {}, []) } - catch { - # If the resolve failed, back out and re-throw the error - delete $rels{$rel}; - $self->_relationships(\%rels); - $self->throw_exception("Error creating relationship $rel: $_"); - }; - - 1; } =head2 relationships @@ -1402,7 +1754,7 @@ Returns all relationship names for this source. =cut sub relationships { - return keys %{shift->_relationships}; + keys %{$_[0]->_relationships}; } =head2 relationship_info @@ -1495,7 +1847,7 @@ sub reverse_relationship_info { # to use the source_names, otherwise we will use the actual classes # the schema may be partial - my $roundtrip_rsrc = try { $other_rsrc->related_source($other_rel) } + my $roundtrip_rsrc = dbic_internal_try { $other_rsrc->related_source($other_rel) } or next; if ($registered_source_name) { @@ -1584,7 +1936,7 @@ sub _minimal_valueset_satisfying_constraint { $args->{columns_info} ||= $self->columns_info; - my $vals = $self->storage->_extract_fixed_condition_columns( + my $vals = extract_equality_conditions( $args->{values}, ($args->{carp_on_nulls} ? 'consider_nulls' : undef ), ); @@ -1598,7 +1950,7 @@ sub _minimal_valueset_satisfying_constraint { $cols->{$args->{carp_on_nulls} ? 'undefined' : 'missing'}{$col} = undef; } else { - # we need to inject back the '=' as _extract_fixed_condition_columns + # we need to inject back the '=' as extract_equality_conditions() # will strip it from literals and values alike, resulting in an invalid # condition in the end $cols->{present}{$col} = { '=' => $vals->{$col} }; @@ -1673,7 +2025,7 @@ sub _resolve_join { $force_left ||= lc($rel_info->{attrs}{join_type}||'') eq 'left'; # the actual seen value will be incremented by the recursion - my $as = $self->storage->relname_to_table_alias( + my $as = $self->schema->storage->relname_to_table_alias( $rel, ($seen->{$rel} && $seen->{$rel} + 1) ); @@ -1692,7 +2044,7 @@ sub _resolve_join { } else { my $count = ++$seen->{$join}; - my $as = $self->storage->relname_to_table_alias( + my $as = $self->schema->storage->relname_to_table_alias( $join, ($count > 1 && $count) ); @@ -1708,14 +2060,20 @@ sub _resolve_join { , -join_path => [@$jpath, { $join => $as } ], -is_single => ( - (! $rel_info->{attrs}{accessor}) + ! $rel_info->{attrs}{accessor} + or + $rel_info->{attrs}{accessor} eq 'single' or - first { $rel_info->{attrs}{accessor} eq $_ } (qw/single filter/) + $rel_info->{attrs}{accessor} eq 'filter' ), -alias => $as, -relation_chain_depth => ( $seen->{-relation_chain_depth} || 0 ) + 1, }, - scalar $self->_resolve_condition($rel_info->{cond}, $as, $alias, $join) + $self->_resolve_relationship_condition( + rel_name => $join, + self_alias => $alias, + foreign_alias => $as, + )->{condition}, ]; } } @@ -1749,14 +2107,17 @@ sub _pk_depends_on { # auto-increment my $rel_source = $self->related_source($rel_name); + my $colinfos; + foreach my $p ($self->primary_columns) { - if (exists $keyhash->{$p}) { - unless (defined($rel_data->{$keyhash->{$p}}) - || $rel_source->column_info($keyhash->{$p}) - ->{is_auto_increment}) { - return 0; - } - } + return 0 if ( + exists $keyhash->{$p} + and + ! defined( $rel_data->{$keyhash->{$p}} ) + and + ! ( $colinfos ||= $rel_source->columns_info ) + ->{$keyhash->{$p}}{is_auto_increment} + ) } return 1; @@ -1911,25 +2272,31 @@ sub _resolve_relationship_condition { $args->{require_join_free_condition} ||= !!$args->{infer_values_based_on}; - $self->throw_exception( "Argument 'self_result_object' must be an object inheriting from DBIx::Class::Row" ) + $self->throw_exception( "Argument 'self_result_object' must be an object inheriting from '$__expected_result_class_isa'" ) if ( exists $args->{self_result_object} and - ( ! defined blessed $args->{self_result_object} or ! $args->{self_result_object}->isa('DBIx::Class::Row') ) + ( + ! defined blessed $args->{self_result_object} + or + ! $args->{self_result_object}->isa( $__expected_result_class_isa ) + ) ) ; -#TEMP - my $rel_rsrc;# = $self->related_source($args->{rel_name}); + my $rel_rsrc = $self->related_source($args->{rel_name}); + my $storage = $self->schema->storage; if (exists $args->{foreign_values}) { -# TEMP - $rel_rsrc ||= $self->related_source($args->{rel_name}); - if (defined blessed $args->{foreign_values}) { + if (! defined $args->{foreign_values} ) { + # fallback: undef => {} + $args->{foreign_values} = {}; + } + elsif (defined blessed $args->{foreign_values}) { - $self->throw_exception( "Objects supplied as 'foreign_values' ($args->{foreign_values}) must inherit from DBIx::Class::Row" ) - unless $args->{foreign_values}->isa('DBIx::Class::Row'); + $self->throw_exception( "Objects supplied as 'foreign_values' ($args->{foreign_values}) must inherit from '$__expected_result_class_isa'" ) + unless $args->{foreign_values}->isa( $__expected_result_class_isa ); carp_unique( "Objects supplied as 'foreign_values' ($args->{foreign_values}) " @@ -1939,12 +2306,41 @@ sub _resolve_relationship_condition { $args->{foreign_values} = { $args->{foreign_values}->get_columns }; } - elsif (! defined $args->{foreign_values} or ref $args->{foreign_values} eq 'HASH') { - my $ri = { map { $_ => 1 } $rel_rsrc->relationships }; - my $ci = $rel_rsrc->columns_info; - ! exists $ci->{$_} and ! exists $ri->{$_} and $self->throw_exception( - "Key '$_' supplied as 'foreign_values' is not a column on related source '@{[ $rel_rsrc->source_name ]}'" - ) for keys %{ $args->{foreign_values} ||= {} }; + elsif ( ref $args->{foreign_values} eq 'HASH' ) { + + # re-build {foreign_values} excluding identically named rels + if( keys %{$args->{foreign_values}} ) { + + my ($col_idx, $rel_idx) = map + { { map { $_ => 1 } $rel_rsrc->$_ } } + qw( columns relationships ) + ; + + my $equivalencies = extract_equality_conditions( + $args->{foreign_values}, + 'consider nulls', + ); + + $args->{foreign_values} = { map { + # skip if relationship *and* a non-literal ref + # this means a multicreate stub was passed in + ( + $rel_idx->{$_} + and + length ref $args->{foreign_values}{$_} + and + ! is_literal_value($args->{foreign_values}{$_}) + ) + ? () + : ( $_ => ( + ! $col_idx->{$_} + ? $self->throw_exception( "Key '$_' supplied as 'foreign_values' is not a column on related source '@{[ $rel_rsrc->source_name ]}'" ) + : ( !exists $equivalencies->{$_} or ($equivalencies->{$_}||'') eq UNRESOLVABLE_CONDITION ) + ? $self->throw_exception( "Value supplied for '...{foreign_values}{$_}' is not a direct equivalence expression" ) + : $args->{foreign_values}{$_} + )) + } keys %{$args->{foreign_values}} }; + } } else { $self->throw_exception( @@ -1987,9 +2383,6 @@ sub _resolve_relationship_condition { "The join-free condition returned for $exception_rel_id must be a hash reference" ) unless ref $jfc eq 'HASH'; -# TEMP - $rel_rsrc ||= $self->related_source($args->{rel_name}); - my ($joinfree_alias, $joinfree_source); if (defined $args->{self_result_object}) { $joinfree_alias = $args->{foreign_alias}; @@ -2013,15 +2406,13 @@ sub _resolve_relationship_condition { exists $fq_col_list->{$_} or $self->throw_exception ( "The join-free condition returned for $exception_rel_id may only " . 'contain keys that are fully qualified column names of the corresponding source ' - . "(it returned '$_')" + . "'$joinfree_alias' (instead it returned '$_')" ) for keys %$jfc; ( - length ref $_ - and defined blessed($_) and - $_->isa('DBIx::Class::Row') + $_->isa( $__expected_result_class_isa ) and $self->throw_exception ( "The join-free condition returned for $exception_rel_id may not " @@ -2119,13 +2510,18 @@ sub _resolve_relationship_condition { $self->throw_exception ("Can't handle condition $rel_info->{cond} for $exception_rel_id yet :("); } - $self->throw_exception(ucfirst "$exception_rel_id does not resolve to a join-free condition fragment") if ( + if ( $args->{require_join_free_condition} and ( ! $ret->{join_free_condition} or $ret->{join_free_condition} eq UNRESOLVABLE_CONDITION ) - ); - - my $storage = $self->schema->storage; + ) { + $self->throw_exception( + ucfirst sprintf "$exception_rel_id does not resolve to a %sjoin-free condition fragment", + exists $args->{foreign_values} + ? "'foreign_values'-based reversed-" + : '' + ); + } # we got something back - sanity check and infer values if we can my @nonvalues; @@ -2134,10 +2530,10 @@ sub _resolve_relationship_condition { and $ret->{join_free_condition} ne UNRESOLVABLE_CONDITION and - my $jfc = $storage->_collapse_cond( $ret->{join_free_condition} ) + my $jfc = normalize_sqla_condition( $ret->{join_free_condition} ) ) { - my $jfc_eqs = $storage->_extract_fixed_condition_columns($jfc, 'consider_nulls'); + my $jfc_eqs = extract_equality_conditions( $jfc, 'consider_nulls' ); if (keys %$jfc_eqs) { @@ -2177,16 +2573,13 @@ sub _resolve_relationship_condition { # (may already be there, since easy to calculate on the fly in the HASH case) if ( ! $ret->{identity_map} ) { - my $col_eqs = $storage->_extract_fixed_condition_columns($ret->{condition}); + my $col_eqs = extract_equality_conditions($ret->{condition}); my $colinfos; for my $lhs (keys %$col_eqs) { next if $col_eqs->{$lhs} eq UNRESOLVABLE_CONDITION; -# TEMP - $rel_rsrc ||= $self->related_source($args->{rel_name}); - # there is no way to know who is right and who is left in a cref # therefore a full blown resolution call, and figure out the # direction a bit further below @@ -2257,13 +2650,13 @@ sub related_source { # if we are not registered with a schema - just use the prototype # however if we do have a schema - ask for the source by name (and # throw in the process if all fails) - if (my $schema = try { $self->schema }) { + if (my $schema = dbic_internal_try { $self->schema }) { $schema->source($self->relationship_info($rel)->{source}); } else { my $class = $self->relationship_info($rel)->{class}; $self->ensure_class_loaded($class); - $class->result_source_instance; + $class->result_source; } } @@ -2307,6 +2700,7 @@ relationship definitions. =cut sub handle { + require DBIx::Class::ResultSourceHandle; return DBIx::Class::ResultSourceHandle->new({ source_moniker => $_[0]->source_name, @@ -2347,17 +2741,23 @@ sub DESTROY { # which will serve as a signal to not try doing anything else # however beware - on older perls the exception seems randomly untrappable # due to some weird race condition during thread joining :((( - local $@; + local $SIG{__DIE__} if $SIG{__DIE__}; + local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT; eval { weaken $_[0]->{schema}; # if schema is still there reintroduce ourselves with strong refs back to us if ($_[0]->{schema}) { my $srcregs = $_[0]->{schema}->source_registrations; - for (keys %$srcregs) { - next unless $srcregs->{$_}; - $srcregs->{$_} = $_[0] if $srcregs->{$_} == $_[0]; - } + + defined $srcregs->{$_} + and + $srcregs->{$_} == $_[0] + and + $srcregs->{$_} = $_[0] + and + last + for keys %$srcregs; } 1; @@ -2365,7 +2765,10 @@ sub DESTROY { $global_phase_destroy = 1; }; - return; + # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage + # collected before leaving this scope. Depending on the code above, this + # may very well be just a preventive measure guarding future modifications + undef; } sub STORABLE_freeze { Storable::nfreeze($_[0]->handle) }