Multiple inheritance - wrong overload selected

Question

I'm trying out multiple inheritance and would like to get the hang of it without using packages like Moose to sort out the issue behind the scenes.

I have two base classes, Left and Right, in a "broken" diamond:

Left  Right
   \   /
   Multi

They both implement an overload for "". When calling a method, below named perform, in any of the base classes, those methods are supposed to use this overload to print a representation of that part of the object. Multi implements perform as so:

sub perform {
    my $self = shift;
    $self->Left::perform;
    $self->Right::perform;
}

What happens is that both base classes perform methods are called as they are supposed to, but when those methods call any other methods (like the "" overload) it'll always be the one in Left. However, if an instance of Right is created separately (not as a part of Multi) it'll call the correct method.

• I wonder how to make a method in this scenario select its own package's methods over its left-most sibling base class' methods?

Here's what I've tried (in perl v5.26.1 and v5.32.1):

#!/usr/bin/perl

use strict;
use warnings;

package Left; #----------------------------------------------------------------

sub new {
    my ($class, @args) = @_;
    my $self = bless {}, $class;
    return $self->_init(@args);
}

sub _init {
    my $self = shift;
    $self->{_leftval} = shift;
    return $self;
}

sub value { shift->{_leftval}; }

use overload '""' => sub {
    my $self = shift;
    'Left(' . $self->value . ')';
};

sub perform {
    my $self = shift;
    print '# LEFT ' . $self . "\n";
}

package Right; #---------------------------------------------------------------

sub new {
    my ($class, @args) = @_;
    my $self = bless {}, $class;
    return $self->_init(@args);
}

sub _init {
    my $self = shift;
    $self->{_rightval} = shift;
    return $self;
}

sub value { shift->{_rightval}; }

use overload '""' => sub {
    my $self = shift;
    'Right(' . $self->value . ')';
};

sub perform {
    my $self = shift;
    print '# RIGHT ' . $self . "\n";
}

package Multi; #---------------------------------------------------------------
use parent -norequire, 'Left', 'Right' ;

sub new {
    my ($class, @args) = @_;
    my $self = bless {}, $class;
    return $self->_init(@args);
}

sub _init {
    my $self = shift;
    $self->Left::_init(shift);
    $self->Right::_init(shift);
    return $self;
}

sub perform {
    my $self = shift;
    $self->Left::perform;
    $self->Right::perform;
}

package main; #----------------------------------------------------------------

my $l = Left->new("a Left");
my $r = Right->new("a Right");
my $m = Multi->new("lEfT", "rIgHt");

$l->perform;
$r->perform;
print "---- and now a Multi ----\n";
$m->perform;

Expected output:

# LEFT Left(a Left)
# RIGHT Right(a Right)
---- and now a Multi ----
# LEFT Left(lEfT)
# RIGHT Right(rIgHt)

Actual output (note the last line):

# LEFT Left(a Left)
# RIGHT Right(a Right)
---- and now a Multi ----
# LEFT Left(lEfT)
# RIGHT Left(lEfT)

Answer 1

A virtual method is resolved based on the object's class, not the caller's namespace/package/class.

In Perl, whether a method is virtual or not isn't an intrinsic property. It depends on how it's called.

$o->method   # Virtual method

Avoiding this require specifying the class

$o->Class::method

---

You don't want a virtual method call, so you'll need to change how you call the method.

package Left;

use overload '""' => \&to_string;

sub to_string {
    my $self = shift;
    'Left(' . $self->value . ')';
}

sub perform {
    my $self = shift;
    print '# LEFT ' . $self->Left::to_string() . "\n";
}

---

Except that's all wrong. If it was one method, this would make sense. But we're talking about every method. This is the air raid siren of red flags.

What we want here is composition, not inheritance. Multi IS A Left and IS A Right isn't correct. Rather, Multi HAS A Left and HAS A Right.

package Multi; #---------------------------------------------------------------
use parent -norequire, 'Left', 'Right' ;

sub new {
    my ($class, @args) = @_;
    my $self = bless {}, $class;
    return $self->_init(@args);
}

sub _init {
    my $self = shift;
    $self->{ left  } = Left ->new(shift);
    $self->{ right } = Right->new(shift);
    return $self;
}

sub perform {
    my $self = shift;
    $self->{ left  }->perform;
    $self->{ right }->perform;
}

Answer 2

This is building on Håkon's answer. bless $self, 'Right' in Right::perform effectively seems to break the inheritance. A second call to $m->perform directly calls Right::perform - Multi::perform isn't even invoked.

As a workaround to this, I added a blessing context class which blesses upon creation and on destruction. I'll have to create one of these contexts in all methods potentially calling any method in another package.

package Reblesser; #-----------------------------------------------------------

sub new {
    my $class = shift;
    my $self = bless {
        object => shift,
        class => shift
    }, $class;
    $self->rebless;
    $self;
}

sub rebless {
    my $self = shift;
    bless $self->{object}, $self->{class} if(ref $self->{object} ne $self->{class});
}

sub DESTROY {
    shift->rebless;
}

Now Left::perform becomes:

sub perform {
    my $self = shift;
    my $ctx = Reblesser->new($self, __PACKAGE__);
    print '# LEFT ' . $self . "\n";
}

Right::perform:

sub perform {
    my $self = shift;
    my $ctx = Reblesser->new($self, __PACKAGE__);
    print '# RIGHT ' . $self . "\n";
}

Multi::perform:

sub perform {
    my $self = shift;
    my $ctx = Reblesser->new($self, __PACKAGE__);
    $self->Left::perform;
    $self->Right::perform;
}

Output (even with multiple $m->perform calls):

# LEFT Left(a Left)
# RIGHT Right(a Right)
---- and now a Multi ----
# LEFT Left(lEfT)
# RIGHT Right(rIgHt)

Answer 3

I wonder how to make a method in this scenario select its own package's methods

Does it help to rebless $self like this:

package Right;

# [...]

sub perform {
    my $self = shift;
    if (ref $self ne "Right") {
        bless $self, "Right";
    }
    print '# RIGHT ' . $self . "\n";
}