How do I use an array as an object attribute in Perl? - perl

I need some help regarding the arrays in Perl
This is the constructor I have.
BuildPacket.pm
sub new {
my $class = shift;
my $Packet = {
_PacketName => shift,
_Platform => shift,
_Version => shift,
_IncludePath => [#_],
};
bless $Packet, $class;
return $Packet;
}
sub SetPacketName {
my ( $Packet, $PacketName ) = #_;
$Packet->{_PacketName} = $PacketName if defined($PacketName);
return $Packet->{_PacketName};
}
sub SetIncludePath {
my ( $Packet, #IncludePath ) = #_;
$Packet->{_IncludePath} = \#IncludePath;
}
sub GetPacketName {
my( $Packet ) = #_;
return $Packet->{_PacketName};
}
sub GetIncludePath {
my( $Packet ) = #_;
#{ $Packet->{_IncludePath} };
}
(The code has been modified according to the suggestions from 'gbacon', thank you)
I am pushing the relative paths into 'includeobjects' array in a dynamic way. The includepaths are being read from an xml file and are pushed into this array.
# PacketInput.pm
if($element eq 'Include')
{
while( my( $key, $value ) = each( %attrs ))
{
if($key eq 'Path')
push(#includeobjects, $value);
}
}
So, the includeobject will be this way:
#includeobjects = (
"./input/myMockPacketName",
"./input/myPacket/my3/*.txt",
"./input/myPacket/in.html",
);
I am using this line for set include path
$newPacket->SetIncludePath(#includeobjects);
Also in PacketInput.pm, I have
sub CreateStringPath
{
my $packet = shift;
print "printing packet in CreateStringPath".$packet."\n";
my $append = "";
my #arr = #{$packet->GetIncludePath()};
foreach my $inc (#arr)
{
$append = $append + $inc;
print "print append :".$append."\n";
}
}
I have many packets, so I am looping through each packet
# PacketCreation.pl
my #packets = PacketInput::GetPackets();
foreach my $packet (PacketInput::GetPackets())
{
print "printing packet in loop packet".$packet."\n";
PacketInput::CreateStringPath($packet);
$packet->CreateTar($platform, $input);
$packet->GetValidateOutputFile($platform);
}
The get and set methods work fine for PacketName. But since IncludePath is an array, I could not get it to work, I mean the relative paths are not being printed.

If you enable the strict pragma, the code doesn't even compile:
Global symbol "#_IncludePath" requires explicit package name at Packet.pm line 15.
Global symbol "#_IncludePath" requires explicit package name at Packet.pm line 29.
Global symbol "#_IncludePath" requires explicit package name at Packet.pm line 30.
Global symbol "#_IncludePath" requires explicit package name at Packet.pm line 40.
Don't use # unquoted in your keys because it will confuse the parser. I recommend removing them entirely to avoid confusing human readers of your code.
You seem to want to pull all the attribute values from the arguments to the constructor, so continue peeling off the scalar values with shift, and then everything left must be the include path.
I assume that the components of the include path will be simple scalars and not references; if the latter is the case, then you'll want to make deep copies for safety.
sub new {
my $class = shift;
my $Packet = {
_PacketName => shift,
_Platform => shift,
_Version => shift,
_IncludePath => [ #_ ],
};
bless $Packet, $class;
}
Note that there's no need to store the blessed object in a temporary variable and then immediately return it because of the semantics of Perl subs:
If no return is found and if the last statement is an expression, its value is returned.
The methods below will also make use of this feature.
Given the constructor above, GetIncludePath becomes
sub GetIncludePath {
my( $Packet ) = #_;
my #path = #{ $Packet->{_IncludePath} };
wantarray ? #path : \#path;
}
There are a couple of things going on here. First, note that we're careful to return a copy of the include path rather than a direct reference to the internal array. This way, the user can modify the value returned from GetIncludePath without having to worry about mucking up the packet's state.
The wantarray operator allows a sub to determine the context of its call and respond accordingly. In list context, GetIncludePath will return the list of values in the array. Otherwise, it returns a reference to a copy of the array. This way, client code can call it either as in
foreach my $path (#{ $packet->GetIncludePath }) { ... }
or
foreach my $path ($packet->GetIncludePath) { ... }
SetIncludePath is then
sub SetIncludePath {
my ( $Packet, #IncludePath ) = #_;
$Packet->{_IncludePath} = \#IncludePath;
}
Note that you could have used similar code in the constructor rather than removing one parameter at a time with shift.
You might use the class defined above as in
#! /usr/bin/perl
use strict;
use warnings;
use Packet;
sub print_packet {
my($p) = #_;
print $p->GetPacketName, "\n",
map(" - [$_]\n", $p->GetIncludePath),
"\n";
}
my $p = Packet->new("MyName", "platform", "v1.0", qw/ foo bar baz /);
print_packet $p;
my #includeobjects = (
"./input/myMockPacketName",
"./input/myPacket/my3/*.txt",
"./input/myPacket/in.html",
);
$p->SetIncludePath(#includeobjects);
print_packet $p;
print "In scalar context:\n";
foreach my $path (#{ $p->GetIncludePath }) {
print $path, "\n";
}
Output:
MyName
- [foo]
- [bar]
- [baz]
MyName
- [./input/myMockPacketName]
- [./input/myPacket/my3/*.txt]
- [./input/myPacket/in.html]
In scalar context:
./input/myMockPacketName
./input/myPacket/my3/*.txt
./input/myPacket/in.html

Another way to reduce typing is to use Moose.
package Packet;
use Moose::Policy 'Moose::Policy::JavaAccessors';
use Moose;
has 'PacketName' => (
is => 'rw',
isa => 'Str',
required => 1,
);
has 'Platform' => (
is => 'rw',
isa => 'Str',
required => 1,
);
has 'Version' => (
is => 'rw',
isa => 'Int',
required => 1,
);
has 'IncludePath' => (
is => 'ro',
isa => 'ArrayRef[Str]',
default => sub {[]},
traits => [ 'Array' ],
handles => {
getIncludePath => 'elements',
getIncludePathMember => 'get',
setIncludePathMember => 'set',
},
);
__PACKAGE__->meta->make_immutable;
no Moose;
1;
Check out Moose::Manual::Unsweetened for another example of how Moose saves time.
If you are adamant in your desire to learn classical Perl OOP, read the following perldoc articles: perlboot, perltoot, perlfreftut and perldsc.
A great book about classical Perl OO is Damian Conway's Object Oriented Perl. It will give you a sense of the possibilities in Perl's object.

Once you understand #gbacon's answer, you can save some typing by using Class::Accessor::Fast:
#!/usr/bin/perl
package My::Class;
use strict; use warnings;
use base 'Class::Accessor::Fast';
__PACKAGE__->follow_best_practice;
__PACKAGE__->mk_accessors( qw(
IncludePath
PacketName
Platform
Version
));
use overload '""' => 'to_string';
sub to_string {
my $self = shift;
sprintf(
"%s [ %s:%s ]: %s",
$self->get_PacketName,
$self->get_Platform,
$self->get_Version,
join(':', #{ $self->get_IncludePath })
);
}
my $obj = My::Class->new({
PacketName => 'dummy', Platform => 'Linux'
});
$obj->set_IncludePath([ qw( /home/include /opt/include )]);
$obj->set_Version( '1.05b' );
print "$obj\n";

Related

How can I implement "thunks" (delayed computation) in a general way using Moo and Type::Tiny?

I want to be able to have a Moo* class with these characteristics:
an object's attribute can store a reference to the object itself
that attribute will be type-constrained using a Type::Tiny type so the reference must be of the right type
the class must function when it is immutable, and the attribute is "required", i.e. an undefined value is unacceptable and it cannot be updated later
E.g.
package GraphQLType;
use Moo;
use Types::Standard -all;
has [qw(children)] => (
is => 'rwp',
isa => ArrayRef[InstanceOf['GraphQLType']],
required => 1,
);
package main;
my $type;
$type = GraphQLType->new(children => [$type]);
The above presents a chicken-and-egg problem: $type will be undefined and therefore fail the type constraint.
A pattern used in graphql-js is "thunking". In Perl terms:
package GraphQLType;
use Moo;
use Types::Standard -all;
has [qw(children)] => (
is => 'rwp',
isa => CodeRef | ArrayRef[InstanceOf['GraphQLType']],
required => 1,
);
package main;
my $type;
$type = GraphQLType->new(children => sub { [$type] });
While that works for the specific type there, how can I have a parameterised type that implements something like this? Also, it will help even more if this can hook into the "lazy" functionality to minimise the code involved in storing the computed value.
package Thunking;
use Moo;
use Types::Thunking -all;
use Types::Standard -all;
has [qw(children)] => (
is => 'lazy',
isa => Thunk[ArrayRef[InstanceOf['GraphQLType']]],
required => 1,
);
Two issues need to be dealt with here: a parameterised Type::Tiny type constraint for a delayed-computation immutable attribute (DCIA), and an actually-functioning DCIA.
Parameterised type
Since this is Perl, there is more than one way to do this. The heart of making a parameterised type in Type::Tiny is to provide a constraint_generator parameter. The most idiomatic way to do this, using only Type::Tiny components, is:
package Types::Thunking;
use Types::TypeTiny -all;
use Type::Library -base;
use Type::Utils -all;
declare "Thunk", constraint_generator => sub { union [ CodeLike, #_ ] };
That's it! If no parameters are given, it works just like a CodeLike. The libraries can take care of any "inline" code generating.
The reason it can be so short is that the constraint_generator must return either a code-ref, which would probably be a closure that captures the parameters passed to it (see below), or simply a Type::Tiny - in which case the other parameterisability parameters are not needed. Since union (which looks like it's normally intended for producing arguments to a declare) returns a suitably-constructed Type::Tiny::Union, it just drops in perfectly.
A more spelled-out version, not using a union type (and for brevity, using CodeRef not CodeLike:
package Types::Thunking;
use Types::Standard -all;
use Type::Library -base;
use Type::Utils -all;
declare "Thunk",
constraint_generator => sub {
my ($param) = #_;
die "parameter must be a type" if grep !UNIVERSAL::isa($_, 'Type::Tiny'), #_;
return sub { is_CodeRef($_) or $param->check($_) };
},
inline_generator => sub {
my ($param) = #_;
die "parameter must be a type" if grep !UNIVERSAL::isa($_, 'Type::Tiny'), #_;
return sub {
my ($constraint, $varname) = #_;
return sprintf(
'Types::Standard::is_CodeRef(%s) or %s',
$varname,
$param->inline_check($varname),
);
};
};
This is the "harness" I used for testing these:
#!/usr/bin/perl
use Thunking;
sub do_test {
use Data::Dumper; local $Data::Dumper::Terse = 1; local $Data::Dumper::Indent = 0;
my ($args, $should_work) = #_;
my $l = eval { Thunking->new(#$args) };
if (!$l) {
say "correctly did not work" and return if !$should_work;
say "INcorrectly did not work" and return if $should_work;
}
my $val = eval { $l->attr };
if (!$val) {
say "correctly did not work" and return if !$should_work;
say "INcorrectly did not work" and return if $should_work;
}
say(($should_work ? "" : "INcorrectly worked: "), Dumper $val);
}
do_test [attr => { k => "wrong type" }], 0;
do_test [attr => ["real value at init"]], 1;
do_test [attr => sub { [ "delayed" ] }], 1;
do_test [attr => sub { { k => "delayed wrong type" } }], 0;
Delayed-computation immutable attribute
In order to make this immutable, we want setting the attribute to fail unless it's us doing it. When reading the attribute, we want to see whether there is computation to be done; if yes, do it; then return the value.
Naive approach
package Thunking;
use Moo;
use Types::Standard -all;
use Types::Thunking -all;
has attr => (
is => 'rwp',
isa => Thunk[ArrayRef],
required => 1,
);
before 'attr' => sub {
my $self = shift;
return if #_; # attempt at setting, hand to auto
my $value = $self->{attr};
return if ref($value) ne 'CODE'; # attempt at reading and already resolved
$self->_set_attr($value->());
}
The before should be fairly self-explanatory but you will see it manually looks in the object's hash-ref, which is usually a clue that your programming is not finished yet. Also, it's rwp and requires the before in the class, which is far from pretty.
Using MooX modules
An approach that tries to generalise this with a separate module, MooX::Thunking. First, another module to encapsulate overriding of Moo functions:
package MooX::Utils;
use strict;
use warnings;
use Moo ();
use Moo::Role ();
use Carp qw(croak);
use base qw(Exporter);
our #EXPORT = qw(override_function);
sub override_function {
my ($target, $name, $func) = #_;
my $orig = $target->can($name) or croak "Override '$target\::$name': not found";
my $install_tracked = Moo::Role->is_role($target) ? \&Moo::Role::_install_tracked : \&Moo::_install_tracked;
$install_tracked->($target, $name, sub { $func->($orig, #_) });
}
Now the thunking MooX module itself, which uses the above to override has:
package MooX::Thunking;
use MooX::Utils;
use Types::TypeTiny -all;
use Class::Method::Modifiers qw(install_modifier);
sub import {
my $target = scalar caller;
override_function($target, 'has', sub {
my ($orig, $name, %opts) = #_;
$orig->($name, %opts), return if $opts{is} ne 'thunked';
$opts{is} = 'ro';
$orig->($name, %opts); # so we have method to modify
install_modifier $target, 'before', $name => sub {
my $self = shift;
return if #_; # attempt at setting, hand to auto
my $value = $self->{$name};
return if !eval { CodeLike->($value); 1 }; # attempt at reading and already resolved
$self->{$name} = $value->();
$opts{isa}->($self->{$name}) if $opts{isa}; # validate
}
});
}
This applies "thunking" to an attribute. It will only function if the attribute is ro, and will quietly resolve any CodeLike values on reading. It can be used like this:
package Thunking;
use Moo;
use MooX::Thunking;
use Types::Standard -all;
use Types::Thunking -all;
has attr => (
is => 'thunked',
isa => Thunk[ArrayRef],
);
Using BUILDARGS and lazy
An alternative approach, suggested by the mighty #haarg:
package MooX::Thunking;
use MooX::Utils;
use Types::TypeTiny -all;
use Class::Method::Modifiers qw(install_modifier);
sub import {
my $target = scalar caller;
override_function($target, 'has', sub {
my ($orig, $name, %opts) = #_;
$orig->($name, %opts), return if $opts{is} ne 'thunked';
$opts{is} = 'lazy';
my $gen_attr = "_gen_$name";
$orig->($gen_attr => (is => 'ro'));
$opts{builder} = sub { $_[0]->$gen_attr->(); };
install_modifier $target, 'around', 'BUILDARGS' => sub {
my ($orig, $self) = (shift, shift);
my $args = $self->$orig(#_);
$args->{$gen_attr} = delete $args->{$name} if eval { CodeLike->($args->{$name}); 1 };
return $args;
};
$orig->($name, %opts);
});
}
It uses the built-in lazy mechanism, creating a builder that will call the supplied CodeLike if that is what is given. One important downside is that this technique does not work for Moo::Roles.

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

method modifiers with moose perl

I need to filter the "string" passed to the attribute "query"
and create a url with the filtered value.
my code
package Search;
use Any::Moose;
has query => qw{ is ro isa Str required 1 };
# my method modifiers
around 'query' => sub {
my $orig = shift;
my $self = shift;
my $content = $self->$orig(#_);
# simple filter
$content =~ s{[^\w\-\s]}{}gi;
return $content;
};
sub create_uri {
my $self = shift;
my $uri = "http://localhost/search/".$self->{query};
return $uri;
};
1;
package main;
my $obj = Search->new({
query => 'foo##$%#%##&-**bar###%!',
});
print $obj->query."\n";
print $obj->create_uri."\n"; # BAD
output here :
print $search->query;
foo-bar , as expected.
When I call "create_uri"
print $search->create_uri;
output :
http://localhost/search/foo##$%#%##&-**bar###%!
The "query" is completely dirty!
How to solve this?
A couple more approaches for you to explore:
Use a BUILDARGS method in your class to clean up the query string before it gets assigned to the attribute at construction.
sub BUILDARGS {
my $type = shift;
my $args = ref $_[0] eq 'HASH' ? shift : {#_};
$args->{query} =~ s{[^\w\-\s]}{}gi;
return $args;
}
Use type coercion.
subtype 'SafeStr', as 'Str', where {!/[^\w\-\s]/};
coerce 'SafeStr', from 'Str', via {
my $str = $_;
$str =~ s/[^\w\-\s]//gi;
return $str;
};
has 'query' => (
is => 'ro',
isa => 'SafeStr',
required => 1,
coerce => 1,
);
When you call print $obj->query you are calling the /subroutine/ called query, which calls your around sub. When you call $self->{query} from within create_uri you access the /attribute/ called query. There are two solutions:
1) Replace $self->{query} with $self->query
2) Instead of using around query, use the trigger option on the attribute, which calls a function every time the attribute is set. See http://metacpan.org/pod/Moose for information.

Make the Moose constructor ignore undef arguments

A hashtable is the typical initializer for your Perl objects. Now your input is unreliable in that you don't know whether for any given key there'll be a defined value, nor whether the key is there at all. Now you want to feed such unreliable input into Moose objects, and while absent keys are perfectly okay you do want to get rid of the undefined values so you don't end up with an object full of undefined attributes.
You could certainly take great care when instantiating objects and filter out the undefined values. But let's say you want to install that filter in your constructor because then it is in one place. You want the constructor to ignore undefined values, but not to die on encountering them.
For accessor methods, you can use around around to prevent the attribute to be set to undef. But those method modifiers aren't called for the constructor, only for accessors. Is there a similar facility in Moose to achieve the same effect for the c'tor, i.e. to preclude any undef attributes from being accepted?
Note that the Moose Any type will create the hash key in the object if the attribute is undef. I don't want that because I want %$self not to contain any undef values.
Here's some testing I did:
package Gurke;
use Moose;
use Data::Dumper;
has color => is => 'rw', isa => 'Str', default => 'green';
has length => is => 'rw', isa => 'Num';
has appeal => is => 'rw', isa => 'Any';
around color => sub {
# print STDERR Dumper \#_;
my $orig = shift;
my $self = shift;
return $self->$orig unless #_;
return unless defined $_[0];
return $self->$orig( #_ );
};
package main;
use Test::More;
use Test::Exception;
my $gu = Gurke->new;
isa_ok $gu, 'Gurke';
diag explain $gu;
ok ! exists $gu->{length}, 'attribute not passed, so not set';
diag q(attempt to set color to undef - we don't want it to succeed);
ok ! defined $gu->color( undef ), 'returns undef';
is $gu->color, 'green', 'value unchanged';
diag q(passing undef in the constructor will make it die);
dies_ok { Gurke->new( color => undef ) }
'around does not work for the constructor!';
lives_ok { $gu = Gurke->new( appeal => undef ) } 'anything goes';
diag explain $gu;
diag q(... but creates the undef hash key, which is not what I want);
done_testing;
This is exactly what MooseX::UndefTolerant does. If you make your class immutable, it will be much faster than writing your own BUILDARGS method, as the code is inlined into the generated constructor.
Just provide your own BUILDARGS subroutine.
package Gurke;
...
around 'BUILDARGS' => sub{
my($orig,$self,#params) = #_;
my $params;
if( #params == 1 ){
($params) = #params;
}else{
$params = { #params };
}
for my $key ( keys %$params ){
delete $params->{$key} unless defined $params->{$key};
}
$self->$orig($params);
};
I realize that it is somewhat a duplicated effort, but you can hook ctor with BUILDARGS:
around BUILDARGS => sub {
my $orig = shift;
my $class = shift;
my %params = ref $_[0] ? %{$_[0]} : #_;
return $class->$orig(
map { $_ => $params{$_} }
grep { defined $params{$_} }
keys %params
);
};
Edit: Edited to support even the reference passed to ctor.
While the example given clarifies that the question is inspired by a desire to handle undef attributes passed to a constructor, the question itself additionally implies the case of passing only undef to the constructor, which is something I've encountered and wanted to solve.
E.g., Class->new(undef).
I like bvr's BUILDARGS answer. It can be extended to handle the case of passing an undef value instead of a hashref as the lone argument to a constructor:
around BUILDARGS => sub {
my $orig = shift;
my $class = shift;
my %params = defined $_[0] ? ref $_[0] ? %{$_[0]} : #_ : ();
return $class->$orig(
map { $_ => $params{$_} }
grep { defined $params{$_} }
keys %params
);
};
MooseX::UndefTolerant does not appear to support this case.