lib/DBIx/Class/MethodAttributes.pm

   1 package # hide from PAUSE
   2     DBIx::Class::MethodAttributes;
   3
   4 use strict;
   5 use warnings;
   6
   7 use DBIx::Class::_Util qw( uniq refdesc visit_namespaces );
   8 use Scalar::Util qw( weaken refaddr );
   9
  10 use mro 'c3';
  11 use namespace::clean;
  12
  13 my $attr_cref_registry;
  14 sub DBIx::Class::__Attr_iThreads_handler__::CLONE {
  15
  16   # This is disgusting, but the best we can do without even more surgery
  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;
  37   });
  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 {
  51   my ($class,$code,@attrs) = @_;
  52   $class->mk_classaccessor('__attr_cache' => {})
  53     unless $class->can('__attr_cache');
  54
  55   # compaction step
  56   defined $attr_cref_registry->{$_}{weakref} or delete $attr_cref_registry->{$_}
  57     for keys %$attr_cref_registry;
  58
  59   # The original misc-attr API used stringification instead of refaddr - can't change that now
  60   if( $attr_cref_registry->{$code} ) {
  61     Carp::confess( sprintf
  62       "Coderefs '%s' and '%s' stringify to the same value '%s': nothing will work",
  63       refdesc($code),
  64       refdesc($attr_cref_registry->{$code}{weakref}),
  65       "$code"
  66     ) if refaddr($attr_cref_registry->{$code}{weakref}) != refaddr($code);
  67   }
  68   else {
  69     weaken( $attr_cref_registry->{$code}{weakref} = $code )
  70   }
  71
  72   $class->__attr_cache->{$code} = [ sort( uniq(
  73     @{ $class->__attr_cache->{$code} || [] },
  74     @attrs,
  75   ))];
  76
  77   # FIXME - DBIC essentially gobbles up any attribute it can lay its hands on:
  78   # decidedly not cool
  79   #
  80   # There should be some sort of warning on unrecognized attributes or
  81   # somesuch... OTOH people do use things in the wild hence the plan of action
  82   # is anything but clear :/
  83   #
  84   # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/lib/DBIx/Class/Service.pm#L93-110
  85   # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L29
  86   # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L36
  87   #
  88   return ();
  89 }
  90
  91 sub FETCH_CODE_ATTRIBUTES {
  92   my ($class,$code) = @_;
  93   @{ $class->_attr_cache->{$code} || [] }
  94 }
  95
  96 sub _attr_cache {
  97   my $self = shift;
  98   +{
  99     %{ $self->can('__attr_cache') ? $self->__attr_cache : {} },
 100     %{ $self->maybe::next::method || {} },
 101   };
 102 }
 103
 104 1;