File Coverage

blib/lib/Attribute/Method/Tags/Registry.pm

Criterion	Covered	Total	%
statement	43	46	93.4
branch	25	30	83.3
condition			n/a
subroutine	8	8	100.0
pod	5	5	100.0
total	81	89	91.0

package Attribute::Method::Tags::Registry;

use strict;
use warnings;

use Carp qw( croak );

our $VERSION = '0.10';

my $by_tag = {};

sub add {
    my ( undef, $class, $method, $tags ) = @_;

    if ( not scalar @{ $tags } ) {
        die "no tags defined\n";
    }

    foreach my $tag ( @{ $tags } ) {
        if ( $tag !~ /^\w+$/ ) {
            die "tags must be alphanumeric\n";
        }
    }

    # dedupe tags
    my %tags = map { $_ => 1 } @{ $tags };

    my $exists = grep {
        exists $by_tag->{ $_ }{ $class }
          and exists $by_tag->{ $_ }{ $class }{ $method }
    } __PACKAGE__->tags;
    if ( $exists ) {
        die "tags for $class->$method already exists, method redefinition perhaps?\n";
    }

    foreach my $tag ( keys %tags ) {
        $by_tag->{ $tag }{ $class }{ $method } = 1;
    }
}

sub tags {
    return sort keys %{ $by_tag };
}

sub classes_with_tag {
    my ( undef, $tag ) = @_;

    croak( "no tag specified" ) if not defined $tag;

    return if not exists $by_tag->{ $tag };

    return sort keys %{ $by_tag->{ $tag } };
}

sub methods_with_tag {
    my ( undef, $class, $tag ) = @_;

    croak( "no class specified" ) if not defined $class;
    croak( "no tag specified" ) if not defined $tag;

    # avoid auto-vivication
    return if not exists $by_tag->{ $tag };

    return sort keys %{ $by_tag->{ $tag }{ $class } };
}

sub method_has_tag {
    my ( undef, $class, $method, $tag ) = @_;

    croak( "no class specified" ) if not defined $class;
    croak( "no method specified" ) if not defined $method;
    croak( "no tag specified" ) if not defined $tag;

    # avoid auto-vivication
    return 0 if not exists $by_tag->{ $tag };
    return 0 if not exists $by_tag->{ $tag }{ $class };

    return exists $by_tag->{ $tag }{ $class }{ $method }
      ? 1
      : 0;
}

1;

__END__