File Coverage

blib/lib/Perl6/Export/Attrs.pm
Criterion Covered Total %
statement 13 15 86.6
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 18 20 90.0


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__