source: trunk/essentials/dev-lang/perl/lib/constant.pm@ 3298

package constant;

use strict;
use 5.006_00;
use warnings::register;

our($VERSION, %declared);
$VERSION = '1.05';

#=======================================================================

# Some names are evil choices.
my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD };

my %forced_into_main = map +($_, 1),
    qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG };

my %forbidden = (%keywords, %forced_into_main);

#=======================================================================
# import() - import symbols into user's namespace
#
# What we actually do is define a function in the caller's namespace
# which returns the value. The function we create will normally
# be inlined as a constant, thereby avoiding further sub calling 
# overhead.
#=======================================================================
sub import {
    my $class = shift;
    return unless @_;                   # Ignore 'use constant;'
    my %constants = ();
    my $multiple  = ref $_[0];

    if ( $multiple ) {
        if (ref $_[0] ne 'HASH') {
            require Carp;
            Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'");
        }
        %constants = %{+shift};
    } else {
        $constants{+shift} = undef;
    }

    foreach my $name ( keys %constants ) {
        unless (defined $name) {
            require Carp;
            Carp::croak("Can't use undef as constant name");
        }
        my $pkg = caller;

        # Normal constant name
        if ($name =~ /^_?[^\W_0-9]\w*\z/ and !$forbidden{$name}) {
            # Everything is okay

        # Name forced into main, but we're not in main. Fatal.
        } elsif ($forced_into_main{$name} and $pkg ne 'main') {
            require Carp;
            Carp::croak("Constant name '$name' is forced into main::");

        # Starts with double underscore. Fatal.
        } elsif ($name =~ /^__/) {
            require Carp;
            Carp::croak("Constant name '$name' begins with '__'");

        # Maybe the name is tolerable
        } elsif ($name =~ /^[A-Za-z_]\w*\z/) {
            # Then we'll warn only if you've asked for warnings
            if (warnings::enabled()) {
                if ($keywords{$name}) {
                    warnings::warn("Constant name '$name' is a Perl keyword");
                } elsif ($forced_into_main{$name}) {
                    warnings::warn("Constant name '$name' is " .
                        "forced into package main::");
                }
            }

        # Looks like a boolean
        # use constant FRED == fred;
        } elsif ($name =~ /^[01]?\z/) {
            require Carp;
            if (@_) {
                Carp::croak("Constant name '$name' is invalid");
            } else {
                Carp::croak("Constant name looks like boolean value");
            }

        } else {
           # Must have bad characters
            require Carp;
            Carp::croak("Constant name '$name' has invalid characters");
        }

        {
            no strict 'refs';
            my $full_name = "${pkg}::$name";
            $declared{$full_name}++;
            if ($multiple) {
                my $scalar = $constants{$name};
                *$full_name = sub () { $scalar };
            } else {
                if (@_ == 1) {
                    my $scalar = $_[0];
                    *$full_name = sub () { $scalar };
                } elsif (@_) {
                    my @list = @_;
                    *$full_name = sub () { @list };
                } else {
                    *$full_name = sub () { };
                }
            }
        }
    }
}

1;

__END__

=head1 NAME

constant - Perl pragma to declare constants

=head1 SYNOPSIS

    use constant PI    => 4 * atan2(1, 1);
    use constant DEBUG => 0;

    print "Pi equals ", PI, "...\n" if DEBUG;

    use constant {
        SEC   => 0,
        MIN   => 1,
        HOUR  => 2,
        MDAY  => 3,
        MON   => 4,
        YEAR  => 5,
        WDAY  => 6,
        YDAY  => 7,
        ISDST => 8,
    };

    use constant WEEKDAYS => qw(
        Sunday Monday Tuesday Wednesday Thursday Friday Saturday
    );

    print "Today is ", (WEEKDAYS)[ (localtime)[WDAY] ], ".\n";

=head1 DESCRIPTION

This will declare a symbol to be a constant with the given value.

When you declare a constant such as C<PI> using the method shown
above, each machine your script runs upon can have as many digits