File Coverage

blib/lib/Data/TagHive.pm

Criterion	Covered	Total	%
statement	59	59	100.0
branch	26	26	100.0
condition	20	22	90.9
subroutine	11	11	100.0
pod	4	5	80.0
total	120	123	97.5

use 5.12.0;
use warnings;

package Data::TagHive 0.005;
# ABSTRACT: hierarchical tags with values

use Carp;

#pod =head1 SYNOPSIS
#pod
#pod   use Data::TagHive;
#pod
#pod   my $taghive = Data::TagHive->new;
#pod
#pod   $taghive->add_tag('book.topic:programming');
#pod
#pod   $taghive->has_tag('book'); # TRUE
#pod
#pod =head1 OVERVIEW
#pod
#pod Data::TagHive is the bizarre, corrupted union of L and
#pod L.  It combines the "simple list of strings" of the former with the
#pod "hierarchical key-value/value pairs" of the latter, using a different interface
#pod from either.
#pod
#pod It's probably better than that sounds, though.
#pod
#pod A Data::TagHive object represents a set of tags.  Each tag is a string that
#pod represents a structure of nested key-value pairs.  For example, a library book
#pod might be tagged:
#pod
#pod   book.pages.size:letter
#pod   book.pages.count:180
#pod   book.type:hardcover
#pod   book.topic:programming.perl.cpan
#pod
#pod Each tag is a set of key-value pairs.  Later pairs are qualified by earlier
#pod pairs.  Values are optional.  Keys and values are separated by colons.
#pod Key-value pairs are separated by dots.
#pod
#pod A tag is considered present if it was set explicitly or if any more-specific
#pod subtag of it was set.  For example, if we had explicitly added all the tags
#pod shown above, a tag hive would then report true if asked whether each of the
#pod following tags were set:
#pod
#pod   book
#pod   book.pages
#pod   book.pages.size
#pod   book.pages.size:letter
#pod   book.pages.count
#pod   book.pages.count:180
#pod   book.type
#pod   book.type:hardcover
#pod   book.topic
#pod   book.topic:programming
#pod   book.topic:programming.perl
#pod   book.topic:programming.perl.cpan
#pod
#pod =cut

sub new {
  my ($class) = @_;

  return bless { state => {} } => $class;
}

my $tagname_re  = qr{ [a-z] [-a-z0-9_]* }x;
my $tagvalue_re = qr{ [-a-z0-9_]+ }x;
my $tagpair_re  = qr{ $tagname_re (?::$tagvalue_re)? }x;
my $tagstr_re   = qr{ \A $tagpair_re (?:\.$tagpair_re)* \z }x;

sub _assert_tagstr {
  my ($self, $tagstr) = @_;
  croak "invalid tagstr <$tagstr>" unless $tagstr =~ $tagstr_re;
}

sub _tag_pairs {
  my ($self, $tagstr) = @_;

  $self->_assert_tagstr($tagstr);

  my @tags = map { my @pair = split /:/, $_; $#pair = 1; \@pair }
             split /\./, $tagstr;

  return @tags;
}

sub __differ {
  my ($x, $y) = @_;

  return 1 if defined $x xor defined $y;
  return unless defined $x;

  return $x ne $y;
}

#pod =method add_tag
#pod
#pod   $taghive->add_tag( $tagstr );
#pod
#pod This method adds the given tag (given as a string) to the hive.  It will fail
#pod if there are conflicts.  For example, if "foo:bar" is already set, "foo:xyz"
#pod cannot be set.  Each tag can only have one value.
#pod
#pod Tags without values may be given values through C, but only if they
#pod have no tags beneath them.  For example, given a tag hive with "foo.bar"
#pod tagged, "foo.bar:baz" could be added, but not "foo:baz"
#pod
#pod =cut

sub add_tag {
  my ($self, $tagstr) = @_;

  my $state = $self->{state};

  my @tags  = $self->all_tags;
  my @pairs = $self->_tag_pairs($tagstr);

  my $stem = '';

  while (my $pair = shift @pairs) {
    $stem .= '.' if length $stem;

    my $key   = $stem . $pair->[0];
    my $value = length($pair->[1]) ? $pair->[1] : undef;

    CONFLICT: {
      if (exists $state->{ $key }) {
        my $existing = $state->{ $key };

        # Easiest cases: if they're both undef, or are eq, no conflict.
        last CONFLICT unless __differ($value, $existing);

        # Easist conflict case: we want to set tag:value1 but tag:value2 is
        # already set.  No matter whether there are descendants on either side,
        # this is a
        # conflict.
        croak "can't add <$tagstr> to taghive; conflict at $key"
          if defined $value and defined $existing and $value ne $existing;

        my $more_to_set = defined($value)         || @pairs;
        my $more_exists = defined($state->{$key}) || grep { /\A\Q$key./ } @tags;

        croak "can't add <$tagstr> to taghive; conflict at $key"
          if $more_to_set and $more_exists;
      }
    }


    $state->{ $key } = $value;

    $stem = defined $value ? "$key:$value" : $key;

    $state->{$stem} = undef;
  }
}

#pod =method has_tag
#pod
#pod   if ($taghive->has_tag( $tagstr )) { ... }
#pod
#pod This method returns true if the tag hive has the tag.
#pod
#pod =cut

sub has_tag {
  my ($self, $tagstr) = @_;

  my $state = $self->{state};

  $self->_assert_tagstr($tagstr);
  return 1 if exists $state->{$tagstr};
  return;
}

#pod =method delete_tag
#pod
#pod   $taghive->delete_tag( $tagstr );
#pod
#pod This method deletes the tag from the hive, along with any tags below it.
#pod
#pod If your hive has "foo.bar:xyz.abc" and you C "foo.bar" it will be
#pod left with nothing but the tag "foo"
#pod
#pod =cut

sub delete_tag {
  my ($self, $tagstr) = @_;

  $self->_assert_tagstr($tagstr);

  my $state = $self->{state};
  my @keys  = grep { /\A$tagstr(?:$|[.:])/ } keys %$state;
  delete @$state{ @keys };

  if ($tagstr =~ s/:($tagvalue_re)\z//) {
    delete $state->{ $tagstr } if $state->{$tagstr} // '' eq $1;
  }
}

#pod =method all_tags
#pod
#pod This method returns, as a list of strings, all the tags set on the hive either
#pod explicitly or implicitly.
#pod
#pod =cut

sub all_tags {
  my ($self) = @_;
  return keys %{ $self->{state} };
}

1;

__END__