Accessing class variables in inherited function? - perl

I'm trying to create child classes in Perl that inherit class functions from a single parent. I got it to partially work, using the object method syntax Child->inheritedMethod() to call inherited functions outside the child, and my $class=shift; $class->inheritedMethod(); inside the child class, as described here.
However, for inherited methods, it seems control is passed to parent class, and the method is run in the parent scope with the parent variables. For example, this is in the Parent class:
our $VERSION = 0.11;
our $NICKNAME = "Parent Base";
sub version{ $VERSION }
sub whoami{ $NICKNAME }
sub whereami{
my $class = shift;
print "should be printing whereami right now...\n";
print "## In ",(caller(1))[3]," of ",$class->whoami," ",$class->version," in ",__PACKAGE__,"\n";
}
Each child class declares its own $VERSION and $NICKNAME, which I hoped would be accessed in place of the parent variables. But when I call whereami from the child, it gives
## Child::Method of Parent Base 0.11 in Parent.
Questions:
Is there a way around this? Some other module I should use like Moo(se)? Export all the methods instead of inheritance, which I hear shouldn't be done (polluting the namespace, not a problem here)?
Would this still be an issue using objects and object
attributes/variables? I'm trying to avoid it due to my team's
aversion to object-oriented.
Is this how inheritance usually works,
or just Perl? I thought the method would be called within the scope
of the child class, not passed to the parent.

The problem is that the method accesses the variable from the lexical scope where it was declared, i.e. the parent class. Class variables are therefore not the same thing as class attributes.
You can access the correct variable by fully qualifying its name (not possible under strict refs:
#!/usr/bin/perl
use warnings;
use strict;
{ package Parent;
our $package = 'Parent';
sub get_package {
my $class = shift;
{ no strict 'refs';
return (caller(0))[3], $class, ${"$class\::package"}
}
}
}
{ package Son;
use parent 'Parent';
our $package = 'Son';
}
print join ' ', 'Son'->get_package, "\n";
print join ' ', 'Parent'->get_package, "\n";
In Moo*, you can use Moo*X::ClassAttribute:
#!/usr/bin/perl
use warnings;
use strict;
{ package Parent;
use Moo;
use MooX::ClassAttribute;
class_has package => (is => 'ro',
default => 'Parent');
sub get_package {
my $class = shift;
return $class->package;
}
}
{ package Son;
use Moo;
use MooX::ClassAttribute;
extends 'Parent';
class_has package => (is => 'ro',
default => 'Son');
}
print 'Parent'->get_package, "\n";
print 'Son'->get_package, "\n";
Note that MooX::ClassAttribute says
Overriding class attributes and their accessors in subclasses is not yet supported.
Unlike in Moose, you can't use the class_has '+package' => (default => 'Son'); syntax for overriding.

Related

How do I call the grandparent's constructor (because the parent's constructor is not defined)?

I believe, the canonical way to call the parent's class' constructor in Perl is:
package Child;
our #ISA = 'Parent';
sub new {
my $class = shift;
my #args = #_;
my $self = $class->SUPER::new(#args);
return $self;
}
However, this construct doesn't seem to work if Parent does not explicitely define a new function (but Grandparent does).
This is the case, for example, with Net::FTP::File.
tq84_ftp.pm:
package tq84_ftp;
use warnings;
use strict;
our #ISA = qw(Net::FTP::File);
sub new {
my $class = shift;
my $self = $class->SUPER::new('localhost')
or die($#);
return $self;
}
1;
script.pl:
use tq84_ftp;
tq84_ftp->new();
Output:
Can't locate package Net::FTP::File for #tq84_ftp::ISA at tq84_ftp.pm line 10.
Can't locate package Net::FTP::File for #tq84_ftp::ISA at tq84_ftp.pm line 10.
Can't locate object method "new" via package "tq84_ftp" at tq84_ftp.pm line 10.
How do I specify that I want Perl to find the correct (here: grantparent's) new function?
However, this construct doesn't seem to work if Parent does not explicitely define a new function (but Grandparent does).
Not true.
$ perl -E'
package Grandparent {
sub new { CORE::say(__PACKAGE__) }
}
package Parent {
our #ISA = "Grandparent";
}
package Child {
our #ISA = "Parent";
sub new { my $class = shift; $class->SUPER::new(); }
}
Child->new();
'
Grandparent
Can't locate package Net::FTP::File
This a warning obtained when you try to inherit from a class that hasn't been declared. Specifically, you are trying to use Net::FTP::File without having loaded it.
Replace
our #ISA = 'Net::FTP::File';
with
use Net::FTP::File qw( );
our #ISA = 'Net::FTP::File';
or with
use parent 'Net::FTP::File';
Can't locate object method "new" via package "tq84_ftp"
This message is a bit unclear, but it's due to the fact that Net::FTP::File->new doesn't exist. Net::FTP::File isn't a class, much less a subclass of Net::FTP. It has no methods, much less a new method. It makes no sense to inherit from Net::FTP::File.
You appear to want to create a Net::FTP object, so replace
use parent 'Net::FTP::File';
with
use parent 'Net::FTP';
Finally, you want to load Net::FTP::File for the methods it adds to Net::FTP objects (which includes object of classes that inherit from Net::FTP). To do that, simply add
use Net::FTP::File qw( );
It seems you assume that Net::FTP::File is a subclass of Net::FTP and, therefore
my $self = $class->SUPER::new('localhost') ...
should invoke Net::FTP's new method.
However, in fact, Net::FTP::File does not inherit from Net::FTP. Instead, it redefines some methods in Net::FTP. Therefore, if your class inherits from Net::FTP::File, it will not be child of Net::FTP.
You can see this easily if you look at the source code for Net::FTP. Note that there is no use base 'Net::FTP' or use parent 'Net::FTP' or our #ISA = qw( Net::FTP ) below:
package Net::FTP::File;
use strict;
use warnings;
use Net::FTP;
# ...
sub Net::FTP::pretty_dir {
shift;
my $newp = shift;
if ( defined $newp ) {
$pretty = $newp;
$DirProcHash{cols} = $cols{pretty} if $pretty;
$DirProcHash{cols} = $cols{utility} if !$pretty;
}
return $pretty;
}
# ...
sub Net::FTP::isfile {
my $ftp = shift;
return 1 if $ftp->exists(#_) && !$ftp->isdir(#_);
0;
}
etc etc.

How to override a sub in a Moose::Role?

I'm trying to implement a Moose::Role class that behaves like an abstract class would in Java. I'd like to implement some methods in the Role, but then have the ability to override those methods in concrete classes. If I try this using the same style that works when I extend classes I get the error Cannot add an override method if a local method is already present. Here's an example:
My abstract class:
package AbstractClass;
use Moose::Role;
sub my_ac_sub {
my $self = shift;
print "In AbstractClass!\n";
return;
}
1;
My concrete class:
package Class;
use Moose;
with 'AbstractClass';
override 'my_ac_sub' => sub {
my $self = shift;
super;
print "In Class!\n";
return;
};
__PACKAGE__->meta->make_immutable;
1;
And then:
use Class;
my $class = Class->new;
$class->my_ac_sub;
Am I doing something wrong? Is what I'm trying to accomplish supposed to be done a different way? Is what I'm trying to do not supposed to be done at all?
Turns out I was using it incorrectly. I opened a ticket and was shown the correct way of doing this:
package Class;
use Moose;
with 'AbstractClass';
around 'my_ac_sub' => sub {
my $next = shift;
my $self = shift;
$self->$next();
print "In Class!\n";
return;
};
__PACKAGE__->meta->make_immutable;
1;
Making this change has the desired effect.
Some time ago, I did this by having a role that consists solely of requires statements. That forms the abstract base class. Then, you can put your default implementations in another class and inherit from that:
#!/usr/bin/env perl
use 5.014;
package AbstractClass;
use Moose::Role;
requires 'my_virtual_method_this';
requires 'my_virtual_method_that';
package DefaultImpl;
use Moose;
with 'AbstractClass';
sub my_virtual_method_this {
say 'this';
}
sub my_virtual_method_that {
say 'that'
}
package MyImpl;
use Moose;
extends 'DefaultImpl';
with 'AbstractClass';
override my_virtual_method_that => sub {
super;
say '... and the other';
};
package main;
my $x = MyImpl->new;
$x->my_virtual_method_this;
$x->my_virtual_method_that;
If you want to provide default implementations for only a few methods define in the role, remove the requires from DefaultImpl.
Output:
$ ./zpx.pl
this
that
... and the other

How can I apply a Moose method modifier to a method based on a method attribute?

I want to apply a Moose 'before' method modifier to a number of methods in my class. I want to provide the modifier method in a role. I can do it a bit like this:
package MyApp::Role;
use Moose::Role
before [qw(foo bar)] => sub {
...
};
package MyApp;
use Moose;
with (MyApp::Role);
sub foo { ... }
sub bar { ... }
sub baz { ... } # this method is unaffected
However, having to maintain the list of relevant methods in the role ties it to the consuming class and that just seems wrong. I would like to do it a smarter way, like with method attributes:
package MyApp;
use Moose;
with (MyApp::Role);
sub foo :SomeFlag { ... }
sub bar :SomeFlag { ... }
sub baz { ... } # this method is unaffected
I'm not familiar with how to identify method attributes or how I would dynamically apply method modifiers to them.
Or, maybe there is a better way of doing this?
Let's use Attribute::Handlers for this – a fairly sane way to use attributes. We must define a function in a base class which itself has the attribute :ATTR(CODE). This takes a number of arguments:
The package where the sub (or other variable) comes from.
A globref, or the string ANON.
A reference to the value (here: coderef).
The name of the attribute.
Optional data for the attribute.
The (compilation) phase where the attribute was invoked.
The filename where the sub was declared.
The line number where the sub was declared.
So what we can do is to write a handler that applies a before:
use strict; use warnings; use feature 'say';
BEGIN {
package MyRole;
use Moose::Role;
use Attribute::Handlers;
sub SomeFlag :ATTR(CODE) {
my ($package, $globref, $code, $attr, $data, $phase, $filename, $line) = #_;
ref($globref) eq 'GLOB'
or die "Only global subroutines can be decorated with :SomeFlag"
. " at $filename line $line.\n";
# use the MOP to install the method modifier
$package->meta->add_before_method_modifier(
*$globref{NAME} => sub {
warn "Just about to call a flagged sub!";
},
);
}
}
BEGIN {
package MyApp;
use Moose;
# important: SomeFlag must be available before the attrs are handled (CHECK phase)
BEGIN { with 'MyRole' };
sub foo :SomeFlag { say "Hi from foo sub!" }
sub bar :SomeFlag { say "Hi from bar sub!" }
sub baz { say "Hi from baz sub!" }
}
package main;
my $o = MyApp->new;
$o->$_ for qw/foo bar baz/;
I stuffed all of this into a single file, but that obviously isn't neccessary (just add the required uses).
Output:
Just about to call a flagged sub! at so.pl line 16.
Hi from foo sub!
Just about to call a flagged sub! at so.pl line 16.
Hi from bar sub!
Hi from baz sub!

How to get parent class instance in Perl

I've used/created lots of classes in Perl and one common thing I need to do in them is to access certain properties of a parent object. For example, let's say I have Class_A and Class_B and they are as simple as this:
Class_A.pm
package Class_A;
use strict;
use warnings;
sub new {
my $class = shift;
my $this = {
history_data => [],
};
bless $this, $class;
}
Class_B.pm
package Class_B;
use strict;
use warnings;
sub new {
my $class = shift;
my $this = {
history_data => [],
};
bless $this, $class;
}
Class_A can use Class_B and create an instance as a property. Both have the property history_data, but if Class_B is an instance created by an instance of Class_A, I want Class_B to use hitory_data in its parent object.
So, what I've done all this time is to just pass a reference when I create the child instance, like this:
#!/usr/bin/perl
use strict;
use warnings;
use Class_A;
use Class_B;
my $class_a = new Class_A;
$class_a->{instance_of_B} = new Class_B parent => $class_a;
I'm doing that very simple, but that instance could be created by some method inside Class_A, when needing to use Class_B. The thing here is that, although Class_B has it's own properties, I want it to use the properties of Class_A when it is its parent.
That works well, but I've several times wondered if it exists a way to do that without passing the parent reference to the child. something like an already implemented way in Perl to call the parent object.
So, that's my question. Is there a way for Class_B to access the instance of its parent Class_A without receiving the reference directly?
Thanks. :-)
EDIT: Another way to put it is this:
Is there a way for Class_B, without having a reference passed, to say "I'm currently an instance of Class_B, living in a property of Class_A, which currently has x, y and z values on its own properties"?
As Michael Carman correctly notes, if you want the Class B object to know which Class A object it is part of, you have to tell it that explicitly.
What you can at least do, however, is to simplify the user interface by having Class A take care of creating its Class B components, e.g. like this:
package Class_A;
use strict;
use warnings;
sub new {
my $class = shift;
my $this = {
history_data => [],
};
bless $this, $class;
$this->{instance_of_B} = Class_B->new( parent => $this );
return $this;
}
Ps. Note that, if the Class A and Class B objects both hold a reference to each other, then what you've just created is a circular reference. Perl only has simple reference-counting garbage collection, which cannot automatically detect such reference circles; this means that, if you then let both objects go out of scope without explicitly breaking at least one link in the circle, the objects will never be garbage-collected (until your program ends) and your code ends up leaking memory.
One way to work around this issue is to weaken one of the references — normally the one from B to A, assuming that the Class A object is the one actually referenced by external code — like this:
package Class_B;
use strict;
use warnings;
use Scalar::Util qw(weaken);
sub new {
my $class = shift;
my $this = { #_ };
weaken $this->{parent};
bless $this, $class;
}
Note that, as a side effect, if someone grabs a reference directly to the Class B object, lets its parent Class A object go out of scope and then tries to call the Class B object's methods directly, the Class B object may find that its parent object has simply disappeared and the reference to it has become undefined. This is, unfortunately, an unavoidable side effect of dealing with Perl's method of garbage collection.
No. An object only knows about it's parent object if you define and set an attribute for it. (A hash entry, in your case.) Perl doesn't track who created whom in the background.
There seems to be a design issue somewhere here. However, see if Aspect::Library::Wormhole might help.
Depending on the exact circumstances, using a dependency injection framework such as Beam::Wire might help.
Update
I am not advocating the code below as a "good" solution or even "good" practice, but here is how Wormhole might help:
package A;
use strict; use warnings;
sub new {
my $class = shift;
bless {
b => undef,
history_data => [],
} => $class;
}
sub set_b {
my $self = shift;
$self->{b} = B->new;
return $self->{b};
}
package B;
use strict; use warnings;
sub new {
my $class = shift;
my $owner = shift;
bless {
history_data => $owner->{history_data} // [],
} => $class;
}
sub add_event {
my $self = shift;
push #{ $self->{history_data} }, [ #_ ];
return;
}
package main;
use strict; use warnings;
use Aspect;
use YAML;
aspect Wormhole => 'A::add_b', 'B::new';
my $x = A->new;
my $y = $x->set_b;
$y->add_event(Horizon => 180, 0, 'Terminal');
print Dump $x;
print Dump $y;

Perl: Testing whether Class Exists

I have a class called Question, and a bunch of sub-classes depending on the type of question. I can create objects against the sub-classes, but I shouldn't be able to create an object of class Question itself:
#! /usr/bin/env perl
use strict;
use warnings;
#
# LOAD IN YOUR QUESTIONS HERE
#
my #list_of_questions;
for my $question_type qw(Science Math English Dumb) {
my $class = "Question::$question_type";
my $question = $class->new;
push #list_of_questions, $question;
}
package Question;
use Carp;
sub new {
my $class = shift;
my $self = {};
if ( $class = eq "Question" ) {
carp qq(Need to make object a sub-class of "Question");
return;
}
bless $self, $class;
return $self;
}
yadda, yadda, yadda...
package Question::Math;
use parent qw(Question);
yadda, yadda, yadda...
package Question::Science;
use parent qw(Question);
yadda, yadda, yadda...
package Question::English;
use parent qw(Question);
yadda, yadda, yadda...
Notice these are not modules, but merely classes I've defined to be used in my program. Thus, I can't test module loading at runtime.
When I run the above, I get:
Can't locate object method "new" via package "Question::Dumb" (perhaps you forgot to load "Question::Dumb"?)
Is there any way to catch for this particular error, so I can handle it myself? I know I could create an array of valid types, but I was hoping someway of being able to add new question type without having to remember to update my array.
AFAICT what you want to do is check the symbol table to see if your "class" (aka "package") has been defined or not. Doing it manually is no hardship, but Class::Load provides slightly more readable sugar and applies "heuristics" - whatever that means. If you don't want to use this module then the source code for is_class_loaded will lead you to whatever answer you're actually seeking.
use Class::Load qw(is_class_loaded);
for my $question_type (qw(Math English Science Dumb)) {
my $class = "Question::$question_type";
if(!is_class_loaded($class)) {
# construct your new package at runtime, then
}
new_question($class);
}
Your variable name ("class_type") was weird, so I fixed it. I also don't know whether Module::Load is better, but we use Class::Load for this at work.
Edit: bare qw()s are deprecated in one of the newer Perls (5.14?). It's a stupid deprecation, but it's there, so we all have to learn to wrap our qw() foreachs in parens now.
You can't have an expression like Invalid::Class->new() not throw an exception in the calling code, but you can wrap it in exception handling and wrap that inside a method. The standard pattern is to supply a 'type' argument describing the subclass you which to create to a factory method. A common anti-pattern is to put that factory method on the base class, creating a circular dependency and having to do more work than should be required.
It is usual to have the factory method on the interface class and to have it construct sub-classes of an unrelated, dedicated base class, possibly warning or throwing when it fails. In code, that looks pretty much like so:
package Question;
use Try::Tiny;
use Carp qw/carp/;
sub new {
my ($class, $type, #args) = #_;
# could do some munging on $type to make it a class name here
my $real_class = "Question::$type";
return try {
$real_class->new(#args);
} catch {
# could differentiate exception types here
carp qq(Invalid Question type "$type");
};
}
package Question::Base;
sub new {
my ($class) = #_;
return bless {} => $class;
}
package Question::Math;
use base 'Question::Base'; # `use parent` expects to load a module
package main;
use Test::More tests => 2;
use Test::Warn;
isa_ok(Question->new('Math'), 'Question::Math');
warning_like(
sub { Question->new('Dumb') }, # I hear there's no such thing
qr/^Invalid Question/
);
Here's what I finally did:
package Question;
use Carp;
sub new {
my $class = shift;
my %params = #_;
#
# Standardize the Parameters
# Remove the dash, double-dash in front of the parameter and
# lowercase the name. Thus, -Question, --question, and question
# are all the same parameter.
#
my %option_hash;
my $question_type;
for my $key (keys %params) {
my $value = $params{$key};
$key =~ s/^-*//; #Remove leading dashes
$key = ucfirst ( lc $key ); #Make Key look like Method Name
if ( $key eq "Type" ) {
$question_type = ucfirst (lc $value);
}
else {
$option_hash{$key} = $value;
}
}
if ( not defined $question_type ) {
carp qq(Parameter "type" required for creating a new question.);
return;
}
#
# The real "class" of this question includes the question type
#
my $self = {};
$class .= "::$question_type";
bless $self, $class;
#
# All _real does is return a _true_ value. This method is in this
# class, so all sub-classes automatically inherit it. If the eval
# fails, this isn't a subclass, or someone wrote their own `_real_
# method in their sub-class.
#
eval { $self->_real; };
if ( $# ) {
carp qq(Invalid question type of $question_type);
return;
}
#
# Everything looks good! Let's fill up our question object
#
for my $method ( keys %option_hash ) {
my $method_set;
eval { $method_set = $self->$method( $option_hash{$method} ) };
if ( $# or not $method_set ) {
carp qq(Can't set "$method" for question type "$question_type");
return;
}
}
return $self;
}
Now, I'm setting my question like this:
my $question = Question->new(
--type => Integer,
--question => "Pick a number between 1 and 10.",
--help => "Try using the top row of your keyboard...",
--from => "1",
--to => "10",
);
if ( not defined $question ) {
die qq(The question is invalid!);
}
Darch use of the Try::Tiny is nice. It looks way better than wrapping everything in an eval. Unfortunately, it's not a standard module. This program is going on almost 100 separate systems, and using CPAN modules is too difficult. This is especially true since these systems are behind a firewall and can't access the CPAN website.
I basically use Darch's method except I create a _real method in my super-class that I try after I bless the object. If it executes (that's all I really care), then this is a sub-class of my super-class.
This does what I really want: Hide my sub-classes behind my superclass -- much like File::Spec does. Most of my classes have the same methods, and a few have one or two extra methods. For example, my Regex question type has a Pattern method that allows me to make sure the answer given matches a given pattern.