The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
#!/usr/bin/env perl

use strict;
use warnings;

# this verifies that method caching doesn't break anything, but the caching behaviour
# can better be verified by looking at the output of this test with e.g.
#
#     METHOD_LEXICAL_DEBUG=1 prove -vb t/cache.t

{
    package MyTest::Parent;

    sub private { 'parent!' } # ordinary public method

    package MyTest::Mother;
    package MyTest::Father;
    package MyTest::Child;

    use Test::More tests => 136;

    use Method::Lexical {
         private                  => sub { 'child!'  },
        'MyTest::Mother::private' => sub { 'mother!' },
        'MyTest::Father::private' => sub { 'father!' },
    };

    our @ISA;

    my $self = bless {};
    my $fqname;

    for my $isa (
        [ [ qw(MyTest::Mother) ], 'mother!' ],
        [ [ qw(MyTest::Mother) ], 'mother!' ], # don't smash the cache the second time through
        [ [ qw(MyTest::Father) ], 'father!' ],
        [ [ qw(MyTest::Parent) ], 'parent!' ]
    ) {
        my $want = 'child!';

        $fqname = 'private';
        is(__PACKAGE__->private, $want, '__PACKAGE__->private ('.__LINE__.')');
        is(__PACKAGE__->$fqname, $want, '__PACKAGE__->$fqname ('.__LINE__.')');
        is($self->private, $want, '$self->private ('.__LINE__.')');
        is($self->$fqname, $want, '$self->$fqname ('.__LINE__.')');

        @ISA = @{$isa->[0]};
        $want = $isa->[1];

        $fqname = 'SUPER::private';
        is(__PACKAGE__->SUPER::private, $want, '__PACKAGE__->SUPER::private ('.__LINE__.')');
        is(__PACKAGE__->$fqname, $want, '__PACKAGE__->$fqname ('.__LINE__.')');
        is($self->SUPER::private, $want, '$self->SUPER::private ('.__LINE__.')');
        is($self->$fqname, $want, '$self->$fqname ('.__LINE__.')');

        $fqname = "SUPER'private";
        is(__PACKAGE__->$fqname, $want, '__PACKAGE__->$fqname ('.__LINE__.')');
        is($self->$fqname, $want, '$self->$fqname ('.__LINE__.')');

        $fqname = 'SUPER::private';
        is(__PACKAGE__->SUPER::private, $want, '__PACKAGE__->SUPER::private ('.__LINE__.')');
        is(__PACKAGE__->$fqname, $want, '__PACKAGE__->$fqname ('.__LINE__.')');
        is($self->SUPER::private, $want, '$self->SUPER::private ('.__LINE__.')');
        is($self->$fqname, $want, '$self->$fqname ('.__LINE__.')');

        $fqname = "SUPER'private";
        is(__PACKAGE__->$fqname, $want, '__PACKAGE__->$fqname ('.__LINE__.')');
        is($self->$fqname, $want, '$self->$fqname ('.__LINE__.')');

        $fqname = 'MyTest::Child::SUPER::private';
        is(__PACKAGE__->MyTest::Child::SUPER::private, $want, '__PACKAGE__->MyTest::Child::SUPER::private ('.__LINE__.')');
        is(__PACKAGE__->$fqname, $want, '__PACKAGE__->$fqname ('.__LINE__.')');
        is($self->MyTest::Child::SUPER::private, $want, '$self->MyTest::Child::SUPER::private ('.__LINE__.')');
        is($self->$fqname, $want, '$self->$fqname ('.__LINE__.')');

        $fqname = "MyTest::Child::SUPER'private";
        is(__PACKAGE__->$fqname, $want, '__PACKAGE__->$fqname ('.__LINE__.')');
        is($self->$fqname, $want, '$self->$fqname ('.__LINE__.')');

        $fqname = "MyTest::Child'SUPER::private";
        is(__PACKAGE__->$fqname, $want, '__PACKAGE__->$fqname ('.__LINE__.')');
        is($self->$fqname, $want, '$self->$fqname ('.__LINE__.')');

        $fqname = "MyTest::Child'SUPER'private";
        is(__PACKAGE__->$fqname, $want, '__PACKAGE__->$fqname ('.__LINE__.')');
        is($self->$fqname, $want, '$self->$fqname ('.__LINE__.')');

        $fqname = "MyTest'Child::SUPER::private";
        is(__PACKAGE__->$fqname, $want, '__PACKAGE__->$fqname ('.__LINE__.')');
        is($self->$fqname, $want, '$self->$fqname ('.__LINE__.')');

        $fqname = "MyTest'Child::SUPER'private";
        is(__PACKAGE__->$fqname, $want, '__PACKAGE__->$fqname ('.__LINE__.')');
        is($self->$fqname, $want, '$self->$fqname ('.__LINE__.')');

        $fqname = "MyTest'Child'SUPER::private";
        is(__PACKAGE__->$fqname, $want, '__PACKAGE__->$fqname ('.__LINE__.')');
        is($self->$fqname, $want, '$self->$fqname ('.__LINE__.')');

        $fqname = "MyTest'Child'SUPER'private";
        is(__PACKAGE__->$fqname, $want, '__PACKAGE__->$fqname ('.__LINE__.')');
        is($self->$fqname, $want, '$self->$fqname ('.__LINE__.')');
    }
}