File Coverage

blib/lib/interface.pm

Criterion	Covered	Total	%
statement	8	29	27.5
branch	0	12	0.0
condition	0	3	0.0
subroutine	3	3	100.0
pod			n/a
total	11	47	23.4

package interface;

#
# given the name of package that specifies an interface, verify that we do
# indeed implement everything required by that interface.
#

use 5.006;

# we just aren't the kind of module you'd bring home to meet the parents

# use strict;
# use warnings;

our $VERSION = '0.03';

# per-package locks to avoid reentry when we make them finish loading

my @checkqueue;

sub import {

  my $callerpackage = caller;

  shift; my @interfaces = @_;

  foreach my $i (@interfaces) {

    push @checkqueue, [$callerpackage, $i];

  }

}


sub CHECK {

  for my $thingie (@checkqueue) {

    my $callerpackage = $thingie->[0];
    my $implements = $thingie->[1];

    my $gripes;
    my $newgripes;

    do {
      eval "package $callerpackage; use $implements;";
      die "$callerpackage: interface $implements could not be loaded: $@" if($@);
    };

    foreach my $i (grep { defined &{$implements.'::'.$_} } keys %{$implements.'::'}) {

      # since they implement all required methods, nothing in $i will ever be called.
      # however, we need this so that $callerpackage->isa($i) is true.

      # warn "can: implements: $implements method: $i callerpackage: $callerpackage result: " . $callerpackage->can($i);

      # unless(defined &{$callerpackage.'::'.$i}) {
      unless(UNIVERSAL::can($callerpackage, $i)) {
        $gripes .= ', ' if $gripes;
        $gripes .= "$i from $implements";
      }

      $gripes .= ", and " if $gripes and $newgripes;
      $gripes .= $newgripes if $newgripes;
      $newgripes = undef;

    }

    if($gripes) {

      die "$callerpackage is missing methods: $gripes";

    }

    push @{$callerpackage.'::ISA'}, $implements;

  }

}

1;

__END__