From: Peter Rabbitson <ribasushi@cpan.org>
Date: Sat, 4 Jun 2016 15:02:00 +0000 (+0200)
Subject: Expand annotations to cover all generated methods
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=09d8fb4a;p=dbsrgits%2FDBIx-Class.git

Expand annotations to cover all generated methods

This is needed for the next commit, as we need a reliable way to tell gened
methods apart from everything else. Given we will be taking the hit of adding
the attributes, just go ahead and annotate *everything*, to be done with all
auto-generated subs once and for all.

This also solves @vanstyn's long-time gripe of not being able to tell where
in a random schema one has declared m2m "relationships" (a typical customer is
*very* unlikely to be using DBIC::IntrospectableM2M)

As of this commit a typical Result can be introspected for m2m as follows:

~$ perl -Ilib -It/lib -MDBICTest -MPackage::Stash -e '

  my $meths = Package::Stash->new("DBICTest::Schema::Artwork")
                             ->get_all_symbols("CODE");

  for my $m (sort keys %$meths ) {
    print "$m\n" if grep {
      $_ =~ /^DBIC_method_is_m2m_sugar/
    } attributes::get($meths->{$m});
  }
'

While the more involved "complete method map" looks as follows:

~$ perl -Ilib -It/lib -MDBICTest -MPackage::Stash -e '

  my $meths = Package::Stash->new("DBICTest::Schema::CD")
                             ->get_all_symbols("CODE");

  for my $m (sort keys %$meths ) {
    if ( my @attrs = attributes::get($meths->{$m}) ) {
      print "\n$m\n";
      print "  $_\n" for @attrs;
    }
  }
'
---

diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm
index 5ccc109..d4493e2 100644
--- a/lib/DBIx/Class/AccessorGroup.pm
+++ b/lib/DBIx/Class/AccessorGroup.pm
@@ -23,6 +23,48 @@ sub mk_classaccessor :DBIC_method_is_indirect_sugar {
   ;
 }
 
+sub mk_group_accessors {
+  my $class = shift;
+  my $type = shift;
+
+  $class->next::method($type, @_);
+
+  # label things
+  if( $type =~ /^ ( inflated_ | filtered_ )? column $/x ) {
+
+    $class = ref $class
+      if length ref $class;
+
+    for my $acc_pair  (
+      map
+        { [ $_, "_${_}_accessor" ] }
+        map
+          { ref $_ ? $_->[0] : $_ }
+          @_
+    ) {
+
+      for my $i (0, 1) {
+
+        my $acc_name = $acc_pair->[$i];
+
+        attributes->import(
+          $class,
+          (
+            $class->can($acc_name)
+              ||
+            Carp::confess("Accessor '$acc_name' we just created on $class can't be found...?")
+          ),
+          'DBIC_method_is_generated_from_resultsource_metadata',
+          ($i
+            ? "DBIC_method_is_${type}_extra_accessor"
+            : "DBIC_method_is_${type}_accessor"
+          ),
+        )
+      }
+    }
+  }
+}
+
 sub get_component_class {
   my $class = $_[0]->get_inherited($_[1]);
 
diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm
index 90ce39b..ecbc5c2 100644
--- a/lib/DBIx/Class/CDBICompat/Relationships.pm
+++ b/lib/DBIx/Class/CDBICompat/Relationships.pm
@@ -128,7 +128,12 @@ sub has_many {
   );
 
   if (@f_method) {
-    quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel), { '$rf' => \sub { my $o = shift; $o = $o->$_ for @f_method; $o } };
+    my @qsub_args = (
+      { '$rf' => \sub { my $o = shift; $o = $o->$_ for @f_method; $o } },
+      { attributes => [ 'DBIC_method_is_generated_from_resultsource_metadata' ] },
+    );
+
+    quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel), @qsub_args;
       my $rs = shift->related_resultset(%s)->search_rs( @_);
       $rs->{attrs}{record_filter} = $rf;
       return (wantarray ? $rs->all : $rs);
diff --git a/lib/DBIx/Class/MethodAttributes.pm b/lib/DBIx/Class/MethodAttributes.pm
index 0365dad..6c23988 100644
--- a/lib/DBIx/Class/MethodAttributes.pm
+++ b/lib/DBIx/Class/MethodAttributes.pm
@@ -158,6 +158,18 @@ sub VALID_DBIC_CODE_ATTRIBUTE {
 
   $_[1] =~ /^ DBIC_method_is_ (?:
     indirect_sugar
+      |
+    generated_from_resultsource_metadata
+      |
+    (?: inflated_ | filtered_ )? column_ (?: extra_)? accessor
+      |
+    single_relationship_accessor
+      |
+    (?: multi | filter ) _relationship_ (?: extra_ )? accessor
+      |
+    proxy_to_relationship
+      |
+    m2m_ (?: extra_)? sugar (?:_with_attrs)?
   ) $/x;
 }
 
@@ -225,6 +237,98 @@ L<DBIx::Class::ResultSet/create> and L<DBIx::Class::Schema/connect>.
 See also the check
 L<DBIx::Class::Schema::SanityChecker/no_indirect_method_overrides>.
 
+=head3 DBIC_method_is_generated_from_resultsource_metadata
+
+This attribute is applied to all methods dynamically installed after various
+invocations of L<ResultSource metadata manipulation
+methods|DBIx::Class::Manual::ResultClass/DBIx::Class::ResultSource>. Notably
+this includes L<add_columns|DBIx::Class::ResultSource/add_columns>,
+L<add_relationship|DBIx::Class::ResultSource/add_relationship>,
+L<the proxied relationship attribute|DBIx::Class::Relationship::Base/proxy>
+and the various L<relationship
+helpers|DBIx::Class::Manual::ResultClass/DBIx::Class::Relationship>,
+B<except> the L<M2M helper|DBIx::Class::Relationship/many_to_many> (given its
+effects are never reflected as C<ResultSource metadata>).
+
+=head3 DBIC_method_is_column_accessor
+
+This attribute is applied to all methods dynamically installed as a result of
+invoking L<add_columns|DBIx::Class::ResultSource/add_columns>.
+
+=head3 DBIC_method_is_inflated_column_accessor
+
+This attribute is applied to all methods dynamically installed as a result of
+invoking L<inflate_column|DBIx::Class::InflateColumn/inflate_column>.
+
+=head3 DBIC_method_is_filtered_column_accessor
+
+This attribute is applied to all methods dynamically installed as a result of
+invoking L<filter_column|DBIx::Class::FilterColumn/filter_column>.
+
+=head3 DBIC_method_is_*column_extra_accessor
+
+For historical reasons any L<Class::Accessor::Grouped> accessor is generated
+twice as C<{name}> and C<_{name}_accessor>. The second method is marked with
+C<DBIC_method_is_*column_extra_accessor> correspondingly.
+
+=head3 DBIC_method_is_single_relationship_accessor
+
+This attribute is applied to all methods dynamically installed as a result of
+invoking L<might_have|DBIx::Class::Relationship/might_have>,
+L<has_one|DBIx::Class::Relationship/has_one> or
+L<belongs_to|DBIx::Class::Relationship/belongs_to> (though for C<belongs_to>
+see L<...filter_rel...|/DBIC_method_is_filter_relationship_accessor> below.
+
+=head3 DBIC_method_is_multi_relationship_accessor
+
+This attribute is applied to the main method dynamically installed as a result
+of invoking L<has_many|DBIx::Class::Relationship/has_many>.
+
+=head3 DBIC_method_is_multi_relationship_extra_accessor
+
+This attribute is applied to the two extra methods dynamically installed as a
+result of invoking L<has_many|DBIx::Class::Relationship/has_many>:
+C<$relname_rs> and C<add_to_$relname>.
+
+=head3 DBIC_method_is_filter_relationship_accessor
+
+This attribute is applied to (legacy) methods dynamically installed as a
+result of invoking L<belongs_to|DBIx::Class::Relationship/belongs_to> with an
+already-existing identically named column. The method is internally
+implemented as an L<inflated_column|/DBIC_method_is_inflated_column_accessor>
+and is labeled with both atributes at the same time.
+
+=head3 DBIC_method_is_filter_relationship_extra_accessor
+
+Same as L</DBIC_method_is_*column_extra_accessor>.
+
+=head3 DBIC_method_is_proxy_to_relationship
+
+This attribute is applied to methods dynamically installed as a result of
+providing L<the proxied relationship
+attribute|DBIx::Class::Relationship::Base/proxy>.
+
+=head3 DBIC_method_is_m2m_sugar
+
+=head3 DBIC_method_is_m2m_sugar_with_attrs
+
+One of the above attributes is applied to the main method dynamically
+installed as a result of invoking
+L<many_to_many|DBIx::Class::Relationship/many_to_many>. The C<_with_atrs> suffix
+serves to indicate whether the user supplied any C<\%attrs> to the
+C<many_to_many> call. There is deliberately no mechanism to retrieve the actual
+supplied values: if you really need this functionality you would need to rely on
+L<DBIx::Class::IntrospectableM2M>.
+
+=head3 DBIC_method_is_extra_m2m_sugar
+
+=head3 DBIC_method_is_extra_m2m_sugar_with_attrs
+
+One of the above attributes is applied to the extra B<four> methods dynamically
+installed as a result of invoking
+L<many_to_many|DBIx::Class::Relationship/many_to_many>: C<$m2m_rs>, C<add_to_$m2m>,
+C<remove_from_$m2m> and C<set_$m2m>.
+
 =head1 METHODS
 
 =head2 MODIFY_CODE_ATTRIBUTES
diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm
index a408b69..8fdeab2 100644
--- a/lib/DBIx/Class/Relationship/Accessor.pm
+++ b/lib/DBIx/Class/Relationship/Accessor.pm
@@ -25,8 +25,15 @@ sub add_relationship_accessor {
 
   if ($acc_type eq 'single') {
 
-    quote_sub "${class}::${rel}" => sprintf(<<'EOC', perlstring $rel);
+    my @qsub_args = ( {}, {
+      attributes => [qw(
+        DBIC_method_is_single_relationship_accessor
+        DBIC_method_is_generated_from_resultsource_metadata
+      )]
+    });
+
 
+    quote_sub "${class}::${rel}" => sprintf(<<'EOC', perlstring $rel), @qsub_args;
       my $self = shift;
 
       if (@_) {
@@ -100,6 +107,38 @@ EOC
         return $pk_val;
       },
     });
+
+
+    # god this is horrible...
+    my $acc =
+      $rsrc->columns_info->{$rel}{accessor}
+        ||
+      $rel
+    ;
+
+    # because CDBI may elect to never make an accessor at all...
+    if( my $main_cref = $class->can($acc) ) {
+
+      attributes->import(
+        $class,
+        $main_cref,
+        qw(
+          DBIC_method_is_filter_relationship_accessor
+          DBIC_method_is_generated_from_resultsource_metadata
+        ),
+      );
+
+      if( my $extra_cref = $class->can("_${acc}_accessor") ) {
+        attributes->import(
+          $class,
+          $extra_cref,
+          qw(
+            DBIC_method_is_filter_relationship_extra_accessor
+            DBIC_method_is_generated_from_resultsource_metadata
+          ),
+        );
+      }
+    }
   }
   elsif ($acc_type eq 'multi') {
 
@@ -108,6 +147,8 @@ EOC
       {},
       {
         attributes => [qw(
+          DBIC_method_is_multi_relationship_accessor
+          DBIC_method_is_generated_from_resultsource_metadata
           DBIC_method_is_indirect_sugar
         )]
       },
@@ -121,6 +162,11 @@ EOC
 EOC
 
 
+    $qsub_args[1]{attributes}[0]
+      =~ s/^DBIC_method_is_multi_relationship_accessor$/DBIC_method_is_multi_relationship_extra_accessor/
+    or die "Unexpected attr '$qsub_args[1]{attributes}[0]' ...";
+
+
     quote_sub "${class}::${rel}_rs", sprintf( <<'EOC', perlstring $rel ), @qsub_args;
       DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
       shift->related_resultset(%s)->search_rs( @_ )
diff --git a/lib/DBIx/Class/Relationship/ManyToMany.pm b/lib/DBIx/Class/Relationship/ManyToMany.pm
index fdd4697..e715f10 100644
--- a/lib/DBIx/Class/Relationship/ManyToMany.pm
+++ b/lib/DBIx/Class/Relationship/ManyToMany.pm
@@ -60,6 +60,10 @@ EOW
       {},
       { attributes => [
         'DBIC_method_is_indirect_sugar',
+        ( keys( %{$rel_attrs||{}} )
+          ? 'DBIC_method_is_m2m_sugar_with_attrs'
+          : 'DBIC_method_is_m2m_sugar'
+        ),
       ] },
     );
 
@@ -82,6 +86,10 @@ EOC
       },
       { attributes => [
         'DBIC_method_is_indirect_sugar',
+        ( keys( %{$rel_attrs||{}} )
+          ? 'DBIC_method_is_m2m_extra_sugar_with_attrs'
+          : 'DBIC_method_is_m2m_extra_sugar'
+        ),
       ] },
     );
 
@@ -206,6 +214,11 @@ EOC
       $guard->commit if $guard;
 EOC
 
+
+    # the last method needs no captures - just kill it all with fire
+    $extra_meth_qsub_args[0] = {};
+
+
     quote_sub "${class}::${remove_meth}", sprintf( <<'EOC', $remove_meth, $rel, $f_rel ), @extra_meth_qsub_args;
 
       $_[0]->throw_exception("'%1$s' expects an object")
diff --git a/lib/DBIx/Class/Relationship/ProxyMethods.pm b/lib/DBIx/Class/Relationship/ProxyMethods.pm
index cb61514..ee49fe8 100644
--- a/lib/DBIx/Class/Relationship/ProxyMethods.pm
+++ b/lib/DBIx/Class/Relationship/ProxyMethods.pm
@@ -24,7 +24,14 @@ sub proxy_to_related {
   my ($class, $rel, $proxy_args) = @_;
   my %proxy_map = $class->_build_proxy_map_from($proxy_args);
 
-  quote_sub "${class}::$_", sprintf( <<'EOC', $rel, $proxy_map{$_} )
+  my @qsub_args = ( {}, {
+    attributes => [qw(
+      DBIC_method_is_proxy_to_relationship
+      DBIC_method_is_generated_from_resultsource_metadata
+    )],
+  } );
+
+  quote_sub "${class}::$_", sprintf( <<'EOC', $rel, $proxy_map{$_} ), @qsub_args
     my $self = shift;
     my $relobj = $self->%1$s;
     if (@_ && !defined $relobj) {