File Coverage

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

Criterion	Covered	Total	%
statement	256	273	93.7
branch	100	146	68.4
condition	69	131	52.6
subroutine	36	36	100.0
pod	2	2	100.0
total	463	588	78.7

package Rose::Class::MakeMethods::Set;

use strict;

use Carp();

our $VERSION = '0.81';

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

our %Inheritable_Set;
# (
#   some_attr_name =>
#   {
#     class1 =>
#     {
#       meta  => { ... },
#       cache => { ... },
#     },
#     class2 => ...,
#     ...
#   },
#   ...
# );

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

  my %methods;

  # Interface example:
  # name:            required_html_attr
  # plural_name:     required_html_attrs
  # list_method:     required_html_attrs
  # hash_method:     required_html_attrs_hash
  # test_method:     is_required_html_attr (or html_attr_is_required)
  # add_method:      add_required_html_attr
  # adds_method:     add_required_html_attrs
  # delete_method:   delete_required_html_attr
  # deletes_method:  delete_required_html_attrs
  # clear_method:    clear_required_html_attrs

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

  my $list_method     = $args->{'list_method'}    || $plural_name;
  my $hash_method     = $args->{'hash_method'}    || $plural_name  . '_hash';
  my $test_method     = $args->{'test_method'}    || $args->{'test_method'} || 'is_' . $name;
  my $add_method      = $args->{'add_method'}     || 'add_' . $name;
  my $adds_method     = $args->{'adds_method'}    || $add_method . 's';
  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 $value_method    = $args->{'value_method'}   || $name . '_value';

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

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

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

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

    return 0  unless(defined $_[0]);

    no strict 'refs';
    return 1  if(exists $class->$hash_method()->{$_[0]});
    return 0;
  };

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

    unless(exists $Inheritable_Set{$name}{$class})
    {
      no strict 'refs';

      my @parents = ($class);

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

          if(exists $Inheritable_Set{$name}{$subclass})
          {
            while(my($k, $v) = each(%{$Inheritable_Set{$name}{$subclass}}))
            {
              next  if(exists $Inheritable_Set{$name}{$class}{$k});
              $Inheritable_Set{$name}{$class}{$k} = $v;
            }
          }
        }
      }
    }

    $Inheritable_Set{$name}{$class} ||= {};
    return wantarray ? %{$Inheritable_Set{$name}{$class}} :
                       $Inheritable_Set{$name}{$class};
  };

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

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

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

    return wantarray ? sort keys %{$class->$hash_method()} :
                       [ sort keys %{$class->$hash_method()} ];
  };

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

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

    my $count = 0;
    my $req_hash = $class->$hash_method();

    return 0  unless(defined $_[0]);

    my %attrs;

    foreach my $arg (grep { defined } @_)
    {
      if(ref $arg eq 'HASH')
      {
        $attrs{$_} = $arg->{$_}  for(keys %$arg);
      }
      else
      {
        $attrs{$arg} = undef;
      }
    }

    while(my($attr, $val) = each(%attrs))
    {
      no strict 'refs';
      next  unless(defined $attr);
      $req_hash->{$attr} = $val;

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

      $count++;
    }

    return $count;
  };

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

  $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(@_);

    my $count = 0;
    my $req_hash = $class->$hash_method();

    foreach my $attr (@_)
    {
      no strict 'refs';
      next  unless(defined $attr);
      next  unless(exists $req_hash->{$attr});
      delete $req_hash->{$attr};
      $count++;

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

    return $count;
  };

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

    my $hash = $class->$hash_method();
    return undef  unless($_[1] && exists $hash->{$_[1]});
    return $hash->{$_[1]} = $_[2]  if(@_ > 2);
    return $hash->{$_[1]};
  };

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

  return \%methods;
}

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

our %Inherited_Set;
# (
#   some_attr_name =>
#   {
#     class1 =>
#     {
#       meta  => { ... },
#       cache => { ... },
#     },
#     class2 => ...,
#     ...
#   },
#   ...
# );

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

  my %methods;

  # Interface example:
  # name:            valid_html_attr
  # plural_name:     valid_html_attrs
  # list_method:     valid_html_attrs
  # cache_method:    valid_html_attrs_cache
  # hash_method:     valid_html_attrs_hash
  # test_method:     is_valid_html_attr (or html_attr_is_valid)
  # add_method:      add_valid_html_attr
  # adds_method:     add_valid_html_attrs
  # delete_method:   delete_valid_html_attr
  # deletes_method:  delete_valid_html_attrs
  # clear_method     clear_valid_html_attrs
  # inherit_method:  inherit_valid_html_attr
  # inherits_method: inherit_valid_html_attrs

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

  my $list_method     = $args->{'list_method'}     || $plural_name;
  my $cache_method    = $args->{'cache_method'}    || $plural_name . '_cache';
  my $hash_method     = $args->{'hash_method'}     || $plural_name  . '_hash';
  my $test_method     = $args->{'test_method'}     || $args->{'test_method'} || 'is_' . $name;
  my $add_method      = $args->{'add_method'}      || 'add_' . $name;
  my $adds_method     = $args->{'adds_method'}     || $add_method . 's';
  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_method . 's';

  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_Set{$name}{$class}{'meta'}{'cache_is_valid'})
    {
      return
        wantarray ? (%{$Inherited_Set{$name}{$class}{'cache'} ||= {}}) :
                    ($Inherited_Set{$name}{$class}{'cache'} ||= {});
    }

    my @parents = ($class);

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

        if($subclass->can($cache_method))
        {
          my $cache = $subclass->$cache_method();

          while(my($attr, $val) = each %$cache)
          {
            next  if($val == DELETED_VALUE);
            $Inherited_Set{$name}{$class}{'cache'}{$attr} = INHERITED_VALUE
              unless(exists $Inherited_Set{$name}{$class}{'cache'}{$attr});
          }
        }
        # Slower method for subclasses that don't want to implement the
        # cache method (which is not strictly part of the public API)
        elsif($subclass->can($list_method))
        {
          foreach my $attr ($subclass->$list_method())
          {
            $Inherited_Set{$name}{$class}{'cache'}{$attr} = INHERITED_VALUE
              unless(exists $Inherited_Set{$name}{$class}{'cache'}{$attr});
          }
        }
      }
    }

    $Inherited_Set{$name}{$class}{'meta'}{'cache_is_valid'} = 1;

    my $want = wantarray;

    return  unless(defined $want);
    $want ? (%{$Inherited_Set{$name}{$class}{'cache'} ||= {}}) :
            ($Inherited_Set{$name}{$class}{'cache'} ||= {});
  };

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

    my %hash = $class->$cache_method();

    while(my($k, $v) = each %hash)
    {
      delete $hash{$k}  if($v == DELETED_VALUE);
    }

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

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

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

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

    return wantarray ? sort keys %{$class->$hash_method()} :
                       [ sort keys %{$class->$hash_method()} ];
  };

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

    if($Inherited_Set{$name}{$class}{'meta'}{'cache_is_valid'})
    {
      return (exists $Inherited_Set{$name}{$class}{'cache'}{$_[0]} &&
                     $Inherited_Set{$name}{$class}{'cache'}{$_[0]} != DELETED_VALUE) ? 1 : 0;
    }

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

    return (exists $cache->{$_[0]} && $cache->{$_[0]} != 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 value(s) to add")  unless(@_);

    my $count = 0;

    foreach my $attr (@_)
    {
      no strict 'refs';
      next  unless(defined $attr);
      $Inherited_Set{$name}{$class}{'cache'}{$attr} = CLASS_VALUE;

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

      $count++;
    }

    # _invalidate_inherited_set_caches($class, $name)  if($count);
    # Inlined since it is private and only called once
    if($count)
    {
      foreach my $test_class (keys %{$Inherited_Set{$name}})
      {
        if($test_class->isa($class) && $test_class ne $class)
        {
          $Inherited_Set{$name}{$test_class}{'meta'}{'cache_is_valid'} = 0;
        }
      }
    }

    return $count;
  };

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

  $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_Set{$name}{$class})
    {
      $class->$cache_method();
    }

    my $count = 0;

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

      if(exists $Inherited_Set{$name}{$class}{'cache'}{$attr} &&
                $Inherited_Set{$name}{$class}{'cache'}{$attr} != DELETED_VALUE)
      {
        $Inherited_Set{$name}{$class}{'cache'}{$attr} = DELETED_VALUE;
        $count++;

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

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

          if($test_class->isa($class) && exists $Inherited_Set{$name}{$test_class}{'cache'}{$attr} &&
             $Inherited_Set{$name}{$test_class}{'cache'}{$attr} == INHERITED_VALUE)
          {
            delete $Inherited_Set{$name}{$test_class}{'cache'}{$attr};
            $Inherited_Set{$name}{$test_class}{'meta'}{'cache_is_valid'} = 0;
          }
        }
      }
    }

    # Not required
    #_invalidate_inherited_set_caches($class, $name)  if($count);

    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;

    foreach my $attr (@_)
    {
      if(exists $Inherited_Set{$name}{$class}{'cache'}{$attr} &&
         $Inherited_Set{$name}{$class}{'cache'}{$attr} == DELETED_VALUE)
      {
        delete $Inherited_Set{$name}{$class}{'cache'}{$attr};
        $Inherited_Set{$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;
}

# Inlined above since it is private and only called once
# sub _invalidate_inherited_set_caches
# {
#   my($class, $name) = @_;
#
#   foreach my $test_class (keys %{$Inherited_Set{$name}})
#   {
#     if($test_class->isa($class) && $test_class ne $class)
#     {
#       $Inherited_Set{$name}{$test_class}{'meta'}{'cache_is_valid'} = 0;
#     }
#   }
# }

1;

__END__