use strict;
use warnings;
-use base qw/DBIx::Class::ResultSource::RowParser DBIx::Class/;
+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 );
-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 Moo;
+use namespace::clean;
+my @hashref_attributes = qw(
+ source_info resultset_attributes
+ _columns _unique_constraints _relationships
+);
+my @arrayref_attributes = qw(
+ _ordered_columns _primaries
+);
+
+has [
+ @hashref_attributes,
+ @arrayref_attributes,
+ qw( source_name name column_info_from_storage sqlt_deploy_callback ),
+] => (
+ is => 'rw',
+);
+
+has '+name' => ( default => "!!NAME NOT SET!!" );
+has '+sqlt_deploy_callback' => ( default => 'default_sqlt_deploy_hook' );
+
+# We use the CAG accessors for this due to the "load-on-get" logic
+# not being cleanly triggerable from within Moo
__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
__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'"
);
=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;
+
+# FIXME
+#
+# <ribasushi> haarg: one more question - is there a straightforward way to inline BUILD/BUILDARGS ?
+# <ribasushi> ( I have both )
+# <haarg> not really. it's something we probably should do, but don't currently.
+
+# Because there are spots that call ->new($rsrc_object) in the wild
+sub BUILDARGS { +{ %{ $_[1] || {} } } }
+
+{
+ my $rsrc_registry;
+
+ sub __derived_instances {
+ map {
+ (defined $_->{weakref})
+ ? $_->{weakref}
+ : ()
+ } values %{ $rsrc_registry->{ refaddr($_[0]) }{ derivatives } }
+ }
+
+ sub BUILD {
+ my $self = shift;
+
+
+ DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
+ and
+ # a constructor with 'name' as sole arg clearly isn't "inheriting" from anything
+ ( not ( keys(%{$_[0]}) == 1 and exists $_[0]->{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 $ancestor = delete $_[0]->{__derived_from};
+
+ # Allow complete transparency to subclasses: ->new( \%random_stuff )
+ %$self = (
+ %{$_[0]},
+ %$self,
+ );
+
+
+ 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
+ ),
+ )
+ ;
+ }
+
+
+ # not a default because we use the CAG accessors, see top of file
+ $self->{resultset_class} ||= 'DBIx::Class::ResultSet';
+
+ $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</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, __derived_from => $self )
+ : ()
+ ),
+ (
+ (@_ == 1 and ref $_[0] eq 'HASH')
+ ? %{ $_[0] }
+ : @_
+ ),
+ });
}
=pod
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
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
=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
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}++;
}
}
else {
+ # the shallow copy is crucial - there are exists() checks within
+ # the wider codebase
%ret = %$colinfo;
}
$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
=cut
sub add_unique_constraints {
+ DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
+
my $self = shift;
my @constraints = @_;
=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) = @_;
...
} );
L<DBIx::Class::ResultSet> produced from this result source.
B<CAVEAT>: C<resultset_attributes> comes with its own set of issues and
-bugs! While C<resultset_attributes> isn't deprecated per se, its usage is
-not recommended!
+bugs! Notably the contents of the attributes are B<entirely static>, which
+greatly hinders composability (things like L<current_source_alias
+|DBIx::Class::ResultSet/current_source_alias> can not possibly be respected).
+While C<resultset_attributes> 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<cannot be turned off>, so you are stuck with them.
In most cases, what you should actually be using are project-specific methods:
=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
=cut
sub relationships {
- return keys %{shift->_relationships};
+ keys %{$_[0]->_relationships};
}
=head2 relationship_info
$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 ),
);
$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)
);
}
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)
);
# 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;
else {
my $class = $self->relationship_info($rel)->{class};
$self->ensure_class_loaded($class);
- $class->result_source_instance;
+ $class->result_source;
}
}
# 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};
projects / dbsrgits/DBIx-Class-Historic.git / blobdiff