Class::Virtual - Base class for virtual base classes.

  package My::Virtual::Idaho;
  use base qw(Class::Virtual);

  __PACKAGE__->virtual_methods(qw(new foo bar this that));




  package My::Private::Idaho;
  use base qw(My::Virtual::Idaho);

  # Check to make sure My::Private::Idaho implemented everything
  my @missing = __PACKAGE__->missing_methods;
  die __PACKAGE__ . ' forgot to implement ' . join ', ', @missing 
      if @missing;

  # If My::Private::Idaho forgot to implement new(), the program will
  # halt and yell about that.
  my $idaho = My::Private::Idaho->new;

  # See what methods we're obligated to implement.
  my @must_implement = __PACKAGE__->virtual_methods;

package Class::Virtual;

use strict;
use vars qw($VERSION @ISA);
$VERSION = '0.06';

use Carp::Assert qw(DEBUG);  # import only the tiny bit we need so it doesn't
                             # get inherited.
use Class::ISA;

use Class::Data::Inheritable;
@ISA = qw(Class::Data::Inheritable);
__PACKAGE__->mk_classdata('__Virtual_Methods');

#"#
sub virtual_methods {
    my($class) = shift;

    if( @_ ) {
        if( defined $class->__Virtual_Methods ) {
            require Carp;
            Carp::croak("Attempt to reset virtual methods.");
        }
        $class->_mk_virtual_methods(@_);
    }
    else {
        return @{$class->__Virtual_Methods};
    }
}


sub _mk_virtual_methods {
    no strict 'refs';   # symbol table mucking!  Getcher goloshes on.

    my($this_class, @methods) = @_;

    $this_class->__Virtual_Methods(\@methods);

    # private method to return the virtual base class
    *{$this_class.'::__virtual_base_class'} = sub {
        return $this_class;
    };

    foreach my $meth (@methods) {
        # Make sure the method doesn't already exist.
        if( $this_class->can($meth) ) {
            require Carp;
            Carp::croak("$this_class attempted to declare $meth() virtual ".
                        "but it appears to already be implemented!");
        }

        # Create a virtual method.
        *{$this_class.'::'.$meth} = sub {
            my($self) = shift;
            my($class) = ref $self || $self;

            require Carp;

            if( $class eq $this_class) {
                my $caller = caller;
                Carp::croak("$caller called the virtual base class ".
                            "$this_class directly!  Use a subclass instead");
            }
            else {
                Carp::croak("$class forgot to implement $meth()");
            }
        };
    }
}

sub missing_methods {
    my($class) = shift;

    my @vmeths = $class->virtual_methods;
    my @super_classes = Class::ISA::self_and_super_path($class);
    my $vclass = $class->__virtual_base_class;

    # Remove everything in the hierarchy beyond, and including,
    # the virtual base class.  They don't concern us.
    my $sclass;
    do {
        $sclass = pop @super_classes;
        Carp::Assert::assert( defined $sclass ) if DEBUG;
    } until $sclass eq $vclass;

    my @missing = ();

    {
        no strict 'refs';
        METHOD: foreach my $meth (@vmeths) {
            CLASS: foreach my $class (@super_classes) {
                next METHOD if defined &{$class.'::'.$meth};
            }

            push @missing, $meth;
        }
    }

    return @missing;
}

return "Club sandwich";