How to return the correct object attribute in perl? - perl

I have a package I created that is meant to return the object's specified attribute (shortened code)
package vendor_info;
my $vars;
sub new{
my $class = shift;
$vars = {
_servers => shift,
_locations => shift,
_favorite => shift,
_default_selection => shift,
_database => shift,
_DB => shift};
bless $vars, $class;
return $vars;
}
sub get_locations{
return $vars->{_locations};
}
sub get_database{
return $vars->{_database};
}
sub get_DB{
return $vars->{_DB};
}
My perl file receives an input parsed from the terminal but in this case, the variable $vendor is hard coded for testing. I have a list of objects in a hash, and I want to return the correct attribute according to the object. Some of the variables have been removed with placeholders.
$vendor = "atrena";
my %vendor_hash = (
"atrena" => new vendor_info("Variable_server","Variable_location","Advanced_CDC|CDC dftso|DFT|gui|GUI|adv_checker|Lint|spl-view-only|view-only-GUI","adv_checker","database","DB"),
"ansys" => new vendor_info("Variable","Location","agppi|agppi|ane3fl|ane3fl|ansys|ansys|ensemble_gui|ensemble_gui|hfss_desktop|hfss_desktop|hfss_gui|hfss_gui|hfss_solve|hfss_solve|hfsshpc_pack|hfsshpc_pack|optimetrics|optimetrics|q3d_desktop|q3d_desktop|rdacis|rdacis|struct|struct","ane3fl","database", "db"),
"coventor" => new vendor_info("var","location","COV_ZsplatViewer|Viewer|COV_VoxelModeler|Voxel-Modeler|MEMSp_Import_Package|Import-Package|MEMSp_Innovator_Plugin|Innovator-Plugin|MEMSp_MATLAB_Simulation|MATLAB-Simulation|MEMSp_Platform|Platform|MTI_AutoBuilder|Auto-Builder|MTI_Catapult|Catapult|MTI_CoventorWare|Coventor-Ware|MTI_Memcap|Memcap|MTI_PreProcessor|PreProcessor","database","db","db")
);
$vendor_object = $vendor_hash{$vendor};
print Dumper( $vendor_object);
$foodb = $vendor_object -> get_database();
The dumper is printing the correct information, however, when I call get_database(), the database called is always the attribute from the last object in the list, which in this case is coventor. The same could be said for any of the sub routine getters.
How do I call the correct attribute for the correct object?

You have $vars as a lexical variable which is scoped to the file which contains your package. So there is only one instance of this variable and it will always contain the data for the last object that was set up.
I'm not sure where you picked up that approach, but it's not how Perl objects work at all. $vars should be scoped to only exist within your constructor and your accessors should be using the object that is passed to them as their first argument (traditionally called $self).
# Only pragmas should start with lower-case letters
package VendorInfo;
sub new{
my $class = shift;
my $vars = {
_servers => shift,
_locations => shift,
_favorite => shift,
_default_selection => shift,
_database => shift,
_DB => shift
};
return bless $vars, $class;
}
# Just one example accessor...
sub get_database{
my $self = shift;
return $self->{_database};
}
One more point, please use Class->new() instead of the potentially problematic new Class syntax that you are using in your code.

Dave Cross already answered your immediate question.
This is an example of a more idiomatic version of your code:
{
package VendorInfo;
use Moo;
for my $attr (qw(
servers
locations
favorite
default_selection
database
DB
)) {
has $attr => (
is => 'ro',
required => 1,
);
}
}
# main program
use strict;
use warnings;
use Data::Dumper;
my %vendor_hash = (
"atrena" => VendorInfo->new(
servers => "Variable_server",
locations => "Variable_location",
favorite => "Advanced_CDC|CDC dftso|DFT|gui|GUI|adv_checker|Lint|spl-view-only|view-only-GUI",
default_selection => "adv_checker",
database => "database",
DB => "DB",
),
"ansys" => VendorInfo->new(
servers => "Variable",
locations => "Location",
favorite => "agppi|agppi|ane3fl|ane3fl|ansys|ansys|ensemble_gui|ensemble_gui|hfss_desktop|hfss_desktop|hfss_gui|hfss_gui|hfss_solve|hfss_solve|hfsshpc_pack|hfsshpc_pack|optimetrics|optimetrics|q3d_desktop|q3d_desktop|rdacis|rdacis|struct|struct",
default_selection => "ane3fl",
database => "database",
DB => "db",
),
"coventor" => VendorInfo->new(
servers => "var",
locations => "location",
favorite => "COV_ZsplatViewer|Viewer|COV_VoxelModeler|Voxel-Modeler|MEMSp_Import_Package|Import-Package|MEMSp_Innovator_Plugin|Innovator-Plugin|MEMSp_MATLAB_Simulation|MATLAB-Simulation|MEMSp_Platform|Platform|MTI_AutoBuilder|Auto-Builder|MTI_Catapult|Catapult|MTI_CoventorWare|Coventor-Ware|MTI_Memcap|Memcap|MTI_PreProcessor|PreProcessor",
default_selection => "database",
database => "db",
DB => "db",
),
);
my $vendor = "atrena";
my $vendor_object = $vendor_hash{$vendor};
print Dumper($vendor_object);
print "The database is: ", $vendor_object->database, "\n";
Things of note:
I renamed vendor_info to VendorInfo. Lowercase module names are (informally) reserved for pragmata.
I used Moo as a helper module for writing classes.
Moo provides a has helper function for declaring attributes. It also generates a constructor for me, so I don't have to write any boilerplate myself.
Moo automatically enables warnings/strict, so I don't have to do that either.
Indirect object syntax (method $object or method class, in your case new vendor_info) is a bad idea because of its syntactic ambiguity. class->method (here: VendorInfo->new) is much better.
The constructor created by Moo takes its arguments in the form of key-value pairs, not a long list (which is a good idea anyway if your sub takes more than 3 arguments).
Every attribute I declared gets a (read-only (because I used 'ro')) accessor, so client code can simply use $object->database.

In addition to other people's points, you will need to add a true statement at the end of your .pm file
This is how I would write your application
VendorInfo.pm
package VendorInfo;
use strict;
use warnings 'all';
sub new {
my $class = shift;
my $self;
#{$self}{qw/
_servers
_locations
_favorite
_default_selection
_database _DB
/} = #_;
return bless $self, $class;
}
sub get_locations {
my $self = shift;
return $self->{_locations};
}
sub get_database {
my $self = shift;
return $self->{_database};
}
sub get_DB {
my $self = shift;
return $self->{_DB};
}
1;
main.pl
use strict;
use warnings 'all';
use VendorInfo;
use Data::Dumper;
my $vendor = 'atrena';
my %vendor_hash = (
atrena => VendorInfo->new(
'Variable_server',
'Variable_location',
'Advanced_CDC|CDC dftso|DFT|gui|GUI|adv_checker|Lint|spl-view-only|view-only-GUI',
'adv_checker',
'database',
'DB',
),
ansys => VendorInfo->new(
'Variable',
'Location',
'agppi|agppi|ane3fl|ane3fl|ansys|ansys|ensemble_gui|ensemble_gui|hfss_desktop|hfss_desktop|hfss_gui|hfss_gui|hfss_solve|hfss_solve|hfsshpc_pack|hfsshpc_pack|optimetrics|optimetrics|q3d_desktop|q3d_desktop|rdacis|rdacis|struct|struct',
'ane3fl',
'database',
'db',
),
coventor => VendorInfo->new(
'var',
'location',
'COV_ZsplatViewer|Viewer|COV_VoxelModeler|Voxel-Modeler|MEMSp_Import_Package|Import-Package|MEMSp_Innovator_Plugin|Innovator-Plugin|MEMSp_MATLAB_Simulation|MATLAB-Simulation|MEMSp_Platform|Platform|MTI_AutoBuilder|Auto-Builder|MTI_Catapult|Catapult|MTI_CoventorWare|Coventor-Ware|MTI_Memcap|Memcap|MTI_PreProcessor|PreProcessor',
'database',
'db',
'db',
),
);
my $vendor_object = $vendor_hash{$vendor};
print Dumper $vendor_object;
my $foodb = $vendor_object->get_database;
print $foodb, "\n";
output
$VAR1 = bless( {
'_servers' => 'Variable_server',
'_default_selection' => 'adv_checker',
'_locations' => 'Variable_location',
'_database' => 'database',
'_DB' => 'DB',
'_favorite' => 'Advanced_CDC|CDC dftso|DFT|gui|GUI|adv_checker|Lint|spl-view-only|view-only-GUI'
}, 'VendorInfo' );
database

Related

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.

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

Perl, #array in perl constructor

I write perl classes, but I don't know how to have a array or a hash in my $this variable ?
I have a pack.pm :
#!/usr/bin/perl -w
use strict;
use Parallel::ForkManager;
package Pack;
our $cgi = new CGI;
sub new {
my ($classe, $nom, $nbports, $gio) = #_;
my $this = {
"nom" => $nom,
"nbports" => $nbports,
"gio" => $gio
};
bless($this, $classe);
return $this;
}
...
1;
I would like to have a #tab, I can access via $this->tab, but I don't want to give it in arg to the instance.
How does it work in Perl ?
Thanks.
Given your answer to my comments, I think you want
my($this) = {
"nom" => $nom,
"nbports" => $nbports,
"gio" => $gio,
"tab" => []
};
i.e. set $this->{tab} to be a reference to a new anonymous array.
Now you can reference it as you wish, e.g.
$this->{"tab"}[0] = "new value";
print "Table contains ", scalar(#{$this->{"tab"}}), "entries\n";
Consider using Moose for your OO Perl needs.
I've created a Moose version of your object that includes an attribute with an attribute featuring Array trait delegation, inlcuding currying of delegated methods. Moose offers easy ways to generate powerful, encapsulated classes without writing reams of boilerplate.
I created a class Pack with attributes: nom, nbports, gio, and tab.
nom is a read-only string and is required when the object is created.
nbports is a read-only integer value and defaults to 32 when not provided.
gio is an optional, read-write boolean value.
tab is an array of strings. All sorts of behavior has been defined for tab:
all_tabs returns a list of the contents of tabs
add_tab pushes values onto the end of tabs
tab_count returns a count of the elements in tabs
alpha_tabs returns a list of the members of tabs alphabetical order
turn_tabs returns a list of the strings in tabs, but with the letters in reverse
Any attempts to set an attribute with be checked for type correctness.
Moose creates all the required methods to support these complex behaviors with the following code:
package Pack;
use Moose;
has 'nom' => (
is => 'ro',
isa => 'Str',
required => 1,
);
has 'nbports' => (
is => 'ro',
isa => 'Int',
default => 32,
);
has 'gio' => (
is => 'rw',
isa => 'Bool',
predicate => 'has_gio',
);
has 'tab' => (
traits => ['Array'],
is => 'ro',
isa => 'ArrayRef[Str]',
default => sub {[]},
handles => {
all_tabs => 'elements',
add_tab => 'push',
turn_tabs => [ 'map', sub { reverse } ],
tab_count => 'count',
alpha_tabs => [ 'sort', sub { lc($a) cmp lc($b) } ],
},
);
__PACKAGE__->meta->make_immutable;
no Moose;
1;
Usable like so:
my $p = Pack->new( nom => 'Roger', tab => [qw( fee fie foe fum )] );
my $gio_state = 'UNSET';
if( $p->has_gio ) {
$gio_state = $p->gio ? 'TRUE' : 'FALSE';
}
print "GIO is $gio_state\n";
my #turned = $p->turn_tabs; # eef eif eof muf
$p->add_tabs( 'faa', 'fim' );
my #sorted = $p->alpha_tabls; # faa fee fie fim foe fum
my $count = $p->tab_count; # 6
my $ports = $p->nbports; # 32
try with:
sub set_tab {
my ($self, #tab) = #_;
$self->{ tab } = \#tab;
}

How do I use an array as an object attribute in 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";

Moose: Expiring cached results of calculations when attribute values change?

In our classes we have a pattern where we create an attribute to represent a
calculated value. For obvious reasons we want to cache the calculated value
and then invalidate the cache when one of the underlying values change.
So we currently have this:
package FooBar;
use Moose;
has 'foo' => (
accessor => {
'foo' => sub {
my $self = shift;
if (#_ > 0) {
# writer
$self->{foo} = $_[0];
# reset fields that are dependant on me
$self->{bar} = undef;
}
# reader part;
return $self->{foo};
}
}
);
has 'bar' => (
accessor => {
'bar' => sub {
my $self = shift;
if (#_ > 0) {
# writer
$self->{bar} = $_[0];
}
# reader part;
$self->{bar} = calculate_bar($self->foo, $self->baz)
if (not defined($self->{bar}));
return $self->{bar};
}
}
);
sub calculate_bar { ... }
This long hand method is getting very tedious and error prone when calculated values
depend on other calculated values.
Is there a smarter/simpler way for 'bar' to monitor the attributes it depends on
vs having 'foo' know who is dependent on it? Also how can I avoid setting bar via hash
member access?
If I understand you correctly, you can use triggers to clear attributes when one is set. Here's an example:
has 'foo' => (
is => 'rw',
trigger => sub{
my ($self) = #_;
$self->clear_bar;
}
);
has 'bar' => (
is => 'rw',
clearer => 'clear_bar',
lazy => 1,
default => sub{
my ($self) = #_;
return calculate_bar( ... );
}
);
So, any writes to foo via $obj->foo($newvalue) will cause bar to be cleared, and recreated on next access.
I think it is quite possible that you're making this harder on yourself by using an Attributes implicit memoization with lazy, when you could just make the memoization explicit making your whole program more transparent
has [qw/foo bar baz/] => ( isa => 'Value', is => 'rw' );
use Memoize;
memoize('_memoize_this');
sub old_lazy_attr {
my $self = shift;
_memoize_this( $self->attr1, $self->attr2, $self->attr3 );
}
sub _memoize_this {
my #args = #_;
# complex stuff
return $result
}
See cpan's Memoize for information and control of the internal cache, also remember that a Memoized function can not be dependent on the state of the object. So the arguments must be passed in explicitly.
Would this work?
#!/usr/bin/perl
package Test;
use Modern::Perl;
use Moose;
has a => (is => 'rw', isa => 'Str', trigger => \&change_a);
has b => (is => 'rw', isa => 'Str', trigger => \&change_b);
has c => (is => 'rw', isa => 'Str');
sub change_a
{
my $self = shift;
say 'update b';
$self->b($self->a . ', bar');
}
sub change_b
{
my $self = shift;
say 'update c';
}
package main;
my $test = Test->new->a('Foo');
Output:
$ perl test.pl
update b
update c
I haven't done any poking around in Moose internals and the meta object protocol, but I think this is a good time to do it.
You want to patch the code generation so that when you specify an attribute as
has 'foo' => ();
has 'bar' => (
depends_on => [qw( foo )],
lazy => \&calculate_bar,
);
the code generation phase creates code for the foo and bar attributes as you specified above.
How to do this is an exercise left to the reader. If I had a clue, I'd try to give you a start. Unfortunately, all I can advise you with is "This is a job for the MOP".