Moose how to change the attribute value only when it is $undef? - perl

Now have:
has 'id' => (
is => 'rw',
isa => 'Str',
default => sub { "id" . int(rand(1000))+1 }
);
Works OK, the:
PKG->new(id => 'some'); #the id is "some"
PKG->new() #the id is #id<random_number>
In the next scenario:
my $value = undef;
PKG->new(id => $value);
(of course) got an error:
Attribute (id) does not pass the type constraint because: Validation failed for 'Str' with value undef at /Users/me/perl5/perlbrew/perls/perl-5.16.3/lib/site_perl/5.16.3/darwin-thread-multi-2level/Moose/Exception.pm line 37
The question is:
How to achieve changing the value after it is set to undef (and only when it is $undef)? So,
has 'id' => (
is => 'rw',
isa => 'Str|Undef', #added undef to acceptable Type
default => sub { "id" . int(rand(1000))+1 }
);
Now, it accepting the $undef, but I don't want $undef but want "id" . int(rand(1000))+1. How to change the attribute value after it is set?
The after is called only for the accessors not for constructors. Maybe some weird coercion from Undef to Str - but only for this one attribute?
Ps: using the PKG->new( id => $value // int(rand(10000)) ) is not an acceptable solution. The module should accept the $undef and should silently change it to the random number.

Type::Tiny has as one of its aims to make it easy to add coercions to individual attributes really easy. Here's an example:
use strict;
use warnings;
{
package Local::Test;
use Moose;
use Types::Standard qw( Str Undef );
my $_id_default = sub { "id" . int(rand(1000)+1) };
has id => (
is => 'rw',
isa => Str->plus_coercions(Undef, $_id_default),
default => $_id_default,
coerce => 1,
);
__PACKAGE__->meta->make_immutable;
}
print Local::Test->new(id => 'xyz123')->dump;
print Local::Test->new(id => undef)->dump;
print Local::Test->new->dump;
You could also look at MooseX::UndefTolerant which makes undef values passed to the constructor act as if they were entirely omitted. This won't cover passing undef to accessors though; just constructors.

Here is an alternative, using Moose' BUILD method, which is called after an object is created.
#!/usr/bin/perl
package Test;
use Moose;
has 'id' => (
is => 'rw',
isa => 'Str|Undef',
);
sub BUILD {
my $self = shift;
unless($self->id){
$self->id("id" . (int(rand(1000))+1));
}
}
1;
package Main;
my $test = Test->new(id => undef);
print $test->id; ###Prints random number if id=> undef
More info on BUILD here:
http://metacpan.org/pod/Moose::Manual::Construction#BUILD

#choroba in a comment mentioned about the triggers. Based on this, found a next solution. The trigger is called twice in the case id=>undef, but otherwise it works.
use Modern::Perl;
package My;
use namespace::sweep;
use Moose;
my $_id_default = sub { "id" . int(rand(100_000_000_000)+1) };
my $_check_id = sub { $_[0]->id(&$_id_default) unless $_[1] };
has id => (
is => 'rw',
isa => 'Str|Undef',
default => $_id_default,
trigger => $_check_id,
);
__PACKAGE__->meta->make_immutable;
package main;
say My->new->id;
say My->new(id=>'aaa')->id;
say My->new(id=>undef)->id;

Related

How can I provide an alternate init arg for an attribute in Moose?

I of course know that I can rename the init arg for an attribute by setting init_arg (e.g)
package Test {
use Moose;
has attr => (
is => 'ro',
isa => 'Str',
init_arg => 'attribute'
);
}
which would allow me to
Test->new({ attribute => 'foo' });
but not
Test->new({ attr => 'foo' });
at the same time
MooseX::Aliases actually has this behavior, but creating an alias also creates accessors. I'm currently trying to understand the code in that module to see if I can't determine how it does it, so that I can replicate said functionality (in a way I understand). If someone could explain how to do it here with an example that'd be great.
update it appears that MX::Aliases is doing this by way of replacing what's actually passed to the constructor in an around initialize_instance_slot but I'm still not sure how that's actually getting called, because in my test code my around isn't actually getting executed.
update munging in BUILDARGS isn't really an option because what I'm trying to do allow setting of the accessor via the name of the label I'm adding to the attribute via Meta Recipe3. You might say I'm doing
has attr => (
is => 'ro',
isa => 'Str',
alt_init_arg => 'attribute'
);
update
here's what I've managed to work out with what I'm trying to do so far.
use 5.014;
use warnings;
package MooseX::Meta::Attribute::Trait::OtherName {
use Moose::Role;
use Carp;
has other_name => (
isa => 'Str',
predicate => 'has_other_name',
required => 1,
is => 'ro',
);
around initialize_instance_slot => sub {
my $orig = shift;
my $self = shift;
my ( $meta_instance, $instance, $params ) = #_;
confess 'actually calling this code';
return $self->$orig(#_)
unless $self->has_other_name && $self->has_init_arg;
if ( $self->has_other_name ) {
$params->{ $self->init_arg }
= delete $params->{ $self->other_name };
}
};
}
package Moose::Meta::Attribute::Custom::Trait::OtherName {
sub register_implementation { 'MooseX::Meta::Attribute::Trait::OtherName' }
}
package Message {
use Moose;
# use MooseX::StrictConstructor;
has attr => (
traits => [ 'OtherName' ],
is => 'ro',
isa => 'Str',
other_name => 'Attr',
);
__PACKAGE__->meta->make_immutable;
}
package Client {
use Moose;
sub serialize {
my ( $self, $message ) = #_;
confess 'no message' unless defined $message;
my %h;
foreach my $attr ( $message->meta->get_all_attributes ) {
if (
$attr->does('MooseX::Meta::Attribute::Trait::OtherName')
&& $attr->has_other_name
) {
$h{$attr->other_name} = $attr->get_value( $message );
}
}
return \%h;
}
__PACKAGE__->meta->make_immutable;
}
my $message = Message->new( Attr => 'foo' );
my $ua = Client->new;
my %h = %{ $ua->serialize( $message )};
use Data::Dumper::Concise;
say Dumper \%h
problem is that my around block is never being run and I'm not sure why, maybe I'm wrapping it in the wrong place or something.
MooseX::Aliases has several moving parts to make this functionality happen, that's because the behavior needs to be applied to several different places in the MOP. Your code here looks very close to the code in MooseX::Aliases's Trait attribute.
I suspect the reason your code isn't being called is due to something going wrong when you try to register your trait. MooseX::Aliases uses Moose::Util::meta_attribute_alias rather than the old fashioned way you're using here. Try replacing your Moose::Meta::Attribute::Custom::Trait::OtherName section with a call to Moose::Util::meta_attribute_alias 'OtherName'; inside your Role.
Second the code you have here won't work for immutable classes. You'll need to add a second trait to handle those because the immutability code is handled by the class's metaclass and not the attribute's metaclass. You'll need to add some more traits to handle attributes in Roles as well I think. Then you'll need to wire up an Moose::Exporter to make sure that all the traits are applied properly when everything is compiled.
I've gotten a simple version of this working up through immutable. This code is also on github.
First the Attribute trait:
package MooseX::AltInitArg::Meta::Trait::Attribute;
use Moose::Role;
use namespace::autoclean;
Moose::Util::meta_attribute_alias 'AltInitArg';
has alt_init_arg => (
is => 'ro',
isa => 'Str',
predicate => 'has_alt_init_arg',
);
around initialize_instance_slot => sub {
my $orig = shift;
my $self = shift;
my ($meta_instance, $instance, $params) = #_;
return $self->$orig(#_)
# don't run if we haven't set any alt_init_args
# don't run if init_arg is explicitly undef
unless $self->has_alt_init_arg && $self->has_init_arg;
if (my #alternates = grep { exists $params->{$_} } ($self->alt_init_arg)) {
if (exists $params->{ $self->init_arg }) {
push #alternates, $self->init_arg;
}
$self->associated_class->throw_error(
'Conflicting init_args: (' . join(', ', #alternates) . ')'
) if #alternates > 1;
$params->{ $self->init_arg } = delete $params->{ $alternates[0] };
}
$self->$orig(#_);
};
1;
__END__
Next the Class trait.
package MooseX::AltInitArg::Meta::Trait::Class;
use Moose::Role;
use namespace::autoclean;
around _inline_slot_initializer => sub {
my $orig = shift;
my $self = shift;
my ($attr, $index) = #_;
my #orig_source = $self->$orig(#_);
return #orig_source
# only run on aliased attributes
unless $attr->meta->can('does_role')
&& $attr->meta->does_role('MooseX::AltInitArg::Meta::Trait::Attribute');
return #orig_source
# don't run if we haven't set any aliases
# don't run if init_arg is explicitly undef
unless $attr->has_alt_init_arg && $attr->has_init_arg;
my $init_arg = $attr->init_arg;
return (
'if (my #aliases = grep { exists $params->{$_} } (qw('
. $attr->alt_init_arg . '))) {',
'if (exists $params->{' . $init_arg . '}) {',
'push #aliases, \'' . $init_arg . '\';',
'}',
'if (#aliases > 1) {',
$self->_inline_throw_error(
'"Conflicting init_args: (" . join(", ", #aliases) . ")"',
) . ';',
'}',
'$params->{' . $init_arg . '} = delete $params->{$aliases[0]};',
'}',
#orig_source,
);
};
1;
__END__
Finally the Moose::Exporter glue.
package MooseX::AltInitArg;
use Moose();
use Moose::Exporter;
use MooseX::AltInitArg::Meta::Trait::Attribute;
Moose::Exporter->setup_import_methods(
class_metaroles => { class => ['MooseX::AltInitArg::Meta::Trait::Class'] }
);
1;
__END__
An example of how this is used then:
package MyApp;
use 5.10.1;
use Moose;
use MooseX::AltInitArg;
has foo => (
is => 'ro',
traits => ['AltInitArg'],
alt_init_arg => 'bar',
);
my $obj = MyApp->new( bar => 'bar' );
say $obj->foo; # prints bar
Meta-Programming in Moose is incredibly powerful, but because there are a lot of moving parts (many of which have solely to do with maximizing performance) you bite off a lot of work when you dive in.
Good luck.
I could be wrong but I think you might be able to accomplish what I think you are trying to do using the BUILDARGS method. This lets you munge the contructor arguments before they are used to create the object.
#!/usr/bin/env perl
use strict;
use warnings;
{
package MyClass;
use Moose;
has attr => (
is => 'ro',
isa => 'Str',
required => 1,
);
around BUILDARGS => sub {
my $orig = shift;
my $self = shift;
my %args = ref $_[0] ? %{shift()} : #_;
if (exists $args{attribute}) {
$args{attr} = delete $args{attribute};
}
$self->$orig(%args);
};
}
my $one = MyClass->new(attribute => "Hi");
my $two = MyClass->new(attr => "Bye");
print $one->attr, "\n";
print $two->attr, "\n";
So what I'm hearing is that:
At construction time, an attribute should be able to be set by its init_arg and any alternate init_args defined on the attribute.
An attribute should not be able to be manipulated by its alternate init_args except at instance construction; that is, aside from the above, the attribute should behave "normally".
Based on that, this seems like a good match for the MooseX::MultiInitArg attribute trait. Yes? :)

Perl, #array in perl constructor

I write perl classes, but I don't know how to have a array or a hash in my $this variable ?
I have a pack.pm :
#!/usr/bin/perl -w
use strict;
use Parallel::ForkManager;
package Pack;
our $cgi = new CGI;
sub new {
my ($classe, $nom, $nbports, $gio) = #_;
my $this = {
"nom" => $nom,
"nbports" => $nbports,
"gio" => $gio
};
bless($this, $classe);
return $this;
}
...
1;
I would like to have a #tab, I can access via $this->tab, but I don't want to give it in arg to the instance.
How does it work in Perl ?
Thanks.
Given your answer to my comments, I think you want
my($this) = {
"nom" => $nom,
"nbports" => $nbports,
"gio" => $gio,
"tab" => []
};
i.e. set $this->{tab} to be a reference to a new anonymous array.
Now you can reference it as you wish, e.g.
$this->{"tab"}[0] = "new value";
print "Table contains ", scalar(#{$this->{"tab"}}), "entries\n";
Consider using Moose for your OO Perl needs.
I've created a Moose version of your object that includes an attribute with an attribute featuring Array trait delegation, inlcuding currying of delegated methods. Moose offers easy ways to generate powerful, encapsulated classes without writing reams of boilerplate.
I created a class Pack with attributes: nom, nbports, gio, and tab.
nom is a read-only string and is required when the object is created.
nbports is a read-only integer value and defaults to 32 when not provided.
gio is an optional, read-write boolean value.
tab is an array of strings. All sorts of behavior has been defined for tab:
all_tabs returns a list of the contents of tabs
add_tab pushes values onto the end of tabs
tab_count returns a count of the elements in tabs
alpha_tabs returns a list of the members of tabs alphabetical order
turn_tabs returns a list of the strings in tabs, but with the letters in reverse
Any attempts to set an attribute with be checked for type correctness.
Moose creates all the required methods to support these complex behaviors with the following code:
package Pack;
use Moose;
has 'nom' => (
is => 'ro',
isa => 'Str',
required => 1,
);
has 'nbports' => (
is => 'ro',
isa => 'Int',
default => 32,
);
has 'gio' => (
is => 'rw',
isa => 'Bool',
predicate => 'has_gio',
);
has 'tab' => (
traits => ['Array'],
is => 'ro',
isa => 'ArrayRef[Str]',
default => sub {[]},
handles => {
all_tabs => 'elements',
add_tab => 'push',
turn_tabs => [ 'map', sub { reverse } ],
tab_count => 'count',
alpha_tabs => [ 'sort', sub { lc($a) cmp lc($b) } ],
},
);
__PACKAGE__->meta->make_immutable;
no Moose;
1;
Usable like so:
my $p = Pack->new( nom => 'Roger', tab => [qw( fee fie foe fum )] );
my $gio_state = 'UNSET';
if( $p->has_gio ) {
$gio_state = $p->gio ? 'TRUE' : 'FALSE';
}
print "GIO is $gio_state\n";
my #turned = $p->turn_tabs; # eef eif eof muf
$p->add_tabs( 'faa', 'fim' );
my #sorted = $p->alpha_tabls; # faa fee fie fim foe fum
my $count = $p->tab_count; # 6
my $ports = $p->nbports; # 32
try with:
sub set_tab {
my ($self, #tab) = #_;
$self->{ tab } = \#tab;
}

Moose (Perl): convert undef to empty string or 0 rather than die()

I've received a lot of exceptions from QA due to incomplete data being fed to my Moose constructors. The attribute name is present in the constructor arguments, but the value is undef.
It's a fact of life with many scripting applications that things are just undef. And oftentimes this is perfectly fine. You don't want an annoying warning from the warnings pragma (so you do no warnings 'uninitialized'), and you certainly don't want your code to die because one little value, say the housenumber, is undef.
So without further ado, I want my Moose constructors to behave like straight Perl (i.e. without use warnings 'uninitialized'), which is to convert undef to 0 or the empty string as required. The attempt shown in this sample does not work for the case where the attribute name is present but the value is undef. I could think of using BUILDARGS to achieve what I want. But is there a declarative way in plain Moose without resorting to MooseX::UndefTolerant (which unfortunately I cannot use as it is not installed)?
package AAA;
use Moose;
has 'hu', is => 'ro', isa => 'Str';
has 'ba', is => 'ro', isa => 'Int';
no Moose; __PACKAGE__->meta->make_immutable;
package BBB;
use Moose; extends 'AAA';
has '+hu', default => ''; # don't want to die on undef
has '+ba', default => 0; # idem
no Moose; __PACKAGE__->meta->make_immutable;
package main;
use Test::More;
use Test::Exception;
# Those AAAs should die ...
throws_ok { AAA->new( hu => undef ) }
qr/Validation failed for 'Str' with value undef/;
throws_ok { AAA->new( ba => undef ) }
qr/Validation failed for 'Int' with value undef/;
# .. but these BBBs should live:
lives_ok { BBB->new( hu => undef ) } 'hu supplied as undef';
lives_ok { BBB->new( ba => undef ) } 'ba supplied as undef';
done_testing;
In Moose::Manual::Types is a way documented to deal with exactly this kind of problem.
Use the Maybe[a] type.
package AAA;
use Moose;
has 'hu', is => 'ro', isa => 'Str';
has 'ba', is => 'ro', isa => 'Int';
no Moose; __PACKAGE__->meta->make_immutable;
package BBB;
use Moose; extends 'AAA';
has 'hu', is => 'rw', isa => 'Maybe[Str]', default => ''; # will not die on undef
has 'ba', is => 'rw', isa => 'Maybe[Int]', default => 0; # idem
sub BUILD {
my $self = shift;
$self->hu('') unless defined $self->hu;
$self->ba(0) unless defined $self->ba;
}
no Moose; __PACKAGE__->meta->make_immutable;
package main;
use Test::More;
use Test::Exception;
# Those AAAs should die ...
throws_ok { AAA->new( hu => undef ) }
qr/Validation failed for 'Str' with value undef/;
throws_ok { AAA->new( ba => undef ) }
qr/Validation failed for 'Int' with value undef/;
# .. but these BBBs should live:
lives_ok { BBB->new( hu => undef ) } 'hu supplied as undef';
lives_ok { BBB->new( ba => undef ) } 'ba supplied as undef';
my $bbb = BBB->new( hu => undef, ba => undef );
is $bbb->hu, '', "hu is ''";
is $bbb->ba, 0, 'ba is 0';
done_testing;
Your complaint really is that Moose is doing exactly what it is supposed to be doing. If you explicitly pass undef as a value, but that value can only be an Int, then you should get an error.
So you need to make a choice. You can either change the type (via union) to allow undef as a valid value like so:
has 'hu', is => 'ro', isa => 'Str | Undef';
has 'ba', is => 'ro', isa => 'Int | Undef';
Or you can just not send in undefined values:
my %aa_params = ();
$aa_params{hu} = $foo if defined $foo;
$aa = AA->new( %aa_params );
Or finally, for some unknown reason you absolutely cannot resist sending in invalid undefined values for things which should not be explicitly set to undefined, just write a quick filter:
sub filt_undef {
my %hash = #_;
return map { $_ => $hash{$_} } grep { defined $hash{$_} } keys %hash;
}
$aa = AA->new( filt_undef( hu => undef ) );
But this seems rather awkward and awful.
Or use on-the-fly coercion:
package BBB;
use Moose;
use MooseX::AttributeShortcuts;
extends 'AAA';
has '+hu',
traits => [Shortcuts],
coerce => [ Undef => sub { '' } ],
;

Moose: Loading object from file in the BUILD method

I have to read a file in the BUILD method and I want to use the load method of the MooseX::Storage package.
But this load method create a new object and so when I instatiate the object this isn’t the object read from file. In the code below I create an object $m1 with state 2 to write the file, I create $m2 with no parameter to read the file but $m2 doesn’t contain the right value.
The package:
package mia;
use Moose;
use MooseX::Storage;
with Storage(format => 'JSON', io => 'File');
has 'nome' => ( is => 'rw', isa => 'Str', default =>'',);
has 'stato' => ( is => 'rw', isa => 'Int', default =>1,);
sub BUILD {
my $self=shift;
if ($self->stato==1){
$self=mia->load("mia.dat");
}
if ($self->stato==2){
$self->stato(0);
$self->nome("prova");
$self->store("mia.dat");
}
}
sub stampa(){
my $self=shift;
print $self->nome." ".$self->stato;
}
the main program
use mia;
my $m;
$m1=mia->new(stato=>2);
$m2=mia->new();
print "\nm1 \n";
$m1->stampa();
print "\nm2 \n";
$m2->stampa();
Your code seems to be acting as if BUILD is a constructor, which it isn't -- it's more like a post-construction hook where you can perform other things like read values from a DB. You should instead either:
store the result of mia->load in an attribute, and optionally use delegated methods to access it, or
use the result of mia->load as the object, rather than constructing a separate one.
Here is an example of the first case, separating the MooseX::Storage object from the object that controls it:
package miaController;
use Moose;
use mia;
has 'nome' => ( is => 'rw', isa => 'Str', default =>'',);
has 'stato' => ( is => 'rw', isa => 'Int', default =>1,);
has 'mia' => ( is => 'rw', isa => 'mia', lazy => 1);
sub BUILD
{
my $self = shift;
if ($self->stato == 1)
{
$self->mia(mia->load("mia.dat"));
}
elsif ($self->stato == 2)
{
$self->stato(0);
$self->nome("prova");
$self->mia->store("mia.dat");
}
}
sub stampa
{
my $self = shift;
print $self->nome." ".$self->stato;
}
package mia;
use Moose;
use MooseX::Storage;
with Storage(format => 'JSON', io => 'File');
package main:
use miaController;
my $m1=miaController->new(stato=>2);
my $m2=miaController->new();
print "\nm1 \n";
$m1->stampa();
print "\nm2 \n";
$m2->stampa();

Moose: Expiring cached results of calculations when attribute values change?

In our classes we have a pattern where we create an attribute to represent a
calculated value. For obvious reasons we want to cache the calculated value
and then invalidate the cache when one of the underlying values change.
So we currently have this:
package FooBar;
use Moose;
has 'foo' => (
accessor => {
'foo' => sub {
my $self = shift;
if (#_ > 0) {
# writer
$self->{foo} = $_[0];
# reset fields that are dependant on me
$self->{bar} = undef;
}
# reader part;
return $self->{foo};
}
}
);
has 'bar' => (
accessor => {
'bar' => sub {
my $self = shift;
if (#_ > 0) {
# writer
$self->{bar} = $_[0];
}
# reader part;
$self->{bar} = calculate_bar($self->foo, $self->baz)
if (not defined($self->{bar}));
return $self->{bar};
}
}
);
sub calculate_bar { ... }
This long hand method is getting very tedious and error prone when calculated values
depend on other calculated values.
Is there a smarter/simpler way for 'bar' to monitor the attributes it depends on
vs having 'foo' know who is dependent on it? Also how can I avoid setting bar via hash
member access?
If I understand you correctly, you can use triggers to clear attributes when one is set. Here's an example:
has 'foo' => (
is => 'rw',
trigger => sub{
my ($self) = #_;
$self->clear_bar;
}
);
has 'bar' => (
is => 'rw',
clearer => 'clear_bar',
lazy => 1,
default => sub{
my ($self) = #_;
return calculate_bar( ... );
}
);
So, any writes to foo via $obj->foo($newvalue) will cause bar to be cleared, and recreated on next access.
I think it is quite possible that you're making this harder on yourself by using an Attributes implicit memoization with lazy, when you could just make the memoization explicit making your whole program more transparent
has [qw/foo bar baz/] => ( isa => 'Value', is => 'rw' );
use Memoize;
memoize('_memoize_this');
sub old_lazy_attr {
my $self = shift;
_memoize_this( $self->attr1, $self->attr2, $self->attr3 );
}
sub _memoize_this {
my #args = #_;
# complex stuff
return $result
}
See cpan's Memoize for information and control of the internal cache, also remember that a Memoized function can not be dependent on the state of the object. So the arguments must be passed in explicitly.
Would this work?
#!/usr/bin/perl
package Test;
use Modern::Perl;
use Moose;
has a => (is => 'rw', isa => 'Str', trigger => \&change_a);
has b => (is => 'rw', isa => 'Str', trigger => \&change_b);
has c => (is => 'rw', isa => 'Str');
sub change_a
{
my $self = shift;
say 'update b';
$self->b($self->a . ', bar');
}
sub change_b
{
my $self = shift;
say 'update c';
}
package main;
my $test = Test->new->a('Foo');
Output:
$ perl test.pl
update b
update c
I haven't done any poking around in Moose internals and the meta object protocol, but I think this is a good time to do it.
You want to patch the code generation so that when you specify an attribute as
has 'foo' => ();
has 'bar' => (
depends_on => [qw( foo )],
lazy => \&calculate_bar,
);
the code generation phase creates code for the foo and bar attributes as you specified above.
How to do this is an exercise left to the reader. If I had a clue, I'd try to give you a start. Unfortunately, all I can advise you with is "This is a job for the MOP".