Class::Interface - A class for implementing/extending interfaces/abstracts in Perl.

  package Bouncable;

  use Class::Interface;
  &interface;   # this actually declares the interface

  sub bounce;
  sub getBounceBack;

  1;

  package Ball;

  use Class::Interface;
  &implements( 'Bouncable' );

  sub bounce {
    my $self = shift;
    print "The ball is bouncing @ ".$self->getBounceBack." strength"
  }

  sub getBounceBack {
    return 10;
  }

  1;

  package AbstractInterestCalculator;

  use Class::Interface;
  &abstract;   # this actually declares this class to be abstract;

  use Class::AccessorMaker {
    interest => 5.1,
    maxInterestValue => 0,
  }

  # a hook for doing calculations
  sub calculate {
    my ( $self, $value ) = @_;

    $self->prepare();
    $value += $self->getInterestValue( $value );

    return $value;
  }

  sub prepare;          # prepare calculations
  sub getInterstValue;  # get the interest value

  1;

  package LowInterestCalculator;

  use Class::Interface;
  &extends( 'AbstractInterestCalculator' );

  sub prepare {
    my ( $self ) = @_;
    $self->interest(1.3);

    # we don't give interest if the value of the account is or
    # exceeds $10.000
    $self->maxInterestValue(10000)
  }

  sub getInterstValue {
    my ( $self, $value ) = @_

    if ( $self->maxInterestValue &&
         $value >= $self->maxInterestValue ) {
      return 0;
    }

    $value *= $self->interest;

    return $value;
  }

  sub new {
    my $class = ref($_[0]) || $_[0]; shift;
    my $self  = bless({}, $class);

    my %value = @_;
    foreach my $field ( keys %value ) {
      $self->$field( $value{$field} ) if $self->can( $field )
    }

    return $self
  }

  my $object = Object->new( attribute1 => "value",
                            attribute2 => [ qw(a b c)],
                           );

  &extends('Runner');
  &implements('Runnable');

  &implements('Runnable');
  &extends('Runner');

package Class::Interface;

use strict;
no strict 'refs';

use base qw(Exporter);
@Class::Interface::EXPORT = qw(implements interface extends abstract);

use Carp;

# some default class vars
$Class::Interface::VERSION = "1.01";

# some class vars for changing behaviour
$Class::Interface::AUTO_CONSTRUCTOR = 0;
$Class::Interface::CONFESS = 0;

# define a contract
sub error(*);

sub interface() {
  my $caller = caller();

  return if !$caller || $caller eq "main";

  # interfaces should be usable.
  eval "use $caller";
  error $@ if $@;

  my @subs = inspectInterface($caller);

  error "Interface $caller does not provide any methods" if $#subs < 0;

  # first prevent usage of interfaces (but allow it from me).
  *{ $caller . "::import" } = sub {
    my $caller = caller();

    if ( $caller ne "Class::Interface" and $caller ne "main" ) {
      error "$caller is an interface. It can't be used";
    }
  };

  # tell any interface users this is an interface and return the
  # expected routines.
  *{ $caller . "::__get_interface_methods__" } = sub {
    return @subs;
  };
}

sub abstract() {
  my $caller = caller();

  return if !$caller || $caller eq "main";

  # interfaces should be usable.
  eval "use $caller";
  error $@ if $@;

  my @subs = inspectInterface( $caller, 1 );

  # abstract classes must have abstract methods
  error "Abstract interface $caller does not provide any methods" if $#subs < 0;

  # tell any abstract users this is an abstract and return the
  # expected routines.
  *{ $caller . "::__get_abstract_methods__" } = sub {
    return @subs;
  };

  # overwrite the abstract routines and make them die on invocation
  foreach my $sub (@subs) {
    *{ $caller . "::" . $sub } = sub {
      die("You are trying to invoke the abstract method $sub from $caller");
    };
  }
}

sub implements(@) {
  my $caller = caller;

  my %missing;
  foreach my $implements (@_) {
    eval "use $implements;";
    error
      "$caller tries to implement non existing interface $implements -- $@"
      if $@;

    unless ( defined ( &{ $implements . "::__get_interface_methods__" } ) ) {
      error "$caller tries to implement non-interface $implements"
    }

    # find the subs from the interface
    foreach my $sub ( &{ $implements . "::__get_interface_methods__" } ) {
      unless ( UNIVERSAL::can( $caller, $sub ) ) {
        $missing{$implements} = [] unless exists $missing{$implements};
        push @{ $missing{$implements} }, $sub;
      }
    }
  }

  if ( keys %missing ) {
    my $dieMessage = "";
    foreach my $interface ( keys %missing ) {
      foreach my $sub ( @{ $missing{$interface} } ) {
        $dieMessage .= ",\n" if $dieMessage;
        $dieMessage .= "$caller fails to implement $sub from $interface";
      }
    }

    error $dieMessage;
  }

  # make sure the import is not found through inheritance.
  unless ( defined &{ $caller . "::import" } ) {
    *{ $caller . "::import" } = sub {

      # don't cascade up to the interface.
      }
  }

  makeMagicConstructor($caller);

  push @{ $caller . "::ISA" }, @_;
}

sub extends(*) {
  my $caller = caller();

  my %missing;
  foreach my $extends (@_) {
    eval "use $extends;";
    error
      "$caller tries to implement non existing abstract class $extends -- $@"
      if $@;

    unless ( defined ( &{ $extends . "::__get_abstract_methods__" } ) ) {
      error "$caller tries to implement non-abstract $extends"
    }


    # find the subs from the interface
    foreach my $sub ( &{ $extends . "::__get_abstract_methods__" } ) {
      unless ( UNIVERSAL::can( $caller, $sub ) ) {
        $missing{$extends} = [] unless exists $missing{$extends};
        push @{ $missing{$extends} }, $sub;
      }
    }
  }

  if ( keys %missing ) {
    my $dieMessage = "";
    foreach my $abstract ( keys %missing ) {
      foreach my $sub ( @{ $missing{$abstract} } ) {
        $dieMessage .= ",\n" if $dieMessage;
        $dieMessage .=
          "$caller fails to implement $sub from abstract class $abstract";
      }
    }

    error $dieMessage;
  }

  makeMagicConstructor($caller);

  push @{ $caller . "::ISA" }, @_;
}

# private methods
#

# perform interface inspections
sub inspectInterface {
  my $interface  = shift;
  my $asAbstract = shift || 0;

  no warnings 'uninitialized';

  ( my $keyName = $interface ) =~ s/\:\:/\//g;
  $keyName .= ".pm";

  my $file = $INC{$keyName};
  open( local *IN, "<$file" );

  my @subs = ();
  my $usesInterfaces;
  my $callsInterface;
  while ( chomp( my $line = <IN> ) ) {
    # leave if the source file says so.
    last if $line eq "__END__";

    $usesInterfaces = 1 if $line =~ /^use Class::Interface/i;
    $callsInterface = 1 if $line =~ /^\&?interface\(?\)?/;
    $callsInterface = 1 if ( $asAbstract && $line =~ /^\&?abstract\(?\)?/ );

    if ( $line =~ /^sub/ ) {
      # strip of any comments
      unless ( ( my $commentChar = index($line, "#") ) < 0 ) {
        $line = substr($line, 0, $commentChar);
      }

      # trim trailing whitespace
      $line =~ s/\ +$//;

      my ($sub) = $line =~ /sub ([^\s]+)/;
      my $lineEnd = substr( $line, length($line) - 1 );

      if ( $lineEnd ne ";" and $lineEnd ne "}" ) {
        # if this is an abstract, implementations are OK
        next if $asAbstract;

        # ai. The sub has an implementation
        error
          "$interface is not a valid interface. $sub has an implementation";
      }

      # strip any funny chars from the routine name
      $sub =~ tr/\;\{\}//d;

      push @subs, $sub;
    }
  }

  if ( !$usesInterfaces ) {
    error("Interface $interface does not use the interface module.");
  }
  if ( !$callsInterface ) {
    error( ( $asAbstract ? "Abstract" : "Interface" ) . " $interface does not load the interface magic.");
  }

  return @subs;
}

# add a default constructor to the caller
sub makeMagicConstructor {
  return if !$Class::Interface::AUTO_CONSTRUCTOR;

  my $caller = shift;

  unless ( defined &{ $caller."::new" } ) {
    *{ $caller."::new"} = sub {
      my $class = ref($_[0]) || $_[0]; shift;
      my $self  = bless({}, $class);

      my %value = @_;
      foreach my $field ( keys %value ) {
        $self->$field( $value{$field} ) if $self->can( $field )
      }

      return $self
    };
  }
}

# die
sub error(*) {
  my $strings = join("", @_);

  if ( $Class::Interface::CONFESS == 1 ) {
    confess $strings;
  } else {
    croak $strings;
  }
}

1;