File Coverage

blib/lib/DBIx/Class/MethodAttributes.pm

Criterion	Covered	Total	%
statement	49	59	83.0
branch	29	42	69.0
condition	4	8	50.0
subroutine	10	12	83.3
pod	1	1	100.0
total	93	122	76.2

package DBIx::Class::MethodAttributes;

use strict;
use warnings;

use DBIx::Class::_Util qw( uniq refdesc visit_namespaces );
use Scalar::Util qw( weaken refaddr );

use namespace::clean;

my ( $attr_cref_registry, $attr_cache_active );
sub DBIx::Class::__Attr_iThreads_handler__::CLONE {

  # This is disgusting, but the best we can do without even more surgery
  # Note the if() at the end - we do not run this crap if we can help it
  visit_namespaces( action => sub {
    my $pkg = shift;

    # skip dangerous namespaces
    return 1 if $pkg =~ /^ (?:
      DB | next | B | .+? ::::ISA (?: ::CACHE ) | Class::C3
    ) $/x;

    no strict 'refs';

    if (
      exists ${"${pkg}::"}{__cag___attr_cache}
        and
      ref( my $attr_stash = ${"${pkg}::__cag___attr_cache"} ) eq 'HASH'
    ) {
      $attr_stash->{ $attr_cref_registry->{$_}{weakref} } = delete $attr_stash->{$_}
        for keys %$attr_stash;
    }

    return 1;
  }) if $attr_cache_active;

  # renumber the cref registry itself
  %$attr_cref_registry = map {
    ( defined $_->{weakref} )
      ? (
        # because of how __attr_cache works, ugh
        "$_->{weakref}"         => $_,
      )
      : ()
  } values %$attr_cref_registry;
}

sub MODIFY_CODE_ATTRIBUTES {
  my $class = shift;
  my $code = shift;

  my $attrs;
  $attrs->{
    $_ =~ /^[a-z]+$/  ? 'builtin'
  : $_ =~ /^DBIC_/    ? 'dbic'
  :                     'misc'
  }{$_}++ for @_;


  # compaction step
  defined $attr_cref_registry->{$_}{weakref} or delete $attr_cref_registry->{$_}
    for keys %$attr_cref_registry;

  # The original misc-attr API used stringification instead of refaddr - can't change that now
  if( $attr_cref_registry->{$code} ) {
    Carp::confess( sprintf
      "Coderefs '%s' and '%s' stringify to the same value '%s': nothing will work",
      refdesc($code),
      refdesc($attr_cref_registry->{$code}{weakref}),
      "$code"
    ) if refaddr($attr_cref_registry->{$code}{weakref}) != refaddr($code);
  }
  else {
    weaken( $attr_cref_registry->{$code}{weakref} = $code )
  }


  # increment the pkg gen, this ensures the sanity checkers will re-evaluate
  # this class when/if the time comes
  mro::method_changed_in($class) if (
    ! DBIx::Class::_ENV_::OLD_MRO
      and
    ( $attrs->{dbic} or $attrs->{misc} )
  );


  # handle legacy attrs
  if( $attrs->{misc} ) {

    # if the user never tickles this - we won't have to do a gross
    # symtable scan in the ithread handler above, so:
    #
    # User - please don't tickle this
    $attr_cache_active = 1;

    $class->mk_classaccessor('__attr_cache' => {})
      unless $class->can('__attr_cache');

    $class->__attr_cache->{$code} = [ sort( uniq(
      @{ $class->__attr_cache->{$code} || [] },
      keys %{ $attrs->{misc} },
    ))];
  }


  # handle DBIC_* attrs
  if( $attrs->{dbic} ) {
    my $slot = $attr_cref_registry->{$code};

    $slot->{attrs} = [ uniq
      @{ $slot->{attrs} || [] },
      grep {
        $class->VALID_DBIC_CODE_ATTRIBUTE($_)
          or
        Carp::confess( "DBIC-specific attribute '$_' did not pass validation by $class->VALID_DBIC_CODE_ATTRIBUTE() as described in DBIx::Class::MethodAttributes" )
      } keys %{$attrs->{dbic}},
    ];
  }


  # FIXME - DBIC essentially gobbles up any attribute it can lay its hands on:
  # decidedly not cool
  #
  # There should be some sort of warning on unrecognized attributes or
  # somesuch... OTOH people do use things in the wild hence the plan of action
  # is anything but clear :/
  #
  # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/lib/DBIx/Class/Service.pm#L93-110
  # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L29
  # https://metacpan.org/source/ZIGOROU/DBIx-Class-Service-0.02/t/lib/DBIC/Test/Service/User.pm#L36
  #
  # For the time being reuse the old logic for any attribute we do not have
  # explicit plans for (i.e. stuff that is neither reserved, nor DBIC-internal)
  #
  # Pass the "builtin attrs" onwards, as the DBIC internals can't possibly  handle them
  return sort keys %{ $attrs->{builtin} || {} };
}

# Address the above FIXME halfway - if something (e.g. DBIC::Helpers) wants to
# add extra attributes - it needs to override this in its base class to allow
# for 'return 1' on the newly defined attributes
sub VALID_DBIC_CODE_ATTRIBUTE {
  #my ($class, $attr) = @_;

###
### !!! IMPORTANT !!!
###
### *DO NOT* yield to the temptation of using free-form-argument attributes.
### The technique was proven instrumental in Catalyst a decade ago, and
### was more recently revived in Sub::Attributes. Yet, while on the surface
### they seem immensely useful, per-attribute argument lists are in fact an
### architectural dead end.
###
### In other words: you are *very strongly urged* to ensure the regex below
### does not allow anything beyond qr/^ DBIC_method_is_ [A-Z_a-z0-9]+ $/x
###

  $_[1] =~ /^ DBIC_method_is_ (?:
    indirect_sugar
      |
    (?: bypassable | mandatory ) _resultsource_proxy
      |
    generated_from_resultsource_metadata
      |
    (?: inflated_ | filtered_ )? column_ (?: extra_)? accessor
      |
    single_relationship_accessor
      |
    (?: multi | filter ) _relationship_ (?: extra_ )? accessor
      |
    proxy_to_relationship
      |
    m2m_ (?: extra_)? sugar (?:_with_attrs)?
  ) $/x;
}

sub FETCH_CODE_ATTRIBUTES {
  #my ($class,$code) = @_;

  sort(
    @{ $_[0]->_attr_cache->{$_[1]} || [] },
    ( defined( $attr_cref_registry->{$_[1]}{ weakref } )
      ? @{ $attr_cref_registry->{$_[1]}{attrs} || [] }
      : ()
    ),
  )
}

sub _attr_cache {
  my $self = shift;
  +{
    %{ $self->can('__attr_cache') ? $self->__attr_cache : {} },
    %{ $self->maybe::next::method || {} },
  };
}

1;

__END__