use base qw( DBIx::Class::MethodAttributes Class::Accessor::Grouped );
use mro 'c3';
-use Scalar::Util qw/weaken blessed/;
+use Scalar::Util 'blessed';
use DBIx::Class::_Util 'fail_on_internal_call';
use namespace::clean;
;
}
-my $successfully_loaded_components;
-
sub get_component_class {
my $class = $_[0]->get_inherited($_[1]);
- # It's already an object, just go for it.
- return $class if blessed $class;
-
- if (defined $class and ! $successfully_loaded_components->{$class} ) {
+ no strict 'refs';
+ if (
+ defined $class
+ and
+ # inherited CAG can't be set to undef effectively, so people may use ''
+ length $class
+ and
+ # It's already an object, just go for it.
+ ! defined blessed $class
+ and
+ ! ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"}
+ ) {
$_[0]->ensure_class_loaded($class);
mro::set_mro( $class, 'c3' );
- no strict 'refs';
- $successfully_loaded_components->{$class}
- = ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"}
- = do { \(my $anon = 'loaded') };
- weaken($successfully_loaded_components->{$class});
+ ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"}
+ = do { \(my $anon = 'loaded') };
}
$class;
my ($class, $rel, $acc_type) = @_;
if ($acc_type eq 'single') {
+
quote_sub "${class}::${rel}" => sprintf(<<'EOC', perlstring $rel);
+
my $self = shift;
if (@_) {
EOC
}
elsif ($acc_type eq 'filter') {
- $class->throw_exception("No such column '$rel' to filter")
- unless $class->result_source_instance->has_column($rel);
- my $f_class = $class->result_source_instance
- ->relationship_info($rel)
- ->{class};
+ my $rsrc = $class->result_source_instance;
+
+ $rsrc->throw_exception("No such column '$rel' to filter")
+ unless $rsrc->has_column($rel);
+
+ my $f_class = $rsrc->relationship_info($rel)->{class};
$class->inflate_column($rel, {
inflate => sub {
}
elsif ($acc_type eq 'multi') {
+
+ quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel );
+ DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
+ DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray;
+ shift->related_resultset(%s)->search( @_ )
+EOC
+
+
quote_sub "${class}::${rel}_rs", sprintf( <<'EOC', perlstring $rel );
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
shift->related_resultset(%s)->search_rs( @_ )
EOC
+
quote_sub "${class}::add_to_${rel}", sprintf( <<'EOC', perlstring $rel );
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
shift->create_related( %s => @_ );
EOC
- quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel );
- DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
- DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray;
- shift->related_resultset(%s)->search( @_ )
-EOC
}
else {
$class->throw_exception("No such relationship accessor type '$acc_type'");
}
}
+ quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth );
+
+ DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
+ DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray;
+
+ my $rs = shift->%s( @_ );
+
+ wantarray ? $rs->all : $rs;
+EOC
+
+
my $qsub_attrs = {
'$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } },
'$carp_unique' => \$cu,
};
+
quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', map { perlstring $_ } ( "${class}::${meth}", $rel, $f_rel ) ), $qsub_attrs;
DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
EOC
- quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth );
-
- DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
- DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray;
-
- my $rs = shift->%s( @_ );
-
- wantarray ? $rs->all : $rs;
-EOC
-
-
quote_sub "${class}::${add_meth}", sprintf( <<'EOC', $add_meth, $rel, $f_rel ), $qsub_attrs;
( @_ >= 2 and @_ <= 3 ) or $_[0]->throw_exception(
my $guard;
- # the API needs is always expected to return the far object, possibly
+ # the API is always expected to return the far object, possibly
# creating it in the process
if( not defined Scalar::Util::blessed( $far_obj ) ) {
use base 'DBIx::Class';
use mro 'c3';
-use Scalar::Util 'blessed';
use DBIx::Class::_Util qw( quote_sub fail_on_internal_call );
use namespace::clean;
__PACKAGE__->mk_group_accessors('inherited_ro_instance' => 'source_name');
-sub get_inherited_ro_instance { shift->get_inherited(@_) }
+sub get_inherited_ro_instance { $_[0]->get_inherited($_[1]) }
sub set_inherited_ro_instance {
- my $self = shift;
+ $_[0]->throw_exception ("Cannot set '$_[1]' on an instance")
+ if length ref $_[0];
- $self->throw_exception ("Cannot set @{[shift]} on an instance")
- if blessed $self;
-
- $self->set_inherited(@_);
+ $_[0]->set_inherited( $_[1], $_[2] );
}
use Scalar::Util 'blessed';
use namespace::clean;
+# FIXME - both of these *PROBABLY* need to be 'inherited_ro_instance' type
__PACKAGE__->mk_classaccessor(table_class => 'DBIx::Class::ResultSource::Table');
-
# FIXME: Doesn't actually do anything yet!
__PACKAGE__->mk_group_accessors( inherited => 'table_alias' );
$class->mk_group_accessors( inherited => 'result_source_instance' )
unless $class->can('result_source_instance');
- my $table = $class->result_source_instance;
- return $table
- if $table and $table->result_class eq $class;
+ # might be pre-made for us courtesy of DBIC::DB::result_source_instance()
+ my $rsrc = $class->result_source_instance;
+
+ return $rsrc
+ if $rsrc and $rsrc->result_class eq $class;
my $table_class = $class->table_class;
$class->ensure_class_loaded($table_class);
- if( $table ) {
- $table = $table_class->new({
- %$table,
+ if( $rsrc ) {
+ $rsrc = $table_class->new({
+ %$rsrc,
result_class => $class,
source_name => undef,
schema => undef
});
}
else {
- $table = $table_class->new({
+ $rsrc = $table_class->new({
name => undef,
result_class => $class,
source_name => undef,
});
}
- $class->result_source_instance($table);
-
- return $table;
+ $class->result_source_instance($rsrc);
}
=head1 NAME
=cut
sub table {
+ return $_[0]->result_source_instance->name unless @_ > 1;
+
my ($class, $table) = @_;
- return $class->result_source_instance->name unless $table;
unless (blessed $table && $table->isa($class->table_class)) {
$class->mk_group_accessors(inherited => 'result_source_instance')
unless $class->can('result_source_instance');
- $class->result_source_instance($table);
-
- return $class->result_source_instance->name;
+ $class->result_source_instance($table)->name;
}
=head2 table_class
=cut
sub source {
- my $self = shift;
+ my ($self, $source_name) = @_;
$self->throw_exception("source() expects a source name")
- unless @_;
-
- my $source_name = shift;
+ unless $source_name;
- my $sreg = $self->source_registrations;
- return $sreg->{$source_name} if exists $sreg->{$source_name};
+ my $source_registrations;
- # if we got here, they probably passed a full class name
- my $mapped = $self->class_mappings->{$source_name};
- $self->throw_exception("Can't find source for ${source_name}")
- unless $mapped && exists $sreg->{$mapped};
- return $sreg->{$mapped};
+ my $rsrc =
+ ( $source_registrations = $self->source_registrations )->{$source_name}
+ ||
+ # if we got here, they probably passed a full class name
+ $source_registrations->{ $self->class_mappings->{$source_name} || '' }
+ ||
+ $self->throw_exception( "Can't find source for ${source_name}" )
+ ;
}
=head2 class
sub register_extra_source { shift->_register_source(@_, { extra => 1 }) }
sub _register_source {
- my ($self, $source_name, $source, $params) = @_;
+ my ($self, $source_name, $supplied_rsrc, $params) = @_;
+
+ my $derived_rsrc = $supplied_rsrc->new({
+ %$supplied_rsrc,
+ source_name => $source_name,
+ });
- $source = $source->new({ %$source, source_name => $source_name });
+ # Do not move into the clone-hashref above: there are things
+ # on CPAN that do hook 'sub schema' </facepalm>
+ # https://metacpan.org/source/LSAUNDERS/DBIx-Class-Preview-1.000003/lib/DBIx/Class/ResultSource/Table/Previewed.pm#L9-38
+ $derived_rsrc->schema($self);
- $source->schema($self);
- weaken $source->{schema} if ref($self);
+ weaken $derived_rsrc->{schema}
+ if length ref($self);
my %reg = %{$self->source_registrations};
- $reg{$source_name} = $source;
+ $reg{$source_name} = $derived_rsrc;
$self->source_registrations(\%reg);
- return $source if $params->{extra};
+ return $derived_rsrc if $params->{extra};
- my $rs_class = $source->result_class;
- if ($rs_class and my $rsrc = dbic_internal_try { $rs_class->result_source_instance } ) {
+ my( $result_class, $result_class_level_rsrc );
+ if (
+ $result_class = $derived_rsrc->result_class
+ and
+ # There are known cases where $rs_class is *ONLY* an inflator, without
+ # any hint of a rsrc (e.g. DBIx::Class::KiokuDB::EntryProxy)
+ $result_class_level_rsrc = dbic_internal_try { $result_class->result_source_instance }
+ ) {
my %map = %{$self->class_mappings};
- if (
- exists $map{$rs_class}
+
+ carp (
+ "$result_class already had a registered source which was replaced by "
+ . 'this call. Perhaps you wanted register_extra_source(), though it is '
+ . 'more likely you did something wrong.'
+ ) if (
+ exists $map{$result_class}
and
- $map{$rs_class} ne $source_name
+ $map{$result_class} ne $source_name
and
- $rsrc ne $_[2] # orig_source
- ) {
- carp
- "$rs_class already had a registered source which was replaced by this call. "
- . 'Perhaps you wanted register_extra_source(), though it is more likely you did '
- . 'something wrong.'
- ;
- }
+ $result_class_level_rsrc != $supplied_rsrc
+ );
- $map{$rs_class} = $source_name;
+ $map{$result_class} = $source_name;
$self->class_mappings(\%map);
}
- return $source;
+ $derived_rsrc;
}
my $global_phase_destroy;
projects / dbsrgits/DBIx-Class.git / commitdiff