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 | |
5ab72593 |
79 | # handle legacy attrs |
80 | if( $attrs->{misc} ) { |
81 | |
82 | # if the user never tickles this - we won't have to do a gross |
83 | # symtable scan in the ithread handler above, so: |
84 | # |
85 | # User - please don't tickle this |
86 | $attr_cache_active = 1; |
87 | |
88 | $class->mk_classaccessor('__attr_cache' => {}) |
89 | unless $class->can('__attr_cache'); |
90 | |
91 | $class->__attr_cache->{$code} = [ sort( uniq( |
92 | @{ $class->__attr_cache->{$code} || [] }, |
93 | keys %{ $attrs->{misc} }, |
94 | ))]; |
95 | } |
96 | |
97 | # handle DBIC_* attrs |
98 | if( $attrs->{dbic} ) { |
99 | my $slot = $attr_cref_registry->{$code}; |
100 | |
101 | $slot->{attrs} = [ uniq |
102 | @{ $slot->{attrs} || [] }, |
103 | grep { |
104 | $class->VALID_DBIC_CODE_ATTRIBUTE($_) |
105 | or |
106 | Carp::confess( "DBIC-specific attribute '$_' did not pass validation by $class->VALID_DBIC_CODE_ATTRIBUTE() as described in DBIx::Class::MethodAttributes" ) |
107 | } keys %{$attrs->{dbic}}, |
108 | ]; |
109 | } |
5f48fa56 |
110 | |
111 | # FIXME - DBIC essentially gobbles up any attribute it can lay its hands on: |
112 | # decidedly not cool |
113 | # |
114 | # There should be some sort of warning on unrecognized attributes or |
115 | # somesuch... OTOH people do use things in the wild hence the plan of action |
116 | # is anything but clear :/ |
117 | # |
118 | # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/lib/DBIx/Class/Service.pm#L93-110 |
119 | # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L29 |
120 | # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L36 |
121 | # |
5ab72593 |
122 | # For the time being reuse the old logic for any attribute we do not have |
123 | # explicit plans for (i.e. stuff that is neither reserved, nor DBIC-internal) |
124 | # |
125 | # Pass the "builtin attrs" onwards, as the DBIC internals can't possibly handle them |
126 | return sort keys %{ $attrs->{builtin} || {} }; |
127 | } |
128 | |
129 | # Address the above FIXME halfway - if something (e.g. DBIC::Helpers) wants to |
130 | # add extra attributes - it needs to override this in its base class to allow |
131 | # for 'return 1' on the newly defined attributes |
132 | sub VALID_DBIC_CODE_ATTRIBUTE { |
133 | #my ($class, $attr) = @_; |
134 | |
135 | # initially no valid attributes |
136 | 0; |
5f48fa56 |
137 | } |
138 | |
139 | sub FETCH_CODE_ATTRIBUTES { |
5ab72593 |
140 | #my ($class,$code) = @_; |
141 | |
142 | sort( |
143 | @{ $_[0]->_attr_cache->{$_[1]} || [] }, |
144 | ( defined( $attr_cref_registry->{$_[1]}{ weakref } ) |
145 | ? @{ $attr_cref_registry->{$_[1]}{attrs} || [] } |
146 | : () |
147 | ), |
148 | ) |
5f48fa56 |
149 | } |
150 | |
151 | sub _attr_cache { |
152 | my $self = shift; |
153 | +{ |
154 | %{ $self->can('__attr_cache') ? $self->__attr_cache : {} }, |
155 | %{ $self->maybe::next::method || {} }, |
156 | }; |
157 | } |
158 | |
159 | 1; |
5ab72593 |
160 | |
161 | __END__ |
162 | |
163 | =head1 NAME |
164 | |
165 | DBIx::Class::MethodAttributes - DBIC-specific handling of CODE attributes |
166 | |
167 | =head1 SYNOPSIS |
168 | |
169 | my @attrlist = attributes::get( \&My::App::Schema::Result::some_method ) |
170 | |
171 | =head1 DESCRIPTION |
172 | |
173 | This class provides the L<DBIx::Class> inheritance chain with the bits |
174 | necessary for L<attribute|attributes> support on methods. |
175 | |
176 | Historically DBIC has accepted any string as a C<CODE> attribute and made |
177 | such strings available via the semi-private L</_attr_cache> method. This |
178 | was used for e.g. the long-deprecated L<DBIx::Class::ResultSetManager>, |
179 | but also has evidence of use on both C<CPAN> and C<DarkPAN>. |
180 | |
181 | Starting mid-2016 DBIC treats any method attribute starting with C<DBIC_> |
182 | as an I<internal boolean decorator> for various DBIC-related methods. |
183 | Unlike the general attribute naming policy, strict whitelisting is imposed |
184 | on attribute names starting with C<DBIC_> as described in |
185 | L</VALID_DBIC_CODE_ATTRIBUTE> below. |
186 | |
187 | =head2 DBIC-specific method attributes |
188 | |
189 | The following method attributes are currently recognized under the C<DBIC_*> |
190 | prefix: |
191 | |
192 | =over |
193 | |
194 | =item * None so far |
195 | |
196 | =back |
197 | |
198 | =head1 METHODS |
199 | |
200 | =head2 MODIFY_CODE_ATTRIBUTES |
201 | |
202 | See L<attributes/MODIFY_type_ATTRIBUTES>. |
203 | |
204 | =head2 FETCH_CODE_ATTRIBUTES |
205 | |
206 | See L<attributes/FETCH_type_ATTRIBUTES>. Always returns the combination of |
207 | all attributes: both the free-form strings registered via the |
208 | L<legacy system|/_attr_cache> and the DBIC-specific ones. |
209 | |
210 | =head2 VALID_DBIC_CODE_ATTRIBUTE |
211 | |
212 | =over |
213 | |
214 | =item Arguments: $attribute_string |
215 | |
216 | =item Return Value: ( true| false ) |
217 | |
218 | =back |
219 | |
220 | This method is invoked when processing each DBIC-specific attribute (the ones |
221 | starting with C<DBIC_>). An attribute is considered invalid and an exception |
222 | is thrown unless this method returns a C<truthy> value. |
223 | |
224 | =head2 _attr_cache |
225 | |
226 | =over |
227 | |
228 | =item Arguments: none |
229 | |
230 | =item Return Value: B<purposefully undocumented> |
231 | |
232 | =back |
233 | |
234 | The legacy method of retrieving attributes declared on DBIC methods |
235 | (L</FETCH_CODE_ATTRIBUTES> was not defined until mid-2016). This method |
236 | B<does not return any DBIC-specific attributes>, and is kept for backwards |
237 | compatibility only. |
238 | |
239 | In order to query the attributes of a particular method use |
240 | L<attributes::get()|attributes/get> as shown in the L</SYNOPSIS>. |
241 | |
242 | =head1 FURTHER QUESTIONS? |
243 | |
244 | Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>. |
245 | |
246 | =head1 COPYRIGHT AND LICENSE |
247 | |
248 | This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE> |
249 | by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can |
250 | redistribute it and/or modify it under the same terms as the |
251 | L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>. |