Perl 继承 - 子程序覆盖

Question

Is there a way to override sub a in class_1_1 and class_2_1 with a new behavior(same for both classes) without adding the overridden method to both class_1_1 and class_2_1 ?

package class_0
    sub a
    sub b
1;

package class_1 
    use parent 'class_0'
    sub b
1;

package class_2
    use parent 'class_0'
    sub b
1;

package class_1_1
    use parent 'class_1'
1;

package class_2_1
    use parent 'class_2'
1;  

Answer 1

One tailor-made solution is to add a role for the wanted behavior.

Here is an example with native OO code, using stand-alone Role::Tiny for roles

use warnings;
use strict;

use SomeClass;

my $obj = SomeClass->new;

$obj->a_method;

The class SomeClass.pm

package SomeClass;

use warnings;
use strict;
use feature 'say';

use Role::Tiny::With;  # To "consume" a role. Comes with Role::Tiny

# Consume roles from "AddedRoles.pm"
# That may add or require methods, or override the ones here
with 'AddedRoles';     

sub new { bless { }, $_[0]] }

sub a_method { say "From ", __PACKAGE__ }

1;

This role can be added to other classes as well, by adding the use statement and the line with 'AddedRoles'; to them, regardless of their inheritance relationships. See the docs for ways to fine tune the process.

The package with the roles, AddedRoles.pm

package AddedRoles;

use feature 'say';  # we get strict and warnings from the package but not this

use Role::Tiny;

# Require that consumers implement methods; Add a method
#require method_1, method_2;    
#sub added_method { say "Adding functionality to consumers" }

# Replace "a_method" in a consumer
around a_method => sub { say "From an overriding role ", __PACKAGE__ } 

1;

The Role::Tiny need be installed (which has no dependencies). To replace a method that is defined in the class that consumes the role we need a method modifier around , ^† provided by Class::Method::Modifiers , so that is an additional dependency.

Roles are often compared to inheritance, and claimed to provide a nicer and lighter alternative since inheritance is normally "baked" into the whole class hierarchy etc. However, inheritance generally specializes behavior while roles are clearly more flexible; they add or modify behavior (or can specialize for that matter). I rather see roles fitting nicely somewhere between inheritance and composition.

Note that with roles we can have a near equivalent of multiple inheritance, with almost none of its formidable (and forbidding) headaches.

The bare-bones example above demonstrates the use of Role::Tiny on its own. But roles are better utilized along with Moose or Moo frameworks, using Moose::Role or Moo:Role .

I would absolutely recommend to look into these frameworks. I strongly believe in the value of learning well how to use the Perl's native OO system, but once one has that under their belt it'd be a shame to not try Moose or Moo .

---

^† In this particular question though the method to override is inherited from another class and in that case there is no need for a modifier. From "Role Composition" in docs

If a method is already defined on a class, that method will not be composed in from the role. A method inherited by a class gets overridden by the role's method of the same name, though.

So in the case of this question it is enough to normally define a sub in the roles package

# In the package that defines roles (like 'AddedRoles' above)
sub a_method  { say "From an overriding role ", __PACKAGE__ } 

and when this role is consumed by a class which inherits a_method , like class_1_1 in the question, the method does get overridden by this one.

Note that if a method is defined in the class itself (not inherited) then a role defined as a normal sub is quietly ignored (it won't override the method and it won't warn or such).

On the other hand, around overrides a method in either case (inherited or defined in the class), but cannot add a method that isn't there at all (and throws an exception if that is attempted).

Answer 2

You can do it with multiple inheritance:

#!/usr/bin/perl

use strict;
use warnings;

package class_0;
    sub new {
        my ($class, $foo) = @_;
        return bless{foo=>$foo}, $class;
    }

    sub a {
        my $self=shift;
        print 'a class_0 foo=' . $self->{foo} . "\n";
    }

    sub b {
        my $self=shift;
        print 'b class_0 foo=' . $self->{foo} . "\n";
    }

package new_a;
    sub a {
        my $self=shift;
        print 'a new_a foo=' . $self->{foo} . "\n";
    }

package class_1;
    use parent -norequire, 'class_0';
    sub b {
        my $self=shift;
        print 'b class_1 foo=' . $self->{foo} . "\n";
    }

package class_1_1;
    use parent -norequire, 'new_a', 'class_1';

package class_2;
    use parent -norequire, 'class_0';
    sub b {
        my $self=shift;
        print 'b class_2 foo=' . $self->{foo} . "\n";
    }

package class_2_1;
    use parent -norequire, 'new_a', 'class_2';

package main;

# example usage
my $c0 = class_0->new(1);
my $c1 = class_1->new(2);
my $c2 = class_2->new(3);
my $c11 = class_1_1->new(4);
my $c21 = class_2_1->new(5);

print "-- a class_0 b class_0\n";
$c0->a; $c0->b;
print "-- a class_0 b class_1\n";
$c1->a; $c1->b;
print "-- a class_0 b class_2\n";
$c2->a; $c2->b;
print "-- a new_a b class_1\n";
$c11->a; $c11->b;
print "-- a new_a b class_2\n";
$c21->a; $c21->b;

Output:

-- a class_0 b class_0
a class_0 foo=1
b class_0 foo=1
-- a class_0 b class_1
a class_0 foo=2
b class_1 foo=2
-- a class_0 b class_2
a class_0 foo=3
b class_2 foo=3
-- a new_a b class_1
a new_a foo=4
b class_1 foo=4
-- a new_a b class_2
a new_a foo=5
b class_2 foo=5