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;