File Coverage

blib/lib/MooX/AttributeFilter.pm

Criterion	Covered	Total	%
statement	35	41	85.3
branch	6	6	100.0
condition	7	10	70.0
subroutine	9	9	100.0
pod			n/a
total	57	66	86.3

# ABSTRACT: Implements 'filter' option for Moo-class attributes


package MooX::AttributeFilter;
use v5.10;
use strictures 1;

our $VERSION = '0.003000'; # TRIAL

use Carp;
use Scalar::Util qw;
use Class::Method::Modifiers qw(install_modifier);
use Sub::Quote qw;
require Method::Generate::Accessor;

my %filterClasses;

sub _generate_filter_source {
    my $this = shift;
    my ( $me, $name, $spec, $source ) = @_;

    if ( $spec->{filter} && $spec->{filter_sub} ) {
        $this->{captures}{ '$filter_for_' . $name } = \$spec->{filter_sub};
        $source =
          $this->_generate_call_code( $name, 'filter', "${me}, ${source}",
            $spec->{filter_sub} );
    }

    return $source;
}

install_modifier "Method::Generate::Accessor", 'around', '_generate_core_set',
  sub {
    my $orig = shift;
    my $this = shift;
    my ( $me, $name, $spec, $source ) = @_;

    unless ( $spec->{".filter_dont_generate"} ) {
        $source = _generate_filter_source( $this, $me, $name, $spec, $source );
    }

    return $orig->( $this, $me, $name, $spec, $source );
  };

install_modifier "Method::Generate::Accessor", 'around', 'is_simple_set', sub {
    my $orig = shift;
    my $this = shift;
    my ( $name, $spec ) = @_;
    return $orig->( $this, @_ ) && !( $spec->{filter} && $spec->{filter_sub} );
};

install_modifier "Method::Generate::Accessor", 'around',
  '_generate_use_default', sub {
    my $orig = shift;
    my $this = shift;
    my ( $me, $name, $spec, $test ) = @_;

    # Prevent double generation for lazy attributes with default/builder.
    $spec->{'.filter_dont_generate'} = 1;
    return $orig->( $this, @_ );
  };

install_modifier "Method::Generate::Accessor", 'around',
  '_generate_get_default', sub {
    my $orig = shift;
    my $this = shift;
    my ( $me, $name, $spec ) = @_;

    my $default = $orig->( $this, $me, $name, $spec );

    return _generate_filter_source( $this, $me, $name, $spec, $default );
  };

install_modifier "Method::Generate::Accessor", 'around',
  '_generate_populate_set', sub {
    my $orig = shift;
    my $this = shift;
    my ( $me, $name, $spec, $source, $test, $init_arg ) = @_;
    local $spec->{".filter_dont_generate"} = 1;

    if ( !$this->has_eager_default( $name, $spec ) ) {
        $source = _generate_filter_source( $this, $me, $name, $spec, $source );
    }

    return $orig->( $this, $me, $name, $spec, $source, $test, $init_arg );
  };

install_modifier "Method::Generate::Accessor", 'around', '_generate_set', sub {
    my $orig = shift;
    my $this = shift;
    my ( $name, $spec ) = @_;
    local $spec->{".filter_dont_generate"} = 1;

    my $rc = $orig->( $this, @_ );

    return $rc unless $spec->{filter} && $spec->{filter_sub};

    my $capName = '$filter_for_' . $name;

    # Call to the filter was generated already.
    unless ( $this->{captures}{$capName} ) {

        # Work around Method::Generate::Accessor limitation: it predefines
        # source as being $_[1] only and not acceping any argument to define it
        # externally. For this purpose the only solution we have is to wrap it
        # into a sub and pass the filter as sub's argument.

        my $name_str = quotify $name;
        $rc = "sub { $rc }->( \$_[0], "
          . $this->_generate_call_code( $name, 'filter',
            "\$_[0], \$_[1], \$_[0]->{${name_str}}",
            $spec->{filter_sub} )
          . " )";
    }

    return $rc;
};

install_modifier "Method::Generate::Accessor", 'around', 'generate_method',
  sub {
    my $orig = shift;
    my $this = shift;
    my ( $into, $name, $spec, $quote_opts ) = @_;

    if ( $filterClasses{$into} && $spec->{filter} ) {

        #croak "Incompatibe 'is' option '$spec->{is}': can't install filter"
        #  unless $spec->{is} =~ /^(rwp?|ro)$/;

        my $filterSub;
        if ( $spec->{filter} eq 1 ) {
            $filterSub = "_filter_${name}";
        }
        else {
            $filterSub = $spec->{filter};
        }

        #        $spec->{filter} = 1;

        croak "Attribute '$name' filter option has invalid value"
          if ref($filterSub) && ref($filterSub) ne 'CODE';

        my $filterCode = ref($filterSub) ? $filterSub : $into->can($filterSub);

        croak
          "No filter method '$filterSub' defined for $into attribute '$name'"
          unless $filterCode;

        $spec->{filter_sub} = $filterCode;
    }

    return $orig->( $this, @_ );
  };

sub import {
    my ($class) = @_;
    my $target = caller;

    my $trait =
         Role::Tiny->can('is_role')
      && Role::Tiny->is_role($target)
      ? 'MooseX::AttributeFilter::Trait::Attribute::Role'
      : 'MooseX::AttributeFilter::Trait::Attribute';

    $filterClasses{$target} = 1;
    install_modifier $target, 'around', 'has', sub {
        my $orig = shift;
        my ( $attr, %opts ) = @_;
        return $orig->( $attr, %opts ) unless $opts{filter};
        $opts{moosify} ||= [];
        push @{ $opts{moosify} }, sub {
            my ($spec) = @_;
            require    # hide from CPANTS
              MooseX::AttributeFilter;
            $spec->{traits} ||= [];
            $spec->{bypass_filter_method_check} = 1;
            push @{ $spec->{traits} }, $trait;
        };
        $orig->( $attr, %opts );
    };
}

1;

__END__