Commit | Line | Data |
5ab72593 |
1 | package DBIx::Class::MethodAttributes; |
5f48fa56 |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use DBIx::Class::_Util qw( uniq refdesc visit_namespaces ); |
7 | use Scalar::Util qw( weaken refaddr ); |
8 | |
9 | use mro 'c3'; |
10 | use namespace::clean; |
11 | |
5ab72593 |
12 | my ( $attr_cref_registry, $attr_cache_active ); |
5f48fa56 |
13 | sub 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 | |
50 | sub 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 |
144 | sub VALID_DBIC_CODE_ATTRIBUTE { |
145 | #my ($class, $attr) = @_; |
146 | |
147 | # initially no valid attributes |
148 | 0; |
5f48fa56 |
149 | } |
150 | |
151 | sub 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 | |
163 | sub _attr_cache { |
164 | my $self = shift; |
165 | +{ |
166 | %{ $self->can('__attr_cache') ? $self->__attr_cache : {} }, |
167 | %{ $self->maybe::next::method || {} }, |
168 | }; |
169 | } |
170 | |
171 | 1; |
5ab72593 |
172 | |
173 | __END__ |
174 | |
175 | =head1 NAME |
176 | |
177 | DBIx::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 | |
185 | This class provides the L<DBIx::Class> inheritance chain with the bits |
186 | necessary for L<attribute|attributes> support on methods. |
187 | |
188 | Historically DBIC has accepted any string as a C<CODE> attribute and made |
189 | such strings available via the semi-private L</_attr_cache> method. This |
190 | was used for e.g. the long-deprecated L<DBIx::Class::ResultSetManager>, |
191 | but also has evidence of use on both C<CPAN> and C<DarkPAN>. |
192 | |
193 | Starting mid-2016 DBIC treats any method attribute starting with C<DBIC_> |
194 | as an I<internal boolean decorator> for various DBIC-related methods. |
195 | Unlike the general attribute naming policy, strict whitelisting is imposed |
196 | on attribute names starting with C<DBIC_> as described in |
197 | L</VALID_DBIC_CODE_ATTRIBUTE> below. |
198 | |
199 | =head2 DBIC-specific method attributes |
200 | |
201 | The following method attributes are currently recognized under the C<DBIC_*> |
202 | prefix: |
203 | |
204 | =over |
205 | |
206 | =item * None so far |
207 | |
208 | =back |
209 | |
210 | =head1 METHODS |
211 | |
212 | =head2 MODIFY_CODE_ATTRIBUTES |
213 | |
214 | See L<attributes/MODIFY_type_ATTRIBUTES>. |
215 | |
216 | =head2 FETCH_CODE_ATTRIBUTES |
217 | |
218 | See L<attributes/FETCH_type_ATTRIBUTES>. Always returns the combination of |
219 | all attributes: both the free-form strings registered via the |
220 | L<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 | |
232 | This method is invoked when processing each DBIC-specific attribute (the ones |
233 | starting with C<DBIC_>). An attribute is considered invalid and an exception |
234 | is 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 | |
246 | The legacy method of retrieving attributes declared on DBIC methods |
247 | (L</FETCH_CODE_ATTRIBUTES> was not defined until mid-2016). This method |
248 | B<does not return any DBIC-specific attributes>, and is kept for backwards |
249 | compatibility only. |
250 | |
251 | In order to query the attributes of a particular method use |
252 | L<attributes::get()|attributes/get> as shown in the L</SYNOPSIS>. |
253 | |
254 | =head1 FURTHER QUESTIONS? |
255 | |
256 | Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. |
257 | |
258 | =head1 COPYRIGHT AND LICENSE |
259 | |
260 | This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> |
261 | by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can |
262 | redistribute it and/or modify it under the same terms as the |
263 | L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. |