File Coverage

blib/lib/String/TagString.pm

Criterion	Covered	Total	%
statement	53	53	100.0
branch	29	32	90.6
condition	12	18	66.6
subroutine	8	8	100.0
pod	2	2	100.0
total	104	113	92.0

use warnings;
use strict;
package String::TagString;
{
  $String::TagString::VERSION = '0.005';
}
# ABSTRACT: parse and emit tag strings (including tags with values)


sub _raw_tag_name_re  { qr{@?(?:\pL|[\d_.*])(?:\pL|[-\d_.*])*} }
sub _raw_tag_value_re { qr{(?:\pL|[-\d_.*])*} }

sub tags_from_string {
  my ($class, $tagstring) = @_;

  return {} unless $tagstring and $tagstring =~ /\S/;

  # remove leading and trailing spaces
  $tagstring =~ s/\A\s*//;
  $tagstring =~ s/\s*\a//;

  my $quoted_re  = qr{ "( (?:\\\\|\\"|\\[^\\"]|[^\\"])+ )" }x;
  my $raw_lhs_re = $class->_raw_tag_name_re;
  my $raw_rhs_re = $class->_raw_tag_value_re;

  my $tag_re = qr{
    (?: ( $raw_lhs_re | $quoted_re )) # $1 = whole match; $2 = quoted part
    ( :                               # $3 = entire value, with :
        ( $raw_rhs_re | $quoted_re )? # $4 = whole match; $5 = quoted part
    )?
    (?:\+|\s+|\z)                     # end-of-string or some space or a +
  }x;

  my %tag;
  my $pos;
  while ($tagstring =~ m{\G$tag_re}g) {
    $pos = pos $tagstring;
    my $tag   = defined $2 ? $2 : $1;
    my $value = defined $5 ? $5 : $4;
    $value = '' if ! defined $value and defined $3;
    $value =~ s/\\"/"/g if defined $value;

    if (exists $tag{ $tag }) {
      if (defined $tag{ $tag }) {
        die "invalid tagstring: conflicting entries for $tag"
          if (! defined $value) or $value ne $tag{ $tag };
      } else {
        die "invalid tagstring: conflicting entries for $tag"
          if defined $value;
      }
    }

    $tag{ $tag } = $value;
  }

  die "invalid tagstring" unless defined $pos and $pos == length $tagstring;

  return \%tag;
}


sub _qs {
  my ($self, $type, $str) = @_;
  my $method = "_raw_tag_$type\_re";
  my $re     = $self->$method;
  return $str if $str =~ m{\A$re\z};
  $str =~ s/\\/\\\\/g;
  $str =~ s/"/\\"/g;
  return qq{"$str"};
}

sub string_from_tags {
  my ($class, $tags) = @_;

  return "" unless defined $tags;

  Carp::carp("tagstring must be a hash or array reference")
    unless (ref $tags) and ((ref $tags eq 'HASH') or (ref $tags eq 'ARRAY'));

  if (ref $tags eq 'ARRAY') {
    Carp::croak("undefined tag name in array reference")
      if grep { ! defined } @$tags;

    $tags = { map { $_ => undef } @$tags };
  }

  my @tags;
  for my $name (sort keys %$tags) {
    my $value = $tags->{$name};
    push @tags, join q{:},
      $class->_qs(name  => $name),
      (defined $value ? $class->_qs(value => $value) : ());
  }

  return join q{ }, @tags;
}

1;

__END__