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 ###
 147 ### !!! IMPORTANT !!!
 148 ###
 149 ### *DO NOT* yield to the temptation of using free-form-argument attributes.
 150 ### The technique was proven instrumental in Catalyst a decade ago, and
 151 ### was more recently revived in Sub::Attributes. Yet, while on the surface
 152 ### they seem immensely useful, per-attribute argument lists are in fact an
 153 ### architectural dead end.
 154 ###
 155 ### In other words: you are *very strongly urged* to ensure the regex below
 156 ### does not allow anything beyond qr/^ DBIC_method_is_ [A-Z_a-z0-9]+ $/x
 157 ###
 158
 159   $_[1] =~ /^ DBIC_method_is_ (?:
 160     indirect_sugar
 161   ) $/x;
 162 }
 163
 164 sub FETCH_CODE_ATTRIBUTES {
 165   #my ($class,$code) = @_;
 166
 167   sort(
 168     @{ $_[0]->_attr_cache->{$_[1]} || [] },
 169     ( defined( $attr_cref_registry->{$_[1]}{ weakref } )
 170       ? @{ $attr_cref_registry->{$_[1]}{attrs} || [] }
 171       : ()
 172     ),
 173   )
 174 }
 175
 176 sub _attr_cache {
 177   my $self = shift;
 178   +{
 179     %{ $self->can('__attr_cache') ? $self->__attr_cache : {} },
 180     %{ $self->maybe::next::method || {} },
 181   };
 182 }
 183
 184 1;
 185
 186 __END__
 187
 188 =head1 NAME
 189
 190 DBIx::Class::MethodAttributes - DBIC-specific handling of CODE attributes
 191
 192 =head1 SYNOPSIS
 193
 194  my @attrlist = attributes::get( \&My::App::Schema::Result::some_method )
 195
 196 =head1 DESCRIPTION
 197
 198 This class provides the L<DBIx::Class> inheritance chain with the bits
 199 necessary for L<attribute|attributes> support on methods.
 200
 201 Historically DBIC has accepted any string as a C<CODE> attribute and made
 202 such strings available via the semi-private L</_attr_cache> method. This
 203 was used for e.g. the long-deprecated L<DBIx::Class::ResultSetManager>,
 204 but also has evidence of use on both C<CPAN> and C<DarkPAN>.
 205
 206 Starting mid-2016 DBIC treats any method attribute starting with C<DBIC_>
 207 as an I<internal boolean decorator> for various DBIC-related methods.
 208 Unlike the general attribute naming policy, strict whitelisting is imposed
 209 on attribute names starting with C<DBIC_> as described in
 210 L</VALID_DBIC_CODE_ATTRIBUTE> below.
 211
 212 =head2 DBIC-specific method attributes
 213
 214 The following method attributes are currently recognized under the C<DBIC_*>
 215 prefix:
 216
 217 =head3 DBIC_method_is_indirect_sugar
 218
 219 The presence of this attribute indicates a helper "sugar" method. Overriding
 220 such methods in your subclasses will be of limited success at best, as DBIC
 221 itself and various plugins are much more likely to invoke alternative direct
 222 call paths, bypassing your override entirely. Good examples of this are
 223 L<DBIx::Class::ResultSet/create> and L<DBIx::Class::Schema/connect>.
 224
 225 =head1 METHODS
 226
 227 =head2 MODIFY_CODE_ATTRIBUTES
 228
 229 See L<attributes/MODIFY_type_ATTRIBUTES>.
 230
 231 =head2 FETCH_CODE_ATTRIBUTES
 232
 233 See L<attributes/FETCH_type_ATTRIBUTES>. Always returns the combination of
 234 all attributes: both the free-form strings registered via the
 235 L<legacy system|/_attr_cache> and the DBIC-specific ones.
 236
 237 =head2 VALID_DBIC_CODE_ATTRIBUTE
 238
 239 =over
 240
 241 =item Arguments: $attribute_string
 242
 243 =item Return Value: ( true| false )
 244
 245 =back
 246
 247 This method is invoked when processing each DBIC-specific attribute (the ones
 248 starting with C<DBIC_>). An attribute is considered invalid and an exception
 249 is thrown unless this method returns a C<truthy> value.
 250
 251 =head2 _attr_cache
 252
 253 =over
 254
 255 =item Arguments: none
 256
 257 =item Return Value: B<purposefully undocumented>
 258
 259 =back
 260
 261 The legacy method of retrieving attributes declared on DBIC methods
 262 (L</FETCH_CODE_ATTRIBUTES> was not defined until mid-2016). This method
 263 B<does not return any DBIC-specific attributes>, and is kept for backwards
 264 compatibility only.
 265
 266 In order to query the attributes of a particular method use
 267 L<attributes::get()|attributes/get> as shown in the L</SYNOPSIS>.
 268
 269 =head1 FURTHER QUESTIONS?
 270
 271 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
 272
 273 =head1 COPYRIGHT AND LICENSE
 274
 275 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
 276 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
 277 redistribute it and/or modify it under the same terms as the
 278 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.