Multiple inheritance - wrong overload selected-CodePudding

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)

CodePudding user response：

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";
}

CodePudding user response：

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)