package Class::Constant;

use warnings;
use strict;

our $VERSION = '0.05';

my %ordinal_for_data;
my %data_by_ordinal;

sub import {
    my ($pkg, @args) = @_;

    my $caller = caller;

    $ordinal_for_data{$caller} ||= 0;

    my $start_ordinal = $ordinal_for_data{$caller};

    my %data;
    my $value = 0;
    for my $arg (@args) {
        if ($arg =~ /^[A-Z][A-Z0-9_]*$/) {
            if (exists $data{name}) {
                my %data_copy = %data;
                $data_by_ordinal{$caller}->[$data{ordinal}] = \%data_copy;
            }

            %data = ();

            $data{name} = $arg;

            $data{ordinal} = $ordinal_for_data{$caller};
            $ordinal_for_data{$caller}++;

            $data{object} = \do { my $x = $data{ordinal} };

            $data{value} = $value;
            $value++;

            next;
        }

        if (ref $arg eq "HASH") {
            $data{methods} = $value = $arg;
            $value++;

            next;
        }

        $data{value} = $value = $arg;
        $value++;
    }

    if (exists $data{name}) {
        my %data_copy = %data;
        $data_by_ordinal{$caller}->[$data{ordinal}] = \%data_copy;
    }

    for my $ordinal ($start_ordinal .. $ordinal_for_data{$caller}-1) {
        my $data = $data_by_ordinal{$caller}->[$ordinal];

        do {
            no strict "refs";
            *{$caller."::".$data->{name}} = sub { bless $data->{object}, $caller };
        };
    }

    if ($start_ordinal == 0 and $ordinal_for_data{$caller} > 0) {
        do {
            no strict "refs";

            unshift @{$caller."::ISA"}, "Class::Constant::Object";

            *{$caller."::by_ordinal"} = sub {
                return if @_ < 2;
                if (not exists $data_by_ordinal{$caller}->[$_[1]]) {
                    require Carp;
                    Carp::croak("Can't locate constant with ordinal \"$_[1]\" in package \"".(ref($_[0])||$_[0])."\"");
                }
                return bless $data_by_ordinal{$caller}->[$_[1]]->{object}, $caller;
            };
        };
    }
}


package
    Class::Constant::Object;

use Scalar::Util qw(refaddr);

use overload
    q{""} => sub { (shift)->as_string(@_) },
    q{==} => sub { (shift)->equals(@_) },
    q{!=} => sub { !(shift)->equals(@_) };

sub as_string {
    return "$data_by_ordinal{ref $_[0]}->[${$_[0]}]->{value}";
}

sub equals {
    return (ref $_[0] eq ref $_[1] && refaddr $_[0] == refaddr $_[1]) ? 1 : 0;
}

sub get_ordinal {
    return ${$_[0]};
}

sub AUTOLOAD {
    my ($self) = @_;

    use vars qw($AUTOLOAD);
    my ($pkg, $method) = $AUTOLOAD =~ m/^(.*)::(.*)/;

    return if $method =~ m/^[A-Z]+$/;

    if ($method !~ m/^get_/) {
        require Carp;
        Carp::croak("Can't locate object method \"$method\" via package \"$pkg\"");
    }

    my ($name) = $method =~ m/^get_(.*)/;

    my $data = $data_by_ordinal{ref $_[0]}->[${$_[0]}];
    return if not $data;

    if (not exists $data->{methods} or not exists $data->{methods}->{$name}) {
        require Carp;
        Carp::croak("Can't locate named constant \"$name\" for \"" .ref($_[0]). "::$data->{name}\"");
    }

    return $data->{methods}->{$name};
}

1;

__END__

=head1 NAME

Class::Constant - Build constant classes

=head1 SYNOPSIS

    use Class::Constant NORTH, EAST, SOUTH, WEST;
    
    use Class::Constant
        NORTH => "north",
        EAST  => "east",
        SOUTH => "south",
        WEST  => "west;
    
    use Class::Constant
        NORTH => { x =>  0, y => -1 },
        EAST  => { x => -1, y =>  0 },
        SOUTH => { x =>  0, y =>  1 },
        WEST  => { x =>  1, y =>  0 };
    
    use Class::Constant
        NORTH => "north",
                 { x =>  0, y => -1 },
        EAST  => "east",
                 { x => -1, y =>  0 },
        SOUTH => "south",
                 { x =>  0, y =>  1 },
        WEST  => "west",
                 { x =>  1, y =>  0 };

=head1 DESCRIPTION

L<Class::Constant> allows you declaratively created so-called "constant
classes". These are very much like enumerated types (as close as a typeless
language like Perl can get, at least).

The classes generated by this module are modeled closely after Java's "typesafe
enumeration" pattern, but with some added spice to make them more useful to
Perl programs.

=head2 SIMPLE USAGE

The simplese usage of L<Class::Constant> is to use it to define a set of values
for a user-defined "type". Consider a class that defines the four main compass
points:

    package Direction;
    
    use Class::Constant NORTH, EAST, SOUTH, WEST;

This generates four constants which can be assigned to some variable:

    my $facing = Direction::NORTH;

There are two major differences between L<Class::Constant> constants and
constants created by the L<constant> pragma:

=over

=item *

L<Class::Constant> constants have no inherent value, and as such only compare
equal to themselves (but see L<"ORDINAL VALUES">, eg:

    if ($facing == Direction::EAST) {
        print "you are facing east\n";
    }

=item *

L<Class::Constant> constants are actually objects blessed into the package that
created them, so they have a "type", of sorts:

    if ($facing->isa("Direction")) {
        ...
    }

=back

Neither of these distinctions are particularly useful in this simple usage, but
are useful when using the more advanced features of this module, described
below.

=head2 CONSTANT VALUES

Althought constants don't have a value as such, real values can be attached to
them to be used when appropriate.

=head3 Stringification

Constants can be declared with a string that will be returned when the constant
is stringified (eg by C<print>). For example:

    use Class::Constant
        NORTH => "north",
        EAST  => "east",
        SOUTH => "south",
        WEST  => "west";

This makes the following possible:

    print "you are facing $facing\n";

=head3 Named sub-constants

You can also declare other constant values that are associated with a constant:

    use Class::Constant
        NORTH => { x =>  0, y => -1 },
        EAST  => { x => -1, y =>  0 },
        SOUTH => { x =>  0, y =>  1 },
        WEST  => { x =>  1, y =>  0 };

These sub-constants are accessed via C<get_*> methods called on the constant
object:

    move_player($facing->get_x, $facing->get_y);

=head3 Combining the two

Of course both a string value and named sub-constants can be declared at the
same time:

    use Class::Constant
        NORTH => "north",
                 { x =>  0, y => -1 },
        EAST  => "east",
                 { x => -1, y =>  0 },
        SOUTH => "south",
                 { x =>  0, y =>  1 },
        WEST  => "west",
                 { x =>  1, y =>  0 };

=head2 ORDINAL VALUES

Each constant has an internal value which is generated by L<Class::Constant> as
it creates the constants. These ordinal values are unique to a package, and are
assigned sequentially to each constant create in that package. For example, in
our Direction packages, the constants would receive ordinal values as follows:

    NORTH   0
    EAST    2
    SOUTH   1
    WEST    3

The ordinal value for a constant can be retrieved by calling the C<get_ordinal>
method on a constant object:

    my $ordinal = Direction::EAST->get_ordinal;

You can also retrieve a constant by its ordinal value using the class method
C<by_ordinal>

    my $west = Direction->by_ordinal(3);

These two methods are typically used together to fetch the "next" or "previous"
constant in the sequence, eg:

    sub turn_left {
        my ($facing) = @_;
        return Direction->by_ordinal(($facing->get_ordinal - 1) % 4);
    }

=head2 OVERLOADING

Constant objects are blessed into the package in which they were declared. The
L<Class::Constant> C<import> method also updates the packages' C<@ISA> to make
constant objects subclass L<Class::Constant::Object>

L<Class::Constant::Object> has C<as_string> and C<equals> methods, and also
sets up overloading for the C<""> (stringification) and C<==> and C<!=>
(equality) operators to use these methods. If you override these methods in
your package, then L<Class::Constant::Object> will arrange to call your methods
instead.


=head1 DIAGNOSTICS

=over

=item C<< Can't locate constant with ordinal "%s" in package "%s" >>

The value passed to C<by_ordinal> does not corespond to any constant in the
named package. This usually means the value you've specified is greater than
the number of declared constants.

=item C<< Can't locate named constant "%s" for "%s" >>

A named constant associated with a declared constant was not found. It was
probably not defined; check your declarations.

=back


=head1 AUTHOR

Robert Norris (rob@cataclysm.cx)

=head1 COPYRIGHT

Copyright (c) 2006 Robert Norris. This program is free software; you can
redistribute it and/or modify it under the same terms as Perl itself.