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