File Coverage

blib/lib/Class/Constant.pm

Criterion	Covered	Total	%
statement	91	96	94.7
branch	26	32	81.2
condition	9	14	64.2
subroutine	19	20	95.0
pod			n/a
total	145	162	89.5

package Class::Constant;
$Class::Constant::VERSION = '0.07';
# ABSTRACT: Build constant classes

use warnings;
use strict;

use Scalar::Util qw(looks_like_number);

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++ if looks_like_number($value);

            next;
        }

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

            next;
        }

        $data{value} = $value = $arg;
        $value++ if looks_like_number($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 blessed);

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

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

sub equals {
    if (blessed $_[1] and $_[1]->isa(__PACKAGE__)) {
        return (refaddr $_[0] == refaddr $_[1]) ? 1 : 0;
    }

    return "".$_[0] eq "".$_[1];
}

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__