X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FPackage.pm;h=ad2202c8c6e4fd32091fc7163413f3dd84c74b52;hb=b4567caf469e38cef213b811061646ac62fcd4fc;hp=f24f9d2655517f6002ba0643351c8a48f66e6918;hpb=9c1bf11e2960c376afb5edfb2615d6de21dc379b;p=gitmo%2FMoose.git diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm index f24f9d2..ad2202c 100644 --- a/lib/Class/MOP/Package.pm +++ b/lib/Class/MOP/Package.pm @@ -4,8 +4,9 @@ package Class::MOP::Package; 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'; @@ -18,11 +19,10 @@ sub initialize { 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 { @@ -32,6 +32,9 @@ sub initialize { }); Class::MOP::store_metaclass_by_name($package_name, $meta); + Class::MOP::weaken_metaclass($package_name) if $options{weaken}; + + return $meta; } } @@ -56,6 +59,114 @@ sub reinitialize { $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'; + # clear @ISA first, to avoid a memory leak + # see https://rt.perl.org/rt3/Public/Bug/Display.html?id=92708 + @{$name . '::ISA'} = (); + %{$name . '::'} = (); + delete ${$first_fragments . '::'}{$last_fragment . '::'}; + + Class::MOP::remove_metaclass_by_name($name); + } + +} + sub _new { my $class = shift; @@ -85,7 +196,7 @@ sub _new { # 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 { @@ -159,13 +270,14 @@ looking at and changing that namespace's symbol table. =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 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. In contrast to C, you may @@ -174,6 +286,31 @@ a package name as C<$package>. Do not call this unless you know what you are doing. +=item B<< Class::MOP::Package->create($package, %options) >> + +Creates a new C instance which represents the specified +package, and also does some initialization of that package. Currently, this +just does the same thing as C, but is overridden in subclasses, +such as C. + +=item B<< Class::MOP::Package->create_anon(%options) >> + +Creates a new anonymous package. Valid keys for C<%options> are: + +=over 4 + +=item C + +If this is true (the default), the instance stored in C'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.