[Bioperl-l] interface checking code

[Matthew Pocock]

This is a multi-part message in MIME format.
--------------000807060907020308080201
Content-Type: text/plain; charset=us-ascii; format=flowed
Content-Transfer-Encoding: 7bit

Hi,

I've knocked up a proof-of-concept module for checking if interfaces are 
implemented fully by packages. The skeleton code can be munged arround 
to check all sorts of usefull properties, and could be augmented with 
abstract method lists, warnings when methods are defined by more than 
one implementation class and so on.

It uses the *{$packageName . ::} tricks to get package symbol tables 
back, and $glob{TERM} magic (e.g. $glob{CODE} to access the code slot) 
to actualy check for things. It's un-podded, but there's demo script 
with some comments.

I would envisage this being used in the .t files to make sure that a 
concrete class is just that e.g. test 1 would be a call to:

Interface->is_not_abstract($package_to_test)

and if this returns true, fail (fataly probably). It's probably not 
worth putting this test in modules directly (e.g. in an INIT block) 
untill/unless modules are stable, or some debug flag is available to 
control this.

If you think we should be able to check a different sort of inheritance 
or implementation property, I'm all ears, and can probably come up with 
some code that does something close.

Have fun with this - it's realy not that magical.

Matthew
-- 
BioJava Consulting LTD - Support and training for BioJava
http://www.biojava.co.uk

--------------000807060907020308080201
Content-Type: text/plain;
 name="Interface.t"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
 filename="Interface.t"

package FooI;

sub meth_1 {};
sub meth_2 {};

package Bar;

@ISA = ("FooI");

sub meth_1 {};
sub meth_2 {}


package Baz;

@ISA = ("FooI");
sub meth_1{};

package main;

use Interface;
use LWP;
use CGI;

print "Checking for exact interface implementation\n";
Interface->implements_exactly("Bar", "FooI");
Interface->implements_exactly("Baz", "FooI");

print "Checking for over-ride exact interface implementation\n";
Interface->over_rides_exactly("Bar", "FooI");
Interface->over_rides_exactly("Baz", "FooI");

print "Checking for abstract methods\n";
Interface->is_not_abstract("Bar");
Interface->is_not_abstract("Baz");

--------------000807060907020308080201
Content-Type: text/plain;
 name="Interface.pm"
Content-Transfer-Encoding: 7bit
Content-Disposition: inline;
 filename="Interface.pm"

package Interface;

use strict;

sub implements_exactly {
  my ($self, $package, $interface) = @_;
  
  my %abstract = $self->_find_methods($interface);
  my %concrete = $self->_find_methods($package);
  
  my @missing_methods = $self->_find_all_missing(\%abstract, \%concrete);
  if(@missing_methods) {
    print "Methods missing from $package defined in $interface:\n";
    foreach my $meth (@missing_methods) {
      print "\t$meth\n";
    }
    
    return 0;
  }
  
  return 1;
}

sub over_rides_exactly {
  my ($self, $package, $interface) = @_;
  
  my %abstract = $self->_find_methods($interface);
  my %concrete = $self->_find_methods($package);
  
  my @missing_methods = $self->_find_all_not_implemented(\%abstract, \%concrete);
  if(@missing_methods) {
    print "Methods missing from $package defined in $interface:\n";
    foreach my $meth (@missing_methods) {
      print "\t$meth\n";
    }
    
    return 0;
  }
  
  return 1;
}

sub is_not_abstract {
  my ($self, $package) = @_;
  
  my %abstract = $self->_find_all_methods($package, "I\$");
  my %concrete = $self->_find_all_methods($package);
  
  my @missing_methods = $self->_find_all_not_implemented(\%abstract, \%concrete);
  if(@missing_methods) {
    print "Methods not implemented:\n";
    foreach my $meth (@missing_methods) {
      print "\t$meth\n";
    }
    
    return 0;
  }
  
  return 1;
}

sub _find_methods {
  my ($self, $interface) = @_;
  my %methods = ();
  
  my %symTab;
  {
    no strict "refs";
    %symTab = %{$interface . "::"};
  }
  
  foreach my $sym (keys(%symTab)) {
    my $val = $symTab{$sym};
    my $code = *{$val}{CODE};
    if(defined $code) {
      $methods{$sym} = $val;
    }
  }
  
  return %methods
}

sub _find_all_methods {
  my ($self, $package, $pattern) = @_;
  
  my %methods;
  if(!defined($pattern) || $package =~ m/$pattern/) { 
    %methods = $self->_find_methods($package);
  } else {
    %methods = ();
  }
  
  my $isa = ();
  {
    no strict "refs";
    my $sym_tab = *{$package . "::"};
    my $sym = $sym_tab->{ISA};
    if(defined $sym) {
      $isa = *{$sym}{ARRAY};
    }
  }
  
  foreach my $sup (@$isa) {
    my %sup_meth = $self->_find_all_methods($sup, $pattern);
    my ($meth, $sub);
    while(($meth, $sub) = each %sup_meth) {
      if(!exists($methods{$meth})) {
        $methods{$meth} = $sub;
      }
    }
  }
  
  return %methods;
}

sub _find_all_missing {
  my ($self, $interface, $concrete) = @_;
  my @missing = grep { !$concrete->{$_} } keys(%$interface);
  
  return @missing
}

sub _find_all_not_implemented {
  my ($self, $interface, $concrete) = @_;
  my @missing = grep { !(exists($concrete->{$_})
                        && exists($interface->{$_})
                        && ($concrete->{$_} ne $interface->{$_}) )}
                      keys(%$interface);
  
  return @missing
}

1;

--------------000807060907020308080201--