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