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.
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 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};
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();
If in a Perl module I have a 'new' function that declares:
my $self = $class->SUPER::new($pArgsProcessor, $pResponse, kStrFormatHtml);
$self->{mStrRunType} = $pArgsProcessor->readQueryString('runType');
$self->{mStrStartDate} = $pArgsProcessor->readQueryString('startdate');
$self->{mStrEndDate} = $pArgsProcessor->readQueryString('enddate');
bless $self, $class;
return $self;
Is there a way to use the data stored in '$self' in another function? I'm trying to use 'mStrRunType'
$self is probably an object, and all the subs in your package can be called as methods. Then:
my $object = Your::Class->new(...);
$object->foo(42);
Inside the foo method, the object will be the first argument:
sub foo {
my ($self, $meaning_of_life) = #_;
say "mStrEndDate = $self->{mStrEndDate}";
...;
}
Notes:
You should not generally rebless the $self in your constructor. If the superclasses are written to support inheritance, then $class->SUPER::new(...) ensures that the reference is blessed into the correct $class.
You naming scheme suggests you might want to use a more complex data structure:
$self->{mStr} = {
RunType => ...,
StartDate => ...,
EndDate => ...,
};
Your constructor looks correct. Assuming that your constructor is similar to this:
sub new {
my $class = shift;
my $pArgsProcessor, $pResponse, kStrFormatHtml; #shift your constructor params..
my $self = $class->SUPER::new($pArgsProcessor, $pResponse, kStrFormatHtml);
$self->{mStrRunType} = $pArgsProcessor->readQueryString('runType');
$self->{mStrStartDate} = $pArgsProcessor->readQueryString('startdate');
$self->{mStrEndDate} = $pArgsProcessor->readQueryString('enddate');
bless $self, $class;
return $self;
}
Then your method should be able to use your parameters:
sub test {
my $self = shift;
if (defined $self->{mStrEndDate}) {
print $self->{mStrEndDate};
} else {
print "not defined?";
}
}
If your keys are still undefined then make sure that $pArgsProcessor methods are returning defined values.
I have a legacy project and I would like to extend a couple of classes in it with a few attributes and methods. I have access to the source code and know that the class uses a blessed hashref. I can of course go ahead and extend that hashref adding the keys that I want and re-bless into my class. But obviously this breaks encapsulation and I would like to avoid it as much as I can.
Is there a way to extend a (non-Moose) Perl class with attributes, not just methods, in a way that does not break encapsulation of the orginal class? The option to use Moose to do this is not available. Thank you.
First, one best practice for writing objects based on hashrefs is to prefix all fields with the package name, e.g.
package Parent;
sub new {
my ($class, $x, $y) = #_;
bless { "Parent::x" => $x, "Parent::y" => $y } => $class;
}
sub x { shift()->{"Parent::x"} }
sub y { shift()->{"Parent::y"} }
In that case, the issue doesn't arise, as every class has its own attribute namespace. But who writes his classes that way?
There are two ways I can think of to circumvent any problems: Proxying the original object via Autoload, or using inside-out object patterns. The third solution is to use prefixed attributes in your class, and hope that the parent never ever uses these names.
Inside-Out Objects
An inside-out object uses the blessed reference as an ID, and stores the attributes in lexical variables inside your class:
package Child;
use Scalar::Util qw/refaddr/;
use parent 'Parent';
my %foo;
sub new {
my ($class, $foo, #args) = #_;
my $self = $class->SUPER::new(#args);
$foo{refaddr $self} = $foo;
return $self;
}
sub foo {
my ($self) = #_;
$foo{refaddr $self};
}
sub set_foo {
my ($self, $val) = #_;
$foo{refaddr $self} = $val;
}
sub DESTROY {
my ($self) = #_;
# remove entries for this object
delete $foo{refaddr $self};
$self->SUPER::DESTROY if $self->SUPER::can('DESTROY');
}
This is a slightly dated pattern, but it works extremely well for your use case.
Proxy objects
We can contain a parent instance in a field of our class (i.e. both has-a and is-a relationship). Whenever we encounter unknown methods, we delegate to that object:
package Child;
use Parent ();
our $SUPER = 'Parent';
use Carp;
sub new {
my ($class, $foo, #args) = #_;
bless {
parent => $SUPER->new(#args),
foo => $foo,
} => $class;
}
sub foo {
my ($self) = #_;
$self->{foo};
}
sub set_foo {
my ($self, $val) = #_;
$self->{foo} = $val;
}
# manually establish pseudo-inheritance
# return true if our class inherits a given package
sub isa {
my ($self, $class) = #_;
return !!1 if $class eq __PACKAGE__;
return +(ref $self ? $self->{parent} : $SUPER)->isa($class);
}
# return a coderef to that method, or false
sub can {
my ($self, $meth) = #_;
my %methods = (new => \&new, foo => \&foo, set_foo => \&set_foo, DESTROY => \&DESTROY);
if (my $code = $methods{$meth}) {
return $code;
}
# check parent
my $code = ( ref $self ? $self->{parent} : $SUPER)->can($meth);
return undef unless $code;
return sub {
my $self = shift;
unshift #_, ref $self ? $self->{parent} : $self;
goto &$code;
};
}
# write explicit destroy to satisfy autoload
sub DESTROY {
my ($self) = #_;
$self->{parent}->DESTROY if ref $self and $SUPER->can('DESTROY');
}
sub AUTOLOAD {
# fetch appropriate method coderef
my $meth = our $AUTOLOAD;
$meth =~ s/.*:://; # clean package name from name
my $code = $_[0]->can($meth);
$code or croak qq(Can't locate object method "$meth" via package "#{[__PACKAGE__]}");
goto &$code;
}
The ugly part is to fake methods defined in superclasses in the can code: We have to wrap the actual method inside a anonymous sub that unpacks our object to call the method on the proxied object. The gotos make our extra levels invisible to the called code, which is neccessary when somebody uses caller.
Most of this boilerplate proxying code can be abstracted into another module (and probably is, somewhere on CPAN).