Commit | Line | Data |
db9fc237 |
1 | package Mouse::Exporter; |
2 | use strict; |
3 | use warnings; |
4 | |
5 | use Carp qw(confess); |
6 | |
1bd3c83e |
7 | # it must be "require", because Mouse::Util depends on Mouse::Exporter |
8 | require Mouse::Util; |
db9fc237 |
9 | |
10 | my %SPEC; |
11 | |
1ff34b4c |
12 | my $strict_bits = strict::bits(qw(subs refs vars)); |
13 | |
1bd3c83e |
14 | sub import{ |
15 | $^H |= $strict_bits; # strict->import; |
16 | ${^WARNING_BITS} = $warnings::Bits{all}; # warnings->import; |
17 | return; |
18 | } |
19 | |
db9fc237 |
20 | sub setup_import_methods{ |
21 | my($class, %args) = @_; |
22 | |
23 | my $exporting_package = $args{exporting_package} ||= caller(); |
24 | |
25 | $SPEC{$exporting_package} = \%args; |
26 | |
27 | # canonicalize args |
28 | my @export_from; |
29 | if($args{also}){ |
30 | my %seen; |
31 | my @stack = ($exporting_package); |
32 | |
33 | while(my $current = shift @stack){ |
34 | push @export_from, $current; |
35 | |
36 | my $also = $SPEC{$current}{also} or next; |
37 | push @stack, grep{ !$seen{$_}++ } @{ $also }; |
38 | } |
39 | } |
40 | else{ |
41 | @export_from = ($exporting_package); |
42 | } |
43 | |
44 | { |
45 | my %exports; |
46 | my @removables; |
4ee3190e |
47 | my @all; |
db9fc237 |
48 | |
1ff34b4c |
49 | my @init_meta_methods; |
50 | |
db9fc237 |
51 | foreach my $package(@export_from){ |
52 | my $spec = $SPEC{$package} or next; |
53 | |
54 | if(my $as_is = $spec->{as_is}){ |
55 | foreach my $thingy (@{$as_is}){ |
4ee3190e |
56 | my($code_package, $code_name, $code); |
db9fc237 |
57 | |
58 | if(ref($thingy)){ |
db9fc237 |
59 | $code = $thingy; |
1bd3c83e |
60 | ($code_package, $code_name) = Mouse::Util::get_code_info($code); |
db9fc237 |
61 | } |
62 | else{ |
63 | no strict 'refs'; |
4ee3190e |
64 | $code_package = $package; |
65 | $code_name = $thingy; |
66 | $code = \&{ $code_package . '::' . $code_name }; |
db9fc237 |
67 | } |
68 | |
4ee3190e |
69 | push @all, $code_name; |
70 | $exports{$code_name} = $code; |
71 | if($code_package eq $package){ |
72 | push @removables, $code_name; |
73 | } |
db9fc237 |
74 | } |
75 | } |
1ff34b4c |
76 | |
77 | if(my $init_meta = $package->can('init_meta')){ |
78 | if(!grep{ $_ == $init_meta } @init_meta_methods){ |
79 | unshift @init_meta_methods, $init_meta; |
80 | } |
81 | } |
db9fc237 |
82 | } |
83 | $args{EXPORTS} = \%exports; |
84 | $args{REMOVABLES} = \@removables; |
85 | |
1bd3c83e |
86 | $args{groups}{all} ||= \@all; |
1ff34b4c |
87 | |
1bd3c83e |
88 | if(my $default_list = $args{groups}{default}){ |
1ff34b4c |
89 | my %default; |
90 | foreach my $keyword(@{$default_list}){ |
91 | $default{$keyword} = $exports{$keyword} |
92 | || confess(qq{The $exporting_package package does not export "$keyword"}); |
93 | } |
94 | $args{DEFAULT} = \%default; |
95 | } |
96 | else{ |
1bd3c83e |
97 | $args{groups}{default} ||= \@all; |
98 | $args{DEFAULT} = $args{EXPORTS}; |
1ff34b4c |
99 | } |
100 | |
101 | if(@init_meta_methods){ |
102 | $args{INIT_META} = \@init_meta_methods; |
103 | } |
db9fc237 |
104 | } |
105 | |
106 | no strict 'refs'; |
107 | |
108 | *{$exporting_package . '::import'} = \&do_import; |
109 | *{$exporting_package . '::unimport'} = \&do_unimport; |
110 | |
db9fc237 |
111 | return; |
112 | } |
113 | |
db9fc237 |
114 | |
115 | # the entity of general import() |
116 | sub do_import { |
1ff34b4c |
117 | my($package, @args) = @_; |
db9fc237 |
118 | |
1ff34b4c |
119 | my $spec = $SPEC{$package} |
120 | || confess("The package $package package does not use Mouse::Exporter"); |
db9fc237 |
121 | |
122 | my $into = _get_caller_package(ref($args[0]) ? shift @args : undef); |
123 | |
124 | my @exports; |
125 | foreach my $arg(@args){ |
1ff34b4c |
126 | if($arg =~ s/^-//){ |
1bd3c83e |
127 | Mouse::Util::not_supported("-$arg"); |
1ff34b4c |
128 | } |
129 | elsif($arg =~ s/^://){ |
1bd3c83e |
130 | my $group = $spec->{groups}{$arg} |
1ff34b4c |
131 | || confess(qq{The $package package does not export the group "$arg"}); |
db9fc237 |
132 | push @exports, @{$group}; |
133 | } |
134 | else{ |
135 | push @exports, $arg; |
136 | } |
137 | } |
138 | |
1ff34b4c |
139 | $^H |= $strict_bits; # strict->import; |
140 | ${^WARNING_BITS} = $warnings::Bits{all}; # warnings->import; |
db9fc237 |
141 | |
142 | if($into eq 'main' && !$spec->{_not_export_to_main}){ |
1ff34b4c |
143 | warn qq{$package does not export its sugar to the 'main' package.\n}; |
db9fc237 |
144 | return; |
145 | } |
146 | |
1ff34b4c |
147 | if($spec->{INIT_META}){ |
148 | foreach my $init_meta(@{$spec->{INIT_META}}){ |
149 | $into->$init_meta(for_class => $into); |
150 | } |
db9fc237 |
151 | |
1ff34b4c |
152 | # _apply_meta_traits($into); # TODO |
db9fc237 |
153 | } |
154 | |
1ff34b4c |
155 | if(@exports){ |
156 | foreach my $keyword(@exports){ |
157 | no strict 'refs'; |
158 | *{$into.'::'.$keyword} = $spec->{EXPORTS}{$keyword} |
159 | || confess(qq{The $package package does not export "$keyword"}); |
160 | } |
161 | } |
162 | else{ |
163 | my $default = $spec->{DEFAULT}; |
164 | while(my($keyword, $code) = each %{$default}){ |
165 | no strict 'refs'; |
166 | *{$into.'::'.$keyword} = $code; |
167 | } |
db9fc237 |
168 | } |
169 | return; |
170 | } |
171 | |
172 | # the entity of general unimport() |
173 | sub do_unimport { |
1ff34b4c |
174 | my($package, $arg) = @_; |
db9fc237 |
175 | |
1ff34b4c |
176 | my $spec = $SPEC{$package} |
177 | || confess("The package $package does not use Mouse::Exporter"); |
db9fc237 |
178 | |
179 | my $from = _get_caller_package($arg); |
180 | |
181 | my $stash = do{ |
182 | no strict 'refs'; |
183 | \%{$from . '::'} |
184 | }; |
185 | |
186 | for my $keyword (@{ $spec->{REMOVABLES} }) { |
4ee3190e |
187 | my $gv = \$stash->{$keyword}; |
188 | if(ref($gv) eq 'GLOB' && *{$gv}{CODE} == $spec->{EXPORTS}{$keyword}){ # make sure it is from us |
189 | delete $stash->{$keyword}; |
190 | } |
db9fc237 |
191 | } |
192 | return; |
193 | } |
194 | |
195 | sub _get_caller_package { |
196 | my($arg) = @_; |
197 | |
198 | # 2 extra level because it's called by import so there's a layer\r |
199 | # of indirection\r |
200 | my $offset = 1;\r |
201 | |
202 | if(ref $arg){ |
203 | return defined($arg->{into}) ? $arg->{into} |
204 | : defined($arg->{into_level}) ? scalar caller($offset + $arg->{into_level}) |
205 | : scalar caller($offset); |
206 | } |
207 | else{ |
208 | return scalar caller($offset); |
209 | } |
210 | } |
211 | |
212 | 1; |
213 | |
214 | __END__ |
215 | |
216 | =head1 NAME |
217 | |
218 | Mouse - The Mouse Exporter |
219 | |
220 | =head1 SYNOPSIS |
221 | |
222 | package MouseX::Foo; |
223 | use Mouse::Exporter; |
224 | |
225 | Mouse::Exporter->setup_import_methods( |
226 | |
227 | ); |
228 | |
229 | =head1 DESCRIPTION |
230 | |
231 | |
232 | =head1 SEE ALSO |
233 | |
234 | L<Moose::Exporter> |
235 | |
236 | =cut |