File Coverage

blib/lib/Enumeration.pm

Criterion	Covered	Total	%
statement	81	84	96.4
branch	19	22	86.3
condition	11	21	52.3
subroutine	23	24	95.8
pod	9	13	69.2
total	143	164	87.2

=for gpg
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1

=head1 NAME

Enumeration - Yet Another enumeration class implementation.

=head1 VERSION

This is version 0.03 of Enumeration, of March 26, 2008.

=cut

use strict;
use warnings;
package Enumeration;
$Enumeration::VERSION = '0.03';

use Scalar::Util qw(refaddr);

use overload '""' => \&value,
             'eq' => \&equals,
             'ne' => \¬_equals;

# Auto-croaking saves program startup time:
sub croak { require Carp; goto &Carp::croak }

# Enumeration constants for each subclass
my %class_symbols;

# This should ONLY be called by subclasses.
# Call as:    __PACKAGE__->set_enumerations(@list_of_symbols);
sub set_enumerations
{
    my $class = shift;
    $class_symbols{$class}{$_} = 1 for @_;
    return 1;
}

# Return a list of enumerations allowable in the given class.
sub enumerations
{
    my $class = shift;
    return keys %{ $class_symbols{$class} };
}

sub import
{
    my $class = shift;
    my $import = @_ && $_[0] eq ':all';

    my $cpkg = caller;
    foreach my $sym (keys %{$class_symbols{$class}})
    {
        no strict 'refs';
        my $full_name  = $cpkg  . '::' . $sym;
        my $local_name = $class . '::' . $sym;

        *$full_name  = sub () { $sym } if $import;
        *$local_name = sub () { $sym }
    }
}


# OO enclosure.
{
    # Enumeration constants for objects created directly from the Enumeration class.
    my %instance_symbols;
    my %instance_value;

    sub new
    {
        my $class = shift;
        my $self = bless \do { my $dummy } => $class;

        # Caller is creating an on-the-fly enumeration
        if ($class eq 'Enumeration')
        {
            my %values = map {$_ => 1} @_;
            $instance_symbols{refaddr $self} = \%values;
        }
        else    # Caller is using a subclass
        {
            croak "Too many arguments to ${class}->new" if @_ > 1;
            $instance_symbols{refaddr $self} = $class_symbols{$class};
            $self->set(shift) if @_;
        }

        return $self;
    }

    sub DESTROY
    {
        my $self = shift;
        delete $instance_symbols{refaddr $self};
        delete $instance_value{refaddr $self};
    }

    # Is a given value in the list of enumeration values that are legal
    # for this class or object?
    sub is_allowable_value
    {
        my $what = shift;    # may be class name string or an object reference
        my $value = shift;
        return 1 if not defined $value;    # undef is always allowed.

        # It's a "free" enum object -- instance contains the allowable values.
        if (ref $what eq 'Enumeration')
        {
            return $instance_symbols{refaddr $what}{$value};
        }

        # It's a subclass-based object -- enumeration is at the class level.
        $what = ref ($what) || $what;
        return $class_symbols{$what}{$value};
    }

    # simple internal routine for generating a consistent error message
    # throughout.
    sub _check
    {
        croak qq{"$_[1]" is not an allowable value}
            if not $_[0]->is_allowable_value($_[1]);
    }

    # Set the object's value.
    sub set
    {
        my $self  = shift;
        my $value = shift;

        $self->_check($value);
        $instance_value{refaddr $self} = $value;
    }

    # Return the object's value.
    sub value
    {
        my $self  = shift;
        return ref($self) . '::' . $instance_value{refaddr $self}
    }
    sub bare_value
    {
        my $self  = shift;
        return $instance_value{refaddr $self}
    }

    # Query the object's status; check to see if it is a given value.
    sub is
    {
        my $self  = shift;
        my $value = shift;

        # Comparing to another enum object?
        if (ref $value && $value->isa('Enumeration'))
        {
            # Compatible classes?  Equivalent values?
            return ref $value eq ref $self  &&
                   _defeq($instance_value{refaddr $self},
                          $instance_value{refaddr $value});
        }

        $self->_check($value);
        return _defeq($instance_value{refaddr $self}, $value);
    }

    # "Complex" equality:
    #     If either value is undef, then they're equal only if both are undef
    #     Otherwise, just a simple string equality.
    sub _defeq
    {
        my ($v1, $v2) = @_;

        return (!defined $v1 && !defined $v2)
            if (!defined $v1 || !defined $v2);

        return $v1 eq $v2;
    }

    # Query the object's status; check to see if it is any of a number
    # of possible values.
    # Each status passed must be an allowable value.
    sub is_any
    {
        my $self = shift;

        foreach my $value (@_)
        {
            next if ref $value && $value->isa('Enumeration');
            $self->_check($value);
        }

        foreach my $value (@_)
        {
            return 1 if $self->is($value);
        }
        return;
    }

    # Opposite of is_any.  (Duh)
    sub is_none
    {
        my $self = shift;
        return ! $self->is_any(@_);
    }

    # Overload methods

    sub equals
    {
        return $_[0]->is($_[1]);
    }

    sub not_equals
    {
        return ! $_[0]->is($_[1]);
    }

}


return 'a true value';
__END__