view release on metacpan or  search on metacpan

lib/constant/lexical.pm  view on Meta::CPAN

use 5.008;

package constant::lexical;

our $VERSION = '2.0003'; # Update POD, too!!!!!

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" . <<'__';

BEGIN { $constant::lexical::{lexsubs} = \($] >= 5.022) }

if (lexsubs) {
 require XSLoader;
  XSLoader::load(__PACKAGE__, $VERSION);
}
else {
 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 } });
  }
  if (lexsubs) {