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;
}
Related
I was expecting a builder method to have access to all the other attributes provided by the caller. But it seems it only has access to those whose name is alphabetically less than the current attribute's. E.g. why can the builder for b here see the value of a but not c? (Both 'a' and 'c' are present in the final object)
Code:
#!/usr/bin/perl -w
use strict;
use Data::Dumper;
{
package P;
use Moo;
printf "Moo version: %s\n", $Moo::VERSION;
# a and c are defined in the same way
has a => ( is => 'ro' );
has c => ( is => 'ro' );
has b => (
is => 'ro',
builder => '_build_b',
);
sub _build_b {
my ($self) = #_;
print Data::Dumper->new(
[ $self ], [ 'self_during_build_b' ]
)->Indent(1)->Sortkeys(1)->Dump;
return "somebuiltvalue";
}
}
my $p = P->new({ a => 1, c => 3 });
print Data::Dumper->new([$p],['p'])->Indent(1)->Sortkeys(1)->Dump;
Output:
Moo version: 2.003004
$self_during_build_b = bless( {
'a' => 1
}, 'P' );
$p = bless( {
'a' => 1,
'b' => 'somebuiltvalue',
'c' => 3
}, 'P' );
In fact, you should not assume anything about any other fields in the builder for a specific member. If the value of some member of your class depends on the values of one or more other members, then the appropriate place to handle that would be the class BUILD method.
I don't know exactly what you are trying to achieve, but are you looking for lazy?
Or, maybe b needs to be a method in your class
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.
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;
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.
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".