File Coverage

blib/lib/unconstant.pm

Criterion	Covered	Total	%
statement	75	102	73.5
branch	13	42	30.9
condition	2	9	22.2
subroutine	17	19	89.4
pod	0	3	0.0
total	107	175	61.1

package unconstant;
use warnings;

use constant ();
my $constant_import;
my $installed;

BEGIN { $constant_import = \&constant::import };

use 5.014;
use strict;
use warnings;

our $VERSION = '0.03';

our %declared;

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

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

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/;

sub unconstant_import {
	return if $installed;
	*constant::import = *constant_import;
	$installed = 1;
}

sub unconstant_unimport {
	return unless $installed;
	no warnings 'redefine';
	*constant::import = $constant_import;
	$installed = 0;
}

sub constant_import {

	my $caller = caller();
	my $package = shift;
	my $flush_mro;
	return unless @_;
	my $multiple  = ref $_[0];

	my $constants;
	if ( $multiple ) {
		if ($multiple 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;
	}


	my $symtab;
	{
		no strict 'refs';
		$symtab = \%{$caller . "::"};
	}

	foreach my $name ( keys %$constants ) {
		my $pkg = $caller;
		my $symtab = $symtab;
		my $orig_name = $name;

		if ($name =~ s/(.*)(?:::|')(?=.)//s) {
			$pkg = $1;
			if ($pkg ne $caller) {
				no strict 'refs';
				$symtab = \%{$pkg . '::'};
			}
		}

		# 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];

			#$symtab->{$name} = sub () { $scalar };
			{
				no warnings;
				*$full_name = sub { $scalar };
			}
			++$flush_mro->{$pkg};
		}
		elsif (@_) {
			my @list = @_;
			{
				no warnings;
				*$full_name = sub { @list };
			}
			$flush_mro->{$pkg}++;
		}
		else {
			die 'foo';
			#*$full_name = sub { };
			*$full_name = sub () { };
		}
	}
	# Flush the cache exactly once if we make any direct symbol table changes.
	if ($flush_mro) {
		mro::method_changed_in($_) for keys %$flush_mro;
	}
}


{
	no warnings;
	*import   = \&unconstant_import;
	*unimport = \&unconstant_unimport;
}


1;

__END__