lib/DBIx/Class/MethodAttributes.pm

   1 package DBIx::Class::MethodAttributes;
   2
   3 use strict;
   4 use warnings;
   5
   6 use DBIx::Class::_Util qw( uniq refdesc visit_namespaces );
   7 use Scalar::Util qw( weaken refaddr );
   8
   9 use namespace::clean;
  10
  11 my ( $attr_cref_registry, $attr_cache_active );
  12 sub DBIx::Class::__Attr_iThreads_handler__::CLONE {
  13
  14   # This is disgusting, but the best we can do without even more surgery
  15   # Note the if() at the end - we do not run this crap if we can help it
  16   visit_namespaces( action => sub {
  17     my $pkg = shift;
  18
  19     # skip dangerous namespaces
  20     return 1 if $pkg =~ /^ (?:
  21       DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3
  22     ) $/x;
  23
  24     no strict 'refs';
  25
  26     if (
  27       exists ${"${pkg}::"}{__cag___attr_cache}
  28         and
  29       ref( my $attr_stash = ${"${pkg}::__cag___attr_cache"} ) eq 'HASH'
  30     ) {
  31       $attr_stash->{ $attr_cref_registry->{$_}{weakref} } = delete $attr_stash->{$_}
  32         for keys %$attr_stash;
  33     }
  34
  35     return 1;
  36   }) if $attr_cache_active;
  37
  38   # renumber the cref registry itself
  39   %$attr_cref_registry = map {
  40     ( defined $_->{weakref} )
  41       ? (
  42         # because of how __attr_cache works, ugh
  43         "$_->{weakref}"         => $_,
  44       )
  45       : ()
  46   } values %$attr_cref_registry;
  47 }
  48
  49 sub MODIFY_CODE_ATTRIBUTES {
  50   my $class = shift;
  51   my $code = shift;
  52
  53   my $attrs;
  54   $attrs->{
  55     $_ =~ /^[a-z]+$/  ? 'builtin'
  56   : $_ =~ /^DBIC_/    ? 'dbic'
  57   :                     'misc'
  58   }{$_}++ for @_;
  59
  60
  61   # compaction step
  62   defined $attr_cref_registry->{$_}{weakref} or delete $attr_cref_registry->{$_}
  63     for keys %$attr_cref_registry;
  64
  65   # The original misc-attr API used stringification instead of refaddr - can't change that now
  66   if( $attr_cref_registry->{$code} ) {
  67     Carp::confess( sprintf
  68       "Coderefs '%s' and '%s' stringify to the same value '%s': nothing will work",
  69       refdesc($code),
  70       refdesc($attr_cref_registry->{$code}{weakref}),
  71       "$code"
  72     ) if refaddr($attr_cref_registry->{$code}{weakref}) != refaddr($code);
  73   }
  74   else {
  75     weaken( $attr_cref_registry->{$code}{weakref} = $code )
  76   }
  77
  78
  79   # increment the pkg gen, this ensures the sanity checkers will re-evaluate
  80   # this class when/if the time comes
  81   mro::method_changed_in($class) if (
  82     ! DBIx::Class::_ENV_::OLD_MRO
  83       and
  84     ( $attrs->{dbic} or $attrs->{misc} )
  85   );
  86
  87
  88   # handle legacy attrs
  89   if( $attrs->{misc} ) {
  90
  91     # if the user never tickles this - we won't have to do a gross
  92     # symtable scan in the ithread handler above, so:
  93     #
  94     # User - please don't tickle this
  95     $attr_cache_active = 1;
  96
  97     $class->mk_classaccessor('__attr_cache' => {})
  98       unless $class->can('__attr_cache');
  99
 100     $class->__attr_cache->{$code} = [ sort( uniq(
 101       @{ $class->__attr_cache->{$code} || [] },
 102       keys %{ $attrs->{misc} },
 103     ))];
 104   }
 105
 106
 107   # handle DBIC_* attrs
 108   if( $attrs->{dbic} ) {
 109     my $slot = $attr_cref_registry->{$code};
 110
 111     $slot->{attrs} = [ uniq
 112       @{ $slot->{attrs} || [] },
 113       grep {
 114         $class->VALID_DBIC_CODE_ATTRIBUTE($_)
 115           or
 116         Carp::confess( "DBIC-specific attribute '$_' did not pass validation by $class->VALID_DBIC_CODE_ATTRIBUTE() as described in DBIx::Class::MethodAttributes" )
 117       } keys %{$attrs->{dbic}},
 118     ];
 119   }
 120
 121
 122   # FIXME - DBIC essentially gobbles up any attribute it can lay its hands on:
 123   # decidedly not cool
 124   #
 125   # There should be some sort of warning on unrecognized attributes or
 126   # somesuch... OTOH people do use things in the wild hence the plan of action
 127   # is anything but clear :/
 128   #
 129   # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/lib/DBIx/Class/Service.pm#L93-110
 130   # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L29
 131   # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L36
 132   #
 133   # For the time being reuse the old logic for any attribute we do not have
 134   # explicit plans for (i.e. stuff that is neither reserved, nor DBIC-internal)
 135   #
 136   # Pass the "builtin attrs" onwards, as the DBIC internals can't possibly  handle them
 137   return sort keys %{ $attrs->{builtin} || {} };
 138 }
 139
 140 # Address the above FIXME halfway - if something (e.g. DBIC::Helpers) wants to
 141 # add extra attributes - it needs to override this in its base class to allow
 142 # for 'return 1' on the newly defined attributes
 143 sub VALID_DBIC_CODE_ATTRIBUTE {
 144   #my ($class, $attr) = @_;
 145
 146   # initially no valid attributes
 147   0;
 148 }
 149
 150 sub FETCH_CODE_ATTRIBUTES {
 151   #my ($class,$code) = @_;
 152
 153   sort(
 154     @{ $_[0]->_attr_cache->{$_[1]} || [] },
 155     ( defined( $attr_cref_registry->{$_[1]}{ weakref } )
 156       ? @{ $attr_cref_registry->{$_[1]}{attrs} || [] }
 157       : ()
 158     ),
 159   )
 160 }
 161
 162 sub _attr_cache {
 163   my $self = shift;
 164   +{
 165     %{ $self->can('__attr_cache') ? $self->__attr_cache : {} },
 166     %{ $self->maybe::next::method || {} },
 167   };
 168 }
 169
 170 1;
 171
 172 __END__
 173
 174 =head1 NAME
 175
 176 DBIx::Class::MethodAttributes - DBIC-specific handling of CODE attributes
 177
 178 =head1 SYNOPSIS
 179
 180  my @attrlist = attributes::get( \&My::App::Schema::Result::some_method )
 181
 182 =head1 DESCRIPTION
 183
 184 This class provides the L<DBIx::Class> inheritance chain with the bits
 185 necessary for L<attribute|attributes> support on methods.
 186
 187 Historically DBIC has accepted any string as a C<CODE> attribute and made
 188 such strings available via the semi-private L</_attr_cache> method. This
 189 was used for e.g. the long-deprecated L<DBIx::Class::ResultSetManager>,
 190 but also has evidence of use on both C<CPAN> and C<DarkPAN>.
 191
 192 Starting mid-2016 DBIC treats any method attribute starting with C<DBIC_>
 193 as an I<internal boolean decorator> for various DBIC-related methods.
 194 Unlike the general attribute naming policy, strict whitelisting is imposed
 195 on attribute names starting with C<DBIC_> as described in
 196 L</VALID_DBIC_CODE_ATTRIBUTE> below.
 197
 198 =head2 DBIC-specific method attributes
 199
 200 The following method attributes are currently recognized under the C<DBIC_*>
 201 prefix:
 202
 203 =over
 204
 205 =item * None so far
 206
 207 =back
 208
 209 =head1 METHODS
 210
 211 =head2 MODIFY_CODE_ATTRIBUTES
 212
 213 See L<attributes/MODIFY_type_ATTRIBUTES>.
 214
 215 =head2 FETCH_CODE_ATTRIBUTES
 216
 217 See L<attributes/FETCH_type_ATTRIBUTES>. Always returns the combination of
 218 all attributes: both the free-form strings registered via the
 219 L<legacy system|/_attr_cache> and the DBIC-specific ones.
 220
 221 =head2 VALID_DBIC_CODE_ATTRIBUTE
 222
 223 =over
 224
 225 =item Arguments: $attribute_string
 226
 227 =item Return Value: ( true| false )
 228
 229 =back
 230
 231 This method is invoked when processing each DBIC-specific attribute (the ones
 232 starting with C<DBIC_>). An attribute is considered invalid and an exception
 233 is thrown unless this method returns a C<truthy> value.
 234
 235 =head2 _attr_cache
 236
 237 =over
 238
 239 =item Arguments: none
 240
 241 =item Return Value: B<purposefully undocumented>
 242
 243 =back
 244
 245 The legacy method of retrieving attributes declared on DBIC methods
 246 (L</FETCH_CODE_ATTRIBUTES> was not defined until mid-2016). This method
 247 B<does not return any DBIC-specific attributes>, and is kept for backwards
 248 compatibility only.
 249
 250 In order to query the attributes of a particular method use
 251 L<attributes::get()|attributes/get> as shown in the L</SYNOPSIS>.
 252
 253 =head1 FURTHER QUESTIONS?
 254
 255 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
 256
 257 =head1 COPYRIGHT AND LICENSE
 258
 259 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
 260 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
 261 redistribute it and/or modify it under the same terms as the
 262 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.