File Coverage

blib/lib/constant/lexical.pm
Criterion Covered Total %
statement 25 38 65.7
branch 8 22 36.3
condition 3 6 50.0
subroutine 5 7 71.4
pod n/a
total 41 73 56.1


line stmt bran cond sub pod time code
1 2     2   13196 use 5.008;
  2         4  
2              
3             package constant::lexical;
4              
5             our $VERSION = '2.0003'; # Update POD, too!!!!!
6              
7             my $old = '#line ' . (__LINE__+1) . " " . __FILE__ . "\n" . <<'__';
8              
9             no constant 1.03 ();
10             use constant hufh => eval 'require Hash::Util::FieldHash';
11             use Sub::Delete;
12             BEGIN {
13             0+$] eq 5.01
14             and VERSION Sub::Delete >= .03
15             and VERSION Sub::Delete 1.00001 # %^H scoping bug
16             }
17             hufh and eval '
18             Hash::Util::FieldHash::fieldhash %hh;
19             use Tie::Hash;
20             {
21             package constant::lexical::_hhfh;
22             @ISA = "Tie::StdHash";
23             sub DELETE { constant::lexical::DESTROY(SUPER::DELETE{@_}) }
24             }
25             tie %hh, constant::lexical::_hhfh::;;
26             ';
27              
28             sub import {
29             $^H |= 0x20000; # magic incantation to make %^H work before 5.10
30             shift;
31             return unless @ '_;
32             my @const = @_ == 1 && ref $_[0] eq 'HASH' ? keys %{$_[0]} : $_[0];
33             my $stashname = caller()."::"; my $stash = \%$stashname;
34             push @{hufh ? $hh{\%^H} ||= [] : ($^H{+__PACKAGE__} ||= bless[])},
35             map {
36             my $fqname = "$stashname$_"; my $ref;
37             if(exists $$stash{$_} && defined $$stash{$_}) {
38             $ref = ref $$stash{$_} eq 'SCALAR'
39             ? $$stash{$_}
40             : *$fqname{CODE};
41             delete_sub($fqname);
42             }
43             [$fqname, $stashname, $_, $ref]
44             } @const;
45             unshift @_, 'constant';
46             goto &{can constant 'import'}
47             }
48              
49             sub DESTROY { for(@{+shift}) {
50             delete_sub(my $fqname = $$_[0]);
51             next unless defined (my $ref = $$_[-1]);
52             ref $ref eq 'SCALAR' or *$fqname = $ref, next;
53             my $stash = \%{$$_[1]}; my $subname = $$_[2];
54             if(exists $$stash{$subname} &&defined $$stash{$subname}) {
55             my $val = $$ref;
56             *$fqname = sub(){$val}
57             } else { $$stash{$subname} = $ref }
58             }}
59              
60             1;
61             __
62              
63             my $new = '#line ' . (__LINE__+1) . " " . __FILE__ . "\n" . <<'__';
64              
65 2     2   1680 BEGIN { $constant::lexical::{lexsubs} = \($] >= 5.022) }
66              
67             if (lexsubs) {
68             require XSLoader;
69             XSLoader::load(__PACKAGE__, $VERSION);
70             }
71             else {
72             require Lexical'Sub;
73             }
74              
75             sub import {
76 11     11   3088 shift;
77 11 100       48 return unless @ '_;
78 10         7 my @args;
79 10 100 66     34 if(@_ == 1 && ref $_[0] eq 'HASH') {
    100          
80 1         1 _validate(keys %{$_[0]});
  1         5  
81 1         1 while(my($k,$v) = each %{$_[0]}) {
  3         8  
82 2     0   10 push @args, $k, sub(){ $v };
  0         0  
83             }
84             }
85             elsif(@_ == 2) {
86 8         14 _validate($_[0]);
87 8         8 my $v = pop;
88 8     0   55 @args = ($_[0], sub(){ $v });
  0         0  
89             }
90             else {
91 1         2 _validate($_[0]);
92 1     1   1 @args = (shift, do { my @v = @'_; sub(){ @v } });
  1         1  
  1         4  
  1         689  
93             }
94 10         9 if (lexsubs) {
95 10         79 install_lexical_sub(splice @args, 0, 2) while @args;
96             }
97             else {
98             import Lexical'Sub @args;
99             }
100             _:
101             }
102              
103             # Plagiarised from constant.pm
104              
105             # Some names are evil choices.
106             my %keywords
107             = map +($_, 1), qw{ BEGIN INIT CHECK END DESTROY AUTOLOAD UNITCHECK };
108              
109             my $normal_constant_name = qr/^_?[^\W_0-9]\w*\z/;
110             my $tolerable = qr/^[A-Za-z_]\w*\z/;
111             my $boolean = qr/^[01]?\z/;
112              
113             sub _validate {
114 10     10   14 for(@_) {
115 11 50       18 defined or require Carp, Carp'croak("Can't use undef as constant name");
116             # Normal constant name
117 11 50 33     87 if (/$normal_constant_name/ and !$keywords{$_}) {
    0          
    0          
    0          
118             # Everything is okay
119              
120             # Starts with double underscore. Fatal.
121             } elsif (/^__/) {
122 0           require Carp;
123 0           Carp::croak("Constant name '$_' begins with '__'");
124              
125             # Maybe the name is tolerable
126             } elsif (/$tolerable/) {
127             # Then we'll warn only if you've asked for warnings
128 0 0         if (warnings::enabled()) {
129 0 0         if ($keywords{$_}) {
130 0           warnings::warn("Constant name '$_' is a Perl keyword");
131             }
132             }
133              
134             # Looks like a boolean
135             # use constant FRED == fred;
136             } elsif (/$boolean/) {
137 0           require Carp;
138 0 0         if (@_) {
139 0           Carp::croak("Constant name '$_' is invalid");
140             } else {
141 0           Carp::croak("Constant name looks like boolean value");
142             }
143              
144             } else {
145             # Must have bad characters
146 0           require Carp;
147 0           Carp::croak("Constant name '$_' has invalid characters");
148             }
149             }
150             }
151              
152             1;
153             __
154              
155             eval($] < 5.011002 ? $old : $new) or die $@;
156              
157             __END__