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