{ package MyBase; sub is { my $self = shift; my ($type) = @_; my $method = 'is_' . $type; if (my $code = $self->can($method)) { return $self->$code; } return 0; } } { package Foo; use base MyBase::; sub is_foo { 1 } } { package Bar; use base MyBase::; sub is_bar { 1 } } { package FooAndBar; # Faker! use base MyBase::; sub is_foo { 1 } sub is_bar { 1 } } printf "%-9s %s %s\n", $_, $_->is('foo'), $_->is('bar') for Foo::, Bar::, FooAndBar::; __END__ Foo 1 0 Bar 0 1 FooAndBar 1 1 #### package MyBase; use strict; use Symbol 'qualify_to_ref'; sub import { my $class = shift; if (@_) { if ($_[0] eq '-base') { my (undef, %p) = @_; my $type = $p{is} or die '...'; my $pkg = caller; _setup_inheritance($class => ($pkg, $type)); } else { die '...'; } } } sub _setup_inheritance { my ($class) = shift; my ($pkg, $type) = @_; $type !~ /\W/ or die '...'; my $method = 'is_' . $type; { my $gref = qualify_to_ref($method); *$gref = sub { 0 } unless defined &$gref; } { my $gref = qualify_to_ref($method => $pkg); *$gref = sub { 1 }; } push @{*{qualify_to_ref(ISA => $pkg)}}, $class; return; } 1; #### { package Foo; use MyBase -base, is => 'foo'; } { package Bar; use MyBase -base, is => 'bar'; } printf "%-9s %s %s\n", $_, $_->is_foo, $_->is_bar for Foo::, Bar::; __END__ Foo 1 0 Bar 0 1