File Coverage

blib/lib/Rose/Class/MakeMethods/Generic.pm

Criterion	Covered	Total	%
statement	374	411	91.0
branch	205	320	64.0
condition	71	124	57.2
subroutine	55	57	96.4
pod	6	6	100.0
total	711	918	77.4

package Rose::Class::MakeMethods::Generic;

use strict;

use Carp();

our $VERSION = '0.854';

use Rose::Object::MakeMethods;
our @ISA = qw(Rose::Object::MakeMethods);

our %Scalar;
# (
#   class_name =>
#   {
#     some_attr_name1 => ...,
#     some_attr_name2 => ...,
#     ...
#   },
#   ...
# );

sub scalar
{
  my($class, $name, $args, $options) = @_;

  my %methods;

  my $interface = $args->{'interface'} || 'get_set';

  if($interface eq 'get_set')
  {
    $methods{$name} = sub
    {
      return $Scalar{$_[0]}{$name} = $_[1]  if(@_ > 1);
      return $Scalar{$_[0]}{$name};
    };
  }
  elsif($interface eq 'get_set_init')
  {
    my $init_method = $args->{'init_method'} || "init_$name";

    $methods{$name} = sub
    {
      return $Scalar{$_[0]}{$name} = $_[1]  if(@_ > 1);
      return defined $Scalar{$_[0]}{$name} ?
        $Scalar{$_[0]}{$name} : ($Scalar{$_[0]}{$name} = $_[0]->$init_method())
    };
  }

  return \%methods;
}

our %Inheritable_Scalar;
# (
#   class_name =>
#   {
#     some_attr_name1 => ...,
#     some_attr_name2 => ...,
#     ...
#   },
#   ...
# );

sub inheritable_scalar
{
  my($class, $name, $args, $options) = @_;

  my %methods;

  my $interface = $args->{'interface'} || 'get_set';

  if($interface eq 'get_set')
  {
    $methods{$name} = sub
    {
      my($class) = ref($_[0]) ? ref(shift) : shift;

      if(@_)
      {
        return $Inheritable_Scalar{$class}{$name} = shift;
      }

      return $Inheritable_Scalar{$class}{$name}
        if(exists $Inheritable_Scalar{$class}{$name});

      my @parents = ($class);

      while(my $parent = shift(@parents))
      {
        no strict 'refs';
        foreach my $subclass (@{$parent . '::ISA'})
        {
          push(@parents, $subclass);

          if(exists $Inheritable_Scalar{$subclass}{$name})
          {
            return $Inheritable_Scalar{$subclass}{$name}
          }
        }
      }

      return undef;
    };
  }
  else { Carp::croak "Unknown interface: $interface" }

  return \%methods;
}

our %Inheritable_Boolean;

sub inheritable_boolean
{
  my($class, $name, $args, $options) = @_;

  my %methods;

  my $interface = $args->{'interface'} || 'get_set';

  if($interface eq 'get_set')
  {
    $methods{$name} = sub
    {
      my($class) = ref($_[0]) ? ref(shift) : shift;

      if(@_)
      {
        return $Inheritable_Boolean{$class}{$name} = $_[0] ? 1 : 0;
      }

      return $Inheritable_Boolean{$class}{$name}
        if(exists $Inheritable_Boolean{$class}{$name});

      my @parents = ($class);

      while(my $parent = shift(@parents))
      {
        no strict 'refs';
        foreach my $subclass (@{$parent . '::ISA'})
        {
          push(@parents, $subclass);

          if(exists $Inheritable_Boolean{$subclass}{$name})
          {
            return $Inheritable_Boolean{$subclass}{$name}
          }
        }
      }

      return undef;
    };
  }
  else { Carp::croak "Unknown interface: $interface" }

  return \%methods;
}

our %Hash;
# (
#   class_name =>
#   {
#     key =>
#     {
#       some_attr_name1 => ...,
#       some_attr_name2 => ...,
#       ...
#     },
#     ...
#   },
#   ...
# );

sub hash
{
  my($class, $name, $args) = @_;

  my %methods;

  my $key = $args->{'hash_key'} || $name;
  my $interface = $args->{'interface'} || 'get_set';

  if($interface eq 'get_set_all')
  {
    $methods{$name} = sub
    {
      my($class) = ref $_[0] ? ref shift : shift;

      # If called with no arguments, return hash contents
      return wantarray ? %{$Hash{$class}{$key} || {}} : $Hash{$class}{$key}  unless(@_);

      # Set hash to arguments
      if(@_ == 1 && ref $_[0] eq 'HASH')
      {
        $Hash{$class}{$key} = $_[0];
      }
      else
      {
        # Push on new values and return complete set
        Carp::croak "Odd number of items in assigment to $name"  if(@_ % 2);

        while(@_)
        {
          local $_ = shift;
          $Hash{$class}{$key}{$_} = shift;
        }
      }

      return wantarray ? %{$Hash{$class}{$key} || {}} : $Hash{$class}{$key};
    }
  }
  elsif($interface eq 'clear')
  {
    $methods{$name} = sub
    {
      $Hash{$_[0]}{$key} = {}
    }
  }
  elsif($interface eq 'reset')
  {
    $methods{$name} = sub
    {
      $Hash{$_[0]}{$key} = undef
    }
  }
  elsif($interface eq 'delete')
  {
    $methods{($interface eq 'manip' ? 'delete_' : '') . $name} = sub
    {
      Carp::croak "Missing key(s) to delete"  unless(@_ > 1);
      delete @{$Hash{$_[0]}{$key}}{@_[1 .. $#_]};
    }
  }
  elsif($interface eq 'exists')
  {
    $methods{$name . ($interface eq 'manip' ? '_exists' : '')} = sub
    {
      Carp::croak "Missing key argument"  unless(@_ == 2);
      defined $Hash{$_[0]}{$key} ? exists $Hash{$_[0]}{$key}{$_[1]} : undef;
    }
  }
  elsif($interface =~ /^(?:keys|names)$/)
  {
    $methods{$name} = sub
    {
      wantarray ? (defined $Hash{$_[0]}{$key} ? keys %{$Hash{$_[0]}{$key}} : ()) :
                  (defined $Hash{$_[0]}{$key} ? [ keys %{$Hash{$_[0]}{$key}} ] : []);
    }
  }
  elsif($interface eq 'values')
  {
    $methods{$name} = sub
    {
      wantarray ? (defined $Hash{$_[0]}{$key} ? values %{$Hash{$_[0]}{$key}} : ()) :
                  (defined $Hash{$_[0]}{$key} ? [ values %{$Hash{$_[0]}{$key}} ] : []);
    }
  }
  elsif($interface eq 'get_set')
  {
    $methods{$name} = sub
    {
      my($class) = ref $_[0] ? ref shift : shift;

      # If called with no arguments, return hash contents
      unless(@_)
      {
        return wantarray ? (defined $Hash{$class}{$key} ? %{$Hash{$class}{$key}} : ()) : $Hash{$class}{$key}
      }

      # If called with a hash ref, set value
      if(@_ == 1 && ref $_[0] eq 'HASH')
      {
        $Hash{$class}{$key} = $_[0];
      }
      else
      {
        # If called with an index, get that value, or a slice for array refs
        if(@_ == 1)
        {
          return ref $_[0] eq 'ARRAY' ? @{$Hash{$class}{$key}}{@{$_[0]}} :
                                        $Hash{$class}{$key}{$_[0]};
        }

        # Push on new values and return complete set
        Carp::croak "Odd number of items in assigment to $name"  if(@_ % 2);

        while(@_)
        {
          local $_ = shift;
          $Hash{$class}{$key}{$_} = shift;
        }
      }

      return wantarray ? %{$Hash{$class}{$key} || {}} : $Hash{$class}{$key};
    };
  }
  else { Carp::croak "Unknown interface: $interface" }

  return \%methods;
}
our %Inheritable_Hash;
# (
#   class_name =>
#   {
#     key =>
#     {
#       some_attr_name1 => ...,
#       some_attr_name2 => ...,
#       ...
#     },
#     ...
#   },
#   ...
# );

sub inheritable_hash
{
  my($class, $name, $args) = @_;

  my %methods;

  my $key = $args->{'hash_key'} || $name;
  my $interface = $args->{'interface'} || 'get_set';

  my $init_method = sub
  {
    my($class) = ref $_[0] ? ref shift : shift;

    # Inherit shallow copy from subclass
    my @parents = ($class);

    SEARCH: while(my $parent = shift(@parents))
    {
      no strict 'refs';
      foreach my $subclass (@{$parent . '::ISA'})
      {
        push(@parents, $subclass);

        if(exists $Inheritable_Hash{$subclass}{$key})
        {
          $Inheritable_Hash{$class}{$key} = { %{$Inheritable_Hash{$subclass}{$key}} };
          last SEARCH;
        }
      }
    }
  };

  if($interface eq 'get_set_all')
  {
    $methods{$name} = sub
    {
      my($class) = ref $_[0] ? ref shift : shift;

      defined $Inheritable_Hash{$class}{$key} || $init_method->($class);

      # If called with no arguments, return hash contents
      return wantarray ? %{$Inheritable_Hash{$class}{$key} || {}} : $Inheritable_Hash{$class}{$key}  unless(@_);

      # Set hash to arguments
      if(@_ == 1 && ref $_[0] eq 'HASH')
      {
        $Inheritable_Hash{$class}{$key} = $_[0];
      }
      else
      {
        # Push on new values and return complete set
        Carp::croak "Odd number of items in assigment to $name"  if(@_ % 2);

        while(@_)
        {
          local $_ = shift;
          $Inheritable_Hash{$class}{$key}{$_} = shift;
        }
      }

      return wantarray ? %{$Inheritable_Hash{$class}{$key} || {}} : $Inheritable_Hash{$class}{$key};
    }
  }
  elsif($interface eq 'clear')
  {
    $methods{$name} = sub
    {
      $Inheritable_Hash{$_[0]}{$key} = {}
    }
  }
  elsif($interface eq 'reset')
  {
    $methods{$name} = sub
    {
      $Inheritable_Hash{$_[0]}{$key} = undef;
    }
  }
  elsif($interface eq 'delete')
  {
    $methods{($interface eq 'manip' ? 'delete_' : '') . $name} = sub
    {
      Carp::croak "Missing key(s) to delete"  unless(@_ > 1);
      defined $Inheritable_Hash{$_[0]}{$key} || $init_method->($_[0]);
      delete @{$Inheritable_Hash{$_[0]}{$key}}{@_[1 .. $#_]};
    }
  }
  elsif($interface eq 'exists')
  {
    $methods{$name . ($interface eq 'manip' ? '_exists' : '')} = sub
    {
      Carp::croak "Missing key argument"  unless(@_ == 2);
      defined $Inheritable_Hash{$_[0]}{$key} || $init_method->($_[0]);
      defined $Inheritable_Hash{$_[0]}{$key} ? exists $Inheritable_Hash{$_[0]}{$key}{$_[1]} : undef;
    }
  }
  elsif($interface =~ /^(?:keys|names)$/)
  {
    $methods{$name} = sub
    {
      defined $Inheritable_Hash{$_[0]}{$key} || $init_method->($_[0]);
      wantarray ? (defined $Inheritable_Hash{$_[0]}{$key} ? keys %{$Inheritable_Hash{$_[0]}{$key} || {}} : ()) :
                  (defined $Inheritable_Hash{$_[0]}{$key} ? [ keys %{$Inheritable_Hash{$_[0]}{$key} || {}} ] : []);
    }
  }
  elsif($interface eq 'values')
  {
    $methods{$name} = sub
    {
      defined $Inheritable_Hash{$_[0]}{$key} || $init_method->($_[0]);
      wantarray ? (defined $Inheritable_Hash{$_[0]}{$key} ? values %{$Inheritable_Hash{$_[0]}{$key} || {}} : ()) :
                  (defined $Inheritable_Hash{$_[0]}{$key} ? [ values %{$Inheritable_Hash{$_[0]}{$key} || {}} ] : []);
    }
  }
  elsif($interface eq 'get_set')
  {
    $methods{$name} = sub
    {
      my($class) = ref $_[0] ? ref shift : shift;

      defined $Inheritable_Hash{$class}{$key} || $init_method->($class);

      # If called with no arguments, return hash contents
      unless(@_)
      {
        return wantarray ? (defined $Inheritable_Hash{$class}{$key} ? %{$Inheritable_Hash{$class}{$key} || {}} : ()) : $Inheritable_Hash{$class}{$key}
      }

      # If called with a hash ref, set value
      if(@_ == 1 && ref $_[0] eq 'HASH')
      {
        $Inheritable_Hash{$class}{$key} = $_[0];
      }
      else
      {
        # If called with an index, get that value, or a slice for array refs
        if(@_ == 1)
        {
          return ref $_[0] eq 'ARRAY' ? @{$Inheritable_Hash{$class}{$key}}{@{$_[0]}} :
                                        $Inheritable_Hash{$class}{$key}{$_[0]};
        }

        # Push on new values and return complete set
        Carp::croak "Odd number of items in assigment to $name"  if(@_ % 2);

        while(@_)
        {
          local $_ = shift;
          $Inheritable_Hash{$class}{$key}{$_} = shift;
        }
      }

      return wantarray ? %{$Inheritable_Hash{$class}{$key} || {}} : $Inheritable_Hash{$class}{$key};
    };
  }
  else { Carp::croak "Unknown interface: $interface" }

  return \%methods;
}

use constant CLASS_VALUE     => 1;
use constant INHERITED_VALUE => 2;
use constant DELETED_VALUE   => 3;

our %Inherited_Hash;
# (
#   some_name =>
#   {
#     class1 =>
#     {
#       meta  => { ... },
#       cache =>
#       {
#         meta =>
#         {
#           attr1 => CLASS_VALUE,
#           attr2 => DELETED_VALUE,
#           ...
#         },
#         attrs =>
#         {
#           attr1 => value1,
#           attr2 => value2,
#           ...
#         },
#       },
#     },
#     class2 => ...,
#     ...
#   },
#   ...
# );

# Used as array indexes to replace {'meta'}, {'attrs'}, and {'cache'}
use constant META  => 0;
use constant CACHE => 1;
use constant ATTRS => 1;

# XXX: This implementation is space-inefficient and pretty silly
sub inherited_hash
{
  my($class, $name, $args) = @_;

  my %methods;

  # Interface example:
  # name:               object_type_class
  # plural_name:        object_type_classes
  #
  # get_set:            object_type_class
  # get_set_all_method: object_type_classes
  # keys_method:        object_type_class_keys
  # cache_method:       object_type_classes_cache
  # exists_method:      object_type_class_exists
  # add_method:         add_object_type_class
  # adds_method:        add_object_type_classes
  # delete_method:      delete_object_type_class
  # deletes_method:     delete_object_type_classes
  # clear_method        clear_object_type_classes
  # inherit_method:     inherit_object_type_class
  # inherits_method:    inherit_object_type_classes

  my $plural_name = $args->{'plural_name'} || $name . 's';

  my $get_set_method     = $name;
  my $get_set_all_method = $args->{'get_set_all_method'} || $args->{'hash_method'} || $plural_name;
  my $keys_method        = $args->{'keys_method'}     || $name . '_keys';
  my $cache_method       = $args->{'cache_method'}    || $plural_name . '_cache';
  my $exists_method      = $args->{'exists_method'}   || $args->{'exists_method'} || $name . '_exists';
  my $add_method         = $args->{'add_method'}      || 'add_' . $name;
  my $adds_method        = $args->{'adds_method'}     || 'add_' . $plural_name;
  my $delete_method      = $args->{'delete_method'}   || 'delete_' . $name;
  my $deletes_method     = $args->{'deletes_method'}  || 'delete_' . $plural_name;
  my $clear_method       = $args->{'clear_method'}    || 'clear_' . $plural_name;
  my $inherit_method     = $args->{'inherit_method'}  || 'inherit_' . $name;
  my $inherits_method    = $args->{'inherits_method'} || 'inherit_' . $plural_name;

  my $interface       = $args->{'interface'} || 'all';

  my $add_implies     = $args->{'add_implies'};
  my $delete_implies  = $args->{'delete_implies'};
  my $inherit_implies = $args->{'inherit_implies'};

  $add_implies = [ $add_implies ]
    if(defined $add_implies && !ref $add_implies);

  $delete_implies = [ $delete_implies ]
    if(defined $delete_implies && !ref $delete_implies);

  $inherit_implies = [ $inherit_implies ]
    if(defined $inherit_implies && !ref $inherit_implies);

  $methods{$cache_method} = sub
  {
    my($class) = ref($_[0]) || $_[0];

    if($Inherited_Hash{$name}{$class}[META]{'cache_is_valid'})
    {
      return
        wantarray ? (%{$Inherited_Hash{$name}{$class}[CACHE] ||= []}) :
                    ($Inherited_Hash{$name}{$class}[CACHE] ||= []);
    }

    my $cache = $Inherited_Hash{$name}{$class}[CACHE] ||= [];

    my @parents = ($class);

    while(my $parent = shift(@parents))
    {
      no strict 'refs';
      foreach my $superclass (@{$parent . '::ISA'})
      {
        push(@parents, $superclass);

        if($superclass->can($cache_method))
        {
          my $supercache = $superclass->$cache_method();

          while(my($attr, $state) = each %{$supercache->[META] || {}})
          {
            next  if($state == DELETED_VALUE);

            no warnings 'uninitialized';
            unless(exists $cache->[ATTRS]{$attr})
            {
              $cache->[ATTRS]{$attr} = $supercache->[ATTRS]{$attr};
              $cache->[META]{$attr} = INHERITED_VALUE;
            }
          }
        }
        # Slower method for superclasses that don't want to implement the
        # cache method (which is not strictly part of the public API)
        elsif($superclass->can($keys_method))
        {
          foreach my $attr ($superclass->$keys_method())
          {
            unless(exists $Inherited_Hash{$name}{$class}[CACHE][ATTRS]{$attr})
            {
              $Inherited_Hash{$name}{$class}[CACHE][META]{$attr} = INHERITED_VALUE;
              $Inherited_Hash{$name}{$class}[CACHE][ATTRS]{$attr} =
                $Inherited_Hash{$name}{$superclass}[CACHE][ATTRS]{$attr};
            }
          }
        }
      }
    }

    $Inherited_Hash{$name}{$class}[META]{'cache_is_valid'} = 1;

    my $want = wantarray;

    return  unless(defined $want);
    $want ? (%{$Inherited_Hash{$name}{$class}[CACHE] ||= []}) :
            ($Inherited_Hash{$name}{$class}[CACHE] ||= []);
  };

  $methods{$get_set_method} = sub
  {
    my($class) = ref($_[0]) ? ref(shift) : shift;
    return 0  unless(defined $_[0]);

    my $key = shift;

    if(@_)
    {
      Carp::croak "More than one value passed to $get_set_method()"  if(@_ > 1);
      $class->$adds_method($key, @_);
    }
    else
    {
      if($Inherited_Hash{$name}{$class}[META]{'cache_is_valid'})
      {
        my $cache = $Inherited_Hash{$name}{$class}[CACHE] ||= [];

        no warnings 'uninitialized';
        return $cache->[ATTRS]{$key}  unless($cache->[META]{$key} == DELETED_VALUE);
        return undef;
      }

      my $cache = $class->$cache_method();

      no warnings 'uninitialized';
      return $cache->[ATTRS]{$key}  unless($cache->[META]{$key} == DELETED_VALUE);
      return undef;
    }
  };

  $methods{$keys_method} = sub
  {
    my($class) = shift;
    $class = ref $class  if(ref $class);
    return wantarray ? keys %{$class->$get_set_all_method()} :
                       [ keys %{$class->$get_set_all_method()} ];
  };

  $methods{$get_set_all_method} = sub
  {
    my($class) = shift;

    $class = ref $class  if(ref $class);

    if(@_)
    {
      $class->$clear_method();
      return $class->$adds_method(@_);
    }

    my $cache = $class->$cache_method();
    my %hash  = %{$cache->[ATTRS] || {}};

    foreach my $k (keys %hash)
    {
      delete $hash{$k}  if($Inherited_Hash{$name}{$class}[CACHE][META]{$k} == DELETED_VALUE);
    }

    return wantarray ? %hash : \%hash;
  };

  $methods{$exists_method} = sub
  {
    my($class) = ref($_[0]) ? ref(shift) : shift;

    my $key = shift;

    return 0  unless(defined $key);

    if($Inherited_Hash{$name}{$class}[META]{'cache_is_valid'})
    {
      my $cache = $Inherited_Hash{$name}{$class}[CACHE] ||= [];
      return (exists $cache->[ATTRS]{$key} && $cache->[META]{$key} != DELETED_VALUE) ? 1 : 0;
    }

    my $cache = $class->$cache_method();

    return (exists $cache->[ATTRS]{$key} && $cache->[META]{$key} != DELETED_VALUE) ? 1 : 0;
  };

  $methods{$add_method} = sub { shift->$adds_method(@_) };

  $methods{$adds_method} = sub
  {
    my($class) = ref($_[0]) ? ref(shift) : shift;
    Carp::croak("Missing name/value pair(s) to add")  unless(@_);

    my @attrs;
    my $count = 0;

    my $cache = $Inherited_Hash{$name}{$class}[CACHE] ||= [];

    # XXX: Lame duplication to avoid copying the hash
    if(@_ == 1 && ref $_[0] eq 'HASH')
    {
      while(my($attr, $value) = each(%{$_[0]}))
      {
        next  unless(defined $attr);

        push(@attrs, $attr);

        $cache->[ATTRS]{$attr} = $value;
        $cache->[META]{$attr}  = CLASS_VALUE;

        if($add_implies)
        {
          foreach my $method (@$add_implies)
          {
            $class->$method($attr => $value);
          }
        }

        $count++;
      }
    }
    else
    {
      Carp::croak("Odd number of arguments passed to $adds_method")  if(@_ % 2);

      while(@_)
      {
        my($attr, $value) = (shift, shift);

        push(@attrs, $attr);

        no strict 'refs';
        next  unless(defined $attr);
        $cache->[ATTRS]{$attr} = $value;
        $cache->[META]{$attr}  = CLASS_VALUE;

        if($add_implies)
        {
          foreach my $method (@$add_implies)
          {
            $class->$method($attr => $value);
          }
        }

        $count++;
      }
    }

    if($count)
    {
      foreach my $test_class (keys %{$Inherited_Hash{$name}})
      {
        if($test_class->isa($class) && $test_class ne $class)
        {
          $Inherited_Hash{$name}{$test_class}[META]{'cache_is_valid'} = 0;

          foreach my $attr (@attrs)
          {
            delete $Inherited_Hash{$name}{$test_class}[CACHE][ATTRS]{$attr};
          }
        }
      }
    }

    return $count;
  };

  $methods{$clear_method} = sub
  {
    my($class) = ref($_[0]) ? ref(shift) : shift;
    my @keys = $class->$keys_method();
    return  unless(@keys);
    $class->$deletes_method(@keys);
  };

  $methods{$delete_method} = sub { shift->$deletes_method(@_) };

  $methods{$deletes_method} = sub
  {
    my($class) = ref($_[0]) ? ref(shift) : shift;
    Carp::croak("Missing value(s) to delete")  unless(@_);

    # Init set if it doesn't exist
    unless(exists $Inherited_Hash{$name}{$class})
    {
      $class->$cache_method();
    }

    my $count = 0;

    my $cache = $Inherited_Hash{$name}{$class}[CACHE] ||= [];

    foreach my $attr (@_)
    {
      no strict 'refs';
      next  unless(defined $attr);

      if(exists $cache->[ATTRS]{$attr} &&
                $cache->[META]{$attr} != DELETED_VALUE)
      {
        $cache->[META]{$attr} = DELETED_VALUE;
        $count++;

        if($delete_implies)
        {
          foreach my $method (@$delete_implies)
          {
            $class->$method($attr);
          }
        }

        foreach my $test_class (keys %{$Inherited_Hash{$name}})
        {
          next  if($class eq $test_class);

          my $test_cache = $Inherited_Hash{$name}{$test_class}[CACHE] ||= [];

          if($test_class->isa($class) && exists $test_cache->[ATTRS]{$attr} &&
             $test_cache->[META]{$attr} == INHERITED_VALUE)
          {
            delete $test_cache->[ATTRS]{$attr};
            delete $test_cache->[META]{$attr};
            $Inherited_Hash{$name}{$test_class}[META]{'cache_is_valid'} = 0;
          }
        }
      }
    }

    return $count;
  };

  $methods{$inherit_method} = sub { shift->$inherits_method(@_) };

  $methods{$inherits_method} = sub
  {
    my($class) = ref($_[0]) ? ref(shift) : shift;
    Carp::croak("Missing value(s) to inherit")  unless(@_);

    my $count = 0;

    my $cache = $Inherited_Hash{$name}{$class}[CACHE] ||= [];

    foreach my $attr (@_)
    {
      if(exists $cache->[ATTRS]{$attr})
      {
        delete $cache->[ATTRS]{$attr};
        delete $cache->[META]{$attr};
        $Inherited_Hash{$name}{$class}[META]{'cache_is_valid'} = 0;
        $count++;
      }

      if($inherit_implies)
      {
        foreach my $method (@$inherit_implies)
        {
          $class->$method($attr);
        }
      }
    }

    return $count;
  };

  if($interface ne 'all')
  {
    Carp::croak "Unknown interface: $interface";
  }

  return \%methods;
}


1;

__END__