#!/usr/bin/perl
# $Id$
# $Author$
# $HeadURL$
# $Date$
# $Revision$
use warnings;
use strict;
{

    package OOP::Perlish::Class::Abstract;
    use warnings;
    use strict;
    use OOP::Perlish::Class;
    use base qw(OOP::Perlish::Class);
    use Carp qw(confess);
    use Data::Dumper;

    our $VERSION = 1.0;

    ############################################################################################
    ## Do a sanity check for required interfaces in pre-validation
    ############################################################################################
    sub ____pre_validate_opts
    {
        my ($self) = @_;
        my $class = ref($self);

        my %required_interfaces;

        for my $parent_class ( $self->_all_isa() ) {
            if( bless( {}, $parent_class )->can('____OOP_PERLISH_CLASS_REQUIRED_INTERFACES') ) {
                @required_interfaces{ @{ $parent_class->____OOP_PERLISH_CLASS_REQUIRED_INTERFACES() } } = undef;
            }
        }

        my %defined_interfaces;

        for my $parent_class ( $self->_all_isa() ) {
            next if( exists( $self->____OOP_PERLISH_CLASS_ABSTRACT_CLASSES()->{$parent_class} ) );
            for my $name ( keys %required_interfaces ) {
                no strict 'refs';
                $defined_interfaces{$name} = undef if( defined( *{ '::' . $class . '::' . $name }{CODE} ) );
                use strict;
            }
        }

        if( scalar keys %required_interfaces != scalar keys %defined_interfaces ) {
            confess(   'Failed to define required interfaces: '
                     . join( ', ', grep { !exists( $defined_interfaces{$_} ) } keys %required_interfaces ) . 'in '
                     . $class );
        }

        return $self->SUPER::____pre_validate_opts();
    }

    ############################################################################################
    ## set interfaces, usually called like 'BEGIN { __PACKAGE__->_interfaces(...) }' as the
    ## first section of a derived class.
    ############################################################################################
    sub _interfaces(@)
    {
        my ( $self, %interfaces ) = @_;
        my $class = ref($self) || $self;

        $self->____OOP_PERLISH_CLASS_ABSTRACT_CLASSES()->{$class} = 1;

        for my $name ( keys %interfaces ) {
            my $type = $interfaces{$name};

            ### Symbol table manipulation; creates a method named for the $name in the package's namespace
            ### The actual method is created via closure in ____oop_perlish_class_interface_factory();
            no strict 'refs';
            *{ '::' . $class . '::' . $name } = $self->____oop_perlish_class_interface_factory( $name, $type );
            use strict;
        }

        return;
    }

    ############################################################################################
    ## return a static reference to an array of required fields for this class; must work for
    ## all derived classes
    ############################################################################################
    sub ____OOP_PERLISH_CLASS_REQUIRED_INTERFACES(@)
    {
        my ($self) = @_;
        my $class = ref($self) || $self;
        our $____OOP_PERLISH_CLASS_REQUIRED_INTERFACES;

        $____OOP_PERLISH_CLASS_REQUIRED_INTERFACES = {} unless( defined($____OOP_PERLISH_CLASS_REQUIRED_INTERFACES) );
        $____OOP_PERLISH_CLASS_REQUIRED_INTERFACES->{$class} = [] unless( exists( $____OOP_PERLISH_CLASS_REQUIRED_INTERFACES->{$class} ) );

        return $____OOP_PERLISH_CLASS_REQUIRED_INTERFACES->{$class};
    }

    ############################################################################################
    ## Place to store a registry of all abstract classes;
    ############################################################################################
    sub ____OOP_PERLISH_CLASS_ABSTRACT_CLASSES(@)
    {
        my ($self) = @_;
        our $____OOP_PERLISH_CLASS_ABSTRACT_CLASSES;

        $____OOP_PERLISH_CLASS_ABSTRACT_CLASSES = {} unless( defined($____OOP_PERLISH_CLASS_ABSTRACT_CLASSES) );

        return $____OOP_PERLISH_CLASS_ABSTRACT_CLASSES;
    }

    ############################################################################################
    ## Return a subroutine for the required interfaces
    ############################################################################################
    sub ____oop_perlish_class_interface_impl_required
    {
        my ( $self, $name ) = @_;
        my $class = ref($self) || $self;

        push( @{ $class->____OOP_PERLISH_CLASS_REQUIRED_INTERFACES() }, $name );

        return sub { confess("Interface $name is required, but was not defined"); };
    }

    ############################################################################################
    ## Return a subroutine for the optional (false) interfaces
    ############################################################################################
    sub ____oop_perlish_class_interface_impl_optional
    {
        my ( $self, $name ) = @_;
        return sub { return; };
    }

    ############################################################################################
    ## Return a subroutine for optional_true interfaces
    ############################################################################################
    sub ____oop_perlish_class_interface_impl_optional_true
    {
        my ( $self, $name ) = @_;
        return sub { return 1; };
    }

    ############################################################################################
    ## Return a subroutine for the given type
    ############################################################################################
    sub ____oop_perlish_class_interface_factory
    {
        my ( $self, $name, $type ) = @_;

        my $method = '____oop_perlish_class_interface_impl_' . lc($type);
        confess('Invalid type of interface specification') unless( $self->can($method) );
        return $self->$method($name);
    }
}
1;
__END__

=head1 NAME

OOP::Perlish::Class::Abstract

=head1 DESCRIPTION

Quickly and easily create abstract classes, which can easily be tested for via 'isa' or OOP::Perlish::Class::Accessor->implements( [ 'ClassA', 'ClassB' ] ); ('implements' is a polymorphism test, not an inheritance test, and is generally preferred)

=head1 SYNOPSIS

=over

=item Defining an abstract class

 package MyAbstractClass;
 use base qw(OOP::Perlish::Class::Abstract);

 BEGIN { 
    __PACKAGE__->_interfaces( 
        my_interface => 'required',
        my_optional_interface => 'optional',
        my_optional_but_true => 'optional_true',
    );
 };

=item Later in an implementation class:

 package MyImplementationClass;
 use base qw(MyAbstractClass);

 sub my_interface
 {
    my ($self) = @_;

    return 'foo';
 }

=item Meanwhile, in a consuming class

 package MyConsumerClass;
 use base qw(OOP::Perlish::Class);

 BEGIN {
    __PACKAGE__->_accessors(
        foo => {
            type => 'OBJECT',
            implements => [ 'MyAbstractClass' ],
        },
    );
 };

 sub quux
 {
    my ($self) = @_;

    return $self->foo()->my_interface();
 }

=item And finally, when used:

 my $foo = MyImplementationClass->new();
 my $bar = MyConsumerClass->new( foo => $foo );

 print $bar->quux() . $/;

=back

=head1 USAGE

The module provides handlers for 'required', 'optional', and 'optional_true' types of interface definitions via the following
built-in method factories:

 ############################################################################################
 ## Return a subroutine for the required interfaces
 ############################################################################################
 sub ____oop_perlish_class_interface_impl_required
 {
     my ( $self, $name ) = @_;
     my $class = ref($self) || $self;

     $self->____OOP_PERLISH_CLASS_REQUIRED_INTERFACES()->{$name} = 1;

     return sub { confess("Interface $name is required, but was not defined in $class (nor in the ancestory of $class)"); };
 }

 ############################################################################################
 ## Return a subroutine for the optional (false) interfaces
 ############################################################################################
 sub ____oop_perlish_class_interface_impl_optional
 {
     my ( $self, $name ) = @_;
     return sub { return; };
 }

 ############################################################################################
 ## Return a subroutine for optional_true interfaces
 ############################################################################################
 sub ____oop_perlish_class_interface_impl_optional_true
 {
     my ( $self, $name ) = @_;
     return sub { return 1; };
 }

if you wish to add additional handlers for an abstract class; simply define a method with the type prefixed with C<____oop_perlish_class_interface_impl_>
e.g.: 

 sub ____oop_perlish_class_interface_impl_my_type
 {
    return sub { return 'default sub for my_type'; };
 }

Which would allow you to specify in the _interfaces() call 

 BEGIN { 
    __PACKAGE__->_interfaces( 
        my_interface => 'my_type',
    );
 };

This is mostly useful for specifying default interfaces that are expected to return references to (possibly empty) hashes or arrays.

=head1 DIAGNOSTICS

 invokes confess() whenever a method is called that was 'required' but never defined. 
 invokes confess() whenever a type is specified in __PACKAGE__->_interfaces() that does not have a handler defined.
 invokes confess() whenever an object is instantiated via new and is missing a required interface definition; 

=cut