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/perl

use perl5i::latest;

use Test::More;

{
    package My::Child;

    our @ISA = qw(My::Parent);

    sub child1 {}
    sub child2 {}
    sub parent1 {}  # don't count this twice
}

{
    package My::Parent;

    sub parent1 {}
    sub parent2 {}
}

note "methods of a class with no parent"; {
    my $class = "My::Parent";

    my $want = [qw(parent1 parent2)];

    is_deeply
      scalar $class->mc->methods->sort,
      scalar $want->sort,
      "methods on a simple class";

    my $obj = bless {}, "My::Parent"; 

    is_deeply
      scalar $obj->mo->methods->sort,
      scalar $want->sort,
      "methods on a simple object";
}


note "methods of a class on a child"; {
    my $class = "My::Child";

    my $want = [qw(child1 child2 parent1 parent2)];

    is_deeply
      scalar $class->mc->methods->sort,
      scalar $want->sort,
      "inherited methods on a class";

    my $obj = bless {}, "My::Child";

    is_deeply
      scalar $obj->mo->methods->sort,
      scalar $want->sort,
      "inherited method on a class";
}


note "just_mine => 1"; {
    my $child = bless {}, "My::Child";
    my $methods = $child->mo->methods({
        just_mine => 1
    });

    is_deeply
      scalar $methods->sort,
      [sort qw(child1 child2 parent1)],
      "just_mine does not show inherited methods";
}


note "with_UNIVERSAL => 1"; {
    my $child = bless {}, "My::Child";
    my %methods = $child->mo->methods({
        with_UNIVERSAL  => 1
    })->map(sub { $_ => 1 });

    my $want = [qw(child1 child2 parent1 isa can VERSION mc mo)];
    for my $method (@$want) {
        ok $methods{$method}, "My::Child->$method";
    }
}


note "UNIVERSAL still works"; {
    # We're not sure what's going to be in UNIVERSAL
    # but we know what should be there at minimum

    my %methods = UNIVERSAL->mc->methods->map(sub { $_ => 1});

    my @min_want = qw(can isa VERSION mc mo);
    for my $method (@min_want) {
        ok $methods{$method}, "UNIVERSAL->$method";
    }
}


# Fcntl has scalar refs in its symbol table probably due to some XS wackiness
SKIP: {
    note "Weird things in the symbol table";
    skip "Need Fcntl", 1 unless eval { "Fcntl"->require };

    my @methods = Fcntl->mc->methods({ just_mine => 1 });
    can_ok "Fcntl", @methods;
}

{
    package My::MixedDefs;
    use perl5i::latest;

    sub    as_sub    {}
    func   as_func   {}
    method as_method {}
}
{
    package My::MixedDefs::Child;
    our @ISA = qw(My::MixedDefs);
    use perl5i::latest;

    sub    as_sub2    {}
    func   as_func2   {}
    method as_method2 {}
}


note "func gets filtered out of methods list"; {
    my( @methods, @expected, @not_expected );

    my $class = "My::MixedDefs";

    @methods      = $class->mc->methods;
    @expected     = qw( as_method as_sub );
    @not_expected = qw( as_func inexistant );
    is_deeply
      scalar @methods->intersect( [ @expected, @not_expected ] )->sort,
      scalar @expected->sort,
      'on a class';

    my $obj = bless {}, $class;

    @methods      = $obj->mo->methods;
    @expected     = qw( as_method as_sub );
    @not_expected = qw( as_func inexistant );
    is_deeply
      scalar @methods->intersect( [ @expected, @not_expected ] )->sort,
      scalar @expected->sort,
      'on an object';

    $class = "My::MixedDefs::Child";

    @methods      = $class->mc->methods;
    @expected     = qw( as_method as_sub as_method2 as_sub2 );
    @not_expected = qw( as_func as_func2 inexistant );
    is_deeply
      scalar @methods->intersect( [ @expected, @not_expected ] )->sort,
      scalar @expected->sort,
      'on a child class';

    $obj = bless {}, $class;

    @methods      = $obj->mo->methods;
    @expected     = qw( as_method as_sub as_method2 as_sub2 );
    @not_expected = qw( as_func as_func2 inexistant );
    is_deeply
      scalar @methods->intersect( [ @expected, @not_expected ] )->sort,
      scalar @expected->sort,
      'on a child object';

    can_ok( $class, 'as_func'); # sanity check
}

done_testing;