Perl Moose add instance attribute not class attribute - perl

I need to add attribute to Moose class instance. In the code below, when I create instance of the class Child and add attribute "app" to it, I find this attribute also added when I create next instances. What I am doing wrong, again I need the attribute per created instance.
#!C:\perl\bin\perl.exe
#!/usr/bin/perl
use v5.10;
use Moose;
use Data::Dumper;
{
package Child;
use Moose;
use utf8;
sub name {
say "My name is Richard";
}
}
sub add_attribute {
my ($object, $attr) = #_;
my $meta = $object->meta;
if (!$object->can("app")) {
$meta->add_attribute(app => (is => 'rw', default => sub{$attr}));
$object->app($attr);
}
else {
#$object->app($attr);
say "attr $attr already exists: object=". ref($object) . ", attr=".($object->app);
}
}
my $child = Child->new;
$child->name;
add_attribute($child, "First");
say "Child Attr: " . $child->app;
say "";
say Dumper($child);
my $child1 = Child->new;
$child1->name;
#add_attribute($child1, "Second");
say "Child1 Attr: " . $child1->app;
say Dumper($child1);
#say Dumper($child1->meta);
output:
My name is Richard
Child Attr: First
$VAR1 = bless( {
'app' => 'First'
}, 'Child' );
My name is Richard
Child1 Attr: First
$VAR1 = bless( {
'app' => 'First'
}, 'Child' );

The trick is to create a new subclass of your original class, add the attribute to that, then rebless the instance into the new subclass. Here's an example:
use v5.14;
package Person {
use Moose;
has name => (is => 'ro');
}
sub add_attribute {
my ($obj, $name, $value) = #_;
my $new_class = Moose::Meta::Class->create_anon_class(
superclasses => [ ref($obj) ],
);
$new_class->add_attribute($name, is => 'rw');
$new_class->rebless_instance($obj, $name => $value);
}
my $alice = Person->new(name => 'Alice');
my $bob = Person->new(name => 'Bob');
add_attribute($alice, foot_size => 6);
say $alice->foot_size;
say $bob->foot_size; # dies, no such method

Related

Perl module that accepts list and creates objects

I am working on an college problem ( in Perl ). We are working on creating modules and I need to write a simple module that "has get/set methods for four attributes: lastname, firstname, full_name and a list of children who are also person objects".
I think I have it down but it's the list of children who are also person objects that throws me. I guess the module needs to accept a list and then create a list of objects? Python is my core language so this one is throwing me. The get/set methods are working fine. Any ideas?
My module is here...
#!/usr/bin/perl
package Person;
sub new
{
my $class = shift;
my $self = {
_firstName => shift,
_lastName => shift,
};
bless $self, $class;
return $self;
}
sub setFirstName {
my ( $self, $firstName ) = #_;
$self->{_firstName} = $firstName if defined($firstName);
return $self->{_firstName};
}
sub getFirstName {
my( $self ) = #_;
return $self->{_firstName};
}
sub setLastName {
my ( $self, $lastName ) = #_;
$self->{_lastName} = $lastName if defined($lastName);
return $self->{_lastName};
}
sub getLastName {
my( $self ) = #_;
return $self->{_lastName};
}
sub getFullName {
my( $self ) = #_;
return $self->{_lastName}.",".$self->{_firstName};
}
1;
My code is here.....
#!/usr/bin/perl
use Person;
$object = new Person("Elvis","Presley");
# Get first name which is set using constructor.
$firstName = $object->getFirstName();
$lastName = $object->getLastName();
$fullname = $object->getFullName();
print "(Getting) First Name is : $firstName\n";
print "(Getting) Last Name is: $lastName\n";
print "(Getting) Full Name is: $fullname\n";
Just use a list of objects in the setter:
#! /usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
{ package Person;
sub new {
my $class = shift;
my $self = {
_firstName => shift,
_lastName => shift,
_children => [],
};
return bless $self, $class
}
sub setFirstName {
my ($self, $firstName) = #_;
$self->{_firstName} = $firstName if defined $firstName;
return $self->{_firstName}
}
sub getFirstName {
my ($self) = #_;
return $self->{_firstName}
}
sub setLastName {
my ($self, $lastName) = #_;
$self->{_lastName} = $lastName if defined $lastName;
return $self->{_lastName}
}
sub getLastName {
my ($self) = #_;
return $self->{_lastName}
}
sub getFullName {
my ($self) = #_;
return $self->{_lastName} . ', ' . $self->{_firstName}
}
sub getChildren {
my ($self) = #_;
return #{ $self->{_children} }
}
sub setChildren {
my ($self, #children) = #_;
$self->{_children} = [ #children ];
}
}
my $object = 'Person'->new('Elvis', 'Presley');
# Get first name which is set using constructor.
my $firstName = $object->getFirstName;
my $lastName = $object->getLastName;
my $fullname = $object->getFullName;
$object->setChildren('Person'->new('Lisa', 'Presley'),
'Person'->new('Deborah', 'Presley'));
say "(Getting) First Name is: $firstName";
say "(Getting) Last Name is: $lastName";
say "(Getting) Full Name is: $fullname";
say "Children: ";
say $_->getFullName for $object->getChildren;
Note that there are modules to make building objects easier, e.g. Moo:
#! /usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
{ package Person;
use Moo;
has first_name => (is => 'ro');
has last_name => (is => 'ro');
has full_name => (is => 'lazy');
has _children => (is => 'ro',
init_arg => undef,
default => sub { [] });
sub _build_full_name {
my ($self) = #_;
return $self->last_name . ', ' . $self->first_name
}
sub add_child {
my ($self, $child) = #_;
push #{ $self->_children }, $child
}
sub children {
my ($self) = #_;
return #{ $self->_children }
}
}
my $object = 'Person'->new(first_name => 'Elvis',
last_name => 'Presley');
# Get first name which is set using constructor.
my $firstName = $object->first_name;
my $lastName = $object->last_name;
my $fullname = $object->full_name;
$object->add_child($_) for 'Person'->new(first_name => 'Lisa',
last_name => 'Presley'),
'Person'->new(first_name => 'Deborah',
last_name => 'Presley');
say "(Getting) First Name is: $firstName";
say "(Getting) Last Name is: $lastName";
say "(Getting) Full Name is: $fullname";
say "Children: ";
say $_->full_name for $object->children;
The requirement means that there should be an attribute which can accommodate a collection of objects, so a reference to an array. This is defined in the constructor
sub new
{
my $class = shift;
my $self = {
_firstName => shift,
_lastName => shift,
_children => [ #_ ],
};
bless $self, $class;
return $self;
}
where [ ] creates an anonymous array and returns its reference, which is a scalar so it can be used for a hash value. The #_ in it contains the optional rest of the arguments (Person objects) after the class and names have been shift-ed.
Arguments need be checked but this gets hard with a plain list, when they are used positionally. Instead, consider using named parameters, ie. passing a hash(ref) to the constructor, with which it's easy to check which arguments have or have not been supplied.
Next, you need a method to add children to this attribute, for example
sub add_children {
my ($self, #children) = #_; # and check what's passed
push #{$self->{_children}}, #children;
return $self; # for chaining if desired
}
Finally, when you invoke this method you pass objects of the class Person to it
use warnings;
use strict;
use Person;
my $object = Person->new('Elvis', 'Presley');
my $child = Person->new('First', 'Last');
$object->add_children( $child );
or, if there is no use of a $child variable (object) in the rest of the code
$object->add_children( Person->new(...) );
You can add a list of children, add_children($c1, $c2, ...), for example to initially populate the data structure, or can add them individually as they appear.
A list of Person children can be used in the constructor as well
my $obj = Person->new('First', 'Last', $c1, $c2,...);
This gets clearer and far more flexible with mentioned named parameters, which are unpacked and sorted out in the constructor. But more to the point, once you learn the Perl's native OO system look at modules for this, best Moose and its light-weight counterpart Moo.
Comments
Always have use warnings; and use strict; at the beginning
Don't use the indirect object notation
my $obj = new ClassName(...); # DO NOT USE
See this post and this great example. The fact that it can be used to call a constructor is really an abuse of its other legitimate uses. Use a normal method call
my $obj = ClassName->new(...);
It's great that your college is teaching you Perl, but slightly disappointing that they're teaching you the "classic" version of Perl OO, when in the real world most OO work in Perl uses a framework like Moo or Moose.
For interest, I've included a Moo version of the Person object below:
package Person;
use Moo;
use Types::Standard qw[Str ArrayRef Object];
has first_name => (
is => 'rw',
isa => Str,
required => 1,
);
has last_name => (
is => 'rw',
isa => Str,
required => 1,
);
has children => (
is => 'rw',
isa => ArrayRef[Object],
);
sub full_name {
my $self = shift;
return $self->first_name . ' ' . $self->last_name;
}
1;
And here's a simple test program:
#!/usr/bin/perl
use strict;
use warnings;
use feature 'say';
use Person;
my $elvis = Person->new(
first_name => "Elvis",
last_name => "Presley",
children => [Person->new(
first_name => 'Lisa Marie',
last_name => 'Presley',
)],
);
my $first_name = $elvis->first_name;
my $last_name = $elvis->last_name;
my $full_name = $elvis->full_name;
say "(Getting) First Name is : $first_name";
say "(Getting) Last Name is: $last_name";
say "(Getting) Full Name is: $full_name";
say "Elvis's first child is ", $elvis->children->[0]->full_name;
A few things to note:
Always include use strict and use warnings in your code
Always use Class->new in preference to new Class
Perl programmers prefer snake_case to camelCase
Moo likes you to use named parameters to an object constructor
Declarative attributes (using has) are far less repetitive than writing all your own getter and setter methods
People programmers tend to prefer a single method (foo() which can be used as both a getter and a setter over separate get_foo() and set_foo() methods.

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

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.

Perl: Recursive object instantiation with Moose

In the example code below, I am defining a class Person that can have child objects of the same class.
When I invoke the printTree method, I am expecting the following output
Sam Ram Geeta
What I see instead is
SamRamRamRamRamRamRamRamRamRamRamR.....
Any hints on what I am doing wrong and how to achieve my goal?
package Person;
use Moose;
has name => ( is => 'ro' );
my #kids;
sub addChild {
my ( $self, $name ) = #_;
my $k = Person->new( name => $name );
push #kids, $k;
return $k;
}
sub printTree {
my $self = shift;
print $self->name;
$_->printTree foreach ( #kids );
}
no Moose;
package main;
my $s = Person->new( name => "Sam" );
my $r = $s->addChild( "Ram" );
my $g = $s->addChild( "Geeta" );
$s->printTree;
The issue is that #Person::kids does not belong to any one instance, and you effectively end up with
#Person::kids = ($r, $g);
$s->printTree() loops through #Person::kids, calls
$r->printTree() loops through #Person::kids, calls
$r->printTree() loops through #Person::kids, calls
$r->printTree() loops through #Person::kids, calls
...
You need to make it an attribute, e.g.
has kids => (
isa => 'ArrayRef[Person]',
traits => ['Array'],
handles => {
all_kids => 'elements',
push_kids => 'push',
},
default => sub { [] },
);
sub addChild {
my ($self, $name) = #_;
my $k = Person->new(name => $name);
$self->push_kids($k);
return $k;
}
sub printTree {
my ($self) = #_;
print $self->name;
$_->printTree foreach $self->all_kids;
}
You can check perldoc Moose::Meta::Attribute::Native::Trait::Array for other useful handles from the Array trait.

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 reference the object when building it with Perl's Class::Struct?

I am new to object oriented Perl and i have to access member variable of same object in another subrutine of same object. Sample code is here :
use Class::Struct;
struct Breed =>
{
name => '$',
cross => '$',
};
struct Cat =>
[
name => '$',
kittens => '#',
markings => '%',
breed => 'Breed',
breed2 => '$',
];
my $cat = Cat->new( name => 'Socks',
kittens => ['Monica', 'Kenneth'],
markings => { socks=>1, blaze=>"white" },
breed => { name=>'short-hair', cross=>1 },
** //breed2 => sub { return $cat->breed->name;}**
);
print "Once a cat called ", $cat->name, "\n";
**print "(which was a ", $cat->breed->name, ")\n";**
print "had two kittens: ", join(' and ', #{$cat->kittens}), "\n";
But i am not sure how to use that $cat->breed->name in subroutine for breed2 ? Can some one help me with this.
The problem in breed2 is that you are trying to refer to a variable that you haven't defined yet. It looks like it is the same name, but it's not the object you are creating. It's a bit of a chicken-and-egg problem.
I'm not so sure that you want an anonymous subroutine like that in that slot anyway. Are you
just trying to shorten $cat->breed->name to $cat->breed2? You can start with undef in breed2 and change its value right after the constructor since you'll have the reference to the object then. However, even if you put a subroutine there, you have to dereference it:
my $cat = Cat->new( name => 'Socks',
kittens => ['Monica', 'Kenneth'],
markings => { socks=>1, blaze=>"white" },
breed => { name=>'short-hair', cross=>1 },
breed2 => undef,
);
$cat->breed2( sub { $cat->breed->name } );
print "Once a cat called ", $cat->name, "\n";
print "(which was a ", $cat->breed2->(), ")\n";
print "had two kittens: ", join(' and ', #{$cat->kittens}), "\n";
You can't use $cat->breed->name inside the Cat constructor.
But you can define breed2() as a method after the constructor:
sub Cat::breed2 {
my ($self) = #_;
return $self->breed->name;
}
First, I'll start with several comments, then I'll get to the meat of your question.
OO Perl is a bit different than other OO systems. There is a very thin layer of basic support for OO that makes it possible to make your objects do just about anything you want. On the down side, you can make your objects do just about anything you want. Classical OO Perl involves a lot of boilerplate code, as you implement accessors and mutators for each attribute, perhaps add type checking and so forth. This has given rise to a wide variety of tools to automate the production of boilerplate code.
There are three ways that I approach OO Perl: Moose, classical hash based all hand coded, and Class::Struct. Moose is great for systems where you have complex needs, but it has a big impact on app start-up time. If launch time is important for your application, Moose is, for now, out of the question. Class::Struct is a great way to get a lowest common denominator, quick, simple OO app together, on the downside it doesn't support inheritance. This is where hand coded OOP comes in. If Moose or Class::Struct aren't viable options for one reason or another, I fall back on the basics. This strategy has worked well for me. The only change I have felt the need to make over the last few years, is to add Moose to my standard toolkit. It's a welcome addition.
Damian Conway's Object Oriented Perl is an amazing book that clearly explains OOP, how OO Perl works, and how to build objects that can do amazing things. It's a bit dated, but the book still holds up. Any serious student of OO Perl should read this book.
Now, for your question--
It looks to me like breed2 is not an attribute of your object, it is instead a method.
use Class::Struct;
use strict;
use warnings;
struct Breed =>
{
name => '$',
cross => '$',
};
struct Cat =>
[
name => '$',
kittens => '#',
markings => '%',
breed => 'Breed',
];
my $cat = Cat->new( name => 'Socks',
kittens => ['Monica', 'Kenneth'],
markings => { socks=>1, blaze=>"white" },
breed => { name=>'short-hair', cross=>1 },
);
# Delegate to Breed::name
sub Cat::breed2 {
my $self = shift;
my $breed = $self->breed; # Get the breed object
my $name;
eval { $name = $breed->name(#_) };
warn "No breed specified for ".( $self->name )."\n"
unless defined $name;
return $name;
}
print "Once a cat called ", $cat->name, "\n",
"(which was a ", $cat->breed2, ")\n",
"had two kittens: ", join(' and ', #{$cat->kittens}), "\n";
Things get a bit hairier if you want to keep a set of pre-defined breeds, and have breed2 select a breed object by name if no value is set.
This stripped down Cat implementation uses class data to keep track of allowed cat breeds, and
package Cat;
use strict;
use warnings;
use Carp qw( croak );
my %breeds = map { $_->{name}, Breed->new( %$_ ) } (
{ name=>'short-hair', cross=>1 },
{ name=>'long-hair', cross=>1 },
{ name=>'siamese', cross=>0 },
);
sub new {
my $class = shift;
my %args = #_;
my $self = {};
bless $self, $class;
for my $arg ( keys %args ) {
$self->$arg( $args{$arg} ) if $self->can($arg);
}
return $self;
}
sub breed {
my $self = shift;
if( #_ ) {
my $v = shift;
croak "Illegal cat breed" unless eval {$v->isa( 'Breed' ) };
$self->{breed} = $v;
}
return $self->{breed};
}
sub breed2 {
my $self = shift;
my #breed_args;
if( #_ ) {
my $v = shift;
croak "$v is not a supported breed\n"
unless exists $breeds{$v};
#breed_args = ( $breeds{$v} );
}
my $breed = $self->breed(#breed_args);
return unless $breed;
return $breed->name;
}
Now, lets look at a Moose solution that uses all sorts of advanced goodies like type coercion and overloading:
BEGIN {
package Breed;
use Moose;
has 'name' => ( isa => 'Str', is => 'ro', required => 1 );
has 'cross' => ( isa => 'Bool', is => 'ro', required => 1 );
use overload '""' => \&_overload_string;
sub _overload_string {
my $self = shift;
return $self->name;
}
__PACKAGE__->meta->make_immutable;
no Moose;
1;
}
BEGIN {
package Cat;
use Moose;
use Moose::Util::TypeConstraints;
use Carp;
subtype 'MyTypes::CatBreed' => as class_type('Breed');
coerce 'MyTypes::CatBreed' =>
from 'Str'
=> via { Cat->supported_breed_by_name( $_ ) };
has 'name' => ( isa => 'Str', is => 'rw', required => 1 );
has 'kittens' => (
traits => ['Array'],
is => 'ro',
isa => 'ArrayRef[Str]',
default => sub{ [] },
handles => {
all_kittens => 'elements',
add_kittens => 'push',
get_kitten => 'get',
count_kittens => 'count',
has_kittens => 'count',
},
);
has 'markings' => (
traits => ['Hash'],
is => 'ro',
isa => 'HashRef[Str]',
default => sub{ {} },
handles => {
set_marking => 'set',
get_marking => 'get',
has_marking => 'exists',
all_markings => 'keys',
delete_marking => 'delete',
},
);
has 'breed' => (
isa => 'MyTypes::CatBreed',
is => 'ro',
coerce => 1,
);
my %breeds;
sub supported_breed_by_name {
my $class = shift;
my $name = shift;
croak 'No breed name specified'
unless defined $name and length $name;
return $breeds{$name};
}
sub add_breed {
my $class = shift;
my $breed = shift;
croak 'No breed specified'
unless eval { $breed->isa('Breed') };
croak 'Breed already exists'
if exists $breeds{$breed};
$breeds{$breed} = $breed;
return $class;
}
sub delete_breed {
my $class = shift;
my $name = shift;
croak 'No breed name specified'
unless defined $name and length $name;
return delete $breeds{$name};
}
__PACKAGE__->meta->make_immutable;
no Moose;
1;
}
# Set up the supported breeds
Cat->add_breed($_) for map Breed->new( %$_ ), (
{ name=>'short-hair', cross=>1 },
{ name=>'long-hair', cross=>1 },
{ name=>'siamese', cross=>0 },
);
# Make a cat
my $cat = Cat->new( name => 'Socks',
kittens => ['Monica', 'Kenneth'],
markings => { socks=>1, blaze=>"white" },
breed => 'short-hair',
);
print
"Once a cat called ", $cat->name, "\n",
"(which was a ", $cat->breed, ")\n",
"had ", , " kittens: ", join(' and ', #{$cat->kittens}), "\n";
Don't use Class::Struct use Moose.
package Breed;
use Moose;
has 'name' => ( isa => 'Str', is => 'ro', required => 1 );
has 'cross' => ( isa => 'Bool', is => 'ro' );
package Cat;
use Moose;
has 'name' => ( isa => 'Str', is => 'ro', required => 1 );
has 'kittens' => ( isa => 'ArrayRef[Cat]', is => 'ro' );
has 'markings' => ( isa => 'HashRef', is => 'ro', default => sub { +{} } );
has 'breeds' => ( isa => 'ArrayRef[Breed]', is => 'ro' );
package main;
use Modern::Perl;
my $cat = Cat->new({
name => 'Socks',
, kittens => [ Cat->new({name=>'Monica'}), Cat->new({name=>'Kenneth'}) ]
, markings => { socks=>1, blaze=>"white" }
, breeds => [ Breed->new({ name=>'short-hair', cross => 1 }) ]
});
say "Once a cat called ", $cat->name;
say "Which was a:";
say "\t".$_->name for #{$cat->breeds};
say "had kittens:";
say "\t".$_->name for #{$cat->kittens};
In this scheme, a cat can have any number of Breeds, and a Cat can have any number of kittens which are also objects of Cat.
update to solve your problem specifically
You can make it implicit in the constructor the second breed is the first if it isn't supplied.
package Cat;
sub BUILD {
my $self = shift;
$self->breeds->[1] = $self->breeds->[0]
if $self->breeds->[0] && ! $self->breeds->[1]
}
You can pass in a token that identifies it as such, in the constructor (this should be easy but I can add an example if you want)
You can make Cat understand that if there is only one breed then both of the parents are the same
package Cat;
sub is_pure_bred { length #{$_[0]->breeds} == 1 ? 1 : 0 }
You can make ignore the breed of the cat, by setting it to undef, and determine the breed by that of the parents. This is because your breed is always a function of your lineage anyway. You can constraint this in a Moose trigger, the cat either requires two cat parents, or it requires a breed.
footnote Moose objects serialize fairly nice with XXX too:
... use XXX; YYY $cat;
--- !!perl/hash:Cat
breeds:
- !!perl/hash:Breed
cross: 1
name: short-hair
kittens:
- !!perl/hash:Cat
markings: {}
name: Monica
- !!perl/hash:Cat
markings: {}
name: Kenneth
markings:
blaze: white
socks: 1
name: Socks
...
You can fix this in a few ways, here are two of them:
use warnings;
use strict;
sub say {print #_, "\n"}
use Class::Struct;
struct Breed =>
{
name => '$',
cross => '$',
};
struct Cat =>
[
name => '$',
kittens => '#',
markings => '%',
breed => 'Breed',
breed2 => '$',
];
sub Cat::breed_name {shift->breed->name} #create a new accessor method
my $cat; # or declare $cat first
$cat = Cat->new( name => 'Socks',
kittens => ['Monica', 'Kenneth'],
markings => { socks=>1, blaze=>"white" },
breed => { name=>'short-hair', cross=>1 },
breed2 => sub { return $cat->breed->name;},
# this is now ok, but a bit awkward to call
);
print "Once a cat called ", $cat->name, "\n";
print "(which was a ", $cat->breed2->(), ")\n"; #returns then calls code ref
print "(which was a ", $cat->breed_name, ")\n"; #new accessor method
print "had two kittens: ", join(' and ', #{$cat->kittens}), "\n";
The reason your closure did not work right is because you can not close over a variable that is defined in the current statement. When the sub {...} tried to close around $cat it couldn't because it was not in scope yet. The solution is simply to predeclare the variable.
However, it doesn't seem like Class::Struct lets you install methods that way cleanly. Instead, adding a new accessor method to the Cat:: package lets you call the method as you would expect.