From: Peter Rabbitson Date: Mon, 25 Apr 2016 09:53:54 +0000 (+0200) Subject: Rename variables/shuffle some code, preparing for next commits X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d46eac43287ebe244e4f622fb77fa2efa16402a9;p=dbsrgits%2FDBIx-Class-Historic.git Rename variables/shuffle some code, preparing for next commits Zero functional changes Read under -w --- diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index 0ae4b5b..c76a456 100644 --- a/lib/DBIx/Class/AccessorGroup.pm +++ b/lib/DBIx/Class/AccessorGroup.pm @@ -6,7 +6,7 @@ use warnings; 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; @@ -24,24 +24,27 @@ sub mk_classaccessor { ; } -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; diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index 025ab24..d281e00 100644 --- a/lib/DBIx/Class/Relationship/Accessor.pm +++ b/lib/DBIx/Class/Relationship/Accessor.pm @@ -24,7 +24,9 @@ sub add_relationship_accessor { my ($class, $rel, $acc_type) = @_; if ($acc_type eq 'single') { + quote_sub "${class}::${rel}" => sprintf(<<'EOC', perlstring $rel); + my $self = shift; if (@_) { @@ -62,12 +64,13 @@ sub add_relationship_accessor { 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 { @@ -100,21 +103,25 @@ EOC } 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'"); diff --git a/lib/DBIx/Class/Relationship/ManyToMany.pm b/lib/DBIx/Class/Relationship/ManyToMany.pm index c7cde16..0c31ebb 100644 --- a/lib/DBIx/Class/Relationship/ManyToMany.pm +++ b/lib/DBIx/Class/Relationship/ManyToMany.pm @@ -56,11 +56,23 @@ EOW } } + 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 @@ -84,17 +96,6 @@ EOW 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( @@ -109,7 +110,7 @@ EOC 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 ) ) { diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm index 94009a5..0f5e9d9 100644 --- a/lib/DBIx/Class/ResultSourceProxy.pm +++ b/lib/DBIx/Class/ResultSourceProxy.pm @@ -7,21 +7,18 @@ use warnings; 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] ); } diff --git a/lib/DBIx/Class/ResultSourceProxy/Table.pm b/lib/DBIx/Class/ResultSourceProxy/Table.pm index d6bac68..c165f77 100644 --- a/lib/DBIx/Class/ResultSourceProxy/Table.pm +++ b/lib/DBIx/Class/ResultSourceProxy/Table.pm @@ -9,8 +9,8 @@ use DBIx::Class::ResultSource::Table; 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' ); @@ -20,32 +20,32 @@ sub _init_result_source_instance { $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 @@ -78,8 +78,9 @@ Gets or sets the table 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)) { @@ -99,9 +100,7 @@ sub table { $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 diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 702d472..5b9d07c 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -616,21 +616,21 @@ source name. =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 @@ -1410,41 +1410,54 @@ has a source and you want to register an extra one. 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' + # 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;