Can I do this in Moose?
package SomeClass;
use Moose;
has start => (
isa => 'Int',
is => 'ro',
lazy => 1,
default => sub { $_[0]->end },
);
has end => (
isa => 'Int',
is => 'ro',
lazy => 1,
default => sub { $_[0]->start },
);
...
In other words, I want two attributes called "start" and "end", and if only one of them is specified, I want the other one to be set to the same thing. Not specifying either one is an error.
Does this mutually-dependent setup work?
Yes, if you remove the possibility of infinite recursion by verifying that at least one of these values is specified:
has start => (
...
predicate => 'has_start',
);
has end => (
...
predicate => 'has_end',
);
sub BUILD
{
my $self = shift;
die "Need to specify at least one of 'start', 'end'!" if not $self->has_start and not $self->has_end;
}
Alternatively, you could delay the check to the default subs:
has start => (
...
predicate => 'has_start',
default => sub {
my $self = shift;
die "Need to specify at least one of 'start', 'end'!" if not $self->has_end;
$self->end;
},
);
has end => (
...
predicate => 'has_end',
default => sub {
my $self = shift;
die "Need to specify at least one of 'start', 'end'!" if not $self->has_start;
$self->start;
},
);
Personally, I'd take advantage of laziness to ensure that I didn't get caught in an infinite recursion:
has start => (
is => 'ro',
isa => 'Int',
lazy => 1,
default => sub { shift->end },
predicate => 'has_start',
);
has end => (
is => 'ro',
isa => 'Int',
lazy => 1,
default => sub { shift->start },
predicate => 'has_end',
);
sub BUILD {
my $self = shift;
die "Need to specify at least one of 'start', 'end'!"
unless $self->has_start || $self->has_end;
}
Related
Here hash2 attribute is dependent on hash1. infact, hash2 is driven by hash1. for example,
hash1 -> key1 => value1, key2 => value2 etc..
hash2 -> key1 => 6, key2 => 6 etc. it is length(value from hash1, going to hash2)
Tried something like below, but not helpful.
has 'hash1' => (
is => 'rw',
isa => 'HashRef[Str]',
default => sub { {} },
handles => {
map { $_ . '_hash1' => $_ } #hash_delegations
},
);
has 'hash2' => (
is => 'rw',
isa => 'HashRef',
builder => '_filter_hash1',
handles => {
map { $_ . 'hash2' => $_ } #hash_delegations
},
);
sub _filter_hash1 {
my $self = shift;
for my $alias ($self->keys_hash1()) {
return {$alias, length($alias)};
}
}
Hash1 is going to set over time, not sure how to make sure that how should I capture the event on hash1 to update the entry in the hash2. Any idea how can I achieve this ?
Are you trying to create a cache of value lengths? In practice, length is so fast you don't need to cache it, but it might be just a simplified example of something more complex. I'd use a trigger, plus a trait on the first hash to enforce setting the value via a method. Changing the hash value directly wouldn't trigger the change in the other attribute.
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
{ package My::Object;
use Moose;
my #hash_delegations = qw( keys );
has 'hash1' => (
is => 'rw',
isa => 'HashRef[Str]',
default => sub { {} },
trigger => \&_update_hash2,
traits => ['Hash'],
handles => { set_hash1 => 'set' },
);
has 'hash2' => (
is => 'ro',
writer => '_set_hash2',
isa => 'HashRef',
);
sub _update_hash2 {
my ($self, $new, $old) = #_;
$self->_set_hash2({ map { $_ => length $self->hash1->{$_} }
keys %{ $self->hash1 }});
}
}
my $o = 'My::Object'->new(hash1 => {a => 42, b => 'Universe'});
say $o->hash2->{$_} for qw( a b );
$o->set_hash1(c => '0123456789');
say $o->hash2->{c};
$o->hash1->{c} = ""; # Wrong!
say $o->hash2->{c}; # Didn't change :-(
Here's an example which uses read-only hashes with triggers and method modifiers...
package MyApp;
use Z qw( Dumper );
use Hash::Util qw( unlock_ref_keys lock_ref_keys );
class '::My::Object' => sub {
my %common = (
is => 'rw',
isa => HashRef[Str],
trigger => sub { lock_ref_keys($_[1]) },
default => sub { lock_ref_keys(my $ref = {}); $ref },
handles_via => 'Hash',
);
has hash1 => (
%common,
handles => [
'set_hash1' => 'set',
'get_hash1' => 'get',
],
);
has hash2 => (
%common,
isa => HashRef[Int],
handles => [
'set_hash2' => 'set',
'get_hash2' => 'get',
],
);
around set_hash1 => sub {
my ( $next, $self, $key, $val ) = ( shift, shift, #_ );
unlock_ref_keys( $self->hash1 );
unlock_ref_keys( $self->hash2 );
my $r = $self->$next( #_ );
$self->set_hash2( $key, length($val) );
lock_ref_keys( $self->hash1 );
lock_ref_keys( $self->hash2 );
return $r;
};
method BUILD => sub {
my ( $self, $args ) = #_;
if ( my $h1 = $args->{hash1} ) {
$self->set_hash1( $_, length $h1->{$_} ) for keys %$h1;
}
};
};
my $obj = 'My::Object'->new(
hash1 => { foo => 'xyzzy' },
);
$obj->set_hash1('bar', 'quux');
print Dumper($obj);
I would like to be able to declare one of a set of mutually dependent attributes required.
Let's assume a simple example of Number 'nr_two' being 'nr_one' + 1, and 'nr_one' being 'nr_two' -1, with one of either having to be passed in upon initialization.
So far, I have seen this problem solved for example through BUILDARGS checks and a lazy builder on each:
has 'nr_one' => (
is => 'ro',
isa => 'Num',
lazy => 1,
builder => '_build_nr_one',
);
sub _build_nr_one { shift->nr_two - 1; }
has 'nr_two' => (
is => 'ro',
isa => 'Num',
lazy => 1,
builder => '_build_nr_two',
);
sub _build_nr_two { shift->nr_one + 1; }
around 'BUILDARGS' => sub {
my $orig = shift;
my $self = shift;
my $args = is_hashref($_[0])? $_[0] : { #_ };
die "Either nr_one or nr_two is required!" unless defined $args{nr_one} || defined $args{nr_two};
return $self->$orig($args);
};
Or, avoiding the around:
has 'nr_one' => (
is => 'ro',
isa => 'Num',
predicate => 'has_nr_one',
lazy => 1,
builder => '_build_nr_one',
);
sub _build_nr_one { shift->nr_two - 1; }
has 'nr_two' => (
is => 'ro',
isa => 'Num',
predicate => 'has_nr_two',
lazy => 1,
builder => '_build_nr_two',
);
sub _build_nr_two { shift->nr_one + 1; }
sub BUILD {
my $self = shift;
die "Either nr_one or nr_two is required!" unless $self->has_nr_one || $self->has_nr_two;
}
However, I am looking for something that can be declared on the attributes,
for example a grouping of some sort that can then be introspected and, for example, triggered in BUILD.
Ideally, I'd like to ship this into a generic role or Meta class to make it available
with some sort of nicer syntax, to avoid having to check for BUILD(ARGS) checks
or rely on the pod to declare things accurately.
Is there cpan module that could help with this, or a pattern someone is aware of to achieve this?
Any hints / partial solutions are appreciated, if not :)
An example of what I would imagine would look something like this:
has 'nr_one' => (
is => 'ro',
isa => 'Num',
lazy => 1,
builder => '_build_nr_one',
required_grouping => 'NumberGroup',
);
sub _build_nr_one { shift->nr_two - 1; }
has 'nr_two' => (
is => 'ro',
isa => 'Num',
lazy => 1,
builder => '_build_nr_two',
required_grouping => 'NumberGroup',
);
sub _build_nr_two { shift->nr_one + 1; }
# when initialized without any attributes, error thrown:
# "One of 'nr_one', 'nr_two' is required"
# or, probably easier: "NumberGroup required!"
I did not find a way to make a custom MooseX::Type or attribute trait automatically add a method modifier to BUILDARGS() that would validate the attributes. But it is simple to do that with a Moose::Role like this:
#! /usr/bin/env perl
package NumberGroup;
use Moose::Role;
around 'BUILDARGS' => sub {
my $orig = shift;
my $self = shift;
my $args = (ref $_[0]) eq "HASH" ? $_[0] : { #_ };
die "Either nr_one or nr_two is required!" unless defined $args->{nr_one} || defined $args->{nr_two};
return $self->$orig($args);
};
package Main;
use Moose;
with 'NumberGroup';
has 'nr_one' => (
is => 'ro',
isa => 'Num',
);
has 'nr_two' => (
is => 'ro',
isa => 'Num',
);
package main;
use strict;
use warnings;
Main->new();
Output:
Either nr_one or nr_two is required! at ./p.pl line 8.
I'm dealing with some non-Moose legacy code and I want to extend it with a Moose class. This is a simplification of the legacy code:
package My::Legacy;
sub create {
my ($class, $args) = #_;
my $fields = { _fields => {}};
foreach my $key ( keys %$args ) {
$fields->{_fields}->{$key} = $args->{$key}
}
bless $fields, $class;
}
1;
The My::Legacy class handles all the CRUD operations, caching and other stuff. All the operations are performed on the values contained in the internal _field hash, so, for example, if you want to update a value it has to be in the _field hash. The My::Legacy class provides setter/getter for this.
The My::Legacy is subclassed by several classes that need the "sugar" provided by it: My::Legacy::ObjectA, My::Legacy::ObjectB, etc.
I need to add a further one and I want to extend it using Moose. The problem is that every time I will set an attribute, I will have to keep its value in sync in the internal _fields hash, so for example if I have...
package My::Legacy::MyMooseObj;
use Moose;
use MooseX::NonMoose;
use namespace::autoclean;
has _fields => (
isa => HashRef,
is => 'rw',
default => sub { {} },
);
has attr_a => (
isa => 'Int',
is => 'ro',
);
has attr_b => (
isa => 'Str',
is => 'ro',
);
__PACKAGE__->meta->make_immutable;
...and I do:
my $MyMooseObj = My::Legacy::MyMooseObj->new();
$MyMooseObj->attr_a(15);
...I want attr_a to be set in _fields as well, so if I dump out the object it will look like:
bless( {
'_fields' => {
'attr_a' => 15,
},
'attr_a' => 15,
}, 'My::Legacy::MyMooseObj' );
The way I come up to achieve this is add a trigger to each attribute in order to write its value in the _fields hash every time is set:
has attr_b => (
isa => 'Str',
is => 'ro',
trigger => sub { # Write in the _fields attribute attr_b value! },
);
This is a bit annoying because every time I add a new attribute I have to make sure it has the trigger set :/
Can you think of a better way of doing it ? Is there any way of telling Moose to read/write the attribute not in the "root" of the object hash by default (so in my case to read/write attributes from _fields) ?
This more or less does what you want...
use strict;
use warnings;
{
package My::Legacy::MyMooseObj;
use Moose;
use MooseX::FunkyAttributes;
use namespace::autoclean;
has _fields => (
isa => 'HashRef',
is => 'rw',
default => sub { {} },
lazy => 1, # you want this, for the rest to work
);
has attr_a => (
isa => 'Int',
is => 'ro',
traits => [ FunkyAttribute ],
custom_get => sub { $_->_fields->{attr_a} },
custom_set => sub { $_->_fields->{attr_a} = $_[-1] },
custom_has => sub { exists($_->_fields->{attr_a}) },
);
has attr_b => (
isa => 'Str',
is => 'rw',
traits => [ FunkyAttribute ],
custom_get => sub { $_->_fields->{attr_b} },
custom_set => sub { $_->_fields->{attr_b} = $_[-1] },
custom_has => sub { exists($_->_fields->{attr_b}) },
);
}
my $obj = My::Legacy::MyMooseObj->new( attr_a => 42 );
$obj->attr_b(666);
print $obj->dump;
With the current version of MooseX::FunkyAttributes, the constructor will not work correctly if you do the whole __PACKAGE__->meta->make_immutable though. :-(
Delving slightly deeper into metaprogramming...
use strict;
use warnings;
{
package My::Legacy::MyMooseObj;
use Moose;
use MooseX::FunkyAttributes;
use namespace::autoclean;
has _fields => (
isa => 'HashRef',
is => 'rw',
default => sub { {} },
lazy => 1, # you want this, for the rest to work
);
sub funky_has {
my ($attr, %opts) = #_;
has $attr => (
is => 'ro',
traits => [ FunkyAttribute ],
custom_get => sub { $_->_fields->{$attr} },
custom_set => sub { $_->_fields->{$attr} = $_[-1] },
custom_has => sub { exists($_->_fields->{$attr}) },
%opts,
);
}
funky_has attr_a => (isa => 'Int');
funky_has attr_b => (isa => 'Str', is => 'rw');
}
my $obj = My::Legacy::MyMooseObj->new( attr_a => 42 );
$obj->attr_b(666);
print $obj->dump;
In the Moose Extension I'm writing I'm trying to access the attributes value from within the attribute, without going through the accessor, but I can't seem to get this right.
I'm trying to be able to write this code
{
package Test;
use Moose;
use MooseX::RemoteName; #provides magic
has attr0 => (
isa => 'Bool',
is => 'ro',
default => sub { 1 },
serializer => sub {
my $s = shift;
return $s->get_value( $s ) ? 'Y' : 'N';
},
);
has attr1 => (
isa => 'Str',
is => 'ro',
)
}
so that I can then do (from my test)
my $t0 = Test->new({ attr1 => 'foo' });
isa_ok my $attr0 = $t0->meta->get_attribute('attr0'), 'Class::MOP::Attribute';
is $attr0->serialized, 'Y', 'remote_name serializes';
isa_ok my $attr1 = $t0->meta->get_attribute('attr1'), 'Class::MOP::Attribute';
is $attr1->serialized, 'foo', 'remote_name serializes'; # undef
This is what I'm trying in the extension
has serializer => (
isa => 'CodeRef',
is => 'ro',
lazy => 1,
default => sub {
return sub {
my $arg = shift;
return $arg->get_value( $arg->associated_class );
}
},
);
sub serialized {
my $self = shift;
my $coderef = $self->serializer;
return &$coderef( $self );
}
my problems appear to be two fold, my anonymous subroutines weren't done right, and I needed to pass the instance of the object to the anonymous subroutine.
This seems to be working in my Moose Extension
has serializer => (
predicate => 'has_serializer',
traits => ['Code'],
is => 'ro',
default => sub {
return sub {
my ( $self, $instance ) = #_;
return $self->get_value( $instance );
}
},
handles => {
serializing => 'execute_method',
},
);
sub serialized {
my ( $self, $instance ) = #_;
return $self->serializing( $instance );
}
which then allows me to write the following (slightly different)
package Test;
use Moose;
use MooseX::RemoteName;
has attr0 => (
isa => 'Bool',
is => 'ro',
lazy => 1,
default => sub { 1 },
serializer => sub {
my ( $attr, $instance ) = #_;
return $attr->get_value( $instance ) ? 'Y' : 'N';
},
);
which will pass this test without issue
subtest t0 => sub {
my $t = Test->new;
is $t->attr0, 1, 'attr0 is 1';
isa_ok my $attr0 = $t->meta->get_attribute('attr0'), 'Class::MOP::Attribute';
is $attr0->serialized( $t ), 'Y', 'attr0 serializes';
isa_ok $t, 'Test';
};
I think I can live passing the instance in, though I'm not entirely sure why get_value needs that.
This could seem like an obviously hopeless case, but is there a trick to create a cyclic graph of immutable objects in Perl? Something like this:
package Node;
use Moose;
has [qw/parent child/] => (is => 'ro', isa => 'Node');
package main;
my $a = Node->new;
my $b = Node->new(parent => $a);
Now if I wanted $a->child to point to $b, what can I do?
You could play games with lazy initialization:
package Node;
use Moose;
has parent => (
is => 'ro',
isa => 'Node',
lazy => 1,
init_arg => undef,
builder => '_build_parent',
);
has _parent => (
is => 'ro',
init_arg => 'parent',
);
has child => (
is => 'ro',
isa => 'Node',
lazy => 1,
init_arg => undef,
builder => '_build_child',
);
has _child => (
is => 'ro',
init_arg => 'child',
predicate => undef,
);
has name => is => 'ro', isa => 'Str';
Generate the builders and predicates on the fly:
BEGIN {
for (qw/ parent child /) {
no strict 'refs';
my $squirreled = "_" . $_;
*{"_build" . $squirreled} = sub {
my($self) = #_;
my $proto = $self->$squirreled;
ref $proto eq "REF" ? $$proto : $proto;
};
*{"has" . $squirreled} = sub {
my($self) = #_;
defined $self->$squirreled;
};
}
}
This allows
my $a = Node->new(parent => \my $b, name => "A");
$b = Node->new(child => $a, name => "B");
for ($a, $b) {
print $_->name, ":\n";
if ($_->has_parent) {
print " - parent: ", $_->parent->name, "\n";
}
elsif ($_->has_child) {
print " - child: ", $_->child->name, "\n";
}
}
Its output is
A:
- parent: B
B:
- child: A
The code could be more elegant with η-conversion, but Moose won't pass parameters to builder methods.
I had to go and look at how really immutable languages do something like
this, and I think the following is probably a reasonable attempt.
use 5.10.0;
{
package Node;
use Moose;
has [qw(parent child)] => ( isa => 'Node', is => 'ro' );
sub BUILD {
my ( $self, $p ) = #_;
return unless exists $p->{_child};
my $child = Node->new( parent => $self, %{ delete $p->{_child} }, );
$self->meta->get_attribute('child')->set_value( $self, $child );
}
}
say Node->new( _child => {} )->dump
Basically instead of trying to build the objects separately, you have
the parent auto-vivify the child based on passing in it's arguments. The
output for this is, which is I believe the structure you were wanting.
$VAR1 = bless( {
'child' => bless( {
'parent' => $VAR1
}, 'Node' )
}, 'Node' );
I'm still very new to Moose, but would a trigger work?
use Modern::Perl;
package Node;
use Moose;
has 'parent' => (
is => 'ro',
isa => 'Node',
trigger => sub{
my ($self, $parent) = #_;
$parent->{child} = $self unless defined $parent->child;
}
);
has 'child' => (
is => 'ro',
isa => 'Node',
trigger => sub{
my ($self, $child) = #_;
$child->{parent} = $self unless defined $child->parent;
}
);
package main;
my $p = Node->new;
my $c = Node->new(parent => $p);
say $p, ' == ', $c->parent;
say $c, ' == ', $p->child;