Simplify guarded pass-through added to CDBI in ee333775
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / ResultSourceProxy.pm
1 package # hide from PAUSE
2     DBIx::Class::ResultSourceProxy;
3
4 use strict;
5 use warnings;
6
7 use base 'DBIx::Class';
8
9 # ! LOAD ORDER SENSITIVE !
10 # needs to be loaded early to query method attributes below
11 # and to do the around()s properly
12 use DBIx::Class::ResultSource;
13 my @wrap_rsrc_methods = qw(
14   add_columns
15   add_relationship
16 );
17
18 use DBIx::Class::_Util qw(
19   quote_sub perlstring fail_on_internal_call describe_class_methods
20 );
21 use namespace::clean;
22
23 # FIXME: this is truly bizarre, not sure why it is this way since 93405cf0
24 # This value *IS* *DIFFERENT* from source_name in the underlying rsrc
25 # instance, and there is *ZERO EFFORT* made to synchronize them...
26 # FIXME: Due to the above marking this as a rsrc_proxy method is also out
27 # of the question...
28 # FIXME: this used to be a sub-type of inherited ( to see run:
29 # `git log -Sinherited_ro_instance lib/DBIx/Class/ResultSourceProxy.pm` )
30 # however given the lack of any sync effort as described above *anyway*,
31 # it makes no sense to guard for erroneous use at a non-trivial cost in
32 # performance (and may end up in the way of future optimizations as per
33 # https://github.com/vovkasm/Class-Accessor-Inherited-XS/issues/2#issuecomment-243246924 )
34 __PACKAGE__->mk_group_accessors( inherited => 'source_name');
35
36 # The marking with indirect_sugar will cause warnings to be issued in darkpan code
37 # (though extremely unlikely)
38 sub get_inherited_ro_instance :DBIC_method_is_indirect_sugar {
39   DBIx::Class::Exception->throw(
40     "The 'inherted_ro_instance' CAG group has been retired - use 'inherited' instead"
41   );
42 }
43 sub set_inherited_ro_instance :DBIC_method_is_indirect_sugar {
44   DBIx::Class::Exception->throw(
45     "The 'inherted_ro_instance' CAG group has been retired - use 'inherited' instead"
46   );
47 }
48
49 sub add_columns :DBIC_method_is_bypassable_resultsource_proxy {
50   my ($class, @cols) = @_;
51   my $source = $class->result_source;
52   local $source->{__callstack_includes_rsrc_proxy_method} = "add_columns";
53
54   $source->add_columns(@cols);
55
56   my $colinfos;
57   foreach my $c (grep { !ref } @cols) {
58     # If this is an augment definition get the real colname.
59     $c =~ s/^\+//;
60
61     $class->register_column(
62       $c,
63       ( $colinfos ||= $source->columns_info )->{$c}
64     );
65   }
66 }
67
68 sub add_column :DBIC_method_is_indirect_sugar {
69   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
70   shift->add_columns(@_)
71 }
72
73 sub add_relationship :DBIC_method_is_bypassable_resultsource_proxy {
74   my ($class, $rel, @rest) = @_;
75   my $source = $class->result_source;
76   local $source->{__callstack_includes_rsrc_proxy_method} = "add_relationship";
77
78   $source->add_relationship($rel => @rest);
79   $class->register_relationship($rel => $source->relationship_info($rel));
80 }
81
82
83 # legacy resultset_class accessor, seems to be used by cdbi only
84 sub iterator_class :DBIC_method_is_indirect_sugar {
85   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
86   shift->result_source->resultset_class(@_)
87 }
88
89 for my $method_to_proxy (qw/
90   source_info
91   result_class
92   resultset_class
93   resultset_attributes
94
95   columns
96   has_column
97
98   remove_column
99   remove_columns
100
101   column_info
102   columns_info
103   column_info_from_storage
104
105   set_primary_key
106   primary_columns
107   sequence
108
109   add_unique_constraint
110   add_unique_constraints
111
112   unique_constraints
113   unique_constraint_names
114   unique_constraint_columns
115
116   relationships
117   relationship_info
118   has_relationship
119 /) {
120   my $qsub_opts = { attributes => [
121     do {
122       no strict 'refs';
123       attributes::get( \&{"DBIx::Class::ResultSource::$method_to_proxy"} );
124     }
125   ] };
126
127   # bypassable default for backcompat, except for indirect methods
128   # ( those will simply warn during the sanheck )
129   if(! grep
130     { $_ eq 'DBIC_method_is_indirect_sugar' }
131     @{ $qsub_opts->{attributes} }
132   ) {
133     push @wrap_rsrc_methods, $method_to_proxy;
134     push @{ $qsub_opts->{atributes} }, 'DBIC_method_is_bypassable_resultsource_proxy';
135   }
136
137   quote_sub __PACKAGE__."::$method_to_proxy", sprintf( <<'EOC', $method_to_proxy ), {}, $qsub_opts;
138     DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
139
140     my $rsrc = shift->result_source;
141     local $rsrc->{__callstack_includes_rsrc_proxy_method} = q(%1$s);
142     $rsrc->%1$s (@_);
143 EOC
144
145 }
146
147 # This is where the "magic" of detecting/invoking the proper overridden
148 # Result method takes place. It isn't implemented as a stateless out-of-band
149 # SanityCheck as invocation requires certain state in the $rsrc object itself
150 # in order not to loop over itself. It is not in ResultSource.pm either
151 # because of load order and because the entire stack is just terrible :/
152 #
153 # The code is not easily readable, as it it optimized for execution time
154 # (this stuff will be run all the time across the entire install base :/ )
155 #
156 {
157   our %__rsrc_proxy_meta_cache;
158
159   sub DBIx::Class::__RsrcProxy_iThreads_handler__::CLONE {
160     # recreating this cache is pretty cheap: just blow it away
161     %__rsrc_proxy_meta_cache = ();
162   }
163
164   for my $method_to_wrap (@wrap_rsrc_methods) {
165
166     my @src_args = (
167       perlstring $method_to_wrap,
168     );
169
170     my $orig = do {
171       no strict 'refs';
172       \&{"DBIx::Class::ResultSource::$method_to_wrap"}
173     };
174
175     my %unclassified_override_warn_emitted;
176
177     my @qsub_args = (
178       {
179         # ref to hashref, this is how S::Q works
180         '$rsrc_proxy_meta_cache' => \\%__rsrc_proxy_meta_cache,
181         '$unclassified_override_warn_emitted' => \\%unclassified_override_warn_emitted,
182         '$orig' => \$orig,
183       },
184       { attributes => [ attributes::get($orig) ] }
185     );
186
187     quote_sub "DBIx::Class::ResultSource::$method_to_wrap", sprintf( <<'EOC', @src_args ), @qsub_args;
188
189       my $overridden_proxy_cref;
190
191       # fall through except when...
192       return &$orig unless (
193
194         # FIXME - this may be necessary some day, but skip the hit for now
195         # Scalar::Util::reftype $_[0] eq 'HASH'
196         #   and
197
198         # there is a class to check in the first place
199         defined $_[0]->{result_class}
200
201           and
202         # we are not in a reinvoked callstack
203         (
204           ( $_[0]->{__callstack_includes_rsrc_proxy_method} || '' )
205             ne
206           %1$s
207         )
208
209           and
210         # there is a proxied method in the first place
211         (
212           ( $rsrc_proxy_meta_cache->{address}{%1$s} ||= 0 + (
213             DBIx::Class::ResultSourceProxy->can(%1$s)
214               ||
215             -1
216           ) )
217             >
218           0
219         )
220
221           and
222         # the proxied method *is overridden*
223         (
224           $rsrc_proxy_meta_cache->{address}{%1$s}
225             !=
226           # the can() should not be able to fail in theory, but the
227           # result class may not inherit from ::Core *at all*
228           # hence we simply ||ourselves to paper over this eventuality
229           (
230             ( $overridden_proxy_cref = $_[0]->{result_class}->can(%1$s) )
231               ||
232             $rsrc_proxy_meta_cache->{address}{%1$s}
233           )
234         )
235
236           and
237         # no short-circuiting atributes
238         (! grep
239           {
240             # checking that:
241             #
242             # - Override is not something DBIC plastered on top of things
243             #   One would think this is crazy, yet there it is... sigh:
244             #   https://metacpan.org/source/KARMAN/DBIx-Class-RDBOHelpers-0.12/t/lib/MyDBIC/Schema/Cd.pm#L26-27
245             #
246             # - And is not an m2m crapfest
247             #
248             # - And is not something marked as bypassable
249
250             $_ =~ / ^ DBIC_method_is_ (?:
251               generated_from_resultsource_metadata
252                 |
253               m2m_ (?: extra_)? sugar (?:_with_attrs)?
254                 |
255               bypassable_resultsource_proxy
256             ) $ /x
257           }
258           keys %%{ $rsrc_proxy_meta_cache->{attrs}{$overridden_proxy_cref} ||= {
259             map { $_ => 1 } attributes::get($overridden_proxy_cref)
260           }}
261         )
262       );
263
264       # Getting this far means that there *is* an override
265       # and it is *not* marked for a skip
266
267       # we were asked to loop back through the Result override
268       if (
269         $rsrc_proxy_meta_cache->{attrs}
270                                  {$overridden_proxy_cref}
271                                   {DBIC_method_is_mandatory_resultsource_proxy}
272       ) {
273         local $_[0]->{__callstack_includes_rsrc_proxy_method} = %1$s;
274
275         # replace $self without compromising aliasing
276         splice @_, 0, 1, $_[0]->{result_class};
277
278         return &$overridden_proxy_cref;
279       }
280       # complain (sparsely) and carry on
281       else {
282
283         # FIXME!!! - terrible, need to swap for something saner later
284         my ($cs) = DBIx::Class::Carp::__find_caller( __PACKAGE__ );
285
286         my $key = $cs . $overridden_proxy_cref;
287
288         unless( $unclassified_override_warn_emitted->{$key} ) {
289
290           # find the real origin
291           my @meth_stack = @{ DBIx::Class::_Util::describe_class_methods(
292             ref $_[0]->{result_class} || $_[0]->{result_class}
293           )->{methods}{%1$s} };
294
295           my $in_class = (shift @meth_stack)->{via_class};
296
297           my $possible_supers;
298           while (
299             @meth_stack
300               and
301             $meth_stack[0]{via_class} ne __PACKAGE__
302           ) {
303             push @$possible_supers, (shift @meth_stack)->{via_class};
304           }
305
306           $possible_supers = $possible_supers
307             ? sprintf(
308               ' ( and possible SUPERs: %%s )',
309               join ', ', map
310                 { join '::', $_, %1$s }
311                 @$possible_supers
312             )
313             : ''
314           ;
315
316           my $fqmeth = $in_class . '::' . %1$s . '()';
317
318           DBIx::Class::_Util::emit_loud_diag(
319
320             # Repurpose the assertion envvar ( the override-check is independent
321             # from the schema san-checker, but the spirit is the same )
322             confess => $ENV{DBIC_ASSERT_NO_FAILING_SANITY_CHECKS},
323
324             msg =>
325               "The override method $fqmeth$possible_supers has been bypassed "
326             . "$cs\n"
327             . "In order to silence this warning you must tag the "
328             . "definition of $fqmeth with one of the attributes "
329             . "':DBIC_method_is_bypassable_resultsource_proxy' or "
330             . "':DBIC_method_is_mandatory_resultsource_proxy' ( see "
331             . "https://is.gd/dbic_rsrcproxy_methodattr for more info )\n"
332           );
333
334           # only set if we didn't throw
335           $unclassified_override_warn_emitted->{$key} = 1;
336         }
337
338         return &$orig;
339       }
340 EOC
341
342   }
343
344   Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
345 }
346
347 # CI sanity check that all annotations make sense
348 if(
349   DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
350     and
351   # no point taxing 5.8 with this
352   ! DBIx::Class::_ENV_::OLD_MRO
353 ) {
354
355   my ( $rsrc_methods, $rsrc_proxy_methods, $base_methods ) = map {
356     describe_class_methods($_)->{methods}
357   } qw(
358     DBIx::Class::ResultSource
359     DBIx::Class::ResultSourceProxy
360     DBIx::Class
361   );
362
363   delete $rsrc_methods->{$_}, delete $rsrc_proxy_methods->{$_}
364     for keys %$base_methods;
365
366   (
367     $rsrc_methods->{$_}
368       and
369     ! $rsrc_proxy_methods->{$_}[0]{attributes}{DBIC_method_is_indirect_sugar}
370   )
371     or
372   delete $rsrc_proxy_methods->{$_}
373     for keys %$rsrc_proxy_methods;
374
375   # see fat FIXME at top of file
376   delete @{$rsrc_proxy_methods}{qw( source_name _source_name_accessor )};
377
378   if (
379     ( my $proxied = join "\n", map "\t$_", sort keys %$rsrc_proxy_methods )
380       ne
381     ( my $wrapped = join "\n", map "\t$_", sort @wrap_rsrc_methods )
382   ) {
383     Carp::confess(
384       "Unexpected mismatch between the list of proxied methods:\n\n$proxied"
385     . "\n\nand the list of wrapped rsrc methods:\n\n$wrapped\n\n"
386     );
387   }
388 }
389
390 1;