view release on metacpan or  search on metacpan

lib/Class/Interface.pm  view on Meta::CPAN

  };

  # 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");
    };
  }
}

=pod

=head2 &implements()

Loads the given interfaces and checks the calling class for presence
of the wanted routines.

If all goes well pushes the name of the interface to the ISA array of
the class.

=cut
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" }, @_;
}

=pod

=head2 &extends()

Loads the given abstract class and checks the calling class for presence
of the abstract routines.

If all goes well pushes the name of the abstract class to the ISA
array of the class.

=cut
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" }, @_;
}