Edit: /usr/share/perl/5.30.0/constant.pm (14724B)
package constant;
use 5.008;
use strict;
use warnings::register;
our $VERSION = '1.33';
our %declared;
#=======================================================================
# Some names are evil choices.
my %keywords = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD };
$keywords{UNITCHECK}++ if $] > 5.009;
my %forced_into_main = map +($_, 1),
qw{ STDIN STDOUT STDERR ARGV ARGVOUT ENV INC SIG };
my %forbidden = (%keywords, %forced_into_main);
my $normal_constant_name = qr/^_?[^\W_0-9]\w*\z/;
my $tolerable = qr/^[A-Za-z_]\w*\z/;
my $boolean = qr/^[01]?\z/;
BEGIN {
# We'd like to do use constant _CAN_PCS => $] > 5.009002
# but that's a bit tricky before we load the constant module :-)
# By doing this, we save several run time checks for *every* call
# to import.
my $const = $] > 5.009002;
my $downgrade = $] < 5.015004; # && $] >= 5.008
my $constarray = exists &_make_const;
if ($const) {
Internals::SvREADONLY($const, 1);
Internals::SvREADONLY($downgrade, 1);
$constant::{_CAN_PCS} = \$const;
$constant::{_DOWNGRADE} = \$downgrade;
$constant::{_CAN_PCS_FOR_ARRAY} = \$constarray;
}
else {
no strict 'refs';
*{"_CAN_PCS"} = sub () {$const};
*{"_DOWNGRADE"} = sub () { $downgrade };
*{"_CAN_PCS_FOR_ARRAY"} = sub () { $constarray };
}
}
#=======================================================================
# 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];
my $caller = caller;
my $flush_mro;
my $symtab;
if (_CAN_PCS) {
no strict 'refs';
$symtab = \%{$caller . '::'};
};
if ( $multiple ) {
if (ref $_[0] ne 'HASH') {
require Carp;
Carp::croak("Invalid reference type '".ref(shift)."' not 'HASH'");
}
$constants = shift;
} else {
unless (defined $_[0]) {
require Carp;
Carp::croak("Can't use undef as constant name");
}
$constants->{+shift} = undef;
}
foreach my $name ( keys %$constants ) {
my $pkg;
my $symtab = $symtab;
my $orig_name = $name;
if ($name =~ s/(.*)(?:::|')(?=.)//s) {
$pkg = $1;
if (_CAN_PCS && $pkg ne $caller) {
no strict 'refs';
$symtab = \%{$pkg . '::'};
}
}
else {
$pkg = $caller;
}
# Normal constant name
if ($name =~ $normal_constant_name 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 =~ $tolerable) {
# 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 =~ $boolean) {
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 || @_ == 1) {
my $scalar = $multiple ? $constants->{$orig_name} : $_[0];
if (_DOWNGRADE) { # for 5.8 to 5.14
# Work around perl bug #31991: Sub names (actually glob
# names in general) ignore the UTF8 flag. So we have to
# turn it off to get the "right" symbol table entry.
utf8::is_utf8 $name and utf8::encode $name;
}
# The constant serves to optimise this entire block out on
# 5.8 and earlier.
if (_CAN_PCS) {
# Use a reference as a proxy for a constant subroutine.
# If this is not a glob yet, it saves space. If it is
# a glob, we must still create it this way to get the
# right internal flags set, as constants are distinct
# from subroutines created with sub(){...}.
# The check in Perl_ck_rvconst knows that inlinable
# constants from cv_const_sv are read only. So we have to:
Internals::SvREADONLY($scalar, 1);
if (!exists $symtab->{$name}) {
$symtab->{$name} = \$scalar;
++$flush_mro->{$pkg};
}
else {
local $constant::{_dummy} = \$scalar;
*$full_name = \&{"_dummy"};
}
} else {
*$full_name = sub () { $scalar };
}
} elsif (@_) {
my @list = @_;
if (_CAN_PCS_FOR_ARRAY) {
_make_const($list[$_]) for 0..$#list;
_make_const(@list);
if (!exists $symtab->{$name}) {
$symtab->{$name} = \@list;
$flush_mro->{$pkg}++;
}
else {
local $constant::{_dummy} = \@list;
*$full_name = \&{"_dummy"};
}
}
else { *$full_name = sub () { @list }; }
} else {
*$full_name = sub () { };
}
}
}
# Flush the cache exactly once if we make any direct symbol table changes.
if (_CAN_PCS && $flush_mro) {
mro::method_changed_in($_) for keys %$flush_mro;
}
}
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 pragma allows you to declare constants at compile-time.
When you declare a constant such as C
using the method shown
above, each machine your script runs upon can have as many digits
of accuracy as it can use. Also, your program will be easier to
read, more likely to be maintained (and maintained correctly), and
far less likely to send a space probe to the wrong planet because
nobody noticed the one equation in which you wrote C<3.14195>.
When a constant is used in an expression, Perl replaces it with its
value at compile time, and may then optimize the expression further.
In particular, any code in an C block will be optimized
away if the constant is false.
=head1 NOTES
As with all C