File Coverage

blib/lib/constant/lexical.pm

Criterion	Covered	Total	%
statement	15	38	39.4
branch	8	22	36.3
condition	3	6	50.0
subroutine	4	6	66.6
pod			n/a
total	30	72	41.6

use 5.008;

package constant::lexical;

our $VERSION = '2.0001';

my $old = '#line ' . (__LINE__+1) . " " . __FILE__ . "\n" . <<'__';

no constant 1.03 ();
use constant hufh => eval 'require Hash::Util::FieldHash';
use Sub::Delete;
BEGIN {
 0+$] eq 5.01
  and VERSION Sub::Delete >= .03
  and VERSION Sub::Delete 1.00001 # %^H scoping bug
}
hufh and eval '
  Hash::Util::FieldHash::fieldhash %hh;
  use Tie::Hash;
  {
   package constant::lexical::_hhfh;
   @ISA = "Tie::StdHash";
   sub DELETE { constant::lexical::DESTROY(SUPER::DELETE{@_}) }
  }
  tie %hh, constant::lexical::_hhfh::;;
';

sub import {
	$^H |= 0x20000; # magic incantation to make %^H work before 5.10
	shift;
	return unless @ '_;
	my @const = @_ == 1 && ref $_[0] eq 'HASH' ? keys %{$_[0]} : $_[0];
	my $stashname = caller()."::"; my $stash = \%$stashname;
	push @{hufh ? $hh{\%^H} ||= [] : ($^H{+__PACKAGE__} ||= bless[])},
	 map {
		my $fqname = "$stashname$_"; my $ref;
		if(exists $$stash{$_} && defined $$stash{$_}) {
			$ref = ref $$stash{$_} eq 'SCALAR'
				? $$stash{$_}
				: *$fqname{CODE};
			delete_sub($fqname);
		}
		[$fqname, $stashname, $_, $ref]
	} @const;
	unshift @_, 'constant';
	goto &{can constant 'import'}
}

sub DESTROY { for(@{+shift}) {
	delete_sub(my $fqname = $$_[0]);
	next unless defined (my $ref = $$_[-1]);
	ref $ref eq 'SCALAR' or *$fqname = $ref, next;
	my $stash = \%{$$_[1]}; my $subname = $$_[2];
	if(exists $$stash{$subname} &&defined $$stash{$subname}) {
		my $val = $$ref;
		*$fqname = sub(){$val}
	} else { $$stash{$subname} = $ref }
}}

1;
__

my $new = '#line ' . (__LINE__+1) . " " . __FILE__ . "\n" . <<'__';

require Lexical'Sub;

sub import {
  shift;
  return unless @ '_;
  my @args;
  if(@_ == 1 && ref $_[0] eq 'HASH') {
   _validate(keys %{$_[0]});
    while(my($k,$v) = each %{$_[0]}) {
     push @args, $k, sub(){ $v };
    }
  }
  elsif(@_ == 2) {
   _validate($_[0]);
    my $v = pop;
    @args = ($_[0], sub(){ $v });
  }
  else {
   _validate($_[0]);
    @args = (shift, do { my @v = @'_; sub(){ @v } });
  }
  import Lexical'Sub @args;
 _:
}

# Plagiarised from constant.pm

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

my $normal_constant_name = qr/^_?[^\W_0-9]\w*\z/;
my $tolerable = qr/^[A-Za-z_]\w*\z/;
my $boolean = qr/^[01]?\z/;

sub _validate {
 for(@_) {
  defined or require Carp, Carp'croak("Can't use undef as constant name");
  # Normal constant name
  if (/$normal_constant_name/ and !$keywords{$_}) {
      # Everything is okay

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

  # Maybe the name is tolerable
  } elsif (/$tolerable/) {
      # Then we'll warn only if you've asked for warnings
      if (warnings::enabled()) {
          if ($keywords{$_}) {
              warnings::warn("Constant name '$_' is a Perl keyword");
          }
      }

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

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

1;
__

eval($] < 5.011002 ? $old : $new) or die $@;

__END__