File Coverage

blib/lib/Set/DynamicGroups.pm

Criterion	Covered	Total	%
statement	89	91	97.8
branch	30	36	83.3
condition	11	11	100.0
subroutine	17	17	100.0
pod	9	9	100.0
total	156	164	95.1

# vim: set ts=2 sts=2 sw=2 expandtab smarttab:
#
# This file is part of Set-DynamicGroups
#
# This software is copyright (c) 2010 by Randy Stauner.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use strict;
use warnings;

package Set::DynamicGroups;
BEGIN {
  $Set::DynamicGroups::VERSION = '0.014';
}
BEGIN {
  $Set::DynamicGroups::AUTHORITY = 'cpan:RWSTAUNER';
}
# ABSTRACT: Manage groups of items dynamically

use Carp qw(croak);

our %Aliases = (
  in      => 'include_groups',
  items   => 'include',
  members => 'include',
  'not'   => 'exclude',
  not_in  => 'exclude_groups',
);


sub new {
  my ($class) = @_;
  my $self = {
    groups => {},
  };
  bless $self, $class;
}


sub add {
  my ($self) = shift;
  my %groups = ref $_[0] ? %{$_[0]} : @_;
  while( my ($name, $spec) = each %groups ){
    $spec = $self->normalize($spec);
    my $group = ($self->{groups}->{$name} ||= {});
    # could use Hash::Merge, but this is a simple case:
    while( my ($key, $val) = each %$spec ){
      $self->_push_unique(($group->{$key} ||= []), {}, @$val);
    }
  }
  return $self;
}


sub add_items {
  my ($self, @append) = @_;

  my $items = ($self->{items} ||= []);
  $self->_push_unique($items, {}, map { ref $_ ? @$_ : $_ } @append);
  return scalar @$items;
}
*add_members    = \&add_items;

# NOTE: See L for comments

sub _determine_items {
  # $name is required (rathan than ref) to push name onto anti-recursion stack
  my ($self, $name, $current) = @_;
  $current ||= {};

  # avoid infinite recursion...
  # 'each' strategy:
  return []
    if exists $current->{$name};
  $current->{$name} = 1;

  # If the group doesn't exist just return an empty arrayref
  # rather than autovivifying and filling with the wrong items, etc.
  return []
    unless my $group = $self->{groups}{$name};

  my @exclude = $self->_flatten_items($group, 'exclude', $current);

  # If no includes (only excludes) are specified,
  # populate the list with all known items.
  # Use _push_unique to maintain order (and uniqueness).
  my @include;
  $self->_push_unique(\@include, +{ map { $_ => 1 } @exclude },
    (exists $group->{include} || exists $group->{include_groups})
    ? $self->_flatten_items($group, 'include', $current)
    : $self->items
  );

  return \@include;
}

sub _flatten_items {
  # $group can currently be ref (rather than name)
  my ($self, $group, $which, $current) = @_;
  my @items = @{ $group->{ $which } || [] };
  if( my $items = $group->{ "${which}_groups" } ){
    my @flat = map { @{ $self->_determine_items($_, $current) } } @$items;
    push(@items, @flat);
  }
  return @items;
}


sub group {
  my ($self) = shift;
  croak("group() requires a single argument.  Perhaps you want groups().")
    if @_ != 1;
  my ($name) = @_;

  croak("Group $name is not defined")
    unless exists $self->{groups}{$name};

  # get the value rather than a whole hash
  my $items = $self->groups($name)->{$name};
  # return a list (not an arrayref)
  return @$items;
}


sub groups {
  my ($self, @names) = @_;
  my %groups;
  my %group_specs = %{$self->{groups}};

  # if names provided, limit to those (and flatten), otherwise do all
  @names = @names
    ? map { ref $_ ? @$_ : $_ } @names
    : keys %group_specs;

  foreach my $name ( @names ){
    # the 'each' dependency resolution "strategy"
    $groups{$name} = $self->_determine_items($name);
  }

  return \%groups;
}


sub items {
  my ($self) = @_;
  # TODO: make it an option which things are included in this list?
  my @items = @{ $self->{items} || [] };
  # concatenate all items included in groups
  $self->_push_unique(\@items, {},
    map { @{ $_->{include} || [] } }
      values %{ $self->{groups} });
  return @items;
}
*members = \&items;


sub normalize {
  my ($self, $spec) = @_;

  # if not a hashref, assume it's an (arrayref of) item(s)
  $spec = {include => $spec}
    unless ref $spec eq 'HASH';

  # TODO: croak if any unrecognized keys are present

  while( my ($alias, $name) = each %Aliases ){
    if( exists($spec->{$alias}) ){
      croak("Cannot include both an option and its alias: " .
        "'$name' and '$alias' are mutually exclusive.")
          if exists $spec->{$name};
      $spec->{$name} = delete $spec->{$alias};
    }
  }

  while( my ($key, $value) = each %$spec ){
    # convert scalar (string) to arrayref
    $spec->{$key} = [$value]
      unless ref $value;
  }

  return $spec;
}

sub _push_unique {
  my ($self, $array, $seen, @push) = @_;

  # Ignore items already present.
  # List assignment on a hash slice benches faster than: ++$s{$_} for @a
  @$seen{ @$array } = (1) x @$array;

  push(@$array, grep { !$$seen{$_}++ } @push);
}


sub set {
  my ($self) = shift;
  my %groups = ref $_[0] ? %{$_[0]} : @_;
  delete $self->{groups}{$_} foreach keys %groups;
  $self->add(%groups);
}


sub set_items {
  my ($self) = shift;
  delete $self->{items};
  return $self->add_items(@_);
}
*set_members = \&set_items;

1;


__END__