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 =~ /^$prefix/;
96 my ($class, %options) = @_;
98 my $cache_ok = delete $options{cache};
100 my $cache_key = $class->_anon_cache_key(%options);
102 if ($cache_ok && defined $ANON_PACKAGE_CACHE{$cache_key}) {
103 return $ANON_PACKAGE_CACHE{$cache_key};
106 $options{weaken} = !$cache_ok unless exists $options{weaken};
108 my $package_name = $class->_anon_package_prefix . ++$ANON_SERIAL;
110 my $meta = $class->create($package_name, %options);
113 $ANON_PACKAGE_CACHE{$cache_key} = $meta;
114 weaken($ANON_PACKAGE_CACHE{$cache_key});
120 sub _anon_cache_key { confess "Packages are not cacheable" }
125 return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
133 my $name = $self->name;
135 # Moose does a weird thing where it replaces the metaclass for
136 # class when fixing metaclass incompatibility. In that case,
137 # we don't want to clean out the namespace now. We can detect
138 # that because Moose will explicitly update the singleton
139 # cache in Class::MOP.
140 no warnings 'uninitialized';
141 my $current_meta = Class::MOP::get_metaclass_by_name($name);
142 return if $current_meta ne $self;
144 my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
147 @{$name . '::ISA'} = ();
148 %{$name . '::'} = ();
149 delete ${$first_fragments . '::'}{$last_fragment . '::'};
151 Class::MOP::remove_metaclass_by_name($name);
159 return Class::MOP::Class->initialize($class)->new_object(@_)
160 if $class ne __PACKAGE__;
162 my $params = @_ == 1 ? $_[0] : {@_};
165 # Need to quote package to avoid a problem with PPI mis-parsing this
166 # as a package statement.
167 'package' => $params->{package},
170 # because of issues with the Perl API
171 # to the typeglob in some versions, we
172 # need to just always grab a new
173 # reference to the hash in the accessor.
174 # Ideally we could just store a ref and
175 # it would Just Work, but oh well :\
185 # all these attribute readers will be bootstrapped
186 # away in the Class::MOP bootstrap section
189 $_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name)
192 $_[0]->_package_stash->namespace
197 # ... these functions have to touch the symbol table itself,.. yuk
199 sub add_package_symbol {
201 $self->_package_stash->add_symbol(@_);
204 sub remove_package_glob {
206 $self->_package_stash->remove_glob(@_);
209 # ... these functions deal with stuff on the namespace level
211 sub has_package_symbol {
213 $self->_package_stash->has_symbol(@_);
216 sub get_package_symbol {
218 $self->_package_stash->get_symbol(@_);
221 sub get_or_add_package_symbol {
223 $self->_package_stash->get_or_add_symbol(@_);
226 sub remove_package_symbol {
228 $self->_package_stash->remove_symbol(@_);
231 sub list_all_package_symbols {
233 $self->_package_stash->list_all_symbols(@_);
236 sub get_all_package_symbols {
238 $self->_package_stash->get_all_symbols(@_);
243 # ABSTRACT: Package Meta Object
251 The Package Protocol provides an abstraction of a Perl 5 package. A
252 package is basically namespace, and this module provides methods for
253 looking at and changing that namespace's symbol table.
259 =item B<< Class::MOP::Package->initialize($package_name) >>
261 This method creates a new C<Class::MOP::Package> instance which
262 represents specified package. If an existing metaclass object exists
263 for the package, that will be returned instead.
265 =item B<< Class::MOP::Package->reinitialize($package) >>
267 This method forcibly removes any existing metaclass for the package
268 before calling C<initialize>. In contrast to C<initialize>, you may
269 also pass an existing C<Class::MOP::Package> instance instead of just
270 a package name as C<$package>.
272 Do not call this unless you know what you are doing.
274 =item B<< $metapackage->name >>
276 This is returns the package's name, as passed to the constructor.
278 =item B<< $metapackage->namespace >>
280 This returns a hash reference to the package's symbol table. The keys
281 are symbol names and the values are typeglob references.
283 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
285 This method accepts a variable name and an optional initial value. The
286 C<$variable_name> must contain a leading sigil.
288 This method creates the variable in the package's symbol table, and
289 sets it to the initial value if one was provided.
291 =item B<< $metapackage->get_package_symbol($variable_name) >>
293 Given a variable name, this method returns the variable as a reference
294 or undef if it does not exist. The C<$variable_name> must contain a
297 =item B<< $metapackage->get_or_add_package_symbol($variable_name) >>
299 Given a variable name, this method returns the variable as a reference.
300 If it does not exist, a default value will be generated if possible. The
301 C<$variable_name> must contain a leading sigil.
303 =item B<< $metapackage->has_package_symbol($variable_name) >>
305 Returns true if there is a package variable defined for
306 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
308 =item B<< $metapackage->remove_package_symbol($variable_name) >>
310 This will remove the package variable specified C<$variable_name>. The
311 C<$variable_name> must contain a leading sigil.
313 =item B<< $metapackage->remove_package_glob($glob_name) >>
315 Given the name of a glob, this will remove that glob from the
316 package's symbol table. Glob names do not include a sigil. Removing
317 the glob removes all variables and subroutines with the specified
320 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
322 This will list all the glob names associated with the current
323 package. These names do not have leading sigils.
325 You can provide an optional type filter, which should be one of
326 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
328 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
330 This works much like C<list_all_package_symbols>, but it returns a
331 hash reference. The keys are glob names and the values are references
332 to the value for that name.
334 =item B<< Class::MOP::Package->meta >>
336 This will return a L<Class::MOP::Class> instance for this class.