File Coverage

blib/lib/Class/Interfaces.pm

Criterion	Covered	Total	%
statement	51	51	100.0
branch	26	26	100.0
condition	1	2	50.0
subroutine	8	8	100.0
pod			n/a
total	86	87	98.8

package Class::Interfaces;

use strict;
use warnings;

our $VERSION = '0.04';

sub import {
    my $class = shift;
    my %interfaces = @_;
    foreach my $interface (keys %interfaces) {
        # build the interface
        my (@methods, @subclasses);
        if (ref($interfaces{$interface}) eq 'HASH') {
            my $interface_spec = $interfaces{$interface};
            # if we have an isa
            if (exists ${$interface_spec}{isa}) {
                # if is an array (multiple inheritance)
                if (ref($interface_spec->{isa}) eq 'ARRAY') {
                    @subclasses = @{$interface_spec->{isa}};
                }
                else {
                    # if its another kind of ref, its an error
                    (!ref($interface_spec->{isa}))
                        || $class->_error_handler("Interface ($interface) isa list must be an array reference");
                    # otherwise its just a single item
                    @subclasses = $interface_spec->{isa};
                }
            }
            if (exists ${$interface_spec}{methods}) {
                (ref($interface_spec->{methods}) eq 'ARRAY')
                    || $class->_error_handler("Method list for Interface ($interface) must be an array reference");
                @methods = @{$interface_spec->{methods}};
            }
        }
        elsif (ref($interfaces{$interface}) eq 'ARRAY') {
            @methods = @{$interfaces{$interface}};
        }
        elsif (!defined($interfaces{$interface})) {
            # allow undefined here, this indicates an empty
            # interface, sometimes called a marker interface
            ;
        }
        else {
            $class->_error_handler("Cannot use a " . $interfaces{$interface} . " to build an interface");
        }
        # now create the interfaces
        my $package = $class->_build_interface_package($interface, @subclasses);
        eval $package;
        $class->_error_handler("Could not create Interface ($interface) because", $@) if $@;
        eval {
            my $method_stub = $class->can('_method_stub');
            no strict 'refs';
            # without at least this VERSION declaration
            # a Marker interface will not work with
            # 'use base' basically it would complain
            # that the package is empty.
            # we only assign this if the VERSION is already
            # empty too, so we don't step on any customizations
            # done in subclasses.
            ${"${interface}::"}{VERSION} ||= -1;
            # now we create all our methods :)
            foreach my $method (@methods) {
                ($method !~ /^(BEGIN|INIT|CHECK|END|DESTORY|AUTOLOAD|import|bootstrap)$/)
                    || $class->_error_handler("Cannot create an interface using reserved perl methods");
                *{"${interface}::${method}"} = $method_stub;
            }
        };
        $class->_error_handler("Could not create sub methods for Interface ($interface) because", $@) if $@;
    }
}

sub _build_interface_package {
    my ($class, $interface, @subclasses) = @_;
    my $package = "package $interface;";
    $package .= "\@${interface}::ISA = qw(" . (join " " => @subclasses) . ");" if @subclasses;
    return $package;
}

sub _error_handler {
    my ($class, $message, $sub_exception) = @_;
    die "$message : $sub_exception" if $sub_exception;
    die "$message";
}

sub _method_stub { die "Method Not Implemented" }

1;

__END__