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 See also the check
 226 L<DBIx::Class::Schema::SanityChecker/no_indirect_method_overrides>.
 227
 228 =head1 METHODS
 229
 230 =head2 MODIFY_CODE_ATTRIBUTES
 231
 232 See L<attributes/MODIFY_type_ATTRIBUTES>.
 233
 234 =head2 FETCH_CODE_ATTRIBUTES
 235
 236 See L<attributes/FETCH_type_ATTRIBUTES>. Always returns the combination of
 237 all attributes: both the free-form strings registered via the
 238 L<legacy system|/_attr_cache> and the DBIC-specific ones.
 239
 240 =head2 VALID_DBIC_CODE_ATTRIBUTE
 241
 242 =over
 243
 244 =item Arguments: $attribute_string
 245
 246 =item Return Value: ( true| false )
 247
 248 =back
 249
 250 This method is invoked when processing each DBIC-specific attribute (the ones
 251 starting with C<DBIC_>). An attribute is considered invalid and an exception
 252 is thrown unless this method returns a C<truthy> value.
 253
 254 =head2 _attr_cache
 255
 256 =over
 257
 258 =item Arguments: none
 259
 260 =item Return Value: B<purposefully undocumented>
 261
 262 =back
 263
 264 The legacy method of retrieving attributes declared on DBIC methods
 265 (L</FETCH_CODE_ATTRIBUTES> was not defined until mid-2016). This method
 266 B<does not return any DBIC-specific attributes>, and is kept for backwards
 267 compatibility only.
 268
 269 In order to query the attributes of a particular method use
 270 L<attributes::get()|attributes/get> as shown in the L</SYNOPSIS>.
 271
 272 =head1 FURTHER QUESTIONS?
 273
 274 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
 275
 276 =head1 COPYRIGHT AND LICENSE
 277
 278 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
 279 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
 280 redistribute it and/or modify it under the same terms as the
 281 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.