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.
144 no warnings 'uninitialized';
145 my $current_meta = Class::MOP::get_metaclass_by_name($name);
146 return if $current_meta ne $self;
148 my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
151 @{$name . '::ISA'} = ();
152 %{$name . '::'} = ();
153 delete ${$first_fragments . '::'}{$last_fragment . '::'};
155 Class::MOP::remove_metaclass_by_name($name);
163 return Class::MOP::Class->initialize($class)->new_object(@_)
164 if $class ne __PACKAGE__;
166 my $params = @_ == 1 ? $_[0] : {@_};
169 # Need to quote package to avoid a problem with PPI mis-parsing this
170 # as a package statement.
171 'package' => $params->{package},
174 # because of issues with the Perl API
175 # to the typeglob in some versions, we
176 # need to just always grab a new
177 # reference to the hash in the accessor.
178 # Ideally we could just store a ref and
179 # it would Just Work, but oh well :\
189 # all these attribute readers will be bootstrapped
190 # away in the Class::MOP bootstrap section
193 $_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name)
196 $_[0]->_package_stash->namespace
201 # ... these functions have to touch the symbol table itself,.. yuk
203 sub add_package_symbol {
205 $self->_package_stash->add_symbol(@_);
208 sub remove_package_glob {
210 $self->_package_stash->remove_glob(@_);
213 # ... these functions deal with stuff on the namespace level
215 sub has_package_symbol {
217 $self->_package_stash->has_symbol(@_);
220 sub get_package_symbol {
222 $self->_package_stash->get_symbol(@_);
225 sub get_or_add_package_symbol {
227 $self->_package_stash->get_or_add_symbol(@_);
230 sub remove_package_symbol {
232 $self->_package_stash->remove_symbol(@_);
235 sub list_all_package_symbols {
237 $self->_package_stash->list_all_symbols(@_);
240 sub get_all_package_symbols {
242 $self->_package_stash->get_all_symbols(@_);
247 # ABSTRACT: Package Meta Object
255 The Package Protocol provides an abstraction of a Perl 5 package. A
256 package is basically namespace, and this module provides methods for
257 looking at and changing that namespace's symbol table.
263 =item B<< Class::MOP::Package->initialize($package_name, %options) >>
265 This method creates a new C<Class::MOP::Package> instance which
266 represents specified package. If an existing metaclass object exists
267 for the package, that will be returned instead. No options are valid at the
270 =item B<< Class::MOP::Package->reinitialize($package, %options) >>
272 This method forcibly removes any existing metaclass for the package
273 before calling C<initialize>. In contrast to C<initialize>, you may
274 also pass an existing C<Class::MOP::Package> instance instead of just
275 a package name as C<$package>.
277 Do not call this unless you know what you are doing.
279 =item B<< Class::MOP::Package->create($package, %options) >>
281 Creates a new C<Class::MOP::Package> instance which represents the specified
282 package, and also does some initialization of that package. Currently, this
283 just does the same thing as C<initialize>, but is overridden in subclasses,
284 such as C<Class::MOP::Class>.
286 =item B<< Class::MOP::Package->create_anon(%options) >>
288 Creates a new anonymous package. Valid keys for C<%options> are:
294 If this is true (the default), the instance stored in C<Class::MOP>'s metaclass
295 cache will be weakened, so that the anonymous package will be garbage collected
296 when the returned instance goes out of scope.
300 =item B<< $metapackage->is_anon >>
302 Returns true if the package is an anonymous package.
304 =item B<< $metapackage->name >>
306 This is returns the package's name, as passed to the constructor.
308 =item B<< $metapackage->namespace >>
310 This returns a hash reference to the package's symbol table. The keys
311 are symbol names and the values are typeglob references.
313 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
315 This method accepts a variable name and an optional initial value. The
316 C<$variable_name> must contain a leading sigil.
318 This method creates the variable in the package's symbol table, and
319 sets it to the initial value if one was provided.
321 =item B<< $metapackage->get_package_symbol($variable_name) >>
323 Given a variable name, this method returns the variable as a reference
324 or undef if it does not exist. The C<$variable_name> must contain a
327 =item B<< $metapackage->get_or_add_package_symbol($variable_name) >>
329 Given a variable name, this method returns the variable as a reference.
330 If it does not exist, a default value will be generated if possible. The
331 C<$variable_name> must contain a leading sigil.
333 =item B<< $metapackage->has_package_symbol($variable_name) >>
335 Returns true if there is a package variable defined for
336 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
338 =item B<< $metapackage->remove_package_symbol($variable_name) >>
340 This will remove the package variable specified C<$variable_name>. The
341 C<$variable_name> must contain a leading sigil.
343 =item B<< $metapackage->remove_package_glob($glob_name) >>
345 Given the name of a glob, this will remove that glob from the
346 package's symbol table. Glob names do not include a sigil. Removing
347 the glob removes all variables and subroutines with the specified
350 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
352 This will list all the glob names associated with the current
353 package. These names do not have leading sigils.
355 You can provide an optional type filter, which should be one of
356 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
358 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
360 This works much like C<list_all_package_symbols>, but it returns a
361 hash reference. The keys are glob names and the values are references
362 to the value for that name.
364 =item B<< Class::MOP::Package->meta >>
366 This will return a L<Class::MOP::Class> instance for this class.