line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Perl6::Export::Attrs; |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
our $VERSION = '0.000004'; |
4
|
|
|
|
|
|
|
|
5
|
1
|
|
|
1
|
|
21052
|
use warnings; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
38
|
|
6
|
1
|
|
|
1
|
|
6
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
24
|
|
7
|
1
|
|
|
1
|
|
5
|
use Carp; |
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
94
|
|
8
|
1
|
|
|
1
|
|
985
|
use Attribute::Handlers; |
|
1
|
|
|
|
|
5541
|
|
|
1
|
|
|
|
|
6
|
|
9
|
1
|
|
|
1
|
|
548
|
use PadWalker qw( var_name peek_my ); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
my %IMPORT_for; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
sub import { |
14
|
|
|
|
|
|
|
my $caller = caller; |
15
|
|
|
|
|
|
|
no strict 'refs'; |
16
|
|
|
|
|
|
|
*{$caller.'::import'} = \&_generic_import; |
17
|
|
|
|
|
|
|
*{$caller.'::IMPORT'} = sub (&) { $IMPORT_for{$caller} = shift }; |
18
|
|
|
|
|
|
|
for my $var_type (qw( SCALAR ARRAY HASH CODE )) { |
19
|
|
|
|
|
|
|
*{$caller.'::MODIFY_'.$var_type.'_ATTRIBUTES'} = \&_generic_handler; |
20
|
|
|
|
|
|
|
} |
21
|
|
|
|
|
|
|
return; |
22
|
|
|
|
|
|
|
} |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
my %tagsets_for; |
25
|
|
|
|
|
|
|
my %is_exported_from; |
26
|
|
|
|
|
|
|
my %named_tagsets_for; |
27
|
|
|
|
|
|
|
my %decl_loc_for; |
28
|
|
|
|
|
|
|
my %name_of; |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
my $IDENT = '[^\W\d]\w*'; |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
sub _generic_handler { |
33
|
|
|
|
|
|
|
my ($package, $referent, @attrs) = @_; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
ATTR: |
36
|
|
|
|
|
|
|
for my $attr (@attrs) { |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
($attr||=q{}) =~ s/\A Export (?: \( (.*) \) )? \z/$1||q{}/exms |
39
|
|
|
|
|
|
|
or next ATTR; |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
my @tagsets = grep {length $_} split m/ \s+,?\s* | ,\s* /xms, $attr; |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
my (undef, $file, $line) = caller(1); |
44
|
|
|
|
|
|
|
$file =~ s{.*/}{}xms; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
if (my @bad_tags = grep {!m/\A :$IDENT \z/xms} @tagsets) { |
47
|
|
|
|
|
|
|
die 'Bad tagset', |
48
|
|
|
|
|
|
|
(@bad_tags==1?' ':'s '), |
49
|
|
|
|
|
|
|
"in :Export attribute at '$file' line $line: [@bad_tags]\n"; |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
my $tagsets = $tagsets_for{$package} ||= {}; |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
for my $tagset (@tagsets) { |
55
|
|
|
|
|
|
|
push @{ $tagsets->{$tagset} }, $referent; |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
push @{ $tagsets->{':ALL'} }, $referent; |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
$is_exported_from{$package}{$referent} = 1; |
60
|
|
|
|
|
|
|
$decl_loc_for{$referent} = "$file line $line"; |
61
|
|
|
|
|
|
|
$name_of{$referent} = _get_lexical_name($referent); |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
undef $attr; |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
return grep {defined $_} @attrs; |
68
|
|
|
|
|
|
|
} |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
my %desc_for = ( |
71
|
|
|
|
|
|
|
SCALAR => 'lexical scalar variable', |
72
|
|
|
|
|
|
|
ARRAY => 'lexical array variable', |
73
|
|
|
|
|
|
|
HASH => 'lexical hash variable', |
74
|
|
|
|
|
|
|
CODE => 'anonymous subroutine', |
75
|
|
|
|
|
|
|
); |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
my %hint_for = ( |
78
|
|
|
|
|
|
|
SCALAR => "(declare the variable with 'our' instead of 'my')", |
79
|
|
|
|
|
|
|
ARRAY => "(declare the variable with 'our' instead of 'my')", |
80
|
|
|
|
|
|
|
HASH => "(declare the variable with 'our' instead of 'my')", |
81
|
|
|
|
|
|
|
CODE => "(specify a name after the 'sub' keyword)", |
82
|
|
|
|
|
|
|
); |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
sub _get_lexical_name { |
85
|
|
|
|
|
|
|
my ($var_ref) = @_; |
86
|
|
|
|
|
|
|
return if ref $var_ref eq 'CODE'; |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
SEARCH: |
89
|
|
|
|
|
|
|
for my $up_level (1..(~0>>1)-1) { |
90
|
|
|
|
|
|
|
my $sym_tab_ref = eval { peek_my($up_level) } |
91
|
|
|
|
|
|
|
or last SEARCH; |
92
|
|
|
|
|
|
|
|
93
|
|
|
|
|
|
|
for my $var_name (keys %{$sym_tab_ref}) { |
94
|
|
|
|
|
|
|
return $var_name if $var_ref == $sym_tab_ref->{$var_name}; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
return; |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
sub _invert_tagset { |
101
|
|
|
|
|
|
|
my ($package, $tagset) = @_; |
102
|
|
|
|
|
|
|
my %inverted_tagset; |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
for my $tag (keys %{$tagset}) { |
105
|
|
|
|
|
|
|
for my $sub_ref (@{$tagset->{$tag}}) { |
106
|
|
|
|
|
|
|
my $type = ref $sub_ref; |
107
|
|
|
|
|
|
|
my $sym = Attribute::Handlers::findsym($package, $sub_ref, $type) |
108
|
|
|
|
|
|
|
|| $name_of{$sub_ref} |
109
|
|
|
|
|
|
|
or die "Can't export $desc_for{$type} ", |
110
|
|
|
|
|
|
|
"at $decl_loc_for{$sub_ref}\n$hint_for{$type}\n"; |
111
|
|
|
|
|
|
|
if (ref $sym) { |
112
|
|
|
|
|
|
|
$sym = *{$sym}{NAME}; |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
$inverted_tagset{$tag}{$sym} = $sub_ref; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
return \%inverted_tagset; |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
my %type_for = qw( $ SCALAR @ ARRAY % HASH ); |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
# Reusable import() subroutine for all packages... |
124
|
|
|
|
|
|
|
sub _generic_import { |
125
|
|
|
|
|
|
|
my $package = shift; |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
my $tagset |
128
|
|
|
|
|
|
|
= $named_tagsets_for{$package} |
129
|
|
|
|
|
|
|
||= _invert_tagset($package, $tagsets_for{$package}); |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
my $is_exported = $is_exported_from{$package}; |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
my $errors; |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
my %request; |
136
|
|
|
|
|
|
|
my $subs_ref; |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
my $args_supplied = @_; |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
my $argno = 0; |
141
|
|
|
|
|
|
|
REQUEST: |
142
|
|
|
|
|
|
|
while ($argno < @_) { |
143
|
|
|
|
|
|
|
my $request = $_[$argno]; |
144
|
|
|
|
|
|
|
if (my ($sub_name) = $request =~ m/\A & ($IDENT) (?:\(\))? \z/xms) { |
145
|
|
|
|
|
|
|
if (exists $request{$sub_name}) { |
146
|
|
|
|
|
|
|
splice @_, $argno, 1; |
147
|
|
|
|
|
|
|
next REQUEST; |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
no strict 'refs'; |
150
|
|
|
|
|
|
|
no warnings 'once'; |
151
|
|
|
|
|
|
|
if (my $sub_ref = *{$package.'::'.$sub_name}{CODE}) { |
152
|
|
|
|
|
|
|
if ($is_exported->{$sub_ref}) { |
153
|
|
|
|
|
|
|
$request{$sub_name} = $sub_ref; |
154
|
|
|
|
|
|
|
splice @_, $argno, 1; |
155
|
|
|
|
|
|
|
next REQUEST; |
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
elsif (my ($sigil, $name) = $request =~ m/\A ([\$\@%])($IDENT) \z/xms) { |
160
|
|
|
|
|
|
|
next REQUEST if exists $request{$sigil.$name}; |
161
|
|
|
|
|
|
|
no strict 'refs'; |
162
|
|
|
|
|
|
|
no warnings 'once'; |
163
|
|
|
|
|
|
|
if (my $var_ref = *{$package.'::'.$name}{$type_for{$sigil}}) { |
164
|
|
|
|
|
|
|
if ($is_exported->{$var_ref}) { |
165
|
|
|
|
|
|
|
$request{$sigil.$name} = $var_ref; |
166
|
|
|
|
|
|
|
splice @_, $argno, 1; |
167
|
|
|
|
|
|
|
next REQUEST; |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
elsif ($request =~ m/\A :$IDENT \z/xms |
172
|
|
|
|
|
|
|
and $subs_ref = $tagset->{$request}) { |
173
|
|
|
|
|
|
|
@request{keys %{$subs_ref}} = values %{$subs_ref}; |
174
|
|
|
|
|
|
|
splice @_, $argno, 1; |
175
|
|
|
|
|
|
|
next REQUEST; |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
$errors .= " $request"; |
178
|
|
|
|
|
|
|
$argno++; |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
# Report unexportable requests... |
182
|
|
|
|
|
|
|
my $real_import = $IMPORT_for{$package}; |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
croak "$package does not export:$errors\nuse $package failed" |
185
|
|
|
|
|
|
|
if $errors && !$real_import; |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
if (!$args_supplied) { |
188
|
|
|
|
|
|
|
%request = %{$tagset->{':DEFAULT'}||={}} |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
my $mandatory = $tagset->{':MANDATORY'} ||= {}; |
192
|
|
|
|
|
|
|
@request{ keys %{$mandatory} } = values %{$mandatory}; |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
my $caller = caller; |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
for my $sub_name (keys %request) { |
197
|
|
|
|
|
|
|
no strict 'refs'; |
198
|
|
|
|
|
|
|
my ($sym_name) = $sub_name =~ m{\A [\$\@&%]? (.*)}xms; |
199
|
|
|
|
|
|
|
*{$caller.'::'.$sym_name} = $request{$sub_name}; |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
if ($real_import) { |
203
|
|
|
|
|
|
|
my $idx=0; |
204
|
|
|
|
|
|
|
while ($idx < @_) { |
205
|
|
|
|
|
|
|
if (defined $_[$idx]) { $idx++ } |
206
|
|
|
|
|
|
|
else { splice @_, $idx, 1 } |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
goto &{$real_import}; |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
return; |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
1; # Magic true value required at end of module |
214
|
|
|
|
|
|
|
__END__ |