Skip to content

Commit

Permalink
Introduce DBIC-specific method attribute support
Browse files Browse the repository at this point in the history 
When attribute support was added back in ed28f83 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.
  • Loading branch information
@ribasushi
ribasushi committed May 30, 2016
1 parent 5f48fa5 commit 5ab7259
Show file tree
Hide file tree
Showing 3 changed files with 251 additions and 50 deletions.
175 changes: 161 additions & 14 deletions lib/DBIx/Class/MethodAttributes.pm
View file
@@ -1,5 +1,4 @@
package # hide from PAUSE
DBIx::Class::MethodAttributes;
package DBIx::Class::MethodAttributes;

use strict;
use warnings;
Expand All @@ -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;

Expand All @@ -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 {
Expand All @@ -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->{$_}
Expand All @@ -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
Expand All @@ -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 {
Expand All @@ -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<DBIx::Class> inheritance chain with the bits
necessary for L<attribute|attributes> support on methods.
Historically DBIC has accepted any string as a C<CODE> attribute and made
such strings available via the semi-private L</_attr_cache> method. This
was used for e.g. the long-deprecated L<DBIx::Class::ResultSetManager>,
but also has evidence of use on both C<CPAN> and C<DarkPAN>.
Starting mid-2016 DBIC treats any method attribute starting with C<DBIC_>
as an I<internal boolean decorator> for various DBIC-related methods.
Unlike the general attribute naming policy, strict whitelisting is imposed
on attribute names starting with C<DBIC_> as described in
L</VALID_DBIC_CODE_ATTRIBUTE> below.
=head2 DBIC-specific method attributes
The following method attributes are currently recognized under the C<DBIC_*>
prefix:
=over
=item * None so far
=back
=head1 METHODS
=head2 MODIFY_CODE_ATTRIBUTES
See L<attributes/MODIFY_type_ATTRIBUTES>.
=head2 FETCH_CODE_ATTRIBUTES
See L<attributes/FETCH_type_ATTRIBUTES>. Always returns the combination of
all attributes: both the free-form strings registered via the
L<legacy system|/_attr_cache> 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<DBIC_>). An attribute is considered invalid and an exception
is thrown unless this method returns a C<truthy> value.
=head2 _attr_cache
=over
=item Arguments: none
=item Return Value: B<purposefully undocumented>
=back
The legacy method of retrieving attributes declared on DBIC methods
(L</FETCH_CODE_ATTRIBUTES> was not defined until mid-2016). This method
B<does not return any DBIC-specific attributes>, and is kept for backwards
compatibility only.
In order to query the attributes of a particular method use
L<attributes::get()|attributes/get> as shown in the L</SYNOPSIS>.
=head1 FURTHER QUESTIONS?
Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
=head1 COPYRIGHT AND LICENSE
This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
redistribute it and/or modify it under the same terms as the
L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
1 change: 0 additions & 1 deletion xt/dist/pod_coverage.t
View file
Expand Up @@ -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 },
Expand Down
125 changes: 90 additions & 35 deletions xt/extra/internals/attributes.t
View file
Expand Up @@ -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'
);
}

Expand Down

0 comments on commit 5ab7259

Please sign in to comment.