view release on metacpan or  search on metacpan

lib/Data/TagHive.pm  view on Meta::CPAN

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<String::TagString> and
#pod L<Data::Hive>.  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<add_tag>, 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];