X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FResultSource.pm;h=a8da52e93532309396fd1053065b4385bcef6589;hb=b83736a7d3235d2f50fe5695550eb3637432d960;hp=6fd80d7fbbc2c6374fddf31a64da67ae88a9ff99;hpb=d098704fa2e7e92b3a6cdf0a251f3e725623f9a4;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 6fd80d7..a8da52e 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -3,33 +3,37 @@ package DBIx::Class::ResultSource; 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 qw( UNRESOLVABLE_CONDITION dbic_internal_try ); +use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try fail_on_internal_call ); use SQL::Abstract 'is_literal_value'; use Devel::GlobalDestruction; -use Scalar::Util qw/blessed weaken isweak/; +use Scalar::Util qw( blessed weaken isweak refaddr ); + +# FIXME - somehow breaks ResultSetManager, do not remove until investigated +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 -/); +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 result_class /); -__PACKAGE__->mk_classdata( sqlt_deploy_callback => 'default_sqlt_deploy_hook' ); - =head1 NAME DBIx::Class::ResultSource - Result source object @@ -117,19 +121,128 @@ 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; + + $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 + } + } +} + +=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, __derived_from => $self ) + : () + ), + ( + (@_ == 1 and ref $_[0] eq 'HASH') + ? %{ $_[0] } + : @_ + ), + }); } =pod @@ -332,13 +445,19 @@ sub add_columns { my ($self, @cols) = @_; $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 @@ -349,11 +468,15 @@ sub add_columns { push(@added, $col) unless exists $columns->{$col}; $columns->{$col} = $column_info; } + push @{ $self->_ordered_columns }, @added; return $self; } -sub add_column { shift->add_columns(@_); } # DO NOT CHANGE THIS TO GLOB +sub add_column { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->add_columns(@_) +} =head2 has_column @@ -395,35 +518,10 @@ 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 = dbic_internal_try { $self->storage } ) - { - $self->{_columns_info_loaded}++; - - # try for the case of storage without table - dbic_internal_try { - my $info = $stor->columns_info_for( $self->from ); - my $lc_info = { map - { (lc $_) => $info->{$_} } - ( keys %$info ) - }; + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; - foreach my $col ( keys %{$self->_columns} ) { - $self->_columns->{$col} = { - %{ $self->_columns->{$col} }, - %{ $info->{$col} || $lc_info->{lc $col} || {} } - }; - } - }; - } - - return $self->_columns->{$column}; + #my ($self, $column) = @_; + $_[0]->columns_info([ $_[1] ])->{$_[1]}; } =head2 columns @@ -480,7 +578,7 @@ sub columns_info { and grep { ! $_->{data_type} } values %$colinfo and - my $stor = dbic_internal_try { $self->storage } + my $stor = dbic_internal_try { $self->schema->storage } ) { $self->{_columns_info_loaded}++; @@ -518,6 +616,8 @@ sub columns_info { } } else { + # the shallow copy is crucial - there are exists() checks within + # the wider codebase %ret = %$colinfo; } @@ -578,7 +678,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 { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + shift->remove_columns(@_) +} =head2 set_primary_key @@ -798,6 +901,8 @@ See also L. =cut sub add_unique_constraints { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + my $self = shift; my @constraints = @_; @@ -938,11 +1043,11 @@ sub unique_constraint_columns { =back - __PACKAGE__->sqlt_deploy_callback('mycallbackmethod'); + __PACKAGE__->result_source_instance->sqlt_deploy_callback('mycallbackmethod'); or - __PACKAGE__->sqlt_deploy_callback(sub { + __PACKAGE__->result_source_instance->sqlt_deploy_callback(sub { my ($source_instance, $sqlt_table) = @_; ... } ); @@ -1090,12 +1195,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: @@ -1254,7 +1362,10 @@ Returns the L for the current schema. =cut -sub storage { shift->schema->storage; } +sub storage { + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; + $_[0]->schema->storage +} =head2 add_relationship @@ -1377,7 +1488,7 @@ Returns all relationship names for this source. =cut sub relationships { - return keys %{shift->_relationships}; + keys %{$_[0]->_relationships}; } =head2 relationship_info @@ -1559,7 +1670,7 @@ sub _minimal_valueset_satisfying_constraint { $args->{columns_info} ||= $self->columns_info; - my $vals = $self->storage->_extract_fixed_condition_columns( + my $vals = $self->schema->storage->_extract_fixed_condition_columns( $args->{values}, ($args->{carp_on_nulls} ? 'consider_nulls' : undef ), ); @@ -1648,7 +1759,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) ); @@ -1667,7 +1778,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) ); @@ -1730,14 +1841,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; @@ -2318,6 +2432,7 @@ relationship definitions. =cut sub handle { + require DBIx::Class::ResultSourceHandle; return DBIx::Class::ResultSourceHandle->new({ source_moniker => $_[0]->source_name, @@ -2359,7 +2474,7 @@ sub DESTROY { # however beware - on older perls the exception seems randomly untrappable # due to some weird race condition during thread joining :((( local $SIG{__DIE__} if $SIG{__DIE__}; - local $@; + local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT; eval { weaken $_[0]->{schema};