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