2 package Class::MOP::Package;
7 use Scalar::Util 'blessed', 'reftype', 'weaken';
9 use Devel::GlobalDestruction 'in_global_destruction';
12 use base 'Class::MOP::Object';
17 my ( $class, @args ) = @_;
19 unshift @args, "package" if @args % 2;
22 my $package_name = delete $options{package};
25 # we hand-construct the class until we can bootstrap it
26 if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
29 my $meta = ( ref $class || $class )->_new({
30 'package' => $package_name,
33 Class::MOP::store_metaclass_by_name($package_name, $meta);
35 Class::MOP::weaken_metaclass($package_name) if $options{weaken};
43 my ( $class, @args ) = @_;
45 unshift @args, "package" if @args % 2;
48 my $package_name = delete $options{package};
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";
54 $package_name = $package_name->name
55 if blessed $package_name;
57 Class::MOP::remove_metaclass_by_name($package_name);
59 $class->initialize($package_name, %options); # call with first arg form for compat
66 return $class->initialize(@args);
73 # this should be sufficient, if you have a
74 # use case where it is not, write a test and
78 my %ANON_PACKAGE_CACHE;
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::' }
89 no warnings 'uninitialized';
90 my $prefix = $self->_anon_package_prefix;
91 $self->name =~ /^\Q$prefix/;
95 my ($class, %options) = @_;
97 my $cache_ok = delete $options{cache};
98 $options{weaken} = !$cache_ok unless exists $options{weaken};
102 $cache_key = $class->_anon_cache_key(%options);
103 undef $cache_ok if !defined($cache_key);
107 if (defined $ANON_PACKAGE_CACHE{$cache_key}) {
108 return $ANON_PACKAGE_CACHE{$cache_key};
112 my $package_name = $class->_anon_package_prefix . ++$ANON_SERIAL;
114 my $meta = $class->create($package_name, %options);
117 $ANON_PACKAGE_CACHE{$cache_key} = $meta;
118 weaken($ANON_PACKAGE_CACHE{$cache_key});
124 sub _anon_cache_key { confess "Packages are not cacheable" }
129 return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
137 my $name = $self->name;
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
143 # cache in Class::MOP using store_metaclass_by_name, which
144 # means that the new metaclass will already exist in the cache
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
153 my $current_meta = Class::MOP::get_metaclass_by_name($name);
154 return if defined($current_meta) && $current_meta ne $self;
156 my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
159 # clear @ISA first, to avoid a memory leak
160 # see https://rt.perl.org/rt3/Public/Bug/Display.html?id=92708
161 @{$name . '::ISA'} = ();
162 %{$name . '::'} = ();
163 delete ${$first_fragments . '::'}{$last_fragment . '::'};
165 Class::MOP::remove_metaclass_by_name($name);
173 return Class::MOP::Class->initialize($class)->new_object(@_)
174 if $class ne __PACKAGE__;
176 my $params = @_ == 1 ? $_[0] : {@_};
179 # Need to quote package to avoid a problem with PPI mis-parsing this
180 # as a package statement.
181 'package' => $params->{package},
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 :\
199 # all these attribute readers will be bootstrapped
200 # away in the Class::MOP bootstrap section
203 $_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name)
206 $_[0]->_package_stash->namespace
211 # ... these functions have to touch the symbol table itself,.. yuk
213 sub add_package_symbol {
215 $self->_package_stash->add_symbol(@_);
218 sub remove_package_glob {
220 $self->_package_stash->remove_glob(@_);
223 # ... these functions deal with stuff on the namespace level
225 sub has_package_symbol {
227 $self->_package_stash->has_symbol(@_);
230 sub get_package_symbol {
232 $self->_package_stash->get_symbol(@_);
235 sub get_or_add_package_symbol {
237 $self->_package_stash->get_or_add_symbol(@_);
240 sub remove_package_symbol {
242 $self->_package_stash->remove_symbol(@_);
245 sub list_all_package_symbols {
247 $self->_package_stash->list_all_symbols(@_);
250 sub get_all_package_symbols {
252 $self->_package_stash->get_all_symbols(@_);
257 # ABSTRACT: Package Meta Object
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.
273 =item B<< Class::MOP::Package->initialize($package_name, %options) >>
275 This method creates a new C<Class::MOP::Package> instance which
276 represents specified package. If an existing metaclass object exists
277 for the package, that will be returned instead. No options are valid at the
280 =item B<< Class::MOP::Package->reinitialize($package, %options) >>
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>.
287 Do not call this unless you know what you are doing.
289 =item B<< Class::MOP::Package->create($package, %options) >>
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>.
296 =item B<< Class::MOP::Package->create_anon(%options) >>
298 Creates a new anonymous package. Valid keys for C<%options> are:
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.
310 =item B<< $metapackage->is_anon >>
312 Returns true if the package is an anonymous package.
314 =item B<< $metapackage->name >>
316 This is returns the package's name, as passed to the constructor.
318 =item B<< $metapackage->namespace >>
320 This returns a hash reference to the package's symbol table. The keys
321 are symbol names and the values are typeglob references.
323 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
325 This method accepts a variable name and an optional initial value. The
326 C<$variable_name> must contain a leading sigil.
328 This method creates the variable in the package's symbol table, and
329 sets it to the initial value if one was provided.
331 =item B<< $metapackage->get_package_symbol($variable_name) >>
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
337 =item B<< $metapackage->get_or_add_package_symbol($variable_name) >>
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.
343 =item B<< $metapackage->has_package_symbol($variable_name) >>
345 Returns true if there is a package variable defined for
346 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
348 =item B<< $metapackage->remove_package_symbol($variable_name) >>
350 This will remove the package variable specified C<$variable_name>. The
351 C<$variable_name> must contain a leading sigil.
353 =item B<< $metapackage->remove_package_glob($glob_name) >>
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
360 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
362 This will list all the glob names associated with the current
363 package. These names do not have leading sigils.
365 You can provide an optional type filter, which should be one of
366 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
368 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
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.
374 =item B<< Class::MOP::Package->meta >>
376 This will return a L<Class::MOP::Class> instance for this class.