view release on metacpan or  search on metacpan

lib/Enumeration.pm  view on Meta::CPAN

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

use Scalar::Util qw(refaddr);

use overload '""' => \&value,
             'eq' => \&equals,
             'ne' => \&not_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;
    }