use strict;
use warnings;
-use Scalar::Util 'blessed', 'reftype';
+use Scalar::Util 'blessed', 'reftype', 'weaken';
use Carp 'confess';
+use Devel::GlobalDestruction 'in_global_destruction';
use Package::Stash;
use base 'Class::MOP::Object';
unshift @args, "package" if @args % 2;
my %options = @args;
- my $package_name = $options{package};
+ my $package_name = delete $options{package};
- # we hand-construct the class
- # until we can bootstrap it
+ # we hand-construct the class until we can bootstrap it
if ( my $meta = Class::MOP::get_metaclass_by_name($package_name) ) {
return $meta;
} else {
});
Class::MOP::store_metaclass_by_name($package_name, $meta);
+ Class::MOP::weaken_metaclass($package_name) if $options{weaken};
+
+
return $meta;
}
}
$class->initialize($package_name, %options); # call with first arg form for compat
}
+sub create {
+ my $class = shift;
+ my @args = @_;
+
+ return $class->initialize(@args);
+}
+
+## ANON packages
+
+{
+ # NOTE:
+ # this should be sufficient, if you have a
+ # use case where it is not, write a test and
+ # I will change it.
+ my $ANON_SERIAL = 0;
+
+ my %ANON_PACKAGE_CACHE;
+
+ # NOTE:
+ # we need a sufficiently annoying prefix
+ # this should suffice for now, this is
+ # used in a couple of places below, so
+ # need to put it up here for now.
+ sub _anon_package_prefix { 'Class::MOP::Package::__ANON__::SERIAL::' }
+
+ sub is_anon {
+ my $self = shift;
+ no warnings 'uninitialized';
+ my $prefix = $self->_anon_package_prefix;
+ $self->name =~ /^\Q$prefix/;
+ }
+
+ sub create_anon {
+ my ($class, %options) = @_;
+
+ my $cache_ok = delete $options{cache};
+ $options{weaken} = !$cache_ok unless exists $options{weaken};
+
+ my $cache_key;
+ if ($cache_ok) {
+ $cache_key = $class->_anon_cache_key(%options);
+ undef $cache_ok if !defined($cache_key);
+ }
+
+ if ($cache_ok) {
+ if (defined $ANON_PACKAGE_CACHE{$cache_key}) {
+ return $ANON_PACKAGE_CACHE{$cache_key};
+ }
+ }
+
+ my $package_name = $class->_anon_package_prefix . ++$ANON_SERIAL;
+
+ my $meta = $class->create($package_name, %options);
+
+ if ($cache_ok) {
+ $ANON_PACKAGE_CACHE{$cache_key} = $meta;
+ weaken($ANON_PACKAGE_CACHE{$cache_key});
+ }
+
+ return $meta;
+ }
+
+ sub _anon_cache_key { confess "Packages are not cacheable" }
+
+ sub DESTROY {
+ my $self = shift;
+
+ return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
+
+ $self->_free_anon
+ if $self->is_anon;
+ }
+
+ sub _free_anon {
+ my $self = shift;
+ my $name = $self->name;
+
+ # Moose does a weird thing where it replaces the metaclass for
+ # class when fixing metaclass incompatibility. In that case,
+ # we don't want to clean out the namespace now. We can detect
+ # that because Moose will explicitly update the singleton
+ # cache in Class::MOP using store_metaclass_by_name, which
+ # means that the new metaclass will already exist in the cache
+ # by this point.
+ # The other options here are that $current_meta can be undef if
+ # remove_metaclass_by_name is called explicitly (since the hash
+ # entry is removed first, and then this destructor is called),
+ # or that $current_meta can be the same as $self, which happens
+ # when the metaclass goes out of scope (since the weak reference
+ # in the metaclass cache won't be freed until after this
+ # destructor runs).
+ my $current_meta = Class::MOP::get_metaclass_by_name($name);
+ return if defined($current_meta) && $current_meta ne $self;
+
+ my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
+
+ no strict 'refs';
+ @{$name . '::ISA'} = ();
+ %{$name . '::'} = ();
+ delete ${$first_fragments . '::'}{$last_fragment . '::'};
+
+ Class::MOP::remove_metaclass_by_name($name);
+ }
+
+}
+
sub _new {
my $class = shift;
my $params = @_ == 1 ? $_[0] : {@_};
return bless {
- package => $params->{package},
+ # Need to quote package to avoid a problem with PPI mis-parsing this
+ # as a package statement.
+ 'package' => $params->{package},
# NOTE:
# because of issues with the Perl API
# Attributes
# NOTE:
-# all these attribute readers will be bootstrapped
+# all these attribute readers will be bootstrapped
# away in the Class::MOP bootstrap section
sub _package_stash {
=over 4
-=item B<< Class::MOP::Package->initialize($package_name) >>
+=item B<< Class::MOP::Package->initialize($package_name, %options) >>
This method creates a new C<Class::MOP::Package> instance which
represents specified package. If an existing metaclass object exists
-for the package, that will be returned instead.
+for the package, that will be returned instead. No options are valid at the
+package level.
-=item B<< Class::MOP::Package->reinitialize($package) >>
+=item B<< Class::MOP::Package->reinitialize($package, %options) >>
This method forcibly removes any existing metaclass for the package
before calling C<initialize>. In contrast to C<initialize>, you may
Do not call this unless you know what you are doing.
+=item B<< Class::MOP::Package->create($package, %options) >>
+
+Creates a new C<Class::MOP::Package> instance which represents the specified
+package, and also does some initialization of that package. Currently, this
+just does the same thing as C<initialize>, but is overridden in subclasses,
+such as C<Class::MOP::Class>.
+
+=item B<< Class::MOP::Package->create_anon(%options) >>
+
+Creates a new anonymous package. Valid keys for C<%options> are:
+
+=over 4
+
+=item C<weaken>
+
+If this is true (the default), the instance stored in C<Class::MOP>'s metaclass
+cache will be weakened, so that the anonymous package will be garbage collected
+when the returned instance goes out of scope.
+
+=back
+
+=item B<< $metapackage->is_anon >>
+
+Returns true if the package is an anonymous package.
+
=item B<< $metapackage->name >>
This is returns the package's name, as passed to the constructor.
projects / gitmo/Moose.git / blobdiff