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
26 # until we can bootstrap it
27 if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
30 my $meta = ( ref $class || $class )->_new({
31 'package' => $package_name,
34 Class::MOP::store_metaclass_by_name($package_name, $meta);
36 Class::MOP::weaken_metaclass($package_name) if $options{weaken};
44 my ( $class, @args ) = @_;
46 unshift @args, "package" if @args % 2;
49 my $package_name = delete $options{package};
51 (defined $package_name && $package_name
52 && (!blessed $package_name || $package_name->isa('Class::MOP::Package')))
53 || confess "You must pass a package name or an existing Class::MOP::Package instance";
55 $package_name = $package_name->name
56 if blessed $package_name;
58 Class::MOP::remove_metaclass_by_name($package_name);
60 $class->initialize($package_name, %options); # call with first arg form for compat
67 return $class->initialize(@args);
74 # this should be sufficient, if you have a
75 # use case where it is not, write a test and
79 my %ANON_PACKAGE_CACHE;
82 # we need a sufficiently annoying prefix
83 # this should suffice for now, this is
84 # used in a couple of places below, so
85 # need to put it up here for now.
86 sub _anon_package_prefix { 'Class::MOP::Package::__ANON__::SERIAL::' }
90 no warnings 'uninitialized';
91 my $prefix = $self->_anon_package_prefix;
92 $self->name =~ /^\Q$prefix/;
96 my ($class, %options) = @_;
98 my $cache_ok = delete $options{cache};
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 $options{weaken} = !$cache_ok unless exists $options{weaken};
114 my $package_name = $class->_anon_package_prefix . ++$ANON_SERIAL;
116 my $meta = $class->create($package_name, %options);
119 $ANON_PACKAGE_CACHE{$cache_key} = $meta;
120 weaken($ANON_PACKAGE_CACHE{$cache_key});
126 sub _anon_cache_key { confess "Packages are not cacheable" }
131 return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
139 my $name = $self->name;
141 # Moose does a weird thing where it replaces the metaclass for
142 # class when fixing metaclass incompatibility. In that case,
143 # we don't want to clean out the namespace now. We can detect
144 # that because Moose will explicitly update the singleton
145 # cache in Class::MOP.
146 no warnings 'uninitialized';
147 my $current_meta = Class::MOP::get_metaclass_by_name($name);
148 return if $current_meta ne $self;
150 my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
153 @{$name . '::ISA'} = ();
154 %{$name . '::'} = ();
155 delete ${$first_fragments . '::'}{$last_fragment . '::'};
157 Class::MOP::remove_metaclass_by_name($name);
165 return Class::MOP::Class->initialize($class)->new_object(@_)
166 if $class ne __PACKAGE__;
168 my $params = @_ == 1 ? $_[0] : {@_};
171 # Need to quote package to avoid a problem with PPI mis-parsing this
172 # as a package statement.
173 'package' => $params->{package},
176 # because of issues with the Perl API
177 # to the typeglob in some versions, we
178 # need to just always grab a new
179 # reference to the hash in the accessor.
180 # Ideally we could just store a ref and
181 # it would Just Work, but oh well :\
191 # all these attribute readers will be bootstrapped
192 # away in the Class::MOP bootstrap section
195 $_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name)
198 $_[0]->_package_stash->namespace
203 # ... these functions have to touch the symbol table itself,.. yuk
205 sub add_package_symbol {
207 $self->_package_stash->add_symbol(@_);
210 sub remove_package_glob {
212 $self->_package_stash->remove_glob(@_);
215 # ... these functions deal with stuff on the namespace level
217 sub has_package_symbol {
219 $self->_package_stash->has_symbol(@_);
222 sub get_package_symbol {
224 $self->_package_stash->get_symbol(@_);
227 sub get_or_add_package_symbol {
229 $self->_package_stash->get_or_add_symbol(@_);
232 sub remove_package_symbol {
234 $self->_package_stash->remove_symbol(@_);
237 sub list_all_package_symbols {
239 $self->_package_stash->list_all_symbols(@_);
242 sub get_all_package_symbols {
244 $self->_package_stash->get_all_symbols(@_);
249 # ABSTRACT: Package Meta Object
257 The Package Protocol provides an abstraction of a Perl 5 package. A
258 package is basically namespace, and this module provides methods for
259 looking at and changing that namespace's symbol table.
265 =item B<< Class::MOP::Package->initialize($package_name, %options) >>
267 This method creates a new C<Class::MOP::Package> instance which
268 represents specified package. If an existing metaclass object exists
269 for the package, that will be returned instead. No options are valid at the
272 =item B<< Class::MOP::Package->reinitialize($package, %options) >>
274 This method forcibly removes any existing metaclass for the package
275 before calling C<initialize>. In contrast to C<initialize>, you may
276 also pass an existing C<Class::MOP::Package> instance instead of just
277 a package name as C<$package>.
279 Do not call this unless you know what you are doing.
281 =item B<< Class::MOP::Package->create($package, %options) >>
283 Creates a new C<Class::MOP::Package> instance which represents the specified
284 package, and also does some initialization of that package. Currently, this
285 just does the same thing as C<initialize>, but is overridden in subclasses,
286 such as C<Class::MOP::Class>.
288 =item B<< Class::MOP::Package->create_anon(%options) >>
290 Creates a new anonymous package. Valid keys for C<%options> are:
296 If this is true (the default), the instance stored in C<Class::MOP>'s metaclass
297 cache will be weakened, so that the anonymous package will be garbage collected
298 when the returned instance goes out of scope.
302 =item B<< $metapackage->is_anon >>
304 Returns true if the package is an anonymous package.
306 =item B<< $metapackage->name >>
308 This is returns the package's name, as passed to the constructor.
310 =item B<< $metapackage->namespace >>
312 This returns a hash reference to the package's symbol table. The keys
313 are symbol names and the values are typeglob references.
315 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
317 This method accepts a variable name and an optional initial value. The
318 C<$variable_name> must contain a leading sigil.
320 This method creates the variable in the package's symbol table, and
321 sets it to the initial value if one was provided.
323 =item B<< $metapackage->get_package_symbol($variable_name) >>
325 Given a variable name, this method returns the variable as a reference
326 or undef if it does not exist. The C<$variable_name> must contain a
329 =item B<< $metapackage->get_or_add_package_symbol($variable_name) >>
331 Given a variable name, this method returns the variable as a reference.
332 If it does not exist, a default value will be generated if possible. The
333 C<$variable_name> must contain a leading sigil.
335 =item B<< $metapackage->has_package_symbol($variable_name) >>
337 Returns true if there is a package variable defined for
338 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
340 =item B<< $metapackage->remove_package_symbol($variable_name) >>
342 This will remove the package variable specified C<$variable_name>. The
343 C<$variable_name> must contain a leading sigil.
345 =item B<< $metapackage->remove_package_glob($glob_name) >>
347 Given the name of a glob, this will remove that glob from the
348 package's symbol table. Glob names do not include a sigil. Removing
349 the glob removes all variables and subroutines with the specified
352 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
354 This will list all the glob names associated with the current
355 package. These names do not have leading sigils.
357 You can provide an optional type filter, which should be one of
358 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
360 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
362 This works much like C<list_all_package_symbols>, but it returns a
363 hash reference. The keys are glob names and the values are references
364 to the value for that name.
366 =item B<< Class::MOP::Package->meta >>
368 This will return a L<Class::MOP::Class> instance for this class.