Add an explicit Sub::Quote dep in ::_Util
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / MethodAttributes.pm
CommitLineData
5ab72593 1package DBIx::Class::MethodAttributes;
5f48fa56 2
3use strict;
4use warnings;
5
6use DBIx::Class::_Util qw( uniq refdesc visit_namespaces );
7use Scalar::Util qw( weaken refaddr );
8
9use mro 'c3';
10use namespace::clean;
11
5ab72593 12my ( $attr_cref_registry, $attr_cache_active );
5f48fa56 13sub DBIx::Class::__Attr_iThreads_handler__::CLONE {
14
15 # This is disgusting, but the best we can do without even more surgery
5ab72593 16 # Note the if() at the end - we do not run this crap if we can help it
5f48fa56 17 visit_namespaces( action => sub {
18 my $pkg = shift;
19
20 # skip dangerous namespaces
21 return 1 if $pkg =~ /^ (?:
22 DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3
23 ) $/x;
24
25 no strict 'refs';
26
27 if (
28 exists ${"${pkg}::"}{__cag___attr_cache}
29 and
30 ref( my $attr_stash = ${"${pkg}::__cag___attr_cache"} ) eq 'HASH'
31 ) {
32 $attr_stash->{ $attr_cref_registry->{$_}{weakref} } = delete $attr_stash->{$_}
33 for keys %$attr_stash;
34 }
35
36 return 1;
5ab72593 37 }) if $attr_cache_active;
5f48fa56 38
39 # renumber the cref registry itself
40 %$attr_cref_registry = map {
41 ( defined $_->{weakref} )
42 ? (
43 # because of how __attr_cache works, ugh
44 "$_->{weakref}" => $_,
45 )
46 : ()
47 } values %$attr_cref_registry;
48}
49
50sub MODIFY_CODE_ATTRIBUTES {
5ab72593 51 my $class = shift;
52 my $code = shift;
53
54 my $attrs;
55 $attrs->{
56 $_ =~ /^[a-z]+$/ ? 'builtin'
57 : $_ =~ /^DBIC_/ ? 'dbic'
58 : 'misc'
59 }{$_}++ for @_;
60
5f48fa56 61
62 # compaction step
63 defined $attr_cref_registry->{$_}{weakref} or delete $attr_cref_registry->{$_}
64 for keys %$attr_cref_registry;
65
66 # The original misc-attr API used stringification instead of refaddr - can't change that now
67 if( $attr_cref_registry->{$code} ) {
68 Carp::confess( sprintf
69 "Coderefs '%s' and '%s' stringify to the same value '%s': nothing will work",
70 refdesc($code),
71 refdesc($attr_cref_registry->{$code}{weakref}),
72 "$code"
73 ) if refaddr($attr_cref_registry->{$code}{weakref}) != refaddr($code);
74 }
75 else {
76 weaken( $attr_cref_registry->{$code}{weakref} = $code )
77 }
78
296248c3 79
80 # increment the pkg gen, this ensures the sanity checkers will re-evaluate
81 # this class when/if the time comes
82 mro::method_changed_in($class) if (
83 ! DBIx::Class::_ENV_::OLD_MRO
84 and
85 ( $attrs->{dbic} or $attrs->{misc} )
86 );
87
88
5ab72593 89 # handle legacy attrs
90 if( $attrs->{misc} ) {
91
92 # if the user never tickles this - we won't have to do a gross
93 # symtable scan in the ithread handler above, so:
94 #
95 # User - please don't tickle this
96 $attr_cache_active = 1;
97
98 $class->mk_classaccessor('__attr_cache' => {})
99 unless $class->can('__attr_cache');
100
101 $class->__attr_cache->{$code} = [ sort( uniq(
102 @{ $class->__attr_cache->{$code} || [] },
103 keys %{ $attrs->{misc} },
104 ))];
105 }
106
296248c3 107
5ab72593 108 # handle DBIC_* attrs
109 if( $attrs->{dbic} ) {
110 my $slot = $attr_cref_registry->{$code};
111
112 $slot->{attrs} = [ uniq
113 @{ $slot->{attrs} || [] },
114 grep {
115 $class->VALID_DBIC_CODE_ATTRIBUTE($_)
116 or
117 Carp::confess( "DBIC-specific attribute '$_' did not pass validation by $class->VALID_DBIC_CODE_ATTRIBUTE() as described in DBIx::Class::MethodAttributes" )
118 } keys %{$attrs->{dbic}},
119 ];
120 }
5f48fa56 121
296248c3 122
5f48fa56 123 # FIXME - DBIC essentially gobbles up any attribute it can lay its hands on:
124 # decidedly not cool
125 #
126 # There should be some sort of warning on unrecognized attributes or
127 # somesuch... OTOH people do use things in the wild hence the plan of action
128 # is anything but clear :/
129 #
130 # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/lib/DBIx/Class/Service.pm#L93-110
131 # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L29
132 # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L36
133 #
5ab72593 134 # For the time being reuse the old logic for any attribute we do not have
135 # explicit plans for (i.e. stuff that is neither reserved, nor DBIC-internal)
136 #
137 # Pass the "builtin attrs" onwards, as the DBIC internals can't possibly handle them
138 return sort keys %{ $attrs->{builtin} || {} };
139}
140
141# Address the above FIXME halfway - if something (e.g. DBIC::Helpers) wants to
142# add extra attributes - it needs to override this in its base class to allow
143# for 'return 1' on the newly defined attributes
144sub VALID_DBIC_CODE_ATTRIBUTE {
145 #my ($class, $attr) = @_;
146
147 # initially no valid attributes
148 0;
5f48fa56 149}
150
151sub FETCH_CODE_ATTRIBUTES {
5ab72593 152 #my ($class,$code) = @_;
153
154 sort(
155 @{ $_[0]->_attr_cache->{$_[1]} || [] },
156 ( defined( $attr_cref_registry->{$_[1]}{ weakref } )
157 ? @{ $attr_cref_registry->{$_[1]}{attrs} || [] }
158 : ()
159 ),
160 )
5f48fa56 161}
162
163sub _attr_cache {
164 my $self = shift;
165 +{
166 %{ $self->can('__attr_cache') ? $self->__attr_cache : {} },
167 %{ $self->maybe::next::method || {} },
168 };
169}
170
1711;
5ab72593 172
173__END__
174
175=head1 NAME
176
177DBIx::Class::MethodAttributes - DBIC-specific handling of CODE attributes
178
179=head1 SYNOPSIS
180
181 my @attrlist = attributes::get( \&My::App::Schema::Result::some_method )
182
183=head1 DESCRIPTION
184
185This class provides the L<DBIx::Class> inheritance chain with the bits
186necessary for L<attribute|attributes> support on methods.
187
188Historically DBIC has accepted any string as a C<CODE> attribute and made
189such strings available via the semi-private L</_attr_cache> method. This
190was used for e.g. the long-deprecated L<DBIx::Class::ResultSetManager>,
191but also has evidence of use on both C<CPAN> and C<DarkPAN>.
192
193Starting mid-2016 DBIC treats any method attribute starting with C<DBIC_>
194as an I<internal boolean decorator> for various DBIC-related methods.
195Unlike the general attribute naming policy, strict whitelisting is imposed
196on attribute names starting with C<DBIC_> as described in
197L</VALID_DBIC_CODE_ATTRIBUTE> below.
198
199=head2 DBIC-specific method attributes
200
201The following method attributes are currently recognized under the C<DBIC_*>
202prefix:
203
204=over
205
206=item * None so far
207
208=back
209
210=head1 METHODS
211
212=head2 MODIFY_CODE_ATTRIBUTES
213
214See L<attributes/MODIFY_type_ATTRIBUTES>.
215
216=head2 FETCH_CODE_ATTRIBUTES
217
218See L<attributes/FETCH_type_ATTRIBUTES>. Always returns the combination of
219all attributes: both the free-form strings registered via the
220L<legacy system|/_attr_cache> and the DBIC-specific ones.
221
222=head2 VALID_DBIC_CODE_ATTRIBUTE
223
224=over
225
226=item Arguments: $attribute_string
227
228=item Return Value: ( true| false )
229
230=back
231
232This method is invoked when processing each DBIC-specific attribute (the ones
233starting with C<DBIC_>). An attribute is considered invalid and an exception
234is thrown unless this method returns a C<truthy> value.
235
236=head2 _attr_cache
237
238=over
239
240=item Arguments: none
241
242=item Return Value: B<purposefully undocumented>
243
244=back
245
246The legacy method of retrieving attributes declared on DBIC methods
247(L</FETCH_CODE_ATTRIBUTES> was not defined until mid-2016). This method
248B<does not return any DBIC-specific attributes>, and is kept for backwards
249compatibility only.
250
251In order to query the attributes of a particular method use
252L<attributes::get()|attributes/get> as shown in the L</SYNOPSIS>.
253
254=head1 FURTHER QUESTIONS?
255
256Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
257
258=head1 COPYRIGHT AND LICENSE
259
260This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
261by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
262redistribute it and/or modify it under the same terms as the
263L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.