Générer automatiquement des méthodes d'enveloppe d'attribut d'orignal

Question

Est-il possible de fournir un encapsuleur d'accesseur pour un attribut orignal sans avoir à l'écrire à chaque fois?

Exemple: * Il est un attribut de type TkRef * Il doit fournir une enveloppe pour régler la valeur * Le nom de l'emballage doit être défini lors de la définition de l'attribut * Je ne veux pas avoir pour écrire l'emballage

J'imagine comme ceci:

has _some_val => (
    is => 'rw', 
    isa => 'TkRef', 
    coerce => 1, 
    init_arg => 'my_accessor_wrapper_name', 
    default => 'default value' 
); 

# Later in the class: 
sub some_public_method { 
    my $self = shift; 
    # will set _some_val behind the scenes: 
    $self->my_accessor_wrapper_name('this will be the new value'); 
    ... 
} 

Answer 1

Je suppose ici que ce fait suite à your previous question si le but est d'envelopper un des accesseurs d'attributs de scalarref pour faire en sorte que lorsque le poseur est appelé avec un nouveau ScalarRef (ou quelque chose qui peut être contraint dans un ScalarRef), plutôt que l'action set habituelle, vous copiez la chaîne stockée dans le nouveau scalaire dans l'ancien scalaire.

Il existe des moyens plus faciles à faire que ci-dessous (par exemple, en écrivant une enveloppe pour has), mais je pense que c'est le « plus ramure »:

use 5.010; 
use strict; 
use warnings; 

{ 
    package MooseX::Traits::SetScalarByRef; 
    use Moose::Role; 
    use Moose::Util::TypeConstraints qw(find_type_constraint); 

    # Supply a default for "is" 
    around _process_is_option => sub 
    { 
     my $next = shift; 
     my $self = shift; 
     my ($name, $options) = @_; 

     if (not exists $options->{is}) 
     { 
      $options->{is} = "rw"; 
     } 

     $self->$next(@_); 
    }; 

    # Supply a default for "isa" 
    my $default_type; 
    around _process_isa_option => sub 
    { 
     my $next = shift; 
     my $self = shift; 
     my ($name, $options) = @_; 

     if (not exists $options->{isa}) 
     { 
      if (not defined $default_type) 
      { 
       $default_type = find_type_constraint('ScalarRef') 
        ->create_child_constraint; 
       $default_type 
        ->coercion('Moose::Meta::TypeCoercion'->new) 
        ->add_type_coercions('Value', sub { my $r = $_; \$r }); 
      } 
      $options->{isa} = $default_type; 
     } 

     $self->$next(@_); 
    }; 

    # Automatically coerce 
    around _process_coerce_option => sub 
    { 
     my $next = shift; 
     my $self = shift; 
     my ($name, $options) = @_; 

     if (defined $options->{type_constraint} 
     and $options->{type_constraint}->has_coercion 
     and not exists $options->{coerce}) 
     { 
      $options->{coerce} = 1; 
     } 

     $self->$next(@_); 
    }; 

    # This allows handles => 1 
    around _canonicalize_handles => sub 
    { 
     my $next = shift; 
     my $self = shift; 

     my $handles = $self->handles; 
     if (!ref($handles) and $handles eq '1') 
     { 
      return ($self->init_arg, 'set_by_ref'); 
     } 

     $self->$next(@_); 
    }; 

    # Actually install the wrapper 
    around install_delegation => sub 
    { 
     my $next = shift; 
     my $self = shift; 

     my %handles = $self->_canonicalize_handles; 
     for my $key (sort keys %handles) 
     { 
      $handles{$key} eq 'set_by_ref' or next; 
      delete $handles{$key}; 
      $self->associated_class->add_method($key, $self->_make_set_by_ref($key)); 
     } 

     # When we call $next, we're going to temporarily 
     # replace $self->handles, so that $next cannot see 
     # the set_by_ref bits which were there. 
     my $orig = $self->handles; 
     $self->_set_handles(\%handles); 
     $self->$next(@_); 
     $self->_set_handles($orig); # and restore! 
    }; 

    # This generates the coderef for the method that we're 
    # going to install 
    sub _make_set_by_ref 
    { 
     my $self = shift; 
     my ($method_name) = @_; 

     my $reader = $self->get_read_method; 
     my $type = $self->type_constraint; 
     my $coerce = $self->should_coerce; 

     return sub { 
      my $obj = shift; 
      if (@_) 
      { 
       my $new_ref = $coerce 
        ? $type->assert_coerce(@_) 
        : do { $type->assert_valid(@_); $_[0] }; 
       ${$obj->$reader} = $$new_ref; 
      } 
      $obj->$reader; 
     }; 
    } 
} 

{ 
    package Local::Example; 
    use Moose; 
    use Moose::Util::TypeConstraints; 

    subtype 'TkRef', as 'ScalarRef'; 
    coerce 'TkRef', from 'Str', via { my $r = $_; return \$r }; 

    has _some_val => (
     traits => [ 'MooseX::Traits::SetScalarByRef' ], 
     isa  => 'TkRef', 
     init_arg => 'some_val', 
     default => 'default value', 
     handles => 1, 
    ); 
} 

use Scalar::Util qw(refaddr); 

my $eg = Local::Example->new; 
say refaddr($eg->some_val); 

$eg->some_val("new string"); 
say refaddr($eg->some_val), " - should not have changed"; 

say ${ $eg->some_val };