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