I want to create a Perl class and populate its attributes. The object attributes will be populated like from a yaml files like below.
$data = LoadFile("$mydir/$ARGV[$j]");
my $X= $data->{a}{b}{c};
package Person;
sub new {
my $class = shift;
my $self = {
a=>shift;
};
bless $self, $class;
return $self;
}
my $p=Person->new();
I want to access the attributes like this. How can I do this?
$p->a($data->{a}{b}{c});
$p->a($data->{a}{b}{c}) makes no sense. Do you mean $p->a->{a}{b}{c}?
package Person;
sub new {
my ($class, $data) = #_;
my $self = bless({}, $class);
$self->{data} = $data;
return $self;
}
sub data { $_[0]{data} }
1;
my $data = LoadFile(...);
my $p = Person->new($data);
say $p->data->{a}{b}{c};
Related
I have been working with OO Perl. I have base class, which is legacy code and I can't change it. I am writing a derived class with a new style (my convenient style too) but when I am deriving it I am getting an error as
Attempt to bless into a reference
My code is similar to the below code:
package Base ;
sub new {
my ($class, %args) = #_;
my $self = {};
$self->{top} = $args{top};
return bless $self, $class;
}
1;
The Derived class:
package derived;
use base qw{Base};
use fields qw{_bot};
sub new {
my __PACKAGE__ $this = shift;
my %arg = #_;
unless (ref $this) {
$this = fields::new($this);
}
$this->Base::new( %arg);
return $this;
}
1;
The caller is
use File::Basename;
BEGIN {
my $root_dir = dirname $0;
push(#INC, $root_dir);
}
use derived;
my $d = new derived(top=>"t1");
I am getting error as
Attempt to bless into a reference at Base.pm line 8.
I'm trying out multiple inheritance and would like to get the hang of it without using packages like Moose to sort out the issue behind the scenes.
I have two base classes, Left and Right, in a "broken" diamond:
Left Right
\ /
Multi
They both implement an overload for "". When calling a method, below named perform, in any of the base classes, those methods are supposed to use this overload to print a representation of that part of the object. Multi implements perform as so:
sub perform {
my $self = shift;
$self->Left::perform;
$self->Right::perform;
}
What happens is that both base classes perform methods are called as they are supposed to, but when those methods call any other methods (like the "" overload) it'll always be the one in Left. However, if an instance of Right is created separately (not as a part of Multi) it'll call the correct method.
I wonder how to make a method in this scenario select its own package's methods over its left-most sibling base class' methods?
Here's what I've tried (in perl v5.26.1 and v5.32.1):
#!/usr/bin/perl
use strict;
use warnings;
package Left; #----------------------------------------------------------------
sub new {
my ($class, #args) = #_;
my $self = bless {}, $class;
return $self->_init(#args);
}
sub _init {
my $self = shift;
$self->{_leftval} = shift;
return $self;
}
sub value { shift->{_leftval}; }
use overload '""' => sub {
my $self = shift;
'Left(' . $self->value . ')';
};
sub perform {
my $self = shift;
print '# LEFT ' . $self . "\n";
}
package Right; #---------------------------------------------------------------
sub new {
my ($class, #args) = #_;
my $self = bless {}, $class;
return $self->_init(#args);
}
sub _init {
my $self = shift;
$self->{_rightval} = shift;
return $self;
}
sub value { shift->{_rightval}; }
use overload '""' => sub {
my $self = shift;
'Right(' . $self->value . ')';
};
sub perform {
my $self = shift;
print '# RIGHT ' . $self . "\n";
}
package Multi; #---------------------------------------------------------------
use parent -norequire, 'Left', 'Right' ;
sub new {
my ($class, #args) = #_;
my $self = bless {}, $class;
return $self->_init(#args);
}
sub _init {
my $self = shift;
$self->Left::_init(shift);
$self->Right::_init(shift);
return $self;
}
sub perform {
my $self = shift;
$self->Left::perform;
$self->Right::perform;
}
package main; #----------------------------------------------------------------
my $l = Left->new("a Left");
my $r = Right->new("a Right");
my $m = Multi->new("lEfT", "rIgHt");
$l->perform;
$r->perform;
print "---- and now a Multi ----\n";
$m->perform;
Expected output:
# LEFT Left(a Left)
# RIGHT Right(a Right)
---- and now a Multi ----
# LEFT Left(lEfT)
# RIGHT Right(rIgHt)
Actual output (note the last line):
# LEFT Left(a Left)
# RIGHT Right(a Right)
---- and now a Multi ----
# LEFT Left(lEfT)
# RIGHT Left(lEfT)
A virtual method is resolved based on the object's class, not the caller's namespace/package/class.
In Perl, whether a method is virtual or not isn't an intrinsic property. It depends on how it's called.
$o->method # Virtual method
Avoiding this require specifying the class
$o->Class::method
You don't want a virtual method call, so you'll need to change how you call the method.
package Left;
use overload '""' => \&to_string;
sub to_string {
my $self = shift;
'Left(' . $self->value . ')';
}
sub perform {
my $self = shift;
print '# LEFT ' . $self->Left::to_string() . "\n";
}
Except that's all wrong. If it was one method, this would make sense. But we're talking about every method. This is the air raid siren of red flags.
What we want here is composition, not inheritance. Multi IS A Left and IS A Right isn't correct. Rather, Multi HAS A Left and HAS A Right.
package Multi; #---------------------------------------------------------------
use parent -norequire, 'Left', 'Right' ;
sub new {
my ($class, #args) = #_;
my $self = bless {}, $class;
return $self->_init(#args);
}
sub _init {
my $self = shift;
$self->{ left } = Left ->new(shift);
$self->{ right } = Right->new(shift);
return $self;
}
sub perform {
my $self = shift;
$self->{ left }->perform;
$self->{ right }->perform;
}
I wonder how to make a method in this scenario select its own package's methods
Does it help to rebless $self like this:
package Right;
# [...]
sub perform {
my $self = shift;
if (ref $self ne "Right") {
bless $self, "Right";
}
print '# RIGHT ' . $self . "\n";
}
This is building on Håkon's answer. bless $self, 'Right' in Right::perform effectively seems to break the inheritance. A second call to $m->perform directly calls Right::perform - Multi::perform isn't even invoked.
As a workaround to this, I added a blessing context class which blesses upon creation and on destruction. I'll have to create one of these contexts in all methods potentially calling any method in another package.
package Reblesser; #-----------------------------------------------------------
sub new {
my $class = shift;
my $self = bless {
object => shift,
class => shift
}, $class;
$self->rebless;
$self;
}
sub rebless {
my $self = shift;
bless $self->{object}, $self->{class} if(ref $self->{object} ne $self->{class});
}
sub DESTROY {
shift->rebless;
}
Now Left::perform becomes:
sub perform {
my $self = shift;
my $ctx = Reblesser->new($self, __PACKAGE__);
print '# LEFT ' . $self . "\n";
}
Right::perform:
sub perform {
my $self = shift;
my $ctx = Reblesser->new($self, __PACKAGE__);
print '# RIGHT ' . $self . "\n";
}
Multi::perform:
sub perform {
my $self = shift;
my $ctx = Reblesser->new($self, __PACKAGE__);
$self->Left::perform;
$self->Right::perform;
}
Output (even with multiple $m->perform calls):
# LEFT Left(a Left)
# RIGHT Right(a Right)
---- and now a Multi ----
# LEFT Left(lEfT)
# RIGHT Right(rIgHt)
I have a series of modules that perform output functions for my scripts. Sometimes the module is called directly -- it is called View -- and sometimes a child class that extends it is used instead (View::ChildName). View declares our $THEMENAME = 'default'; when it is loaded, but the child declares its own specific $THEMENAME when it loads.
Problem: When new() is called on a child theme, it calls my $self = $class->next::method(%params); (using mro) to get some core things set by the parent class before extending it. One of the core bits is that the parent class sets $self->{'themeName'}. However, if it simply calls $THEMENAME, it gets the parent's setting: "default."
The only way I've reliably and successfully solved this is to turn off strict temporarily and do this:
my $packName = ref $self;
{
no strict;
$self->{'themeName'} = ${${packName} . "::THEMENAME"};
}
This works, but in profiling the code, if objects are created frequently, this actually adds more overhead than I expected. I tried the alternative of always using the parent's package name, e.g. the child sets $View::THEMENAME. This works, but only if the theme name is set within new and not on the load of the module; if it is on load, there is erratic behavior if several different child objects (of different children) are created over the course of the script.
These options both seem less than ideal. Is there a good way to do this? The only thing I found was this old question and I think incorporating Moo would probably add more overhead than I'm trying to avoid by getting rid of my current no strict block. Has anything been added to more modern versions of Perl that might solve my issue?
The alternative is to dodge the issue all together and simply set $self->{'themeName'} within each child object's new method, although I'm trying to avoid that change since there's a fair number of legacy child classes that expect $THEMENAME to exist.
Minimal reproducible example of View.pm:
use strict;
package View;
our $THEMENAME = 'default';
sub new {
my $class = shift;
my $params = shift;
my $self = { 'setting' => $params{'setting'} };
bless $self, $class;
$self->{'themeName'} = $THEMENAME;
return $self;
}
And of View/Child.pm:
use strict;
use mro;
package View::Child;
use parent 'View';
our $THEMENAME = 'child';
sub new {
my $class = shift;
my $params = shift;
my $self = $class->next::method($params);
bless $self, $class;
say STDOUT $self->{'themeName'};
# Prints 'default' not 'child'.
return $self;
}
Now a script to call it:
use View::Child;
my $object = View::Child->new();
If you added the first code block to View.pm, it gives the expected result instead, but seems to add about 9 ms to each call to new -- more than the time it takes for it to handle everything else I have in the much longer full length new method -- which adds up if the program runs many iterations:
use strict;
package View;
our $THEMENAME = 'default';
sub new {
my $class = shift;
my $params = shift;
my $self = { };
bless $self, $class;
my $packName = ref $self;
{
no strict;
$self->{'themeName'} = ${${packName} . "::THEMENAME"};
}
return $self;
}
The concept of class properties is one you should forget (in Perl). It's fine for the module to have constants and possibly variables, but they shouldn't be considered part of the class.
I see four approaches you could take:
Update the property in the child's constructor.
Provide the value as a parameter
Override the accessor
Provide the default as a method
Update the property in the child's constructor
# View.pm
sub new {
my ($class, $params) = #_;
my $self = bless({}, $class);
$self->{ setting } = $params->{ setting };
$self->{ themeName } = 'default';
return $self;
}
sub themeName { $_[0]->{themeName} } # Optional
# Child/View.pm
sub new {
my ($class, $params) = #_;
my $self = $class->next::method($params);
$self->{ themeName } = 'child';
return $self;
}
Provide the value as a parameter
# View.pm
sub new {
my ($class, $params) = #_;
my $self = bless({}, $class);
$self->{ setting } = $params->{ setting };
$self->{ themeName } = $params->{ themeName } // 'default';
return $self;
}
sub themeName { $_[0]->{themeName} } # Optional
# Child/View.pm
sub new {
my ($class, $params) = #_;
my $self = $class->next::method({ themeName => 'child', %$params });
return $self;
}
Override the accessor
# View.pm
sub new {
my ($class, $params) = #_;
my $self = bless({}, $class);
$self->{ setting } = $params->{ setting };
return $self;
}
sub themeName { 'default' }
# Child/View.pm
# No need to override `new`.
sub themeName { 'child' }
Provide the default as a method
# View.pm
sub new {
my ($class, $params) = #_;
my $self = bless({}, $class);
$self->{ setting } = $params->{ setting };
$self->{ themeName } = $class->defaultThemeName;
return $self;
}
sub defaultThemeName { 'default' }
sub themeName { $_[0]->{themeName} } # Optional
# Child/View.pm
# No need to override `new`.
sub defaultThemeName { 'child' }
One potential solution would be to add THEMENAME as an overridable method.
View.pm:
use strict;
package View;
our $THEMENAME = 'default';
sub THEMENAME {return 'default'}
sub new {
my $class = shift;
my $params = shift;
my $self = { 'setting' => $params->{'setting'} };
bless $self, $class;
$self->{'themeName'} = $self->THEMENAME;
return $self;
}
View/Child.pm:
use strict;
use mro;
package View::Child;
use parent 'View';
our $THEMENAME = 'child';
sub THEMENAME {return 'child'}
sub new {
my $class = shift;
my $params = shift;
my $self = $class->next::method($params);
bless $self, $class;
say STDOUT $self->{'themeName'};
# Prints 'default' not 'child'.
#
return $self;
}
# perl -Mlib=. -MView::Child -e 'View::Child->new()'
child
My final solution follows what #plentyofcoffee and #ikegami outlined, but I wanted to see if I could come up with a way to set it automatically without each child module implementing it (keeping in mind legacy code). Assuming the child does want to set it, it passes $param{'themeName'} to the parent's constructor, which sets it to $self->{'themeName'}. If themeName is undefined, I came up with this regex in the parent class that extracts the name of the child as a fallback themeName:
unless ($self->{'themeName'}) {
state $getThemeNameRegEx = qr#^SAFARI::(.*::)+(.*?)$#;
$class =~ /$getThemeNameRegEx/;
$self->{'themeName'} = $2 // "default";
}
This sets to default if the name doesn't contain at least two levels below SAFARI, e.g. SAFARI::View is default (the parent module is in use without a child) and SAFARI::View::mysite is mysite.
I have a problem and that is when I want to initialize two objects using the $ self variable. The first object will be initialized but the second will not. Here is some code:
###Class main
use bar;
use arg;
sub new{
my $class = shift;
my $args = shift;
my $self = {};
$self->{'foo'} = $class->SUPER->new($args);
$self->{'bar'} = bar->new();
bless($self, $class);
return $self;
}
sub getFoo{
my $self = shift;
return $self->{'foo'};
}
sub getBar{
my $self = shift;
return $self->{'bar'};
}
For the function getFoo such it returns a value but for getBar the value returned is undef, why does this happen? Thanks
EDIT1
Yes, arg is class's parent and foo is a class that i want to use certain methods.
####class bar
package bar;
sub new{
my $class = shift;
my $self = {
_bar1 => shift // 0,
_bar2 => shift //0,
};
bless($self,$class);
return $self;
}
sub getBar1{
my $self = shift;
return $self->{_bar1};
}
But if I do this now in my class main
$self->{__bar}->getBar1;
The message return is : can´t call method "getBar1" on an undefined value.
You place the object in
$self->{bar}
then you call
$self->{__bar}->getBar1
Change that to
$self->{bar}->getBar1
You appear to have a number of other problems. From your description of your code, Unnamed.pm should contain something like the following: (Don't use main; that's already being used.)
package Unnamed;
use strict;
use warnings qw( all );
use foo qw( );
use bar qw( );
use parent 'arg';
sub new {
my $class = shift;
my $args = shift;
my $self = $class->SUPER::new($args);
$self->{foo} = foo->new();
$self->{bar} = bar->new();
return $self;
}
sub get_foo {
my $self = shift;
return $self->{foo};
}
sub get_bar {
my $self = shift;
return $self->{bar};
}
1;
Then, you can do
my $o = Unnamed->new();
$o->get_bar->bar_method();
I have a base class that is instantiated with a complex data structure with a three-digit number of entries, all of them constants. A few of those constants are class-specific and should be instantiated with different constants. I am having trouble achieving this. It boils down to this:
tstbase.pm:
package tstbase;
my $THISCLASSCONSTANT = "baseconstant.2";
my %complexdatastructure = (
"attribute.1" => "baseconstant.1",
"attribute.2" => $THISCLASSCONSTANT,
);
sub new {
my $class = shift;
my $self = { };
bless ($self, $class);
$self->_init( $THISCLASSCONSTANT );
return $self;
};
sub _init {
my $self = shift;
$THISCLASSCONSTANT = shift;
foreach (keys %complexdatastructure) {
$self->{$_} = $complexdatastructure{$_};
};
};
tstsubclass.pm:
package tstsubclass;
use parent "tstbase";
my $THISCLASSCONSTANT = "subclassconstant.2";
sub _init {
my $self = shift;
$self->SUPER::_init( $THISCLASSCONSTANT );
};
tst.pl:
#!/usr/bin/perl
use tstbase;
use tstsubclass;
my $baseobj = tstbase->new;
print "Testbase ".$baseobj->{"attribute.1"}." ".$baseobj->{"attribute.2"}."\n";
my $subobj = tstsubclass->new;
print "Testsubclass ".$subobj->{"attribute.1"}." ".$subobj->{"attribute.2"}."\n";
Right now the output is
Testbase baseconstant.1 baseconstant.2
Testsubclass baseconstant.1 baseconstant.2
whereas I want it to be
Testbase baseconstant.1 baseconstant.2
Testsubclass baseconstant.1 subclassconstant.2
Is that possible? I am happy to use
sub THISCLASSCONSTANT = { "subclassconstant.2" }
if it helps. tstsubclass shall not have any baseconstant values.
Right now I instantiate the class with magic strings and do a search & replace. It works, but seems less elegant and performant.
Any help is greatly appreciated. I have asked this question before ( Perl: Using common constructor for base and subclass ) but have over-simplified the example, hence the response could only hint at a possible solution.
Thanks,
Marcus
The simplest way would be to work with references in your %complexdatastructure.
But note that when doing this, $THISCLASSCONSTANT will be changed after the first call to tstsubclass->new.
package tstbase;
my $THISCLASSCONSTANT = "baseconstant.2";
my %complexdatastructure = (
"attribute.1" => \ "baseconstant.1",
"attribute.2" => \ $THISCLASSCONSTANT,
);
sub new {
my $class = shift;
my $self = { };
bless ($self, $class);
$self->_init( $THISCLASSCONSTANT );
return $self;
};
sub _init {
my $self = shift;
$THISCLASSCONSTANT = shift;
foreach (keys %complexdatastructure) {
$self->{$_} = ${$complexdatastructure{$_}};
};
};
Now your output is the desired one, but if you alter the order of the new calls like this:
my $subobj = tstsubclass->new;
print "Testsubclass ".$subobj->{"attribute.1"}." ".$subobj->{"attribute.2"}."\n";
my $baseobj = tstbase->new;
print "Testbase ".$baseobj->{"attribute.1"}." ".$baseobj->{"attribute.2"}."\n";
You'll get:
Testsubclass baseconstant.1 subclassconstant.2
Testbase baseconstant.1 subclassconstant.2
What you could do now is to write your "own" little local (i don't know why the normal local isn't working even with altering the declarations of $THISCLASSCONSTANT to our)
change your tstbase::_init into:
sub _init {
my $self = shift;
my $oldconstant = $THISCLASSCONSTANT;
$THISCLASSCONSTANT = shift;
foreach (keys %complexdatastructure) {
$self->{$_} = ${$complexdatastructure{$_}};
};
$THISCLASSCONSTANT = $oldconstant;
};
Now i think you have what you want.