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