Automatically generate moose attribute wrapper methods - perl

Question

Is is possible to supply an accessor wrapper for a moose attribute without having to write it every time?
Example:
* There is an an attribute of type TkRef
* It should provide a wrapper for setting the value
* The name of the wrapper should be defined when defining the attribute
* I don't want to have to write the wrapper
I imagine it like this:
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

I'm assuming here that this follows on from your previous question so the aim is to wrap a ScalarRef attribute's accessors to ensure that when the setter is called with a new ScalarRef (or something that can be coerced into a ScalarRef), rather that the usual set action happening, you copy the string stored in the new scalar into the old scalar.
There are easier ways to do this than below (say, by writing a wrapper for has), but I think this is the "most antlered":
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 };