Perl: Best way of making parent subroutine (not method) available to children - perl

I have multiple classes defined in my main program. One is a parent class. The other are children classes:
# Main Program
...
package Foo; #Parent class
....
sub glob2regex {
my $glob = shift;
...here be dragons...
return $regex;
};
....
package Foo::Bar; #Child Class
base qw(Foo);
sub some_method {
my $self = shift;
my $regex = shift;
my $type = shift;
if ( $type eq "glob" ) {
$regex = glob2regex($regex); #ERROR: glob2regex is not defined.
}
...
}
I have a function in my parent class called glob2regex. It isn't really a method because it doesn't do anything with the object. Instead, it's a helper function that my child classes can use.
However, calling it in my child class as shown above won't work because it's not defined in my child class. I could prepend the full parent class name on it (i.e. call it as Foo::glob2regex instead of just glob2regex), or I could modify it into an object, and call it as $self->glob2regex. There maybe a even better way of handling this situation that I'm overlooking.
What is the best way to make a function like this that's defined in the parent class available in the child classes?
--
Test Program
#! /usr/bin/env perl
#
use strict;
use warnings;
use feature qw(say);
use utf8;
########################################################################
# MAIN PROGRAM
my $bar = Foo::Bar->new;
$bar->just_foo_it;
#
########################################################################
########################################################################
#
package Foo;
sub lets_foo_it {
say "I've done foo!";
}
#
########################################################################
########################################################################
#
package Foo::Bar;
use base qw(Foo);
*Foo::Bar::lets_foo_it = *Foo::lets_foo_it;
sub new {
my $class = shift;
my $self = {};
bless $self, $class;
return $self;
}
sub just_foo_it {
my $self = shift;
lets_foo_it();
}
#
########################################################################

Exporting is usually done using Exporter.
BEGIN {
package Foo;
use Exporter qw( import );
our #EXPORT_OK = qw( glob2regex );
sub glob2regex { ... }
...
$INC{'Foo.pm'} = 1;
}
BEGIN {
package Foo::Bar;
use Foo qw( glob2regex );
our #ISA = 'Foo';
... glob2regex(...) ...
$INC{'Foo/Bar.pm'} = 1;
}
Note that it's very unusual for a class module to export subroutines. You should consider it a red flag indicating a likely design flaw.

Seems like a bit of your problem is: "How do I use within a file?". I have a pragma I use in early development for this type of thing, but it breaks down to:
package Foo;
BEGIN { $INC{ __PACKAGE__ . '.pm'} = __FILE__ . ':' . ( __LINE__ - 1 ); }
Once it's in the %INC table, you're usually fine just using it.
Remember that a use is a require combined with an import at compile time. Once you've defined the Foo import, you can create an import function to take care of that part of use.
sub import {
my $caller = caller;
return unless $caller->isa( __PACKAGE__ );
{ no strict 'refs';
*{"$caller\::glob2regex"} = *glob2regex{CODE};
}
}
As I wrote above, I use this type of thing in early development--basically, when I want a sort of "scratchpad" with object relationships. In maintainable code, my preference would be to call Foo::glob2regex(...), or as I have at times insert it into a util package and export it from there:
package Foo::Util;
use strict;
use warnings;
use parent 'Exporter';
our #EXPORT_OK = qw<glob2regex>;
sub glob2regex { ... }

Related

Perl with Moo: How to call superclass's implementation of a method?

I have a class X with a subclass Y. X has a method calculate() that I'd like to override in Y with some additional behaviour, an if statement that, if it fails, call X.calculate(). In Python this would be accomplished with:
class X(object):
def calculate(self, my_arg):
return "Hello!"
class Y(X):
def calculate(self, my_arg):
if type(my_arg) is int and my_arg > 5:
return "Goodbye!"
return super(Y, self).calculate(my_arg)
How can I do this in Perl using the Moo module?
As the docs point out:
No support for super, override, inner, or augment - the author considers augment to be a bad idea, and override can be translated:
around foo => sub {
my ($orig, $self) = (shift, shift);
...
$self->$orig(#_);
...
};
(emphasis mine)
#!/usr/bin/env perl
use strict;
use warnings;
package X;
use Moo;
sub calculate {
return 'Hello!'
}
package Y;
use Moo;
extends 'X';
around calculate => sub {
my $orig = shift;
my $self = shift;
if ( $_[0] > 5 ) {
return $self->$orig(#_);
}
return 'Goodbye!';
};
package main;
my $y = Y->new;
print $y->calculate(3), "\n";
print $y->calculate(11), "\n";
This can be done in Perl via the SUPER:: pseudo-class, which is part of Perl's method resolution system. You just put it in front of the method-call. It does not work for class methods or function calls.
use strict;
use warnings;
use feature 'say';
package Foo;
use Moo;
sub frobnicate {
my $self = shift;
say "foo";
}
package Bar;
use Moo;
extends 'Foo';
sub frobnicate {
my $self = shift;
say "bar";
$self->SUPER::frobnicate;
}
package main;
Bar->new->frobnicate;
You can even use this to call each parent's method if you have multi-level inheritance.
package Grandparent;
sub foo { ... }
package Parent;
use parent 'Grandparent';
sub foo { $_[0]->SUPER::foo }
package Child;
use parent 'Parent';
sub foo { $_[0]->SUPER::foo }
This will subsequently call foo in Child, Parent and Grandparent.

Perl: How to make sure overridden method is called when accessed from within the base class

I have a base class which calls a method which is overridden in a child class, in Perl. Currently, it still calls the base class version of the method, but I want it to call the base if there is one. Here is a simplified rendition of my code:
package Test;
use strict;
use warnings;
sub Main
{
my $self = shift;
return $self->SomeFunc();
}
sub SomeFunc
{
my $self = shift;
#...
return 1;
}
package Test2;
use strict;
use warnings;
use base qw(Test);
sub SomeFunc
{
my $self = shift;
#...
return 0;
}
package main;
use Test2;
my $test = new Test2();
print $test->Main();
and I am getting a 1 when I run this!
PS my apologies, I'm not used to creating examples in working perl code, please forgive the obvious errors.
The problem would be in your constructor, but you don't have one so your code doesn't even do what you say it does
You have probably written something like
sub new {
bless {};
}
which blesses an empty hash into the current package. Instead you need to take the class name from the first parameter passed to the constructor, like this
You should also avoid using capital letters in your lexical identifiers as they are reserved for global identifiers like package names. If you must use CamelCase then at least makeSureTheFirstLetterIsLowerCase. The standard for both Perl and Python is to use the much_clearer_snake_case
Test.pm
package Test;
use strict;
use warnings;
sub new {
my $class = shift;
bless {}, $class;
}
sub main {
my $self = shift;
$self->some_func();
}
sub some_func {
my $self = shift;
'Test::some_func';
}
Test2.pm
package Test2;
use strict;
use warnings;
use parent 'Test';
sub some_func {
my $self = shift;
'Test2::some_func';
}
main.pl
use strict;
use warnings;
my $test = Test->new;
print $test->main, "\n";
$test = Test2->new;
print $test->main, "\n";
output
Test::some_func
Test2::some_func
new doesn't mean anything in perl unless you make a function with that method name.
You need to bless an object
You can either directly bless an object
my $test = { };
bless $test, "Test2";
or make a new method that does the blessing for you:
sub new{
my $class = shift;
my $test = { };
bless $test, $class;
}

Perl inheritance through ISA

Question regarding inheritance in Perl using #ISA:
Input - 3 files: one is a main script, two containing parent & child packages, correspondingly:
main:
#!/usr/bin/perl
use child qw(parent_or_child_function srictly_parent_function);
parent_or_child_function();
srictly_parent_function();
parent.pm:
package parent;
sub srictly_parent_function
{
print "this is strictly parent function\n";
}
sub parent_or_child_function
{
print "this is parent function which can be inherited\n";
}
1;
child.pm:
package child;
our #ISA = 'parent';
use Exporter qw(import);
#EXPORT_OK = qw(parent_or_child_function srictly_parent_function);
sub parent_or_child_function
{
print "this is child function that replaced parent's\n";
}
1;
Output is:
$main
this is child function that replaced parent's
Undefined subroutine &child::srictly_parent_function called at main line 6.
What am I doing wrong? I understand that child package doesn't have strictly_parent_function , but shouldn't child's #ISA package be searched for it?
Firstly, make parent actually an object.
package parent;
use strict;
use warnings;
# Constructor
sub new {
my ($proto) = #_;
my $class = ref($proto) || $proto;
my $self = {};
# Bless is what casts $self (instance of this class) as an object
return bless($self, $class);
}
sub srictly_parent_function {
my ($self) = #_;
print "this is strictly parent function\n";
}
sub parent_or_child_function {
my ($self) = #_;
print "this is parent function which can be inherited\n";
}
1;
Then with parent as an object, child can inherit
package child;
use strict;
use warnings;
# I prefer use base, as it's safer than pushing classes into #ISA
# See http://docstore.mik.ua/orelly/perl2/prog/ch31_03.htm)
use base qw(parent);
sub parent_or_child_function {
my ($self) = #_;
print "this is child function that replaced parent's\n";
}
# To give an example for accessing variables from a class.
my $variable = "WHATEVER";
sub get_variable { return $variable;}
1;
Then to test your code:
perl -e "use child; $object = child->new(); $object->parent_or_child_function();"
or to script it up properly;
# Load up child class
use child qw();
# Invoke constructor to create an instance of the class
my $object = child->new();
# Invoke function from child class
$object->parent_or_child_function();
# Get Variable
$object->get_variable();

How does an object access the symbol table for the current package?

How could I access the symbol table for the current package an object was instantiated in? For example, I have something like this:
my $object = MyModule->new;
# this looks in the current package, to see if there's a function named run_me
# I'd like to know how to do this without passing a sub reference
$object->do_your_job;
If in the implementation of do_your_job I use __PACKAGE__, it will search in the MyModule package. How could I make it look in the right package?
EDIT:I'll try to make this clearer. Suppose I have the following code:
package MyMod;
sub new {
return bless {},$_[0]
}
sub do_your_job {
my $self = shift;
# of course find_package_of is fictional here
# just for this example's sake, $pkg should be main
my $pkg = find_package_of($self);
if(defined &{ $pkg . '::run_me' }) {
# the function exists, call it.
}
}
package main;
sub run_me {
print "x should run me.\n";
}
my $x = MyMod->new;
# this should find the run_me sub in the current package and invoke it.
$x->do_your_job;
Now, $x should somehow notice that main is the current package, and search it's symbol table. I tried using Scalar::Util's blessed , but it still gave me MyModule instead of main. Hopefully, this is a bit clearer now.
You just want caller
caller tells you the package from which it was called. (Here I added some standard perl.)
use Symbol qw<qualify_to_ref>;
#...
my $pkg = caller;
my $symb = qualify_to_ref( 'run_me', $pkg );
my $run_me = *{$symb}{CODE};
$run_me->() if defined $run_me;
To look it up and see if it's defined and then look it up to call it would duplicate it as standard perl doesn't do Common Subexpression Elimination, so you might as well 1) retrieve it, and 2) check definedness of the slot, and 3) run it if it is defined.
Now if you create an object in one package and use it in another, that's not going to be too much help. You would probably need to add an additional field like 'owning_package' in the constructor.
package MyMod;
#...
sub new {
#...
$self->{owning_package} = caller || 'main';
#...
}
Now $x->{owning_package} will contain 'main'.
See perldoc -f caller:
#!/usr/bin/perl
package A;
use strict; use warnings;
sub do_your_job {
my ($self) = #_;
my ($pkg) = caller;
if ( my $sub = $pkg->can('run_me') ) {
$sub->();
}
}
package B;
use strict; use warnings;
sub test {
A->do_your_job;
}
sub run_me {
print "No, you can't!\n";
}
package main;
use strict; use warnings;
B->test;
Output:
C:\Temp> h
No, you can't!

How do I inherit subroutines in Perl with 'use base'?

How do I apply 'use base' in Perl to inherit subs from some base module?
I'm used to C++ inheritance mechanics, and all the sites I googled for this caused more confusion then help. I want to do something like the following:
#! /usr/bin/perl
#The base class to inherit from
use strict;
use warnings;
package 'TestBase';
#-------------------------------
sub tbSub
{
my ($self, $parm) = #_;
print "\nTestBase: $parm\n";
}
1;
.
#! /usr/bin/perl
#The descendent class
use strict;
use warnings;
use base qw(TestBase);
sub main;
sub mySub;
#-------------------------------
#Entry point...
main();
#---code------------------------
sub main
{
mySub(1);
tbSub(2);
mySub(3);
}
#-------------------------------
sub mySub
{
my $parm = shift;
print "\nTester: $parm\n";
}
Perl complains/cannot find tbSub.
The C++ mechnics aren't much different than the Perl mechanics: To use inheritance, you need two classes: the base class and the inheriting class. But you don't have any descendent class.
You are also lacking a constructor. Unlike C++, Perl will not provide a default constructor for you.
Your base class contains a bad syntax error, so I guess you didn't try the code before posting.
Finally, as tsee already observed, you will have to let Perl know whether you want a function call or a method call.
What you really want would look something like this:
my $foo = TestDescendent->new();
$foo->main();
package TestBase;
sub new {
my $class = shift;
return bless {}, $class;
}
sub tbSub
{
my ($self, $parm) = #_;
print "\nTestBase: $parm\n";
}
package TestDescendent;
use base 'TestBase';
sub main {
my $self = shift;
$self->mySub( 1 );
$self->tbSub( 2 );
$self->mySub( 3 );
}
sub mySub
{
my $self = shift;
my $parm = shift;
print "\nTester: $parm\n";
}
1;
You should have a look at using Moose which is a postmodern object system for Perl5. You will probably find it a lot easier to grasp than using standard Perl OO semantics... especially when coming from another OO language.
Here's a Moose version of your question....
package TestBase;
use Moose;
sub tbSub {
my ($self, $parm) = #_;
print "\nTestBase: $parm\n";
}
package TestDescendent;
use Moose;
extends 'TestBase';
sub main {
my $self = shift;
$self->mySub( 1 );
$self->tbSub( 2 );
$self->mySub( 3 );
}
sub mySub {
my ($self, $parm) = #_;
print "\nTester: $parm\n";
}
package main;
my $foo = TestDescendent->new();
$foo->main
The differences are....
Constructor automatically created for you &
Inheritance defined by "extends" command instead of "use base".
So this example only covers the tip of the Moose iceberg ;-)
As a sidenote, there is little good reason to use base rather than the newer use parent.
It seems to me, you are mixing up two things here: Object-Oriented and Procedural Perl. Perl OO is kind of "different" (as in not mainstream but workable).
Your TestBase.pm module seems to expect to be run as a Perl object (Perl oo-style), but your Perl script wants to access it as "normal" module. Perl doesn't work the way C++ does (as you realised) so you would have to construct your code differently. See Damian Conway's books for explanations (and smarter code than mine below).
Procedural:
#! /usr/bin/perl
#The module to inherit from
package TestBase;
use strict;
use warnings;
use Exporter ();
our #ISA = qw (Exporter);
our #EXPORT = qw (tbSub);
#-------------------------------
sub tbSub
{
my ($parm) = #_;
print "\nTestBase: $parm\n";
}
1;
.
#! /usr/bin/perl
#The descendent class
use strict;
use warnings;
use TestBase;
sub main;
sub mySub;
#-------------------------------
#Entry point...
main();
#---code------------------------
sub main
{
mySub(1);
tbSub(2);
mySub(3);
}
#-------------------------------
sub mySub
{
my $parm = shift;
print "\nTester: $parm\n";
}
Perl OO
#! /usr/bin/perl
#The base class to inherit from
package TestBase;
use strict;
use warnings;
#-------------------------------
sub new { my $s={ };
return bless $s;
}
sub tbSub
{
my ($self,$parm) = #_;
print "\nTestBase: $parm\n";
}
1;
.
#! /usr/bin/perl
#The descendent class
use strict;
use warnings;
use TestBase;
sub main;
sub mySub;
#-------------------------------
#Entry point...
main();
#---code------------------------
sub main
{
my $tb = TestBase->new();
mySub(1);
$tb->tbSub(2);
mySub(3);
}
#-------------------------------
sub mySub
{
my $parm = shift;
print "\nTester: $parm\n";
}
Perl's inheritance inherits methods, not functions. That means you will have to call
main->tbSub(2);
However, what you really want is to inherit the method into a proper class:
package Derived;
use base "TestBase";
package main;
Derived->somemethod("foo");
Calling methods in the current package as functions won't pass in the $self or "this" object nor the class name magically. Internally,
Class->somemethod("foo")
essentially ends up being called as
Class::somemethod("Class", "foo")
internally. Of course, this assumes Class has a subroutine/method named "somemethod". If not, the superclasses of Class will be checked and if those don't have a method "somemethod" either, you'll get a fatal error. (Same logic applies for $obj->method("foo").)
OO syntax uses the -> operator to separate the message and arguments from the receiver of the message. A short illustration below.
You->do_something( #params );
OR
$you->do_something( #params );
package A;
sub do_neat_thing {
my ( $class_or_instance, #args ) = #_;
my $class = ref( $class_or_instance );
if ( $class ) {
say "Instance of '$class' does a neat thing.";
}
else {
say "$class_or_instance does a neat thing.";
}
}
...
package main;
A->do_neat_thing(); # A does a neat thing.
my $a_obj = A->new();
$a_obj->do_neat_thing(); # Instance of 'A' does a neat thing.