What's wrong with the code below ? When run, I get: "Use of uninitialized value in concatenation (.) or string at ./main.pl line 14"
#!/usr/bin/perl
package Test;
use Moose;
has 'message' => (isa => 'HashRef', is => 'ro', default => sub{{(localtime)[2] => {(localtime)[3] => "hello"}}});
# the one below works fine
#has 'message' => (isa => 'HashRef', is => 'ro', default => sub{{"18" => {"16" => "hello"}}});
sub show {
my $self = shift;
print("Test: " . $self->message->{(localtime)[2]}->{(localtime)[3]} . "\n");
}
my $o = Test->new();
$o->show();
If I do not use localtime() then it works fine. Also localtime[2] and [3] do not change very often (2 is hours, 3 is month day) so the problem is not that. If I run the script with a debugger, I get:
x $self
0 Test=HASH(0x3597300)
'message' => HASH(0x3597618)
16 => 'hello'
So it looks like I 'lose' one level of indirection, not really sure why... Any idea ?
The outer {} do not parse as a hashref. Add an explicit return:
has 'message' => (isa => 'HashRef', is => 'ro', default => sub{ return {(localtime)[2] => {(localtime)[3] => "hello"}} });
A + to force this works, too.
has 'message' => (isa => 'HashRef', is => 'ro', default => sub{ +{(localtime)[2] => {(localtime)[3] => "hello"}} });
Related
I have a Moose class Person
package Person;
use Moose;
has 'first_name' => (
is => 'rw',
isa => 'Str',
);
has 'last_name' => (
is => 'rw',
isa => 'Str',
);
has 'check' => (
is => 'rw',
isa => 'CodeRef',
);
no Moose;
__PACKAGE__->meta->make_immutable;
I am initializing a new Person object in another file like so
use Person;
my $user = Person->new(
first_name => 'Example',
last_name => 'User',
check => sub {
print "yo yo\n";
},
);
print "here\n";
$user->check();
print "here\n";
The two here debug statements are printing but the debug message in the subroutine is not.
I'd like to know the correct way for me to pass a function to the constructor such that I can pass an anonymous sub routine to the object.
$user->check() is equivalent to $user->check. It just returns the value of the check attribute (i.e, the coderef) without doing anything with it -- just like any other accessor would. The fact that this attribute holds a coderef doesn't change that.
If you want to retrieve the coderef, then call it, you need another arrow:
$user->check->()
An alternative is to use the trait Code implemented by Moose::Meta::Attribute::Native::Trait::Code, and then define a handle with a different name.
package Person;
use Moose;
has 'check' => (
is => 'rw',
isa => 'CodeRef',
traits => ['Code'],
handles => {
run_check => 'execute',
},
);
And then call it like this
my $user = Person->new(
first_name => 'Example',
last_name => 'User',
check => sub {
print "yo yo\n";
},
);
print "here\n";
$user->run_check;
print "here\n";
This allows you to separate the accessor for the code-ref from the functionality it fulfills.
I've created subtype Birth_d with coercion as shown below, and I'm trying to use it in combination with the built-in Maybe type, per Moose::Manual::Types.
I'm getting the error You cannot coerce an attribute (birth_d) unless its type (Maybe[Birth_d]) has a coercion. Here's complete test code:
package Student;
use Moose;
use Moose::Util::TypeConstraints;
use DateTime::Format::MySQL;
class_type 'Birth_d', { class => 'DateTime' };
coerce 'Birth_d',
from 'Str',
via { DateTime::Format::MySQL->parse_date( $_ ) };
has 'name' => (
isa => 'Str',
is => 'ro',
);
has 'birth_d' => (
isa => 'Maybe[Birth_d]', # This works: isa => 'Birth_d'
coerce => 1,
is => 'ro',
);
package main;
use Test::More;
my $student = Student->new(
name => 'Johnnie Appleseed',
birth_d => '2015-01-01'
);
is ( $student->birth_d->ymd(), '2015-01-01' );
my $student2 = Student->new(
name => 'Foo Bar',
birth_d => undef
);
is( $student2->birth_d, undef );
Replacing isa => 'Maybe[Birth_d]' with isa => 'Birth_d' works, but is not what is needed. I need to make the birth_d optional, and if not supplied, should be undef.
I should add, I tried using MooseX::Types to tuck this Birth_d type away in a separate place, but found its cavalier use of barewords a bit unorthodox, so I slowly backed away. I'm open to reconsidering it, if it makes sense to do so.
Moose does not do any chaining of coercions, in other words you have to tell it explicitly how to convert to a Maybe[Birth_d].
You can do this by reusing the existing coercion to Birth_d:
package Student;
use Moose;
use Moose::Util::TypeConstraints;
use DateTime::Format::MySQL;
# save the Moose::Meta::TypeConstraint object
# you can also get it with find_type_constraint('Birth_d')
my $birth_d = class_type 'Birth_d', { class => 'DateTime' };
coerce 'Birth_d',
from 'Str',
via { DateTime::Format::MySQL->parse_date( $_ ) };
subtype 'MaybeBirth_d',
as 'Maybe[Birth_d]';
coerce 'Maybe[Birth_d]',
from 'Str|Undef',
via { $birth_d->coerce($_) };
has 'name' => (
isa => 'Str',
is => 'ro',
);
has 'birth_d' => (
isa => 'Maybe[Birth_d]',
coerce => 1,
is => 'ro',
predicate => 'has_birth_d', # as per your comment
);
package main;
use Test::More;
my $student = Student->new(
name => 'Johnnie Appleseed',
birth_d => '2015-01-01'
);
is ( $student->birth_d->ymd(), '2015-01-01' );
my $student2 = Student->new(
name => 'Foo Bar',
birth_d => undef
);
is( $student2->birth_d, undef );
ok( $student2->has_birth_d );
done_testing;
I would find it more useful to not have a Maybe[Birth_d] type, but simply declare the attribute with the Birth_d type, and no "required" set.
That way, if a valid String is passed in, it will be accepted, an invalid String will lead to an error, and nothing just does not need to be passed in.
However, you can coerce to a maybe type:
subtype 'MaybeBirth_d',
as maybe_type(class_type('DateTime'));
coerce 'MaybeBirth_d',
from 'Str',
via { DateTime::Format::MySQL->parse_date( $_ ) };
has 'birth_d' => (
isa => 'MaybeBirth_d',
coerce => 1,
is => 'ro',
);
I just do not see the value of being able to pass in undef for a birthdate - how is that better than not setting it?
I would also like to suggest using no Moose::Util::TypeConstraints; and no Moose; at the end of your package, or namespace::autoclean; at the beginning, as well as __PACKAGE__->meta->make_immutable; at the end of your Student class.
I'm dealing with some non-Moose legacy code and I want to extend it with a Moose class. This is a simplification of the legacy code:
package My::Legacy;
sub create {
my ($class, $args) = #_;
my $fields = { _fields => {}};
foreach my $key ( keys %$args ) {
$fields->{_fields}->{$key} = $args->{$key}
}
bless $fields, $class;
}
1;
The My::Legacy class handles all the CRUD operations, caching and other stuff. All the operations are performed on the values contained in the internal _field hash, so, for example, if you want to update a value it has to be in the _field hash. The My::Legacy class provides setter/getter for this.
The My::Legacy is subclassed by several classes that need the "sugar" provided by it: My::Legacy::ObjectA, My::Legacy::ObjectB, etc.
I need to add a further one and I want to extend it using Moose. The problem is that every time I will set an attribute, I will have to keep its value in sync in the internal _fields hash, so for example if I have...
package My::Legacy::MyMooseObj;
use Moose;
use MooseX::NonMoose;
use namespace::autoclean;
has _fields => (
isa => HashRef,
is => 'rw',
default => sub { {} },
);
has attr_a => (
isa => 'Int',
is => 'ro',
);
has attr_b => (
isa => 'Str',
is => 'ro',
);
__PACKAGE__->meta->make_immutable;
...and I do:
my $MyMooseObj = My::Legacy::MyMooseObj->new();
$MyMooseObj->attr_a(15);
...I want attr_a to be set in _fields as well, so if I dump out the object it will look like:
bless( {
'_fields' => {
'attr_a' => 15,
},
'attr_a' => 15,
}, 'My::Legacy::MyMooseObj' );
The way I come up to achieve this is add a trigger to each attribute in order to write its value in the _fields hash every time is set:
has attr_b => (
isa => 'Str',
is => 'ro',
trigger => sub { # Write in the _fields attribute attr_b value! },
);
This is a bit annoying because every time I add a new attribute I have to make sure it has the trigger set :/
Can you think of a better way of doing it ? Is there any way of telling Moose to read/write the attribute not in the "root" of the object hash by default (so in my case to read/write attributes from _fields) ?
This more or less does what you want...
use strict;
use warnings;
{
package My::Legacy::MyMooseObj;
use Moose;
use MooseX::FunkyAttributes;
use namespace::autoclean;
has _fields => (
isa => 'HashRef',
is => 'rw',
default => sub { {} },
lazy => 1, # you want this, for the rest to work
);
has attr_a => (
isa => 'Int',
is => 'ro',
traits => [ FunkyAttribute ],
custom_get => sub { $_->_fields->{attr_a} },
custom_set => sub { $_->_fields->{attr_a} = $_[-1] },
custom_has => sub { exists($_->_fields->{attr_a}) },
);
has attr_b => (
isa => 'Str',
is => 'rw',
traits => [ FunkyAttribute ],
custom_get => sub { $_->_fields->{attr_b} },
custom_set => sub { $_->_fields->{attr_b} = $_[-1] },
custom_has => sub { exists($_->_fields->{attr_b}) },
);
}
my $obj = My::Legacy::MyMooseObj->new( attr_a => 42 );
$obj->attr_b(666);
print $obj->dump;
With the current version of MooseX::FunkyAttributes, the constructor will not work correctly if you do the whole __PACKAGE__->meta->make_immutable though. :-(
Delving slightly deeper into metaprogramming...
use strict;
use warnings;
{
package My::Legacy::MyMooseObj;
use Moose;
use MooseX::FunkyAttributes;
use namespace::autoclean;
has _fields => (
isa => 'HashRef',
is => 'rw',
default => sub { {} },
lazy => 1, # you want this, for the rest to work
);
sub funky_has {
my ($attr, %opts) = #_;
has $attr => (
is => 'ro',
traits => [ FunkyAttribute ],
custom_get => sub { $_->_fields->{$attr} },
custom_set => sub { $_->_fields->{$attr} = $_[-1] },
custom_has => sub { exists($_->_fields->{$attr}) },
%opts,
);
}
funky_has attr_a => (isa => 'Int');
funky_has attr_b => (isa => 'Str', is => 'rw');
}
my $obj = My::Legacy::MyMooseObj->new( attr_a => 42 );
$obj->attr_b(666);
print $obj->dump;
I have one object that has an attribute of an array of another group of objects. I have a toString method that I want to print out the entire contents of the objects. The main goal is to have the Job object call all the post process jobs that are in the array. I want to call the method toString on the objects in the object array as well. Currently, I'm getting this error:
Can't call method "toString" without a package or object reference at JobClass.pm line 52, <JOBFILE> line 5. (which is $item->toString(); in the foreach loop)
Dumper on $item shows the following:
$VAR1 = bless( {
'ImportID' => '22',
'ImportTableID' => '1234',
'ImportTable' => 'testImport'
}, 'PostJob' );
Main goal of what I'm trying to understand is how I can call a method on an object returned from an member array.
Classes instantiated this way:
my $postJob = PostJob->new(ImportTable => "testImport",ImportTableID => "1234", ImportID => "22");
my #postJobs ="";
push (#postJobs,$postJob);
$postJob->toString(); #this works fine
my $job = Job->new(DirectoryName => "testDir",StagingTableName => "stageTable", QBStagingTableID => "5678",postProcessJobs => \#postJobs);
$job->toString(); #Breaks with error above
Code is below:
package PostJob;
use Moose;
use strict;
use Data::Dumper;
has 'ImportTable' => (isa => 'Str', is => 'rw', required => 1);
has 'ImportTableID' => (isa => 'Str', is => 'rw', required => 1);
has 'ImportID' => (isa => 'Str', is => 'rw', required => 1);
sub toString {
# Print all the values
my $self = shift;;
print "Table Name for Post Job is ".$self->ImportTable."\n";
print "Table ID for Post Job is ".$self->ImportTableID."\n";
print "Import ID for Post Job is ".$self->ImportID."\n";
}
package Job;
use strict;
use Data::Dumper;
use Moose;
has 'DirectoryName' => (isa => 'Str', is => 'rw', required => 1);
has 'StagingTableName' => (isa => 'Str', is => 'rw', required => 1);
has 'StagingTableID' => (isa => 'Str', is => 'rw', required => 1);
has 'postProcessJobs'=> (isa => 'ArrayRef', is => 'rw', required => 0);
sub addPostJob {
my ($self,$postJob) = #_;
push(#{$self->postProcessJobs()},$postJob);
}
sub toString
{
# Print all the values.
my $self = shift;
print "DUMPING JOB OBJECT CONTENTS*****************************\n";
print "Directory is ".$self->DirectoryName."\n";
print "Staging Table is ".$self->StagingTableName."\n";
print "Staging Table ID is ".$self->StagingTableID."\n";
print "DUMPING POST JOB CONTENTS*****************************\n";
foreach my $item (#{$self->postProcessJobs()})
{
$item->toString();
print Dumper($item);
}
print "END DUMPING JOBS*****************************\n";
}
1;
The problem is on the following line:
my #postJobs ="";
This creates the first member of the array, but this member is not a job, it is an empty string. Replace it with
my #postJobs;
and the error goes away.
I'm having trouble with this Moose-related error when using BUILD. When I change to BUILDALL it appears to work. Note the use of Class::MOP::load_class
Using BUILD
Perl version: 5.012002
Class::MOP::Version: 1.11
Moose::Version: 1.24
Applying fixup GV::WebServer::Fixups::Development
aflott-g3 at a.pl line 83.
Error: trying to call refresh() in GV::WebServer::Fixups::Development produced: The 'add_attribute' method cannot be called on an immutable instance at /opt/cidc-perl/perl-5.12.2/lib/perl5/x86_64-linux/Class/MOP/Class/Immutable/Trait.pm line 32
Class::MOP::Class::Immutable::Trait::_immutable_cannot_call('add_attribute') called at /opt/cidc-perl/perl-5.12.2/lib/perl5/x86_64-linux/Class/MOP/Class/Immutable/Trait.pm line 37
Class::MOP::Class:::around('CODE(0x13a2e028)', 'Class::MOP::Class::Immutable::Moose::Meta::Class=HASH(0x13d58...', 'architecture', 'is', 'ro', 'isa', 'Str', 'lazy', 1, ...) called at /opt/cidc-perl/perl-5.12.2/lib/perl5/x86_64-linux/Class/MOP/Method/Wrapped.pm line 159
Class::MOP::Method::Wrapped::__ANON__('Class::MOP::Class::Immutable::Moose::Meta::Class=HASH(0x13d58...', 'architecture', 'is', 'ro', 'isa', 'Str', 'lazy', 1, 'default', ...) called at /opt/cidc-perl/perl-5.12.2/lib/perl5/x86_64-linux/Class/MOP/Method/Wrapped.pm line 89
Class::MOP::Class::Immutable::Moose::Meta::Class::add_attribute('Class::MOP::Class::Immutable::Moose::Meta::Class=HASH(0x13d58...', 'architecture', 'is', 'ro', 'isa', 'Str', 'lazy', 1, 'default', ...) called at a.pl line 47
Amethyst::SystemInfo::BUILD('Amethyst::SystemInfo=HASH(0x13e83010)', 'HASH(0x13e50cc0)') called at generated method (unknown origin) line 147
Amethyst::SystemInfo::new('Amethyst::SystemInfo') called at a.pl line 92
GV::WebServer::Fixups::AutoSet::set() called at a.pl line 84
GV::WebServer::Fixups::Development::refresh('GV::WebServer::Fixups::Development') called at a.pl line 114
main::__ANON__() called at /opt/cidc-perl/perl-5.12.2/lib/perl5/Try/Tiny.pm line 76
eval {...} called at /opt/cidc-perl/perl-5.12.2/lib/perl5/Try/Tiny.pm line 67
Try::Tiny::try('CODE(0x13e82fe0)', 'Try::Tiny::Catch=REF(0x13e8cd50)') called at a.pl line 118
Using BUILDALL:
Perl version: 5.012002
Class::MOP::Version: 1.11
Moose::Version: 1.24
Applying fixup GV::WebServer::Fixups::Development
aflott-g3 at a.pl line 71.
aflott-g3364136 at a.pl line 81.
Full error
From this code:
package Amethyst::SystemInfo;
use v5.10;
use Moose;
use Sys::Hostname qw();
use Sys::HostIP;
use Try::Tiny;
has '_host_ip' => ('is' => 'ro', 'isa' => 'Sys::HostIP', 'default' => sub { Sys::HostIP->new });
has 'eth0_ipv4' => ('is' => 'rw', 'isa' => 'Str',);
has 'ethernet_interfaces' => ('is' => 'rw', 'isa' => 'HashRef',);
has 'hostname' => ('is' => 'ro', 'isa' => 'Str', 'default' => sub { Sys::Hostname::hostname });
sub BUILD {
my ($self) = #_;
$self->ethernet_interfaces($self->_host_ip->interfaces);
if ($self->ethernet_interfaces->{'eth0'}) {
$self->eth0_ipv4($self->ethernet_interfaces->{'eth0'});
}
foreach my $attrib (
qw(architecture domain fqdn kernel kernelrelease kernelversion memorytotal operatingsystem processor processorcount swap)
) {
$self->meta->add_attribute(
$attrib => (
'is' => 'ro',
'isa' => 'Str',
'lazy' => 1,
'default' => sub { return $self->_load_value($attrib) }
)
);
}
$self->meta->make_immutable;
return;
}
sub _load_value {
my ($self, $module_name) = #_;
try {
Class::MOP::load_class("Pfacter::$module_name");
}
catch {
warn("Failed to load Pfacter::$module_name");
};
my $value = "Pfacter::$module_name"->pfact({'pfact' => {'kernel' => 'Linux'}});
unless (defined($value)) {
warn("finding value for $module_name returned undef");
}
chomp($value);
return $value;
}
no Moose;
package GV::WebServer::Fixups::Development;
use v5.10;
sub refresh {
warn Amethyst::SystemInfo->new->hostname;
return GV::WebServer::Fixups::AutoSet::set();
}
package GV::WebServer::Fixups::AutoSet;
use v5.10;
sub set {
my $sysinfo = Amethyst::SystemInfo->new;
warn $sysinfo->hostname, ' ', $sysinfo->swap;
}
package main;
use v5.10;
use Class::MOP;
use Try::Tiny;
my $module_name = "GV::WebServer::Fixups::Development";
say('Perl version: ', $]);
say('Class::MOP::Version: ', $Class::MOP::VERSION);
say('Moose::Version: ', $Moose::VERSION);
say("Applying fixup $module_name");
Class::MOP::load_class($module_name);
my $ret;
try {
$ret = $module_name->refresh;
}
catch {
warn("Error: trying to call refresh() in $module_name produced: " . shift);
};
You are modifying the class every time you construct an object of that class. That makes no sense. Just move your class construction code out of BUILD and BUILDARGS and place it with the rest of the class construction code.
package Amethyst::SystemInfo;
use v5.10;
use Moose;
use Sys::Hostname qw();
use Sys::HostIP;
use Try::Tiny;
has '_host_ip' => ('is' => 'ro', 'isa' => 'Sys::HostIP', 'default' => sub { Sys::HostIP->new });
has 'eth0_ipv4' => ('is' => 'rw', 'isa' => 'Str',);
has 'ethernet_interfaces' => ('is' => 'rw', 'isa' => 'HashRef',);
has 'hostname' => ('is' => 'ro', 'isa' => 'Str', 'default' => sub { Sys::Hostname::hostname });
foreach my $attrib (qw(
architecture domain fqdn kernel kernelrelease kernelversion
memorytotal operatingsystem processor processorcount swap
)) {
has $attrib => (
'is' => 'ro',
'isa' => 'Str',
'lazy' => 1,
'default' => sub { return $_[0]->_load_value($attrib) },
);
}
sub BUILD {
my ($self) = #_;
$self->ethernet_interfaces($self->_host_ip->interfaces);
if ($self->ethernet_interfaces->{'eth0'}) {
$self->eth0_ipv4($self->ethernet_interfaces->{'eth0'});
}
}
sub _load_value {
...
}
no Moose;
__PACKAGE__->meta->make_immutable;
1;
Kudos to phaylon and bvr.