use v5.20.0;
use strict;
use warnings;
no warnings 'once';

use B;
use Scalar::Util;
use FindBin '$Bin';

use lib "$Bin/lib";
use lib "$Bin/../lib";
use lib '/home/tai/src/p5/p5-lexical-accessor/lib';

eval 'require Local::Example::Core;   1' or warn $@;
eval 'require Local::Example::Plain;  1' or warn $@;
eval 'require Local::Example::Marlin; 1' or warn $@;
eval 'require Local::Example::Moo;    1' or warn $@;
eval 'require Local::Example::Moose;  1' or warn $@;
eval 'require Local::Example::Mouse;  1' or warn $@;
eval 'require Local::Example::Tiny;   1' or warn $@;

sub is_xs {
	my $sub = $_[0];
	if ( Scalar::Util::blessed($sub) and $sub->isa( "Class::MOP::Method" ) ) {
		$sub = $sub->body;
	}
	elsif ( not ref $sub ) {
		no strict "refs";
		if ( not exists &{$sub} ) {
			my ( $pkg, $method ) = ( $sub =~ /\A(.+)::([^:]+)\z/ );
			if ( my $found = $pkg->can($method) ) {
				return lc(is_xs($found));
			}
			return "--";
		}
		$sub = \&{$sub};
	}
	require B;
	B::svref_2object( $sub )->XSUB ? 'XS' : 'PP';
}

my $current_class;

sub show_class {
	$current_class = shift;
	print "[ $current_class ]\n";
}

sub show_method {
	my $m = shift;
	printf(
		"%-15s %-7s %-7s %-7s %-7s %-7s %-7s %-7s\n",
		$m,
		map {
			is_xs("Local::Example::$_\::$current_class\::$m")
		} qw( Moo Moose Mouse Tiny Core Plain Marlin ),
	);
}

sub show_methods {
	show_method $_ for @_;
}

print "=" x 74, "\n";
printf "%-15s %-7s %-7s %-7s %-7s %-7s %-7s %-7s\n", qw( Method Moo Moose Mouse Tiny Core Plain Marlin );
print "=" x 74, "\n";
show_class('NamedThing');           show_methods qw/ new name BUILDALL DEMOLISHALL DESTROY /;
show_class('Person');               show_methods qw/ new name age has_age introduction BUILDALL DEMOLISHALL DESTROY /;
show_class('Employee');             show_methods qw/ new name age has_age employee_id introduction BUILDALL DEMOLISHALL DESTROY /;
show_class('Employee::Developer');  show_methods qw/ new name age has_age employee_id introduction get_languages all_languages add_language BUILDALL DEMOLISHALL DESTROY /;
print "=" x 74, "\n";
print "Key: XS = XSUB, PP = Pure Perl, lowercase = via inheritance.\n";
print "=" x 74, "\n";

__END__
==========================================================================
Method          Moo     Moose   Mouse   Tiny    Core    Plain   Marlin 
==========================================================================
[ NamedThing ]
new             PP      PP      XS      pp      XS      PP      XS     
name            XS      PP      XS      PP      PP      PP      XS     
BUILDALL        pp      pp      xs      pp      --      --      XS     
DEMOLISHALL     pp      pp      xs      --      --      --      --     
DESTROY         --      PP      XS      pp      --      --      --     
[ Person ]
new             PP      PP      XS      pp      XS      PP      XS     
name            xs      pp      xs      pp      pp      pp      XS     
age             XS      PP      XS      PP      PP      PP      XS     
has_age         XS      PP      XS      PP      PP      PP      XS     
introduction    PP      PP      PP      PP      PP      PP      PP     
BUILDALL        pp      pp      xs      pp      --      --      XS     
DEMOLISHALL     pp      pp      xs      --      --      --      --     
DESTROY         --      PP      XS      pp      --      --      --     
[ Employee ]
new             PP      PP      XS      pp      XS      PP      XS     
name            xs      pp      xs      pp      pp      pp      XS     
age             xs      pp      xs      pp      pp      pp      XS     
has_age         xs      pp      xs      pp      pp      pp      XS     
employee_id     XS      PP      XS      PP      PP      PP      XS     
introduction    pp      pp      pp      pp      pp      pp      PP     
BUILDALL        pp      pp      xs      pp      --      --      XS     
DEMOLISHALL     pp      pp      xs      --      --      --      --     
DESTROY         --      PP      XS      pp      --      --      --     
[ Employee::Developer ]
new             PP      PP      XS      pp      XS      PP      XS     
name            xs      pp      xs      pp      pp      pp      XS     
age             xs      pp      xs      pp      pp      pp      XS     
has_age         xs      pp      xs      pp      pp      pp      XS     
employee_id     xs      pp      xs      pp      pp      pp      XS     
introduction    PP      PP      PP      PP      PP      PP      PP     
get_languages   PP      PP      XS      PP      PP      PP      XS     
all_languages   PP      PP      PP      PP      PP      PP      PP     
add_language    PP      PP      PP      PP      PP      PP      PP     
BUILDALL        pp      pp      xs      pp      --      --      XS     
DEMOLISHALL     pp      pp      xs      --      --      --      --     
DESTROY         --      PP      XS      pp      --      --      --     
==========================================================================
Key: XS = XSUB, PP = Pure Perl, lowercase = via inheritance.
==========================================================================