From: Peter Rabbitson Date: Wed, 25 May 2016 09:44:20 +0000 (+0200) Subject: Introduce DBIC-specific method attribute support X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5ab7259324b6e3d0feea533239b6d77db0b28c9c;p=dbsrgits%2FDBIx-Class-Historic.git Introduce DBIC-specific method attribute support When attribute support was added back in ed28f830 it was done in a weird roundabout manner, with the only way to access the attributes via a chained class accessor __attr_cache hidden behind a cascading method _attr_cache. This is wasteful and rather inelegant. To mitigate this, and the propensity of DBIC to eat any attribute it can lay its hands on, introduce special handling for attributes prefixed with DBIC_ Any such attributes are handled by a much simpler storage system, and are not made available to the legacy _attr_cache interface. --- diff --git a/lib/DBIx/Class/MethodAttributes.pm b/lib/DBIx/Class/MethodAttributes.pm index 6dac252..cea3961 100644 --- a/lib/DBIx/Class/MethodAttributes.pm +++ b/lib/DBIx/Class/MethodAttributes.pm @@ -1,5 +1,4 @@ -package # hide from PAUSE - DBIx::Class::MethodAttributes; +package DBIx::Class::MethodAttributes; use strict; use warnings; @@ -10,10 +9,11 @@ use Scalar::Util qw( weaken refaddr ); use mro 'c3'; use namespace::clean; -my $attr_cref_registry; +my ( $attr_cref_registry, $attr_cache_active ); sub DBIx::Class::__Attr_iThreads_handler__::CLONE { # This is disgusting, but the best we can do without even more surgery + # Note the if() at the end - we do not run this crap if we can help it visit_namespaces( action => sub { my $pkg = shift; @@ -34,7 +34,7 @@ sub DBIx::Class::__Attr_iThreads_handler__::CLONE { } return 1; - }); + }) if $attr_cache_active; # renumber the cref registry itself %$attr_cref_registry = map { @@ -48,9 +48,16 @@ sub DBIx::Class::__Attr_iThreads_handler__::CLONE { } sub MODIFY_CODE_ATTRIBUTES { - my ($class,$code,@attrs) = @_; - $class->mk_classaccessor('__attr_cache' => {}) - unless $class->can('__attr_cache'); + my $class = shift; + my $code = shift; + + my $attrs; + $attrs->{ + $_ =~ /^[a-z]+$/ ? 'builtin' + : $_ =~ /^DBIC_/ ? 'dbic' + : 'misc' + }{$_}++ for @_; + # compaction step defined $attr_cref_registry->{$_}{weakref} or delete $attr_cref_registry->{$_} @@ -69,10 +76,37 @@ sub MODIFY_CODE_ATTRIBUTES { weaken( $attr_cref_registry->{$code}{weakref} = $code ) } - $class->__attr_cache->{$code} = [ sort( uniq( - @{ $class->__attr_cache->{$code} || [] }, - @attrs, - ))]; + # handle legacy attrs + if( $attrs->{misc} ) { + + # if the user never tickles this - we won't have to do a gross + # symtable scan in the ithread handler above, so: + # + # User - please don't tickle this + $attr_cache_active = 1; + + $class->mk_classaccessor('__attr_cache' => {}) + unless $class->can('__attr_cache'); + + $class->__attr_cache->{$code} = [ sort( uniq( + @{ $class->__attr_cache->{$code} || [] }, + keys %{ $attrs->{misc} }, + ))]; + } + + # handle DBIC_* attrs + if( $attrs->{dbic} ) { + my $slot = $attr_cref_registry->{$code}; + + $slot->{attrs} = [ uniq + @{ $slot->{attrs} || [] }, + grep { + $class->VALID_DBIC_CODE_ATTRIBUTE($_) + or + Carp::confess( "DBIC-specific attribute '$_' did not pass validation by $class->VALID_DBIC_CODE_ATTRIBUTE() as described in DBIx::Class::MethodAttributes" ) + } keys %{$attrs->{dbic}}, + ]; + } # FIXME - DBIC essentially gobbles up any attribute it can lay its hands on: # decidedly not cool @@ -85,12 +119,33 @@ sub MODIFY_CODE_ATTRIBUTES { # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L29 # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L36 # - return (); + # For the time being reuse the old logic for any attribute we do not have + # explicit plans for (i.e. stuff that is neither reserved, nor DBIC-internal) + # + # Pass the "builtin attrs" onwards, as the DBIC internals can't possibly handle them + return sort keys %{ $attrs->{builtin} || {} }; +} + +# Address the above FIXME halfway - if something (e.g. DBIC::Helpers) wants to +# add extra attributes - it needs to override this in its base class to allow +# for 'return 1' on the newly defined attributes +sub VALID_DBIC_CODE_ATTRIBUTE { + #my ($class, $attr) = @_; + + # initially no valid attributes + 0; } sub FETCH_CODE_ATTRIBUTES { - my ($class,$code) = @_; - @{ $class->_attr_cache->{$code} || [] } + #my ($class,$code) = @_; + + sort( + @{ $_[0]->_attr_cache->{$_[1]} || [] }, + ( defined( $attr_cref_registry->{$_[1]}{ weakref } ) + ? @{ $attr_cref_registry->{$_[1]}{attrs} || [] } + : () + ), + ) } sub _attr_cache { @@ -102,3 +157,95 @@ sub _attr_cache { } 1; + +__END__ + +=head1 NAME + +DBIx::Class::MethodAttributes - DBIC-specific handling of CODE attributes + +=head1 SYNOPSIS + + my @attrlist = attributes::get( \&My::App::Schema::Result::some_method ) + +=head1 DESCRIPTION + +This class provides the L inheritance chain with the bits +necessary for L support on methods. + +Historically DBIC has accepted any string as a C attribute and made +such strings available via the semi-private L method. This +was used for e.g. the long-deprecated L, +but also has evidence of use on both C and C. + +Starting mid-2016 DBIC treats any method attribute starting with C +as an I for various DBIC-related methods. +Unlike the general attribute naming policy, strict whitelisting is imposed +on attribute names starting with C as described in +L below. + +=head2 DBIC-specific method attributes + +The following method attributes are currently recognized under the C +prefix: + +=over + +=item * None so far + +=back + +=head1 METHODS + +=head2 MODIFY_CODE_ATTRIBUTES + +See L. + +=head2 FETCH_CODE_ATTRIBUTES + +See L. Always returns the combination of +all attributes: both the free-form strings registered via the +L and the DBIC-specific ones. + +=head2 VALID_DBIC_CODE_ATTRIBUTE + +=over + +=item Arguments: $attribute_string + +=item Return Value: ( true| false ) + +=back + +This method is invoked when processing each DBIC-specific attribute (the ones +starting with C). An attribute is considered invalid and an exception +is thrown unless this method returns a C value. + +=head2 _attr_cache + +=over + +=item Arguments: none + +=item Return Value: B + +=back + +The legacy method of retrieving attributes declared on DBIC methods +(L was not defined until mid-2016). This method +B, and is kept for backwards +compatibility only. + +In order to query the attributes of a particular method use +L as shown in the L. + +=head1 FURTHER QUESTIONS? + +Check the list of L. + +=head1 COPYRIGHT AND LICENSE + +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L. diff --git a/xt/dist/pod_coverage.t b/xt/dist/pod_coverage.t index 4f46824..004f35e 100644 --- a/xt/dist/pod_coverage.t +++ b/xt/dist/pod_coverage.t @@ -116,7 +116,6 @@ my $exceptions = { 'DBIx::Class::Admin::*' => { skip => 1 }, 'DBIx::Class::ClassResolver::PassThrough' => { skip => 1 }, - 'DBIx::Class::MethodAttributes' => { skip => 1 }, 'DBIx::Class::Componentised' => { skip => 1 }, 'DBIx::Class::AccessorGroup' => { skip => 1 }, 'DBIx::Class::Relationship::*' => { skip => 1 }, diff --git a/xt/extra/internals/attributes.t b/xt/extra/internals/attributes.t index e305f97..b107a21 100644 --- a/xt/extra/internals/attributes.t +++ b/xt/extra/internals/attributes.t @@ -21,75 +21,130 @@ BEGIN { } use Test::More; -use DBIx::Class::_Util qw( quote_sub modver_gt_or_eq ); +use Test::Exception; +use DBIx::Class::_Util qw( quote_sub ); require DBIx::Class; -@DBICTest::ATTRTEST::ISA = 'DBIx::Class'; +@DBICTest::AttrLegacy::ISA = 'DBIx::Class'; +sub DBICTest::AttrLegacy::VALID_DBIC_CODE_ATTRIBUTE { 1 } my $var = \42; my $s = quote_sub( - 'DBICTest::ATTRTEST::attr', + 'DBICTest::AttrLegacy::attr', '$v', { '$v' => $var }, { - attributes => [qw( ResultSet )], - package => 'DBICTest::ATTRTEST', + attributes => [qw( ResultSet DBIC_random_attr )], + package => 'DBICTest::AttrLegacy', }, ); -is $s, \&DBICTest::ATTRTEST::attr, 'Same cref installed'; +is $s, \&DBICTest::AttrLegacy::attr, 'Same cref installed'; -is DBICTest::ATTRTEST::attr(), 42, 'Sub properly installed and callable'; +is DBICTest::AttrLegacy::attr(), 42, 'Sub properly installed and callable'; is_deeply - [ attributes::get( $s ) ], - [ 'ResultSet' ], + [ sort( attributes::get( $s ) ) ], + [qw( DBIC_random_attr ResultSet )], 'Attribute installed', unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 + +@DBICTest::AttrTest::ISA = 'DBIx::Class'; +{ + package DBICTest::AttrTest; + + eval <<'EOS' or die $@; + sub VALID_DBIC_CODE_ATTRIBUTE { $_[1] =~ /DBIC_attr/ } + sub attr :lvalue :method :DBIC_attr1 { $$var} + 1; +EOS + + ::throws_ok { + attributes->import( + 'DBICTest::AttrTest', + DBICTest::AttrTest->can('attr'), + 'DBIC_unknownattr', + ); + } qr/DBIC-specific attribute 'DBIC_unknownattr' did not pass validation/; +} + +is_deeply + [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ], + [qw( DBIC_attr1 lvalue method )], + 'Attribute installed', +unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 + +ok( + ! DBICTest::AttrTest->can('__attr_cache'), + 'Inherited classdata never created on core attrs' +); + +is_deeply( + DBICTest::AttrTest->_attr_cache, + {}, + 'Cache never instantiated on core attrs' +); + sub add_more_attrs { # Test that secondary attribute application works attributes->import( - 'DBICTest::ATTRTEST', - DBICTest::ATTRTEST->can('attr'), - 'method', + 'DBICTest::AttrLegacy', + DBICTest::AttrLegacy->can('attr'), 'SomethingNobodyUses', ); # and that double-application also works attributes->import( - 'DBICTest::ATTRTEST', - DBICTest::ATTRTEST->can('attr'), + 'DBICTest::AttrLegacy', + DBICTest::AttrLegacy->can('attr'), 'SomethingNobodyUses', ); is_deeply [ sort( attributes::get( $s ) )], - [ - qw( ResultSet SomethingNobodyUses method ), - - # before 5.10/5.8.9 internal reserved would get doubled, sigh - # - # FIXME - perhaps need to weed them out somehow at FETCH_CODE_ATTRIBUTES - # time...? In any case - this is not important at this stage - ( modver_gt_or_eq( attributes => '0.08' ) ? () : 'method' ) - ], + [ qw( DBIC_random_attr ResultSet SomethingNobodyUses ) ], 'Secondary attributes installed', unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 is_deeply ( - DBICTest::ATTRTEST->_attr_cache->{$s}, - [ - qw( ResultSet SomethingNobodyUses ), - - # after 5.10/5.8.9 FETCH_CODE_ATTRIBUTES is never called for reserved - # attribute names, so there is nothing for DBIC to see - # - # FIXME - perhaps need to teach ->_attr to reinvoke attributes::get() ? - # In any case - this is not important at this stage - ( modver_gt_or_eq( attributes => '0.08' ) ? () : 'method' ) - ], - 'Attributes visible in DBIC-specific attribute API', + DBICTest::AttrLegacy->_attr_cache->{$s}, + [ qw( ResultSet SomethingNobodyUses ) ], + 'Attributes visible in legacy DBIC attribute API', + ); + + + + # Test that secondary attribute application works + attributes->import( + 'DBICTest::AttrTest', + DBICTest::AttrTest->can('attr'), + 'DBIC_attr2', + ); + + # and that double-application also works + attributes->import( + 'DBICTest::AttrTest', + DBICTest::AttrTest->can('attr'), + 'DBIC_attr2', + 'DBIC_attr3', + ); + + is_deeply + [ sort( attributes::get( DBICTest::AttrTest->can("attr") )) ], + [qw( DBIC_attr1 DBIC_attr2 DBIC_attr3 lvalue method )], + 'DBIC-specific attribute installed', + unless $^V =~ /c/; # FIXME work around https://github.com/perl11/cperl/issues/147 + + ok( + ! DBICTest::AttrTest->can('__attr_cache'), + 'Inherited classdata never created on core+DBIC-specific attrs' + ); + + is_deeply( + DBICTest::AttrTest->_attr_cache, + {}, + 'Legacy DBIC attribute cache never instantiated on core+DBIC-specific attrs' ); }