1 package # hide from PAUSE
2 DBIx::Class::MethodAttributes;
7 use DBIx::Class::_Util qw( uniq refdesc visit_namespaces );
8 use Scalar::Util qw( weaken refaddr );
13 my $attr_cref_registry;
14 sub DBIx::Class::__Attr_iThreads_handler__::CLONE {
16 # This is disgusting, but the best we can do without even more surgery
17 visit_namespaces( action => sub {
20 # skip dangerous namespaces
21 return 1 if $pkg =~ /^ (?:
22 DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3
28 exists ${"${pkg}::"}{__cag___attr_cache}
30 ref( my $attr_stash = ${"${pkg}::__cag___attr_cache"} ) eq 'HASH'
32 $attr_stash->{ $attr_cref_registry->{$_}{weakref} } = delete $attr_stash->{$_}
33 for keys %$attr_stash;
39 # renumber the cref registry itself
40 %$attr_cref_registry = map {
41 ( defined $_->{weakref} )
43 # because of how __attr_cache works, ugh
44 "$_->{weakref}" => $_,
47 } values %$attr_cref_registry;
50 sub MODIFY_CODE_ATTRIBUTES {
51 my ($class,$code,@attrs) = @_;
52 $class->mk_classaccessor('__attr_cache' => {})
53 unless $class->can('__attr_cache');
56 defined $attr_cref_registry->{$_}{weakref} or delete $attr_cref_registry->{$_}
57 for keys %$attr_cref_registry;
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",
64 refdesc($attr_cref_registry->{$code}{weakref}),
66 ) if refaddr($attr_cref_registry->{$code}{weakref}) != refaddr($code);
69 weaken( $attr_cref_registry->{$code}{weakref} = $code )
72 $class->__attr_cache->{$code} = [ sort( uniq(
73 @{ $class->__attr_cache->{$code} || [] },
77 # FIXME - DBIC essentially gobbles up any attribute it can lay its hands on:
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 :/
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
91 sub FETCH_CODE_ATTRIBUTES {
92 my ($class,$code) = @_;
93 @{ $class->_attr_cache->{$code} || [] }
99 %{ $self->can('__attr_cache') ? $self->__attr_cache : {} },
100 %{ $self->maybe::next::method || {} },