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};
102 $cache_key = $class->_anon_cache_key(%options);
104 if (defined $ANON_PACKAGE_CACHE{$cache_key}) {
105 return $ANON_PACKAGE_CACHE{$cache_key};
109 $options{weaken} = !$cache_ok unless exists $options{weaken};
111 my $package_name = $class->_anon_package_prefix . ++$ANON_SERIAL;
113 my $meta = $class->create($package_name, %options);
116 $ANON_PACKAGE_CACHE{$cache_key} = $meta;
117 weaken($ANON_PACKAGE_CACHE{$cache_key});
123 sub _anon_cache_key { confess "Packages are not cacheable" }
128 return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
136 my $name = $self->name;
138 # Moose does a weird thing where it replaces the metaclass for
139 # class when fixing metaclass incompatibility. In that case,
140 # we don't want to clean out the namespace now. We can detect
141 # that because Moose will explicitly update the singleton
142 # cache in Class::MOP.
143 no warnings 'uninitialized';
144 my $current_meta = Class::MOP::get_metaclass_by_name($name);
145 return if $current_meta ne $self;
147 my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
150 @{$name . '::ISA'} = ();
151 %{$name . '::'} = ();
152 delete ${$first_fragments . '::'}{$last_fragment . '::'};
154 Class::MOP::remove_metaclass_by_name($name);
162 return Class::MOP::Class->initialize($class)->new_object(@_)
163 if $class ne __PACKAGE__;
165 my $params = @_ == 1 ? $_[0] : {@_};
168 # Need to quote package to avoid a problem with PPI mis-parsing this
169 # as a package statement.
170 'package' => $params->{package},
173 # because of issues with the Perl API
174 # to the typeglob in some versions, we
175 # need to just always grab a new
176 # reference to the hash in the accessor.
177 # Ideally we could just store a ref and
178 # it would Just Work, but oh well :\
188 # all these attribute readers will be bootstrapped
189 # away in the Class::MOP bootstrap section
192 $_[0]->{_package_stash} ||= Package::Stash->new($_[0]->name)
195 $_[0]->_package_stash->namespace
200 # ... these functions have to touch the symbol table itself,.. yuk
202 sub add_package_symbol {
204 $self->_package_stash->add_symbol(@_);
207 sub remove_package_glob {
209 $self->_package_stash->remove_glob(@_);
212 # ... these functions deal with stuff on the namespace level
214 sub has_package_symbol {
216 $self->_package_stash->has_symbol(@_);
219 sub get_package_symbol {
221 $self->_package_stash->get_symbol(@_);
224 sub get_or_add_package_symbol {
226 $self->_package_stash->get_or_add_symbol(@_);
229 sub remove_package_symbol {
231 $self->_package_stash->remove_symbol(@_);
234 sub list_all_package_symbols {
236 $self->_package_stash->list_all_symbols(@_);
239 sub get_all_package_symbols {
241 $self->_package_stash->get_all_symbols(@_);
246 # ABSTRACT: Package Meta Object
254 The Package Protocol provides an abstraction of a Perl 5 package. A
255 package is basically namespace, and this module provides methods for
256 looking at and changing that namespace's symbol table.
262 =item B<< Class::MOP::Package->initialize($package_name) >>
264 This method creates a new C<Class::MOP::Package> instance which
265 represents specified package. If an existing metaclass object exists
266 for the package, that will be returned instead.
268 =item B<< Class::MOP::Package->reinitialize($package) >>
270 This method forcibly removes any existing metaclass for the package
271 before calling C<initialize>. In contrast to C<initialize>, you may
272 also pass an existing C<Class::MOP::Package> instance instead of just
273 a package name as C<$package>.
275 Do not call this unless you know what you are doing.
277 =item B<< $metapackage->name >>
279 This is returns the package's name, as passed to the constructor.
281 =item B<< $metapackage->namespace >>
283 This returns a hash reference to the package's symbol table. The keys
284 are symbol names and the values are typeglob references.
286 =item B<< $metapackage->add_package_symbol($variable_name, $initial_value) >>
288 This method accepts a variable name and an optional initial value. The
289 C<$variable_name> must contain a leading sigil.
291 This method creates the variable in the package's symbol table, and
292 sets it to the initial value if one was provided.
294 =item B<< $metapackage->get_package_symbol($variable_name) >>
296 Given a variable name, this method returns the variable as a reference
297 or undef if it does not exist. The C<$variable_name> must contain a
300 =item B<< $metapackage->get_or_add_package_symbol($variable_name) >>
302 Given a variable name, this method returns the variable as a reference.
303 If it does not exist, a default value will be generated if possible. The
304 C<$variable_name> must contain a leading sigil.
306 =item B<< $metapackage->has_package_symbol($variable_name) >>
308 Returns true if there is a package variable defined for
309 C<$variable_name>. The C<$variable_name> must contain a leading sigil.
311 =item B<< $metapackage->remove_package_symbol($variable_name) >>
313 This will remove the package variable specified C<$variable_name>. The
314 C<$variable_name> must contain a leading sigil.
316 =item B<< $metapackage->remove_package_glob($glob_name) >>
318 Given the name of a glob, this will remove that glob from the
319 package's symbol table. Glob names do not include a sigil. Removing
320 the glob removes all variables and subroutines with the specified
323 =item B<< $metapackage->list_all_package_symbols($type_filter) >>
325 This will list all the glob names associated with the current
326 package. These names do not have leading sigils.
328 You can provide an optional type filter, which should be one of
329 'SCALAR', 'ARRAY', 'HASH', or 'CODE'.
331 =item B<< $metapackage->get_all_package_symbols($type_filter) >>
333 This works much like C<list_all_package_symbols>, but it returns a
334 hash reference. The keys are glob names and the values are references
335 to the value for that name.
337 =item B<< Class::MOP::Package->meta >>
339 This will return a L<Class::MOP::Class> instance for this class.