From: Peter Rabbitson Date: Fri, 27 May 2016 14:14:28 +0000 (+0200) Subject: Annotate every indirect sugar-method X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1b822bd3e15476666e97d9a95754f123410b3c56;p=dbsrgits%2FDBIx-Class.git 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 73f54e27 (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. --- diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm index 77cf852..5ccc109 100644 --- 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 index 7ffe560..0dec0b3 100644 --- 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 below. The following method attributes are currently recognized under the C 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 and L. =head1 METHODS diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm index d281e00..a408b69 100644 --- 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 index 994e7d7..007676e 100644 --- a/lib/DBIx/Class/Relationship/Base.pm +++ b/lib/DBIx/Class/Relationship/Base.pm @@ -611,7 +611,7 @@ See L 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 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 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 index 0c31ebb..fdd4697 100644 --- 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 index 2c5131d..3d06065 100644 --- a/lib/DBIx/Class/ResultSet.pm +++ b/lib/DBIx/Class/ResultSet.pm @@ -986,7 +986,7 @@ See also L. =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. =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 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. =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 index 71cd52c..a514139 100644 --- a/lib/DBIx/Class/ResultSetColumn.pm +++ b/lib/DBIx/Class/ResultSetColumn.pm @@ -278,7 +278,7 @@ resultset (or C 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 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 index f8a1661..85d0bfc 100644 --- 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. =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 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 index cfd37ca..cd18d2e 100644 --- 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 (@_); diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 1097701..7ccebb4 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -1359,7 +1359,7 @@ Alias for L =cut -sub insert_or_update { +sub insert_or_update :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->update_or_insert(@_); } @@ -1429,7 +1429,7 @@ Accessor to the L this object was created from. =cut -sub result_source { +sub result_source :DBIC_method_is_indirect_sugar { # While getter calls are routed through here for sensible exception text # it makes no sense to have setters do the same thing DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 45dcd7e..618b585 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -552,7 +552,7 @@ version, overload L instead. =cut -sub connect { +sub connect :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->clone->connection(@_); } @@ -835,7 +835,7 @@ those values. =cut -sub populate { +sub populate :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; my ($self, $name, $data) = @_; diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm index d949b01..c8f0180 100644 --- a/lib/DBIx/Class/Storage.pm +++ b/lib/DBIx/Class/Storage.pm @@ -25,7 +25,7 @@ __PACKAGE__->mk_group_accessors(component_class => 'cursor_class'); __PACKAGE__->cursor_class('DBIx::Class::Cursor'); -sub cursor { +sub cursor :DBIC_method_is_indirect_sugar { DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call; shift->cursor_class(@_); } diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 7f3549d..e94d98d 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -1065,6 +1065,42 @@ sub fail_on_internal_call { : $fr ; + + die "\nMethod $fr->[3] is not marked with the 'DBIC_method_is_indirect_sugar' attribute\n\n" unless ( + + # unlikely but who knows... + ! @$fr + + or + + # This is a weird-ass double-purpose method, only one branch of which is marked + # as an illegal indirect call + # Hence the 'indirect' attribute makes no sense + # FIXME - likely need to mark this in some other manner + $fr->[3] eq 'DBIx::Class::ResultSet::new' + + or + + # RsrcProxy stuff is special and not attr-annotated on purpose + # Yet it is marked (correctly) as fail_on_internal_call(), as DBIC + # itself should not call these methods as first-entry + $fr->[3] =~ /^DBIx::Class::ResultSourceProxy::[^:]+$/ + + or + + # FIXME - there is likely a more fine-graned way to escape "foreign" + # callers, based on annotations... (albeit a slower one) + # For the time being just skip in a dumb way + $fr->[3] !~ /^DBIx::Class|^DBICx::|^DBICTest::/ + + or + + grep + { $_ eq 'DBIC_method_is_indirect_sugar' } + do { no strict 'refs'; attributes::get( \&{ $fr->[3] }) } + ); + + if ( defined $fr->[0] and diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index 5f52f75..6c293cc 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -443,6 +443,12 @@ sub connection { }; weaken( $assertion_arounds->{refaddr $replacement} = $replacement ); + + attributes->import( + $origin, + $replacement, + attributes::get($orig_rsrc) + ); } @@ -518,8 +524,13 @@ sub connection { }; weaken( $assertion_arounds->{refaddr $replacement} = $replacement ); - } + attributes->import( + $origin, + $replacement, + attributes::get($orig_rsrc_instance) + ); + } } Class::C3::initialize if DBIx::Class::_ENV_::OLD_MRO;