Better way to get all attributes from a Moose class as a hash - perl

I want to get all attributes back from a class as a hash.
Is there any better way to do it than this ?
Ideally(?) I would like to be able to say something like:
my $hash = \%{ Diag->new( {range =>1, code => 'AB'} ) };
But will settle for:
my $d = Diag->new( {range =>1, code => 'AB'} );
my $hash = $d->hash;
package Diag;
use Moose;
my #attrs = qw/range code severity source message/;
has 'range' => ( is => 'rw', isa => 'Int' );
has 'code' => ( is => 'rw', isa => 'String' );
has 'severity' => ( is => 'rw', isa => 'Int' );
has 'source' => ( is => 'rw', isa => 'String' );
has 'message' => ( is => 'rw', isa => 'String' );
sub hash {
my $self = shift;
my $hash = {};
for (#attrs) {
$hash->{$_} = $self->$_;
}
return $hash;
}
no Moose;
1;
EDIT Hash with string output for pack/unpack:
# Combining this attribute and the record_format would be great.
# if $self->record->format worked that would be cool.
has 'record' => (
is => 'ro',
isa => 'HashRef',
default => sub {
{
foo => 'A5',
foo2 => 'A16',
}
);
sub record_format
{
my $self = shift;
my #fields = qw( foo foo2 );
return _build_format_string($self->record, \#fields);
}
sub _build_format_string {
return join '', map { $_[1]->{$_} } #{ $_[2] };
}
EDIT2
I found that if I created an Attribute Trait I could make this a little nicer. This way the hash order is with the attribute and only one format method is needed.
package Order;
use Moose::Role;
has order => (
is => 'ro',
isa => 'ArrayRef',
predicate => 'has_order',
);
Moose::Util::meta_attribute_alias('Order');
1;
package Record;
use Moose;
has 'record' => (
traits => [qw/Order/],
is => 'ro',
isa => 'HashRef',
default => sub {
{
foo => 'A5',
foo2 => 'A16',
},
;
},
order => [qw(foo foo2)]
);
sub format {
my ( $self, $attr ) = #_;
my $fields = $self->meta->get_attribute($attr)->order();
return join '', map { $self->{$attr}{$_} } #$fields;
}
1;
my $r = Record->new();
print $r->format("record");
Outputs: A5A16

I would much rather pack that into a method, but your "ideal" case is almost there
my $data = { %{ Diag->new( {range =>1, code => 'AB'} ) } };
The %{...} returns a (key,value,...) list so you want {} to make a hashref out of it, not \ (which curiously turns it back into an object).
But really, that should be tucked away in a method
my $data = Diag->new(...)->get_data;
package Diag;
...
sub get_data { return { %{$_[0]} } };
...
1;
For purely presentational purposes – to print them out – consider using a module, so you don't have to worry about (or know) which attributes have what reference as a value. I use Data::Dump for conciseness of its output
my $obj = Diag->new(...);
say $obj->stringify(); # whole object serialized
say for $obj->stringify('attr1', 'attr1', ...); # serialized values for each
package Diag;
...
use Data::Dump qw(pp);
...
sub stringify {
my $self = shift;
return map { pp $self->{$_} } #_ if #_;
return { pp %$self } }
}
If native OO is used and not Moo/Moose also overload "" for say $obj; use
use overload q("") => sub { return shift->stringify() }
In Moo and Moose the stringification of object under "" (implied in prints as well) is provided.
By further clarifications the code below doesn't address the actual problem. I'll edit but I am leaving this for now as it was deemed generally useful.
It has come up in comments and question edit that a part of the intent is to be able to retrieve values for attribute(s) as well, and packed. The added code does that, but as there is explicit dereferencing a check with ref should be added so to correctly retrieve all values, from either of arrayref, hashref, or string/number. For example
sub record_format {
my ($self, #attrs) = #_;
#attrs = qw(attr1 attr2 ...) if not #attrs; # default list
my $packed;
foreach my $attr (#attrs) {
my $val = $self->{$attr};
my $rv = ref $val;
if (not $rv) { $packed .= $val }
elsif ($rv eq 'HASH') { $packed .= join '', values %$val }
elsif ($rv eq 'ARRAY') { $packed .= join '', #$val }
}
return $packed;
}
This packs values of the passed attributes or of the listed defaults.
The desired $self->record->format can't work nicely since $self->record doesn't return an object so you can't string another method call. You can write an accessor but if you made it return an object under any circumstances that would likely be a surprising behavior, thus not good design.

Related

Moose trigger caller

Is there any way of knowing the trigger caller attribute in Moose ?
For example, taking the example from Moose::Manual::Attributes:
has 'size' => (
is => 'rw',
trigger => \&_size_set,
);
sub _size_set {
my ( $self, $size, $old_size ) = #_;
my $msg = $self->name;
if ( #_ > 2 ) {
$msg .= " - old size was $old_size";
}
$msg .= " - size is now $size";
warn $msg;
}
Is it possible in _set_size to know that the attribute size called it, without needing to specify the name of the caller attribute explicitly?
EDIT: updated per comment.
It might be simpler to create a wrapper that adds one argument:
sub make_trigger {
my ($name, $sub) = #_;
return sub {
my $self = shift;
$self->$sub($name, #_);
};
}
has 'size' => (
is => 'rw',
trigger => make_trigger(size => \&_size_set),
);
sub _size_set {
my ( $self, $name, $size, $old_size ) = #_;
...
}
Here's what #RsrchBoy refers to as the "proper way"...
use v5.14;
use strict;
use warnings;
BEGIN {
package MooseX::WhatTheTrig::Trait::Attribute
{
use Moose::Role;
use Scope::Guard qw(guard);
after _process_trigger_option => sub
{
my $class = shift;
my ($name, $opts) = #_;
return unless exists $opts->{trigger};
my $orig = delete $opts->{trigger};
$opts->{trigger} = sub
{
my $self = shift;
my $guard = guard {
$self->meta->_set_triggered_attribute(undef);
};
$self->meta->_set_triggered_attribute($name);
$self->$orig(#_);
};
}
}
package MooseX::WhatTheTrig::Trait::Class
{
use Moose::Role;
has triggered_attribute => (
is => 'ro',
writer => '_set_triggered_attribute',
);
}
}
package Example
{
use Moose -traits => ['MooseX::WhatTheTrig::Trait::Class'];
has [qw(foo bar)] => (
traits => ['MooseX::WhatTheTrig::Trait::Attribute'],
is => 'rw',
trigger => sub {
my ($self, $new, $old) = #_;
$_ //= 'undef' for $old, $new;
my $attr = $self->meta->triggered_attribute;
say "Changed $attr for $self from $old to $new!";
}
);
}
my $obj = Example->new(foo => 1, bar => 2);
$obj->foo(3);
$obj->bar(4);
You'll notice that the "foo" and "bar" attributes share a trigger, but that the trigger is able to differentiate between the two attributes.
Moose::Exporter has some sugar for making this a little less ugly. I might have a play at turning this into a CPAN module some time.
The proper way to do this would be to employ an attribute trait of some sort; one that passes the name, or (preferably) the metaclass instance of the attribute the trigger belongs to. One could even create a trait that allows the class' metaclass to be asked if we're in an attribute trigger, and if so, which one. (This would be transparent and not break anyone's expectations as to how trigger works.)
The easiest would be to curry your triggers as shown in another example.

How to auto generate a bunch of setters / getters tied to a network service in Moose?

By way of teaching myself Moose, I'm working on a Moose object that interfaces to a particular piece of hardware. Said hardware takes a number of different commands that set various properties of the hardware, all of the form PROPERTYNAME=VALUE for a setter, and PROPERTYNAME? for a getter (note that these 'setters' and 'getters' are on the network interface to the hardware). What I want to do is create an object where all of these properties of the hardware are implemented with an attribute-like interface. Since getting and setting the various properties takes the same form for all properties, is there a way to automatically generate the setters and getters from a list of those properties?
I.E.: Rather than this:
Package MyHardware;
use Moose;
has property1 => (
'is' => 'rw',
'reader' => 'set_property1',
'writer' => 'get_property1',
);
has property2 => (
'is' => 'rw',
'reader' => 'set_property2',
'writer' => 'get_property2',
);
# ...
has propertyN => (
'is' => 'rw',
'reader' => 'set_propertyN',
'writer' => 'get_propertyN',
);
Is there something I can do like this:
Package MyHardware;
use Moose;
attributes => (
'is' => 'rw',
'names' => [qw/property1 property2 ... propertyN/],
'reader' => sub {
my $self = shift;
my $property = shift;
return $self->_send_command("$property?");
},
'writer' => sub {
my $self = shift;
my $property = shift;
my $value = shift;
return $self->_send_command("$property=$value");
},
);
EDIT: Here's what I want to happen:
# CALLER:
my $hw = MyHardware->new();
$hw->property1('foo');
print $hw->property2 . "\n";
And "under the hood":
$hw->property1('foo');
# Becomes
sub { return $hw->_send_command('property1=foo'); }
# And
$hw->property2();
# Becomes
sub { return $hw->_send_command('property2?'); }
How about looping over the properties?
use strict;
use warnings;
use Moose;
foreach my $prop ( qw( property1 property2 property3 property4 ) ) {
has $prop => (
is => 'rw',
isa => 'Str',
reader => "get_$prop",
writer => "set_$prop",
);
}
1;
Figured it out. I realize that I shouldn't be using attributes at all to do this. Instead, I'll dynamically generate methods using Class::MOP::Class like so:
my $meta = Class::MOP::Class->initialize(__PACKAGE__);
foreach my $prop (qw/property1 property2 property3/) {
$meta->add_method(qq/set_$prop/, sub {
my $self = shift;
my $value = shift;
return $self->_send_command(qq/$prop=$value/);
}
);
$meta->add_method(qq/get_$prop/, sub {
my $self = shift;
return $self->_send_command(qq/$prop?/);
}
);
}
Doing it with calls to has() would have effectively put the object state in two places - on the hardware and in the instance - and I only want it in one.
You don't store any value, so you don't want attributes.
You don't don't even want two subs since you want a single name for both getting and setting.
for my $prop (qw( property1 property2 property3 )) {
my $accessor = sub {
my $self = shift;
if (#_) {
$self->_send_command("$prop=$value");
} else {
return $self->_send_command("$prop?");
}
};
no strict 'refs';
*$prop = $accessor;
}
I would recommend using a has rather than an individual attribute for each of your properties.
Package MyHardware;
use Moose;
has properties => (
'is' => 'rw',
'isa' => 'HashRef',
'lazy_build' => 1,
);
sub _build_properties {
my $self = shift;
return {
'property1' => '',
'property2' => '',
};
}
print $self->properties->{property1};
Generate getters and setters for instance data
BEGIN
{
my #attr = qw(prop1 prop2 prop3 prop4);
no strict 'refs';
for my $a (#attr)
{
*{__PACKAGE__ . "::get_$a"} = sub { $_[0]->{$a} };
*{__PACKAGE__ . "::set_$a"} = sub { $_[0]->{$a} = $_[1] };
}
}

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? :)

Moose around method modifier, setter and constructor (new): intercept all updates to an attribute

Update
The code I posted in my original question was illustrative of the way method modifier do or don't work.
It was not necessarily illustrative of the problem description I gave.
This code should be. It works, but contains a hack in the trigger I used to code the requirement of tracking all updates and acting upon them based on the value supplied to the setter.
package Article;
use Moose;
use Moose::Util::TypeConstraints;
has 'name', is => 'rw', isa => 'Str', required => 1;
has 'price', is => 'rw', isa => 'Num', required => 1;
has 'quantity', is => 'rw', isa => 'Num', required => 1,
trigger => \&update_quantity;
has 'quantity_original', is => 'rw', isa => 'Num',
predicate => 'quantity_fix',
clearer => 'quantity_back_to_normal';
# https://metacpan.org/module/Moose::Cookbook::Basics::Recipe3
# A trigger accepts a subroutine reference, which will be called as a method
# whenever the attribute is set. This can happen both during object
# construction or later by passing a new object to the attribute's accessor
# method. However, it is not called when a value is provided by a default or
# builder.
sub update_quantity {
my( $self, $val ) = #_;
# print STDERR $val, "\n";
if ( $val == int $val ) {
$self->quantity_back_to_normal;
} else {
$self->quantity_original( $val );
# Updating quantity via setter would retrigger this code.
# Which would defeat its purpose. The following won't:
$self->{quantity} = 1; # hack, yes; but it does work
}
}
around name => sub {
my $orig = shift;
my $self = shift;
return $self->$orig( #_ ) if #_; # setter
return $self->$orig unless $self->quantity_fix;
return sprintf '%s (%s)', $self->$orig, $self->quantity_original;
};
around price => sub {
my $orig = shift;
my $self = shift;
return $self->$orig( #_ ) if #_; # setter
return $self->$orig unless $self->quantity_fix;
return int( 100 * $self->$orig * $self->quantity_original + 0.5 ) / 100;
};
__PACKAGE__->meta->make_immutable; no Moose;
package main;
use Test::More;
{ my $art = Article->new( name => 'Apfel', price => 33, quantity => 4 );
is $art->price, 33, 'supplied price';
is $art->quantity, 4, 'supplied quantity';
is $art->name, 'Apfel', 'supplied name';
}
{ my $art = Article->new( name => 'Mehl', price => 33, quantity => 4.44 );
# diag explain $art;
is $art->quantity, 1, 'has quantity fixed';
is $art->price, 33 * 4.44, 'has price fixed';
is $art->name, 'Mehl (4.44)', 'has name fixed';
# tougher testing ...
$art->quantity(3);
is $art->quantity, 3, 'supplied quantity again';
is $art->price, 33, 'supplied price again';
is $art->name, 'Mehl', 'supplied name again';
}
done_testing;
Still not sure what Moose facility to employ to do the job.
An abundance of features and facilities does not always make things easier.
At least not when you try not to reinvent any wheels and reuse what can be reused.
Original question
It appears the around method modifier isn't called as part of building the object (when calling new). Test case here:
package Bla;
use Moose;
has 'eins', is => 'rw', isa => 'Int';
has 'zwei', is => 'rw', isa => 'Num';
around [qw/ eins zwei /] => sub {
my $orig = shift;
my $self = shift;
return $self->$orig unless #_;
my $val = shift;
if ( $val == int $val ) {
return $self->$orig( $val );
}
else {
return $self->$orig( 1 );
warn "replaced $val by 1";
}
};
package main;
use Test::More;
use Test::Exception;
dies_ok { Bla->new( eins => 33.33 ) } 'dies because of Int type constraint';
my $bla = Bla->new( zwei => 22.22 );
is $bla->zwei, 22.22, 'around has not been called';
done_testing;
Let me explain what I want to achieve. There's a class that has quantity and price (and some more state). When quantity comes in (via new or the setter, I don't care), I want to make sure it ends up as an integer (hence the constraint). If it's not an integer, I want to replace it by just 1 and make some other updates to the object, like saving the original quantity and multiplying the price by the original quantity. Both for the constructor and the setter.
What should I do? Provide a subroutine that does the job and call it from both around BUILDARGS and around quantity?
How about this?
package Bla;
use Moose;
use Moose::Util::TypeConstraints;
subtype 'MyInt',
as 'Int';
coerce 'MyInt',
from 'Num',
via { 1 };
has 'eins', is => 'rw', isa => 'Int';
has 'zwei', is => 'rw', isa => 'MyInt', coerce => 1;
package main;
use Test::More;
use Test::Exception;
dies_ok { Bla->new( eins => 33.33 ) } 'dies because of Int type constraint';
my $bla = Bla->new( zwei => 22.22 );
is $bla->zwei, 1, '22.22 -> 1';
my $bla2 = Bla->new( zwei => 41 );
is $bla2->zwei, 41, '41 -> 41';
done_testing;
When I keep running against walls, I know I did something wrong, and I'm running against walls. The design sucks. I think the key problem is that you have one field serving two purposes.
If the only purpose of orig_quantity is to normalize the price, I suggested that you normalize quantity and price after they are set. This could be done explicitly, or it could be done implicitly when you try to fetch them as shown below.
has price => (
accessor => '_price',
isa => 'Num',
handles => {
price => sub {
my $self = shift;
return $self->_price(#_) if #_;
$self->normalize();
return $self->_price();
},
},
);
has quantity => (
accessor => '_quantity',
isa => 'Num',
handles => {
quantity => sub {
my $self = shift;
return $self->_quantity(#_) if #_;
$self->normalize();
return $self->_quantity();
},
},
);
sub normalize {
my ($self) = #_;
my $quantity = $self->_quantity();
return if is_an_int($quantity);
$self->_quantity(1);
$self->_price($self->_price() / $quantity);
}
If you actually do need orig_quantity, then you probably want the constructor to set this directly and make quantity a derived value.

How should I define a Moose object subroutine after its initialization?

How should I define a Moose object subroutine after its initialization?
I'm writing an object module using Moose and I plan to serialize (nstore) the created objects.
Examine the following (simplified!) example:
package MyObj 0.001;
use Moose;
use namespace::autoclean;
has 'size' => (
is => 'ro',
isa => 'Int',
required => 1,
);
sub some_sub {
my ($self, #more) = #_;
if ($self->size() < 100) # do something;
elsif (($self->size() < 500)) # do something else;
elsif (($self->size() < 7500)) # do something else;
# ...
}
1;
some_sub acts differently depending on size. Since size is read-only, it remains constant after the object has been initialized.
So, assuming I call some_sub zillion times, it's a pity that I have to go through all the ifs each time.
I'd better do this once after the object has been initialized, then set some_sub to be a simpler function with noifs at all.
But... how can I do that?
UPDATE
Perhaps I should add a lazy attribute of type subref that will hold a reference to the chosen subroutine. some_sub will then simply call $self->chosen_sub->(#_). What do you think?
has calculation_method => (is => 'ro', lazy_build => 1, init_arg => undef);
sub _build_calculation_method {
my $self = shift;
return '_calculate_small' if $self->size < 100;
return '_calculate_medium' if $self->size < 500;
return '_calculate_large' if $self->size < 7500;
return '_calculate_enormous';
}
sub _calculate_small { ... }
sub _calculate_medium { ... }
# etc.
sub calculate {
my $self = shift;
my $method = $self->calculation_method;
return $self->$method(#_);
}
As a bonus, calculation_method is now serializable too.
Perhaps another case for MooseX::SingletonMethod! (Sorry I'm reading your questions in reverse order!).
For eg:
use 5.012;
use warnings;
package MyObj 0.001;
use MooseX::SingletonMethod;
use namespace::autoclean;
has 'size' => (
is => 'ro',
isa => 'Int',
required => 1,
);
sub _which_sub {
my ($self) = #_;
if ($self->size < 100) { return sub{ 'A' } }
elsif ($self->size < 500) { return sub{ 'B' } }
elsif ($self->size < 7500) { return sub{ 'C' } }
return sub { 'D' };
}
package main;
my $obj = MyObj->new( size => 200 );
$obj->add_singleton_method( some_sub => $obj->_which_sub );
say $obj->some_sub; # => B
And it should be possible to add this single method creation from inside your class. Have a look at this blog post for some guidance: Moose Singleton Method: Now without roles!. And also a hotchpotch of posts here
Regarding your update:
use 5.012;
use warnings;
package MyObj;
use Moose;
use namespace::autoclean;
has 'size' => (
is => 'ro',
isa => 'Int',
required => 1,
);
has 'chosen_sub' => (
is => 'ro',
isa => 'CodeRef',
lazy => 1,
builder => '_build_chosen_sub',
init_arg => undef, # unless want option of providing anon sub at construction?
);
sub _build_chosen_sub {
my ($self) = #_;
if ($self->size < 100) { return sub{ 'A' } }
elsif ($self->size < 500) { return sub{ 'B' } }
elsif ($self->size < 7500) { return sub{ 'C' } }
return sub { 'D' };
}
package main;
my $obj = MyObj->new( size => 200 );
say $obj->chosen_sub->(); # => B