Commit | Line | Data |
38bf2a25 |
1 | |
2 | package Class::MOP::Package; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
0db1c8dc |
7 | use Scalar::Util 'blessed', 'reftype', 'weaken'; |
38bf2a25 |
8 | use Carp 'confess'; |
0db1c8dc |
9 | use Devel::GlobalDestruction 'in_global_destruction'; |
38bf2a25 |
10 | use Package::Stash; |
11 | |
38bf2a25 |
12 | use base 'Class::MOP::Object'; |
13 | |
14 | # creation ... |
15 | |
16 | sub initialize { |
17 | my ( $class, @args ) = @_; |
18 | |
19 | unshift @args, "package" if @args % 2; |
20 | |
21 | my %options = @args; |
0db1c8dc |
22 | my $package_name = delete $options{package}; |
38bf2a25 |
23 | |
24 | |
064a13a3 |
25 | # we hand-construct the class until we can bootstrap it |
38bf2a25 |
26 | if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) { |
27 | return $meta; |
28 | } else { |
29 | my $meta = ( ref $class || $class )->_new({ |
30 | 'package' => $package_name, |
31 | %options, |
32 | }); |
33 | Class::MOP::store_metaclass_by_name($package_name, $meta); |
34 | |
0db1c8dc |
35 | Class::MOP::weaken_metaclass($package_name) if $options{weaken}; |
36 | |
37 | |
38bf2a25 |
38 | return $meta; |
39 | } |
40 | } |
41 | |
42 | sub reinitialize { |
43 | my ( $class, @args ) = @_; |
44 | |
45 | unshift @args, "package" if @args % 2; |
46 | |
47 | my %options = @args; |
48 | my $package_name = delete $options{package}; |
49 | |
50 | (defined $package_name && $package_name |
51 | && (!blessed $package_name || $package_name->isa('Class::MOP::Package'))) |
52 | || confess "You must pass a package name or an existing Class::MOP::Package instance"; |
53 | |
54 | $package_name = $package_name->name |
55 | if blessed $package_name; |
56 | |
57 | Class::MOP::remove_metaclass_by_name($package_name); |
58 | |
59 | $class->initialize($package_name, %options); # call with first arg form for compat |
60 | } |
61 | |
0db1c8dc |
62 | sub create { |
63 | my $class = shift; |
64 | my @args = @_; |
65 | |
66 | return $class->initialize(@args); |
67 | } |
68 | |
69 | ## ANON packages |
70 | |
71 | { |
72 | # NOTE: |
73 | # this should be sufficient, if you have a |
74 | # use case where it is not, write a test and |
75 | # I will change it. |
76 | my $ANON_SERIAL = 0; |
77 | |
78 | my %ANON_PACKAGE_CACHE; |
79 | |
80 | # NOTE: |
81 | # we need a sufficiently annoying prefix |
82 | # this should suffice for now, this is |
83 | # used in a couple of places below, so |
84 | # need to put it up here for now. |
85 | sub _anon_package_prefix { 'Class::MOP::Package::__ANON__::SERIAL::' } |
86 | |
87 | sub is_anon { |
88 | my $self = shift; |
89 | no warnings 'uninitialized'; |
90 | my $prefix = $self->_anon_package_prefix; |
9520ee8e |
91 | $self->name =~ /^\Q$prefix/; |
0db1c8dc |
92 | } |
93 | |
94 | sub create_anon { |
95 | my ($class, %options) = @_; |
96 | |
97 | my $cache_ok = delete $options{cache}; |
85db9063 |
98 | $options{weaken} = !$cache_ok unless exists $options{weaken}; |
0db1c8dc |
99 | |
4f629382 |
100 | my $cache_key; |
101 | if ($cache_ok) { |
102 | $cache_key = $class->_anon_cache_key(%options); |
83dcb866 |
103 | undef $cache_ok if !defined($cache_key); |
104 | } |
0db1c8dc |
105 | |
83dcb866 |
106 | if ($cache_ok) { |
4f629382 |
107 | if (defined $ANON_PACKAGE_CACHE{$cache_key}) { |
108 | return $ANON_PACKAGE_CACHE{$cache_key}; |
109 | } |
0db1c8dc |
110 | } |
111 | |
0db1c8dc |
112 | my $package_name = $class->_anon_package_prefix . ++$ANON_SERIAL; |
113 | |
114 | my $meta = $class->create($package_name, %options); |
115 | |
116 | if ($cache_ok) { |
117 | $ANON_PACKAGE_CACHE{$cache_key} = $meta; |
118 | weaken($ANON_PACKAGE_CACHE{$cache_key}); |
119 | } |
120 | |
121 | return $meta; |
122 | } |
123 | |
124 | sub _anon_cache_key { confess "Packages are not cacheable" } |
125 | |
126 | sub DESTROY { |
127 | my $self = shift; |
128 | |
129 | return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated |
130 | |
131 | $self->_free_anon |
132 | if $self->is_anon; |
133 | } |
134 | |
135 | sub _free_anon { |
136 | my $self = shift; |
137 | my $name = $self->name; |
138 | |
139 | # Moose does a weird thing where it replaces the metaclass for |
140 | # class when fixing metaclass incompatibility. In that case, |
141 | # we don't want to clean out the namespace now. We can detect |
142 | # that because Moose will explicitly update the singleton |
4f9d7bba |
143 | # cache in Class::MOP using store_metaclass_by_name, which |
144 | # means that the new metaclass will already exist in the cache |
145 | # by this point. |
146 | # The other options here are that $current_meta can be undef if |
147 | # remove_metaclass_by_name is called explicitly (since the hash |
148 | # entry is removed first, and then this destructor is called), |
149 | # or that $current_meta can be the same as $self, which happens |
150 | # when the metaclass goes out of scope (since the weak reference |
151 | # in the metaclass cache won't be freed until after this |
152 | # destructor runs). |
0db1c8dc |
153 | my $current_meta = Class::MOP::get_metaclass_by_name($name); |
4f9d7bba |
154 | return if defined($current_meta) && $current_meta ne $self; |
0db1c8dc |
155 | |
156 | my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/); |
157 | |
158 | no strict 'refs'; |
bc8d31d0 |
159 | # clear @ISA first, to avoid a memory leak |
160 | # see https://rt.perl.org/rt3/Public/Bug/Display.html?id=92708 |
0db1c8dc |
161 | @{$name . '::ISA'} = (); |
162 | %{$name . '::'} = (); |
163 | delete ${$first_fragments . '::'}{$last_fragment . '::'}; |
164 | |
165 | Class::MOP::remove_metaclass_by_name($name); |
166 | } |
167 | |
168 | } |
169 | |
38bf2a25 |
170 | sub _new { |
171 | my $class = shift; |
172 | |
173 | return Class::MOP::Class->initialize($class)->new_object(@_) |
174 | if $class ne __PACKAGE__; |
175 | |
176 | my $params = @_ == 1 ? $_[0] : {@_}; |
177 | |
178 | return bless { |
9c1bf11e |
179 | # Need to quote package to avoid a problem with PPI mis-parsing this |
180 | # as a package statement. |
181 | 'package' => $params->{package}, |
38bf2a25 |
182 | |
183 | # NOTE: |
184 | # because of issues with the Perl API |
185 | # to the typeglob in some versions, we |
186 | # need to just always grab a new |
187 | # reference to the hash in the accessor. |
188 | # Ideally we could just store a ref and |
189 | # it would Just Work, but oh well :\ |
190 | |
191 | namespace => \undef, |
192 | |
193 | } => $class; |
194 | } |
195 | |
196 | # Attributes |
197 | |
198 | # NOTE: |
064a13a3 |
199 | # all these attribute readers will be bootstrapped |
38bf2a25 |
200 | # away in the Class::MOP bootstrap section |
201 | |
202 | sub _package_stash { |
203 | $_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name) |
204 | } |
205 | sub namespace { |
206 | $_[0]->_package_stash->namespace |
207 | } |
208 | |
209 | # Class attributes |
210 | |
211 | # ... these functions have to touch the symbol table itself,.. yuk |
212 | |
213 | sub add_package_symbol { |
214 | my $self = shift; |
215 | $self->_package_stash->add_symbol(@_); |
216 | } |
217 | |
218 | sub remove_package_glob { |
219 | my $self = shift; |
220 | $self->_package_stash->remove_glob(@_); |
221 | } |
222 | |
223 | # ... these functions deal with stuff on the namespace level |
224 | |
225 | sub has_package_symbol { |
226 | my $self = shift; |
227 | $self->_package_stash->has_symbol(@_); |
228 | } |
229 | |
230 | sub get_package_symbol { |
231 | my $self = shift; |
232 | $self->_package_stash->get_symbol(@_); |
233 | } |
234 | |
235 | sub get_or_add_package_symbol { |
236 | my $self = shift; |
237 | $self->_package_stash->get_or_add_symbol(@_); |
238 | } |
239 | |
240 | sub remove_package_symbol { |
241 | my $self = shift; |
242 | $self->_package_stash->remove_symbol(@_); |
243 | } |
244 | |
245 | sub list_all_package_symbols { |
246 | my $self = shift; |
247 | $self->_package_stash->list_all_symbols(@_); |
248 | } |
249 | |
250 | sub get_all_package_symbols { |
251 | my $self = shift; |
252 | $self->_package_stash->get_all_symbols(@_); |
253 | } |
254 | |
255 | 1; |
256 | |
257 | # ABSTRACT: Package Meta Object |
258 | |
259 | __END__ |
260 | |
261 | =pod |
262 | |
263 | =head1 DESCRIPTION |
264 | |
265 | The Package Protocol provides an abstraction of a Perl 5 package. A |
266 | package is basically namespace, and this module provides methods for |
267 | looking at and changing that namespace's symbol table. |
268 | |
269 | =head1 METHODS |
270 | |
271 | =over 4 |
272 | |
57272677 |
273 | =item B<< Class::MOP::Package->initialize($package_name, %options) >> |
38bf2a25 |
274 | |
275 | This method creates a new C<Class::MOP::Package> instance which |
276 | represents specified package. If an existing metaclass object exists |
57272677 |
277 | for the package, that will be returned instead. No options are valid at the |
278 | package level. |
38bf2a25 |
279 | |
57272677 |
280 | =item B<< Class::MOP::Package->reinitialize($package, %options) >> |
38bf2a25 |
281 | |
282 | This method forcibly removes any existing metaclass for the package |
283 | before calling C<initialize>. In contrast to C<initialize>, you may |
284 | also pass an existing C<Class::MOP::Package> instance instead of just |
285 | a package name as C<$package>. |
286 | |
287 | Do not call this unless you know what you are doing. |
288 | |
57272677 |
289 | =item B<< Class::MOP::Package->create($package, %options) >> |
290 | |
291 | Creates a new C<Class::MOP::Package> instance which represents the specified |
292 | package, and also does some initialization of that package. Currently, this |
293 | just does the same thing as C<initialize>, but is overridden in subclasses, |
294 | such as C<Class::MOP::Class>. |
295 | |
296 | =item B<< Class::MOP::Package->create_anon(%options) >> |
297 | |
298 | Creates a new anonymous package. Valid keys for C<%options> are: |
299 | |
300 | =over 4 |
301 | |
302 | =item C<weaken> |
303 | |
304 | If this is true (the default), the instance stored in C<Class::MOP>'s metaclass |
305 | cache will be weakened, so that the anonymous package will be garbage collected |
306 | when the returned instance goes out of scope. |
307 | |
308 | =back |
309 | |
310 | =item B<< $metapackage->is_anon >> |
311 | |
312 | Returns true if the package is an anonymous package. |
313 | |
38bf2a25 |
314 | =item B<< $metapackage->name >> |
315 | |
316 | This is returns the package's name, as passed to the constructor. |
317 | |
318 | =item B<< $metapackage->namespace >> |
319 | |
320 | This returns a hash reference to the package's symbol table. The keys |
321 | are symbol names and the values are typeglob references. |
322 | |
323 | =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >> |
324 | |
325 | This method accepts a variable name and an optional initial value. The |
326 | C<$variable_name> must contain a leading sigil. |
327 | |
328 | This method creates the variable in the package's symbol table, and |
329 | sets it to the initial value if one was provided. |
330 | |
331 | =item B<< $metapackage->get_package_symbol($variable_name) >> |
332 | |
333 | Given a variable name, this method returns the variable as a reference |
334 | or undef if it does not exist. The C<$variable_name> must contain a |
335 | leading sigil. |
336 | |
337 | =item B<< $metapackage->get_or_add_package_symbol($variable_name) >> |
338 | |
339 | Given a variable name, this method returns the variable as a reference. |
340 | If it does not exist, a default value will be generated if possible. The |
341 | C<$variable_name> must contain a leading sigil. |
342 | |
343 | =item B<< $metapackage->has_package_symbol($variable_name) >> |
344 | |
345 | Returns true if there is a package variable defined for |
346 | C<$variable_name>. The C<$variable_name> must contain a leading sigil. |
347 | |
348 | =item B<< $metapackage->remove_package_symbol($variable_name) >> |
349 | |
350 | This will remove the package variable specified C<$variable_name>. The |
351 | C<$variable_name> must contain a leading sigil. |
352 | |
353 | =item B<< $metapackage->remove_package_glob($glob_name) >> |
354 | |
355 | Given the name of a glob, this will remove that glob from the |
356 | package's symbol table. Glob names do not include a sigil. Removing |
357 | the glob removes all variables and subroutines with the specified |
358 | name. |
359 | |
360 | =item B<< $metapackage->list_all_package_symbols($type_filter) >> |
361 | |
362 | This will list all the glob names associated with the current |
363 | package. These names do not have leading sigils. |
364 | |
365 | You can provide an optional type filter, which should be one of |
366 | 'SCALAR', 'ARRAY', 'HASH', or 'CODE'. |
367 | |
368 | =item B<< $metapackage->get_all_package_symbols($type_filter) >> |
369 | |
370 | This works much like C<list_all_package_symbols>, but it returns a |
371 | hash reference. The keys are glob names and the values are references |
372 | to the value for that name. |
373 | |
374 | =item B<< Class::MOP::Package->meta >> |
375 | |
376 | This will return a L<Class::MOP::Class> instance for this class. |
377 | |
378 | =back |
379 | |
380 | =cut |