line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Export::Lexical; |
2
|
|
|
|
|
|
|
|
3
|
3
|
|
|
3
|
|
88373
|
use 5.010; |
|
3
|
|
|
|
|
12
|
|
4
|
3
|
|
|
3
|
|
14
|
use strict; |
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
64
|
|
5
|
3
|
|
|
3
|
|
15
|
use warnings; |
|
3
|
|
|
|
|
10
|
|
|
3
|
|
|
|
|
71
|
|
6
|
3
|
|
|
3
|
|
15
|
use B; |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
138
|
|
7
|
3
|
|
|
3
|
|
15
|
use Carp; |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
1320
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
our $VERSION = '0.0.6'; |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
my %exports_for = (); |
12
|
|
|
|
|
|
|
my %modifier_for = (); # e.g., $modifier_for{$pkg} = 'silent' |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
sub MODIFY_CODE_ATTRIBUTES { |
15
|
6
|
|
|
6
|
|
7344
|
my ( $package, $coderef, @attrs ) = @_; |
16
|
|
|
|
|
|
|
|
17
|
6
|
|
|
|
|
11
|
my @unused_attrs = (); |
18
|
|
|
|
|
|
|
|
19
|
6
|
|
|
|
|
21
|
while ( my $attr = shift @attrs ) { |
20
|
6
|
50
|
|
|
|
39
|
if ( $attr =~ /^Export_?Lexical$/i ) { |
21
|
6
|
|
|
|
|
11
|
push @{ $exports_for{$package} }, $coderef; |
|
6
|
|
|
|
|
27
|
|
22
|
|
|
|
|
|
|
} |
23
|
|
|
|
|
|
|
else { |
24
|
0
|
|
|
|
|
0
|
push @unused_attrs, $attr; |
25
|
|
|
|
|
|
|
} |
26
|
|
|
|
|
|
|
} |
27
|
|
|
|
|
|
|
|
28
|
6
|
|
|
|
|
17
|
return @unused_attrs; |
29
|
|
|
|
|
|
|
} |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
sub import { |
32
|
3
|
|
|
3
|
|
26
|
my ($class) = @_; |
33
|
|
|
|
|
|
|
|
34
|
3
|
|
|
|
|
13
|
my $caller = caller; |
35
|
3
|
|
|
|
|
41
|
my $key = _get_key($caller); |
36
|
3
|
|
|
|
|
6
|
my @params = (); |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
{ |
39
|
|
|
|
|
|
|
# Export our subroutines, if necessary. |
40
|
3
|
|
|
3
|
|
17
|
no strict 'refs'; ## no critic (ProhibitNoStrict) |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
1425
|
|
|
3
|
|
|
|
|
5
|
|
41
|
|
|
|
|
|
|
|
42
|
3
|
50
|
|
|
|
5
|
if ( !exists &{ $caller . '::MODIFY_CODE_ATTRIBUTES' } ) { |
|
3
|
|
|
|
|
21
|
|
43
|
3
|
|
|
|
|
7
|
*{ $caller . '::MODIFY_CODE_ATTRIBUTES' } = \&MODIFY_CODE_ATTRIBUTES; |
|
3
|
|
|
|
|
16
|
|
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
|
46
|
3
|
50
|
|
|
|
14
|
if ( !exists &{ $caller . '::import' } ) { |
|
3
|
|
|
|
|
14
|
|
47
|
3
|
|
|
|
|
13
|
*{ $caller . '::import' } = sub { |
48
|
3
|
|
|
3
|
|
362
|
my ( $class, @args ) = @_; |
49
|
|
|
|
|
|
|
|
50
|
3
|
|
|
|
|
14
|
_export_all_to( $caller, scalar caller ); |
51
|
|
|
|
|
|
|
|
52
|
3
|
50
|
|
|
|
196
|
$^H{$key} = @args ? ( join ',', @args ) : 1; ## no critic (ProhibitPunctuationVars, RequireLocalizedPunctuationVars) |
53
|
3
|
|
|
|
|
16
|
}; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
|
56
|
3
|
50
|
|
|
|
5
|
if ( !exists &{ $caller . '::unimport' } ) { |
|
3
|
|
|
|
|
15
|
|
57
|
3
|
|
|
|
|
14
|
*{ $caller . '::unimport' } = sub { |
58
|
6
|
|
|
6
|
|
39
|
my ( $class, @args ) = @_; |
59
|
|
|
|
|
|
|
|
60
|
6
|
100
|
|
|
|
19
|
if ( @args ) { |
61
|
|
|
|
|
|
|
# Leave the '1' on the front of the list from a previous 'use |
62
|
|
|
|
|
|
|
# $module', as well as any subs previously imported. |
63
|
3
|
|
|
|
|
8
|
$^H{$key} = join ',', $^H{$key}, map { "!$_" } @args; ## no critic (ProhibitPunctuationVars, RequireLocalizedPunctuationVars) |
|
3
|
|
|
|
|
4652
|
|
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
else { |
66
|
3
|
|
|
|
|
324
|
$^H{$key} = ''; ## no critic (ProhibitPunctuationVars, RequireLocalizedPunctuationVars) |
67
|
|
|
|
|
|
|
} |
68
|
3
|
|
|
|
|
11
|
}; |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
|
72
|
3
|
|
|
|
|
12
|
while ( my $modifier = shift ) { |
73
|
5
|
100
|
|
|
|
25
|
if ( $modifier =~ /^:(silent|warn)$/ ) { |
74
|
|
|
|
|
|
|
croak qq('$modifier' requested when '$modifier_for{$caller}' already in use) |
75
|
2
|
50
|
|
|
|
6
|
if $modifier_for{$caller}; |
76
|
|
|
|
|
|
|
|
77
|
2
|
|
|
|
|
4
|
$modifier_for{$caller} = $modifier; |
78
|
2
|
|
|
|
|
72
|
next; |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
3
|
|
|
|
|
51
|
push @params, $modifier; |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
sub _export_all_to { |
86
|
3
|
|
|
3
|
|
35
|
my ( $from, $caller ) = @_; |
87
|
|
|
|
|
|
|
|
88
|
3
|
50
|
|
|
|
14
|
return if !exists $exports_for{$from}; |
89
|
|
|
|
|
|
|
|
90
|
3
|
|
|
|
|
5
|
for my $ref ( @{ $exports_for{$from} } ) { |
|
3
|
|
|
|
|
9
|
|
91
|
6
|
|
|
|
|
33
|
my $obj = B::svref_2object($ref); |
92
|
6
|
|
|
|
|
57
|
my $pkg = $obj->GV->STASH->NAME; |
93
|
6
|
|
|
|
|
134
|
my $sub = $obj->GV->NAME; |
94
|
6
|
|
|
|
|
17
|
my $key = _get_key($pkg); |
95
|
|
|
|
|
|
|
|
96
|
3
|
|
|
3
|
|
16
|
no strict 'refs'; ## no critic (ProhibitNoStrict) |
|
3
|
|
|
|
|
5
|
|
|
3
|
|
|
|
|
86
|
|
97
|
3
|
|
|
3
|
|
14
|
no warnings 'redefine'; ## no critic (ProhibitNoWarnings) |
|
3
|
|
|
|
|
6
|
|
|
3
|
|
|
|
|
935
|
|
98
|
|
|
|
|
|
|
|
99
|
6
|
50
|
|
|
|
8
|
next if exists &{ $caller . '::' . $sub }; |
|
6
|
|
|
|
|
28
|
|
100
|
|
|
|
|
|
|
|
101
|
6
|
|
|
|
|
71
|
*{ $caller . '::' . $sub } = sub { |
102
|
24
|
|
|
24
|
|
11265
|
my $hints = ( caller 0 )[10]; |
103
|
|
|
|
|
|
|
|
104
|
24
|
100
|
|
|
|
1056
|
return _fail( $pkg, $sub ) if $hints->{$key} =~ /(?:^$)|(?:!$sub\b)/; # no $module |
105
|
|
|
|
|
|
|
# no $module '$sub' |
106
|
|
|
|
|
|
|
|
107
|
15
|
50
|
|
|
|
323
|
goto $ref if $hints->{$key} =~ /(?:^1\b)|(?:\b$sub\b)/; # use $module |
108
|
|
|
|
|
|
|
# use $module '$sub' |
109
|
6
|
|
|
|
|
31
|
}; |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
sub _fail { |
114
|
9
|
|
|
9
|
|
23
|
my ( $pkg, $sub ) = @_; |
115
|
|
|
|
|
|
|
|
116
|
9
|
100
|
|
|
|
36
|
if ( defined $modifier_for{$pkg} ) { |
117
|
6
|
100
|
|
|
|
20
|
if ( $modifier_for{$pkg} eq ':silent' ) { |
118
|
3
|
|
|
|
|
17
|
return; |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
3
|
50
|
|
|
|
9
|
if ( $modifier_for{$pkg} eq ':warn' ) { |
122
|
3
|
|
|
|
|
41
|
carp "$pkg\::$sub not allowed here"; |
123
|
3
|
|
|
|
|
2047
|
return; |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
|
127
|
3
|
|
|
|
|
54
|
croak "$pkg\::$sub not allowed here"; |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
|
130
|
|
|
|
|
|
|
sub _get_key { |
131
|
9
|
|
|
9
|
|
16
|
my ( $pkg ) = @_; |
132
|
|
|
|
|
|
|
|
133
|
9
|
|
|
|
|
27
|
return __PACKAGE__ . '/' . $pkg; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
1; |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
__END__ |