Annotate every indirect sugar-method

Now that the churn is over we can add annotations to each method a user ought to never override. See next commit for the actual use case and diagnostics emitter. Unfortunately this adds yet another small compile-time hit, similar to 73f54e2 (a hit incurred regardless whether the upcoming validation framework is used or not). Complete test of DBIx::Class::Helpers v2.032002 goes from about ~64.6 seconds CPU time up to ~65.5, adding another ~1% of startup speed loss. The savings in debugging sessions should make this all worth it... or so one hopes.
Altreus · Jul 26, 2016 · 1b822bd · 1b822bd
1 parent 4c90556
commit 1b822bd
Show file tree

Hide file tree

Showing 14 changed files with 148 additions and 51 deletions.
diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm
@@ -9,12 +9,12 @@ use Scalar::Util 'blessed';
 use DBIx::Class::_Util 'fail_on_internal_call';
 use namespace::clean;
 
-sub mk_classdata {
+sub mk_classdata :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   shift->mk_classaccessor(@_);
 }
 
-sub mk_classaccessor {
+sub mk_classaccessor :DBIC_method_is_indirect_sugar {
   my $self = shift;
   $self->mk_group_accessors('inherited', $_[0]);
   (@_ > 1)

diff --git a/lib/DBIx/Class/MethodAttributes.pm b/lib/DBIx/Class/MethodAttributes.pm
@@ -143,8 +143,22 @@ sub MODIFY_CODE_ATTRIBUTES {
 sub VALID_DBIC_CODE_ATTRIBUTE {
   #my ($class, $attr) = @_;
 
-  # initially no valid attributes
-  0;
+###
+### !!! IMPORTANT !!!
+###
+### *DO NOT* yield to the temptation of using free-form-argument attributes.
+### The technique was proven instrumental in Catalyst a decade ago, and
+### was more recently revived in Sub::Attributes. Yet, while on the surface
+### they seem immensely useful, per-attribute argument lists are in fact an
+### architectural dead end.
+###
+### In other words: you are *very strongly urged* to ensure the regex below
+### does not allow anything beyond qr/^ DBIC_method_is_ [A-Z_a-z0-9]+ $/x
+###
+
+  $_[1] =~ /^ DBIC_method_is_ (?:
+    indirect_sugar
+  ) $/x;
 }
 
 sub FETCH_CODE_ATTRIBUTES {
@@ -200,11 +214,13 @@ L</VALID_DBIC_CODE_ATTRIBUTE> below.
 The following method attributes are currently recognized under the C<DBIC_*>
 prefix:
 
-=over
-
-=item * None so far
+=head3 DBIC_method_is_indirect_sugar
 
-=back
+The presence of this attribute indicates a helper "sugar" method. Overriding
+such methods in your subclasses will be of limited success at best, as DBIC
+itself and various plugins are much more likely to invoke alternative direct
+call paths, bypassing your override entirely. Good examples of this are
+L<DBIx::Class::ResultSet/create> and L<DBIx::Class::Schema/connect>.
 
 =head1 METHODS
 

diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm
@@ -104,20 +104,30 @@ EOC
   elsif ($acc_type eq 'multi') {
 
 
-    quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel );
+    my @qsub_args = (
+      {},
+      {
+        attributes => [qw(
+          DBIC_method_is_indirect_sugar
+        )]
+      },
+    );
+
+
+    quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel ), @qsub_args;
       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 );
+    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( @_ )
 EOC
 
 
-    quote_sub "${class}::add_to_${rel}", sprintf( <<'EOC', perlstring $rel );
+    quote_sub "${class}::add_to_${rel}", sprintf( <<'EOC', perlstring $rel ), @qsub_args;
       DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
       shift->create_related( %s => @_ );
 EOC

diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm
@@ -611,7 +611,7 @@ See L<DBIx::Class::ResultSet/search_related> for more information.
 
 =cut
 
-sub search_related {
+sub search_related :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   shift->related_resultset(shift)->search(@_);
 }
@@ -623,7 +623,7 @@ it guarantees a resultset, even in list context.
 
 =cut
 
-sub search_related_rs {
+sub search_related_rs :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   shift->related_resultset(shift)->search_rs(@_)
 }
@@ -643,7 +643,7 @@ current result or where conditions.
 
 =cut
 
-sub count_related {
+sub count_related :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   shift->related_resultset(shift)->search_rs(@_)->count;
 }
@@ -720,7 +720,7 @@ See L<DBIx::Class::ResultSet/find> for details.
 
 =cut
 
-sub find_related {
+sub find_related :DBIC_method_is_indirect_sugar {
   #my ($self, $rel, @args) = @_;
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   return shift->related_resultset(shift)->find(@_);
@@ -785,7 +785,7 @@ L<DBIx::Class::ResultSet/update_or_create> for details.
 
 =cut
 
-sub update_or_create_related {
+sub update_or_create_related :DBIC_method_is_indirect_sugar {
   #my ($self, $rel, @args) = @_;
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   shift->related_resultset(shift)->update_or_create(@_);

diff --git a/lib/DBIx/Class/Relationship/ManyToMany.pm b/lib/DBIx/Class/Relationship/ManyToMany.pm
@@ -56,7 +56,15 @@ EOW
       }
     }
 
-    quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth );
+    my @main_meth_qsub_args = (
+      {},
+      { attributes => [
+        'DBIC_method_is_indirect_sugar',
+      ] },
+    );
+
+
+    quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth ), @main_meth_qsub_args;
 
       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;
@@ -67,13 +75,18 @@ EOW
 EOC
 
 
-    my $qsub_attrs = {
-      '$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } },
-      '$carp_unique' => \$cu,
-    };
+    my @extra_meth_qsub_args = (
+      {
+        '$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } },
+        '$carp_unique' => \$cu,
+      },
+      { attributes => [
+        'DBIC_method_is_indirect_sugar',
+      ] },
+    );
 
 
-    quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', map { perlstring $_ } ( "${class}::${meth}", $rel, $f_rel ) ), $qsub_attrs;
+    quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', map { perlstring $_ } ( "${class}::${meth}", $rel, $f_rel ) ), @extra_meth_qsub_args;
 
       DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
         and
@@ -95,8 +108,11 @@ EOC
       ;
 EOC
 
+    # the above is the only indirect method, the 3 below have too much logic
+    shift @{$extra_meth_qsub_args[1]{attributes}};
 
-    quote_sub "${class}::${add_meth}", sprintf( <<'EOC', $add_meth, $rel, $f_rel ), $qsub_attrs;
+
+    quote_sub "${class}::${add_meth}", sprintf( <<'EOC', $add_meth, $rel, $f_rel ), @extra_meth_qsub_args;
 
       ( @_ >= 2 and @_ <= 3 ) or $_[0]->throw_exception(
         "'%1$s' expects an object or hashref to link to, and an optional hashref of link data"
@@ -140,7 +156,7 @@ EOC
 EOC
 
 
-    quote_sub "${class}::${set_meth}", sprintf( <<'EOC', $set_meth, $add_meth, $rel, $f_rel ), $qsub_attrs;
+    quote_sub "${class}::${set_meth}", sprintf( <<'EOC', $set_meth, $add_meth, $rel, $f_rel ), @extra_meth_qsub_args;
 
       my $self = shift;
 
@@ -190,8 +206,7 @@ EOC
       $guard->commit if $guard;
 EOC
 
-
-    quote_sub "${class}::${remove_meth}", sprintf( <<'EOC', $remove_meth, $rel, $f_rel );
+    quote_sub "${class}::${remove_meth}", sprintf( <<'EOC', $remove_meth, $rel, $f_rel ), @extra_meth_qsub_args;
 
       $_[0]->throw_exception("'%1$s' expects an object")
         unless defined Scalar::Util::blessed( $_[1] );

diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
@@ -986,7 +986,7 @@ See also L</search_related_rs>.
 
 =cut
 
-sub search_related {
+sub search_related :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   return shift->related_resultset(shift)->search(@_);
 }
@@ -998,7 +998,7 @@ it guarantees a resultset, even in list context.
 
 =cut
 
-sub search_related_rs {
+sub search_related_rs :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   return shift->related_resultset(shift)->search_rs(@_);
 }
@@ -1769,7 +1769,7 @@ with the passed arguments, then L</count>.
 
 =cut
 
-sub count_literal {
+sub count_literal :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   shift->search_literal(@_)->count
 }
@@ -1849,7 +1849,7 @@ an object for the first result (or C<undef> if the resultset is empty).
 
 =cut
 
-sub first {
+sub first :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   return $_[0]->reset->next;
 }
@@ -2867,7 +2867,7 @@ L</new>.
 
 =cut
 
-sub create {
+sub create :DBIC_method_is_indirect_sugar {
   #my ($self, $col_data) = @_;
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   return shift->new_result(shift)->insert;

diff --git a/lib/DBIx/Class/ResultSetColumn.pm b/lib/DBIx/Class/ResultSetColumn.pm
@@ -278,7 +278,7 @@ resultset (or C<undef> if there are none).
 
 =cut
 
-sub min {
+sub min :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   $_[0]->func('MIN');
 }
@@ -299,7 +299,7 @@ Wrapper for ->func_rs for function MIN().
 
 =cut
 
-sub min_rs {
+sub min_rs :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   $_[0]->func_rs('MIN')
 }
@@ -321,7 +321,7 @@ resultset (or C<undef> if there are none).
 
 =cut
 
-sub max {
+sub max :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   $_[0]->func('MAX');
 }
@@ -342,7 +342,7 @@ Wrapper for ->func_rs for function MAX().
 
 =cut
 
-sub max_rs {
+sub max_rs :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   $_[0]->func_rs('MAX')
 }
@@ -364,7 +364,7 @@ the resultset. Use on varchar-like columns at your own risk.
 
 =cut
 
-sub sum {
+sub sum :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   $_[0]->func('SUM');
 }
@@ -385,7 +385,7 @@ Wrapper for ->func_rs for function SUM().
 
 =cut
 
-sub sum_rs {
+sub sum_rs :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   $_[0]->func_rs('SUM')
 }

diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm
@@ -704,7 +704,7 @@ sub add_columns {
   return $self;
 }
 
-sub add_column {
+sub add_column :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   shift->add_columns(@_)
 }
@@ -748,7 +748,7 @@ contents of the hashref.
 
 =cut
 
-sub column_info {
+sub column_info :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
 
   #my ($self, $column) = @_;
@@ -912,7 +912,7 @@ sub remove_columns {
   $self->_ordered_columns([ grep { not $to_remove{$_} } @{$self->_ordered_columns} ]);
 }
 
-sub remove_column {
+sub remove_column :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   shift->remove_columns(@_)
 }
@@ -1143,7 +1143,7 @@ See also L</add_unique_constraint>.
 
 =cut
 
-sub add_unique_constraints {
+sub add_unique_constraints :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
 
   my $self = shift;
@@ -1606,7 +1606,7 @@ Returns the L<storage handle|DBIx::Class::Storage> for the current schema.
 
 =cut
 
-sub storage {
+sub storage :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   $_[0]->schema->storage
 }

diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm
@@ -6,6 +6,9 @@ use warnings;
 
 use base 'DBIx::Class';
 
+# needs to be loaded early to query method attributes below
+use DBIx::Class::ResultSource;
+
 use DBIx::Class::_Util qw( quote_sub fail_on_internal_call );
 use namespace::clean;
 
@@ -38,7 +41,7 @@ sub add_columns {
   }
 }
 
-sub add_column {
+sub add_column :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   shift->add_columns(@_)
 }
@@ -53,7 +56,7 @@ sub add_relationship {
 
 
 # legacy resultset_class accessor, seems to be used by cdbi only
-sub iterator_class {
+sub iterator_class :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   shift->result_source->resultset_class(@_)
 }
@@ -89,7 +92,13 @@ for my $method_to_proxy (qw/
   relationship_info
   has_relationship
 /) {
-  quote_sub __PACKAGE__."::$method_to_proxy", sprintf( <<'EOC', $method_to_proxy );
+
+  my $qsub_opts = { attributes => [ do {
+    no strict 'refs';
+    attributes::get( \&{"DBIx::Class::ResultSource::$method_to_proxy"} )
+  } ] };
+
+  quote_sub __PACKAGE__."::$method_to_proxy", sprintf( <<'EOC', $method_to_proxy ), {}, $qsub_opts;
     DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
 
     shift->result_source->%s (@_);