I'm dynamically adding classes, methods and attributes using Moose::Meta::Class.
Can someone explain why this code is working (calling generate() subroutine internally, inside Cat class):
package Cat;
use Moose;
sub generate {
my $siberian = Moose::Meta::Class->create( 'Siberian' );
$siberian->add_method( echo => sub { print "yeah!\n" } );
my $tiger = Moose::Meta::Class->create( 'Tiger' );
$tiger->add_attribute(
Siberian => {
is => 'ro',
default => sub { $siberian->new_object; }
},
);
__PACKAGE__->meta->add_attribute(
Tiger => {
is => 'ro',
default => sub { $tiger->new_object },
},
);
print "Generation done!\n";
}
generate();
package main;
use Data::Printer;
my $a = Cat->new;
# $a->generate;
p( $a );
$a->Tiger->Siberian->echo; # returns 'yeah!'
output of p($a):
Cat {
Parents Moose::Object
public methods (3) : generate, meta, Tiger
private methods (0)
internals: {
Tiger Tiger
}
}
and this one (calling generate sub externally, via $a->generate) doesn't:
package Cat;
use Moose;
sub generate {
my $siberian = Moose::Meta::Class->create('Siberian');
$siberian->add_method(
echo => sub { print "yeah!\n" }
);
my $tiger = Moose::Meta::Class->create('Tiger');
$tiger->add_attribute(
Siberian => {
is => 'ro',
default => sub { $siberian->new_object; }
},
);
__PACKAGE__->meta->add_attribute(
Tiger => {
is => 'ro',
default => sub { $tiger->new_object },
},
);
print "Generation done!\n";
}
# generate();
package main;
use Data::Printer;
my $a = Cat->new;
$a->generate;
p($a);
$a->Tiger->Siberian->echo; # returns 'yeah!'
output of p($a):
Cat {
Parents Moose::Object
public methods (3) : generate, meta, Tiger
private methods (0)
internals: {}
}
and program returns an error:
Can't call method "Siberian" on an undefined value at base2.pl line
39.
Since generate is not object, but class method, it's needed to call it before new:
Cat->generate;
my $a = Cat->new;
Related
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.
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
I found myself instantiating the same objects in numerous tests, so I'm trying to replace this constant setup by using Bread::Board. Most of the time I will want the dependencies to have the same configuration. But occasionally I may want to have an instance created with parameters that are not the default. I'd also like to be able to change this after I've created an instance of the container. e.g. I'd normally want
my $c = Test::Container->new;
my $bar = $c->resolve( service => 'bar' ); # where bar depends on foo
but sometimes what I really need is something like
my $bar = $c->resolve( service => 'bar', {
services => {
foo => { init => 'arg' }
}
}
so that service foo is initialized differently while creating the instance of bar.
This was provided to me by Jesse Luehrs (Doy) on #moose and appears that it'll do what I want.
#!/usr/bin/env perl
use v5.14;
use strict;
use warnings;
package Container {
use Moose;
use Bread::Board;
extends 'Bread::Board::Container';
has '+name' => (default => 'Container');
sub BUILD {
my $self = shift;
container $self => as {
service foo => (
block => sub {
my $s = shift;
$s->param('foo_val');
},
parameters => {
foo_val => { isa => 'Str' },
},
);
service bar => (
block => sub {
my $s = shift;
$s->param('foo')->inflate(foo_val => $s->param('foo_val')) . 'BAR';
},
dependencies => ['foo'],
parameters => {
foo_val => { isa => 'Str', default => 'FOO' },
},
);
};
}
}
my $c = Container->new;
warn $c->resolve(service => 'bar');
warn $c->resolve(service => 'bar', parameters => { foo_val => 'baz' });
I have a couple of packages:
package FOO;
use Moose;
has 'obj' => (is=>'ro');
sub hash {
my $self = shift;
return $self->make_hash($self->obj};
}
and another package extending FOO:
package FOOBAR;
use Moose;
extends 'FOO';
has [qw/val1 val2/] => (is => 'rw');
sub BUILD {
my ($self) = #_;
$self->val1($self->hash->{val1});
$self->val2($self->hash->{val2});
}
Basically I want to do FOOBAR->new(obj=>$obj); and use a hash generated from $obj to populate the attributes specified in FOOBAR (~20 or so attributes)
Is using 'BUILD' like this a good way of solving it?
Why? Then you end up with two copy of the data. Delegate instead.
has obj => (
is => 'ro',
handles => {
val1 => sub { my $self = shift; my $obj = $self->obj; ... },
val2 => sub { my $self = shift; my $obj = $self->obj; ... },
},
);
If the accessors are practically identical, you can do something like
sub make_obj_accessor {
my ($name) = #_;
return sub {
my $self = shift;
my $obj = $self->obj;
... $name ...
};
}
has obj => (
is => 'ro',
handles => {
(map make_obj_accessor($_), qw(
val1
val2
))
},
);
Of course, if you really only have a hash, all you need is
FOOBAR->new( %hash )
Puppy meta data gets read in from config file using (General::Config) and creates this hash of hashes
$puppy_hashes = {
puppy_blue => { name => 'charlie', age => 4 },
puppy_red => { name => 'sam', age => 9 },
puppy_yellow => { name => 'jerry', age => 2 },
puppy_green => { name => 'phil', age => 5 },
}
the MotherDogRobot package consumes the puppies hash to birth an array of puppy objects (lol)
package MotherDogRobot;
use Moose;
use Puppy;
use Data::Dumper;
#moose includes warn and strict
sub init_puppy{
my($self,%options) = #_;
my $puppy = Puppy->new( %options );
return ($puppy);
}
sub birth_puppies{
my($self,$puppy_hashes) = #_;
my #keys = keys %{$puppy_hashes};
my #puppies = map { $self->init_puppy( $puppy_hashes->{$_} ) } #keys;
return(#puppies);
}
sub show_me_new_puppies{
my($self,$puppy_hashes) #_;
print Dumper($self->birth_puppies($puppy_hashes));
}
Error odd number of arguments
passing %options to Puppy->new(%options)
no luck birthing puppies -- which means I can't put lasers on their heads =/
UPDATE
I think the problem is that I'm passing a Hash Ref to init_puppy() instead of an array or hash, so when I try to pass %options to the new constructor, it's not getting a proper ( key => value) pair -- hence the odd number of arguments error.
But from this standpoint I've been looking at this code too long I cant figure out how to dereference this properly.
btw this is my official day 22 of using Perl!
you're using empty variables as if they're not empty, that is, you're not doing anything at all
print "hi $_ " for my #foo;
This assumes that the incomplete snippet you've shown is what you're really using
update: Similarly in sub init_puppy, you never initialize my($self,%options)=#_;
#!/usr/bin/perl --
use strict;
use warnings;
Main( #ARGV );
exit( 0 );
sub Main {
my $puppy_hashes = {
puppy_blue => { name => 'charlie', age => 4 },
puppy_red => { name => 'sam', age => 9 },
puppy_yellow => { name => 'jerry', age => 2 },
puppy_green => { name => 'phil', age => 5 },
};
for my $puppy ( MotherDogRobot->birth_puppies($puppy_hashes) ) {
print join ' ', $puppy, $puppy->name, $puppy->age, $puppy->dump, "\n";
}
}
BEGIN {
package Puppy;
BEGIN { $INC{'Puppy.pm'} = __FILE__; }
use Any::Moose;
has 'name' => ( is => 'rw', isa => 'Str' );
has 'age' => ( is => 'rw', isa => 'Int' );
package MotherDogRobot;
BEGIN { $INC{'MotherDogRobot.pm'} = __FILE__; }
use Moose;
use Puppy;
sub init_puppy {
my ( $self, %options ) = #_;
my $puppy = Puppy->new(%options);
return ($puppy);
}
sub birth_puppies {
my ( $self, $puppy_hashes ) = #_;
my #puppies = map { $self->init_puppy( %{$_} ) } values %$puppy_hashes;
return (#puppies);
}
no Moose;
}
The standard Moose constructor will accept both
->new( %{ $puppy_hashes->{$_} } )
and
->new( $puppy_hashes->{$_} )
if $puppy_hashes contains what you say it does, and $_ is an existing key.
Furthermore, Moose will not give the error Error odd number of argments when you pass no arguments. (You're not assigning anything to %config.)
I can't tell which part of what you said is wrong, but what you said doesn't add up.