I have some Perl objects which were built some time ago not with Moose,
but with bless, inheritance is implemented using the 'parent' pragma.
Now I would like to know whether there is a way to check whether a certain class has used 'parent' or not.
e.g. if I have two classes
package Animal;
sub new {
my $class = shift;
return bless {}, $class;
}
1;
and
package Cat;
use parent 'Animal';
sub new {
my $class = shift;
return bless {}, $class;
}
1;
would there be some check I could make to determine that the 'Cat' class
has a parent ( do not care which, but not itself ), and Animal does not, given a $foo which is either of them?
I can't picture why you'd ever want to know this, but it's possible using the following:
use mro;
my $inherits = #{ mro::get_linear_isa($class) } > 1;
or
my $isa = do { no strict 'refs'; \#{ $class . '::ISA' } };
my $inherits = #$isa;
Notes:
All classes inherit from UNIVERSAL, but that's ignored unless a class explicitly declares it inherits from it.
These methods don't care how the inheritance was declared (use parent or some other means).
Related
I don't know if this is possible, but I would like to call a known subclass function from Perl. I need something "generic" to call something more specific. My superclass is going to assume that all classes that subclass it have a known function defined. I guess this is similar to Java "implements".
For example let's say I have the following code:
GenericStory.pm
package Story::GenericStory;
sub new{
my $class = shift;
my $self = {};
bless $self, class;
return $self;
}
sub tellStory {
my $self;
#do common things
print "Once upon a time ". $self->specifics();
}
#
Story1.pm
package Story::Story1;
use base qw ( Story::GenericStory );
sub new {
my $class = shift;
my $self = $class->SUPER::new(#_);
return $self;
}
sub specifics {
my $self;
print " there was a dragon\n";
}
#
Story2.pm
package Story::Story2;
use base qw ( Story::GenericStory );
sub new {
my $class = shift;
my $self = $class->SUPER::new(#_);
return $self;
}
sub specifics {
print " there was a house\n";
}
#
MAIN
my $story1 = Story::Story1->new();
my $story2 = Story::Story2->new();
#Once upon a time there was a dragon.
$story1->tellStory();
#Once upon a time there was a house.
$story2->tellStory();
EDIT:
The code works fine. I simply forgot a "my $self = shift;" in tellStory();
Your code works fine as is (modulo trivial errors); you may want to add in the superclass:
sub specifics {
require Carp;
Carp::confess("subclass does not implement required interface");
}
or similar.
What you want is very much like a trait (or in Perl: a role).
Traits are a relatively recent addition to object oriented systems. They are like interfaces in that they can require an inheriting class to implement certain methods, but they are like a abstract superclass in that they can provide certain methods themselves.
The Moose object system allows roles. A class can be declared with a certain role. Here your example written with MooseX::Declare:
use MooseX::Declare;
role Story::StoryTeller{
requires 'specifics';
method tellStory() {
print "Once upon a time ";
$self->specifics();
}
}
class Story::Story1 with Story::StoryTeller {
method specifics() {
print " there was a dragon\n";
}
}
class Story::Story2 with Story::StoryTeller {
method specifics() {
print " there was a house\n";
}
}
my $story1 = Story::Story1->new();
my $story2 = Story::Story2->new();
#Once upon a time there was a dragon.
$story1->tellStory();
#Once upon a time there was a house.
$story2->tellStory();
This isn't inheritance: $story1->isa("Story::StoryTeller") is false, but it does this role: $story1->DOES("Story::StoryTeller") is true.
For every class that DOES a certain role, an instance of that class can all methods of the role. Therefore, $story1->can("tellStory") is true, and in reverse for every Story::StoryTeller instance, $instance->can("specifics") will be true.
A role cannot be instantiated on its own.
How would I create my class such that some methods will exist in the instance only if certain values were passed to the constructor?
Perhaps a more generic way of asking is: How can I add a method to an existing class instance?
You can attach an anonymous sub to an object based on flags:
use strict;
use warnings;
package Object;
sub new {
my $class = shift;
my $self = bless {}, $class;
my %args = #_;
if ($args{method}) {
$self->{method} = sub { print "hello\n" }
}
return $self;
}
sub method {
my $self = shift;
if (not defined $self->{method}) {
warn "Not bound\n";
return;
}
$self->{method}->();
}
1;
to use:
use Object;
my $obj1 = Object->new(method=>1);
$obj1->method();
my $obj2 = Object->new();
$obj2->method();
You can extend this to a number of methods through the same interface.
You can use Moose to apply a role at runtime.
package My::Class;
use Moose;
has foo => ( isa => 'Str', is => 'ro', required => 1 );
sub BUILD {
my $self = shift;
if ($self->foo eq 'bar') {
My::Class::Role->meta->apply($self);
}
}
no Moose;
package My::Class::Role;
use Moose::Role;
sub frobnicate {
my $self = shift;
print "Frobnicated!\n";
}
no Moose;
my $something = My::Class->new( foo => 'bar' );
print $something, "\n";
$something->frobnicate;
my $something_else = My::Class->new( foo => 'baz' );
print $something_else, "\n";
$something_else->frobnicate;
Gives:
Moose::Meta::Class::__ANON__::SERIAL::1=HASH(0x2fd5a10)
Frobnicated!
My::Class=HASH(0x2fd2c08)
Can't locate object method "frobnicate" via package "My::Class" at testmoose.pl line 32.
use AUTOLOAD to define the function. As a example method foo is called if $self->{foo} exists
sub AUTOLOAD {
my $methodname = $AUTOLOAD;
if ($methodname eq "foo" && exists($_[0]->{foo})){
goto &fooimplementationsub;
}
return;
}
An alternative technique is to use globs to define a new method at runtime
*PACKAGE::method = sub {
#code here
};
This has the disadvantage that the method is now visible to all instances of the class so is not quite what you want.
A third and possibly more risky/inefficient method is to use string eval
eval <<EOF
sub foo {
#code here
};
EOF
Again this has the disadvantage that the method is now visible to all instances of the class so is not quite what you want.
Methods are just subroutines in a package, and a package is just a hash holding typeglobs. And hashes can be modified at runtime.
So you could, in theory, add or remove methods given values in a constructor.
package WeirdClass;
sub new {
my ($class, $name, $code) = #_;
if ($name) {
no strict;
*{__PACKAGE__ . "::$name"} = $code;
}
bless {} => $class;
}
And then use it like:
my $object = WeirdClass->new(foo => sub {say "foo"});
$object->foo(); # prints "foo\n";
However, this method is available for all objects of that class:
my $another_object = WeirdClass->new();
$another_object->foo; # works too.
Using autoload, one can mock arbitrary methods:
package BetterClass;
sub new {
my ($class, %args) = #_;
bless \%args => $class;
}
# destructor will be called at cleanup, catch with empty implementation
sub DESTROY {};
sub AUTOLOAD {
my $self = shift;
(my $method = our $AUTOLOAD) =~ s/.*://; # $AUTOLOAD is like "BetterClass::foo"
# check if method is allowed
die "forbidden method $method" unless $self->{can}{$method};
# mock implementations
given ($method) {
say "foo" when "foo";
say "bar" when "bar";
when ("add") {
my ($x, $y) = #_;
return $x + $y;
}
default { die "unknown method $method" }
}
}
Then:
my $o = BetterClass->new(can => { foo => 1, bar => 0});
$o->foo;
my $p = BetterClass->new(can => {bar => 1, add => 1});
$p->bar;
say $p->add(5, 6);
Of course, these techniques can be combined freely.
Edit: can()
To make the AUTOLOAD work with can, the protected methods should be moved into a data structure:
my %methods;
BEGIN {
%methods = (
foo => sub {say "foo"},
bar => sub {say "bar"},
add => sub {
my ($self, $x, $y) = #_;
$x + $y;
},
);
}
Then override the can method:
# save a reference to the origional `can` before we override
my $orig_can;
BEGIN{ $orig_can = __PACKAGE__->can("can") }
sub can {
my ($self, $meth) = #_;
# check if we have a special method
my $code = $methods{$meth} if ref $self and $self->{can}{$meth};
return $code if $code;
# check if we have a normal method
return $self->$orig_can($meth);
}
And AUTOLOAD would change to
my ($self) = #_; # do not `shift`
(my $method = our $AUTOLOAD) =~ s/.*://;
my $code = $self->can($method) or die "unknown method $method";
goto &$code; # special goto. This is a AUTOLOAD idiom, and avoids extra call stack frames
Don't do too much magic. I've gotten away from AUTOLOAD because it causes maintenance issues where mysterious methods suddenly appear and disappear.
One way to handle what you want is to define all the methods you need, and if a particular object is of the wrong type, simply cause that method to croak:
sub Foo {
my $self = shift;
my $parameter = shift;
if ( $self->Class_type ne "Foo" ) {
croak qq(Invalid method 'Foo' on object #{[ref $self]});
}
print "here be dragons\";
return "Method 'Foo' successfully called";
}
The above will not allow method Foo to be called unless the class type is Foo.
If your objects won't change (or you don't want them to change) once an object is created, you can define that object as a sub-class.
Before you bless a newly created object, check that special value and decide whether or not you need to create a specific sub-class instead.
package My_class;
sub new {
my $class = shift;
my $class_type = shift;
my $self = shift;
if ( $class_type eq "Foo" ) {
bless $self, "My_class::Foo";
}
else {
bless $self, $class;
}
package My_class::Foo;
use base qw(My_class);
sub Foo {
my $self = shift;
return "Foo Method successfully called!";
}
Notice that my class My_class::Foo is a sub-class of My_class via the use base pragma. That means all methods for My_class are valid with objects of My_class::Foo. However, only objects of My_class::Foo can call the Foo method.
When I create my object (via the new subroutine), I look at the $class_type parameter. If it's a type Foo, I bless the class as My_class::Foo.
Here's an example where I use sub-classes to do what you want.
Every object is a class type of Question. You can see my constructor on line 1129. I pass in a question type as one of the parameters to my constructor.
In line 1174 to 1176, I create my object, but then append the question type to the class, and then bless the question as that sub-class type. All of my subclasses are a type Question (see my use base qw(Question); below each package declaration. However, only questions of sub-class Question::Date and Question::Regex have a method Format. And, only objects of type Question::Words have a method Force.
Hope this helps.
None of the answers so far given actually handle the question actually asked.
Adding methods to an instance in Perl is not directly supported. Object instances are always instances of some class, and that class is the thing that actually has methods. You cannot add a method to a single instance of a class, without making that method also available on every other instance of the same class.
For your problem you have two basic solutions:
Provide the methods always, but test a flag to see whether the method should apply to the given instance or not. This is by far the simplest.
Bless each object into subclasses depending on the flags. Subclass the main class to provide those methods as appropriate.
If you truely want to add methods on individual instances, then what you'll have to do is arrange that every instance is a single instance of a newly-derived class for every object. This gets harder to arrange for, doubly-so if you want to avoid leaking memory and cleaning up the classes once the objects are DESTROYed. This would however allow truely per-instance methods.
Since it is highly unlikely you'll truely need this third option it is far better to go with one of the first.
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;
I am extending a module and I want some tips on good practices. Specially namespace conflicts: what exactly are they and how to avoid them.
When extending, should I not access variables in the SUPER class and only alter its state through accessors or object methods? What to do in case there are no (or limited) accessors? Am I "allowed" to access these object variables directly?
Cheers!
It is best to only access things through accessors because this prevents changes in the implementation of the superclass from affecting the subclasses. You should stay far away from anything that starts with an underbar. Those things are private to the class. Try to stay away from anything that is not documented. Relying on those things will get you into trouble. Also, consider using has-a versus is-a relationship.
Let's imagine a widget class. This class has name and price members (note, none of this is particularly good code, I have just tossed of a version with out thinking about it for the sake of an example):
package Widget;
use strict;
use warnings;
sub new {
my $class = shift;
my %args = #_;
return bless {
price => $args{price} || 0,
name => $args{name} || "unkown",
}, $class;
}
sub price { shift->{price} }
sub name { shift->{name} }
1;
You decide to subclass widget to add a weight member:
package Widget::WithWeight;
use strict;
use warnings;
use base 'Widget';
sub new {
my $class = shift;
my %args = #_;
my $self = $class->SUPER::new(%args);
$self->{weight} = $args{weight} || 0;
return bless $self, $class;
}
sub weight { shift->{weight} }
sub price_per_pound {
my $self = shift;
return $self->{price}/$self->{weight};
}
1;
Now imagine the author of the first module changes his/her mind about how to store the price. Perhaps it was stored as a floating point number and the author realized that storing it as an integer number of pennies would be better:
package Widget;
use strict;
use warnings;
sub new {
my $class = shift;
my %args = #_;
if ($args{price}) {
$args{price} =~ s/[.]//;
}
return bless {
price => $args{price} || "000",
name => $args{name} || "unkown",
}, $class;
}
sub price {
my $self = shift;
my $price = $self->{price};
substr($price, -2, 0) = ".";
return $price;
}
sub name { shift->{name} }
1;
Suddenly, your tests will start failing, but if you had used the price accessor instead, you would have been insulated from that change.
Namespace conflicts can happen if you inherit from two modules into one and they both provide (export) the same sub.
I suggest you have a look at Moose, an extension to Perl that provides you with classes and roles. You can avoid many conflicts if you use roles. See http://www.iinteractive.com/moose/
Moose also makes automatic accessors for the class variables, making it safer to access them from inheriting classes.
I have two classes: a base class, Foo::Base and a derived class, Foo::Base::Sub. I want to have Foo::Base::Sub do some type and data checking on the constructor`s argument--a hash--before blessing it. I've tried overriding Foo::Base->new's constructor, doing the checks and then calling Foo::Base->new (since the code would be exactly the same):
package Foo::Base::Sub;
sub new {
...check argument's type and data...
Foo::Base->new(%my_hash)
}
The problem is that by calling Foo::Base's constructor, the hash will now be blessed as a Foo::Base object and not a Foo::Base::Sub object. The obvious solution is simply to put the code from Foo::Base::new into Foo::Base::Sub::new but then I'm repeating code. The other thing is that Foo::Base is not mine--thus I'd like to avoid having to modify it after the module has loaded or forking it unnecessarily.
It seems to me that this problem must have come up before and so there must be a canonical solution. Moreover, it really touches on type coercion which is generally not an issue Perl.
So is there a simple modification or am I going about this the wrong way?
A standard Perl idiom is to use SUPER to call up the inheritance chain:
#Foo::Base::Sub::ISA = qw(Foo::Base);
sub new {
my $package = shift;
my $self = $package->SUPER::new();
# Other subconstructor stuff here
return $self;
}
As noted in the comments, Foo::Base's constructor must use the two-argument form of bless:
sub new {
my $package = shift;
my $self = bless {}, $package;
# Other superconstructor stuff here
return $self;
}
When the superclass' constructor is called, $package will be the subclass.
I'm used to split this to two parts, new and init.
package Foo::Base;
sub new {
my $class = shift;
my $self = bless {}, $class;
return $self->init(#_);
}
sub init {
my ($self, #params) = #_;
# do something initialization and checks
return $self;
}
package Foo::Sub;
use base 'Foo::Base';
sub init {
my ($self, #params) = #_;
# do something initialization and checks
$self = $self->SUPER::init(#params);
# do something other if you wish
return $self;
}
Note that 'Foo::Sub' doesn't implement new constructor.
You might want to look at the various ways of invoking super. The SUPER module may work although I havent tried it myself.