File Coverage

blib/lib/MouseX/Types/Enum.pm

Criterion	Covered	Total	%
statement	84	87	96.5
branch	18	20	90.0
condition	16	24	66.6
subroutine	19	20	95.0
pod	0	2	0.0
total	137	153	89.5

package MouseX::Types::Enum;
use 5.008001;

use strict;
use warnings;

our $VERSION = "2.01";

use Mouse;
use Carp qw/confess/;
use Class::Inspector;

has id => (is => 'ro', isa => 'Str');

around BUILDARGS => sub {
    my ($orig, $class, @params) = @_;

    # This package is abstract class
    confess __PACKAGE__ . " is abstract class." if $class eq __PACKAGE__;

    return $class->$orig(@params);
};

my @EXPORT_MOUSE_METHODS = qw/
    extends with has
    before after around
    override super
    augment inner
    blessed confess
/;
my %_ENUM_METAS;

sub _build_enum {
    my ($child, %build_params) = @_;
    my $parent = __PACKAGE__;

    #@type Mouse::Meta::Class
    my $meta = Mouse->init_meta(for_class => $child);

    $meta->add_around_method_modifier(BUILDARGS => sub {
        my ($orig, $class, @params) = @_;
        # disallow creating instance
        if (caller(2) ne __PACKAGE__) {
            confess sprintf("Cannot call $child->new outside of %s (called in %s)", __PACKAGE__, caller(2) . "")
        }
        return $class->$orig(@params);
    });

    # this subroutine should be called as `__PACKAGE__->build_enum`.
    unless (caller() eq $child && !ref($child)) {
        confess "Please call as `__PACKAGE__->_build_enum`.";
    }

    # check reserved subroutine names
    my @child_subs = @{Class::Inspector->functions($child)};
    my @parent_subs = @{Class::Inspector->functions($parent)};
    my %reserved_subs = map {$_ => undef} @parent_subs;
    my %dup_allow_subs = map {$_ => undef} (@EXPORT_MOUSE_METHODS, 'meta', 'BUILDARGS');
    for my $sub_name (@child_subs) {
        if (exists $reserved_subs{$sub_name} && !exists $dup_allow_subs{$sub_name}) {
            confess "`$sub_name` is reserved by " . __PACKAGE__ . ".";
        }
    }

    {
        no strict 'refs';
        no warnings 'redefine';
        # Overwrite enums
        my @enum_subs = grep {$_ =~ /^[A-Z0-9_]+$/} @child_subs;
        my %ignored_subs = map {$_ => undef} ('BUILDARGS', @{$build_params{ignore}});
        for my $sub_name (@enum_subs) {
            next if exists $ignored_subs{$sub_name};
            my ($id, @args) = $child->$sub_name;
            confess "seems to be invalid argument." if scalar(@args) % 2;
            confess "unique id is required for $child->$sub_name ." unless $id;
            my %args = @args;

            if (exists $child->_enums->{$id}) {
                confess "id `$id` is duplicate."
            }
            $child->_enums->{$id} = undef;

            *{"${child}\::${sub_name}"} = sub {
                my $class = shift;
                if ($class && $class ne $child) {
                    confess "`${child}::$sub_name` can only be called as static method of `$child`. Please call `${child}->${sub_name}`.";
                }
                return $class->_enums->{$id} //= $class->new(
                    id => $id,
                    %args
                );
            }
        }
    }

    $child->meta->make_immutable;
}

use overload
    # MouseX::Types::Enum can only be applied following operators
    'eq' => \&_equals,
    'ne' => \&_not_equals,
    '==' => \&_equals,
    '!=' => \&_not_equals,
    '""' => \&_to_string,
;

sub get {
    my ($class, $id) = @_;
    confess "this is class method." if ref($class);
    return $class->_enums->{$id} // confess "$id is not found."
}

sub all {
    my ($class) = shift;
    confess "this is class method." if ref($class);
    return $class->_enums;
}

sub _to_string {
    my ($self) = @_;
    return sprintf("%s[id=%s]", ref($self), $self->id);
}

sub _equals {
    my ($first, $second) = @_;
    return (ref($first) eq ref($second)) && ($first->id eq $second->id);
}

sub _not_equals {
    my ($first, $second) = @_;
    return !_equals($first, $second);
}

sub _enum_meta {
    my ($class) = @_;
    return $_ENUM_METAS{$class} //= {};
}

sub _enums {
    my ($class) = @_;
    return $class->_enum_meta->{enums} //= {};
}

sub _overwrite_flg {
    my ($class) = @_;
    return $class->_enum_meta->{overwrite_flg} //= {};
}


1;
__END__