From: Jesse Luehrs Date: Mon, 18 Apr 2011 00:11:28 +0000 (-0500) Subject: unify the anon package stuff in CMOP::Package X-Git-Tag: 2.0100~220 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0db1c8dc30c9abe5d086b0c6a25572ec68d01187;p=gitmo%2FMoose.git unify the anon package stuff in CMOP::Package --- diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 8a97606..8aa4170 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -13,7 +13,6 @@ use Class::MOP::MiniTrait; use Carp 'confess'; use Scalar::Util 'blessed', 'reftype', 'weaken'; use Sub::Name 'subname'; -use Devel::GlobalDestruction 'in_global_destruction'; use Try::Tiny; use List::MoreUtils 'all'; @@ -408,131 +407,75 @@ sub _remove_generated_metaobjects { } } -## ANON classes - -{ - # 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_CLASS_SERIAL = 0; - - # 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. - my $ANON_CLASS_PREFIX = 'Class::MOP::Class::__ANON__::SERIAL::'; - - sub is_anon_class { - my $self = shift; - no warnings 'uninitialized'; - $self->name =~ /^$ANON_CLASS_PREFIX/o; - } - - sub create_anon_class { - my ($class, %options) = @_; - $options{weaken} = 1 unless exists $options{weaken}; - my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL; - return $class->create($package_name, %options); - } - - 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_class - if $self->is_anon_class; - } - - sub free_anon_class { - 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. - no warnings 'uninitialized'; - my $current_meta = Class::MOP::get_metaclass_by_name($name); - return if $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); - } - -} - # creating classes with MOP ... sub create { - my ( $class, @args ) = @_; + my $class = shift; + my @args = @_; unshift @args, 'package' if @args % 2 == 1; - - my (%options) = @args; - my $package_name = $options{package}; + my %options = @args; (ref $options{superclasses} eq 'ARRAY') || confess "You must pass an ARRAY ref of superclasses" if exists $options{superclasses}; - + (ref $options{attributes} eq 'ARRAY') || confess "You must pass an ARRAY ref of attributes" - if exists $options{attributes}; - + if exists $options{attributes}; + (ref $options{methods} eq 'HASH') || confess "You must pass a HASH ref of methods" - if exists $options{methods}; - - $options{meta_name} = 'meta' - unless exists $options{meta_name}; - - my (%initialize_options) = @args; - delete @initialize_options{qw( - package - superclasses - attributes - methods - meta_name - version - authority - )}; - my $meta = $class->initialize( $package_name => %initialize_options ); - - $meta->_instantiate_module( $options{version}, $options{authority} ); - - $meta->_add_meta_method($options{meta_name}) - if defined $options{meta_name}; - - $meta->superclasses(@{$options{superclasses}}) - if exists $options{superclasses}; + if exists $options{methods}; + + my $package = delete $options{package}; + my $superclasses = delete $options{superclasses}; + my $attributes = delete $options{attributes}; + my $methods = delete $options{methods}; + my $meta_name = exists $options{meta_name} + ? delete $options{meta_name} + : 'meta'; + + my $meta = $class->SUPER::create($package => %options); + + $meta->_add_meta_method($meta_name) + if defined $meta_name; + + $meta->superclasses(@{$superclasses}) + if defined $superclasses; # NOTE: # process attributes first, so that they can # install accessors, but locally defined methods # can then overwrite them. It is maybe a little odd, but # I think this should be the order of things. - if (exists $options{attributes}) { - foreach my $attr (@{$options{attributes}}) { + if (defined $attributes) { + foreach my $attr (@{$attributes}) { $meta->add_attribute($attr); } } - if (exists $options{methods}) { - foreach my $method_name (keys %{$options{methods}}) { - $meta->add_method($method_name, $options{methods}->{$method_name}); + if (defined $methods) { + foreach my $method_name (keys %{$methods}) { + $meta->add_method($method_name, $methods->{$method_name}); } } return $meta; } +# XXX: something more intelligent here? +sub _anon_package_prefix { 'Class::MOP::Class::__ANON__::SERIAL::' } + +sub create_anon_class { shift->create_anon(@_) } +sub is_anon_class { shift->is_anon(@_) } + +sub _anon_cache_key { + my $class = shift; + my %options = @_; + # Makes something like Super::Class|Super::Class::2 + return join '=' => ( + join( '|', sort @{ $options{superclasses} || [] } ), + ); +} + # Instance Construction & Cloning sub new_object { @@ -2190,13 +2133,4 @@ metaclass. =back -=head2 Destruction - -=over 4 - -=item B<< $metaclass->free_anon_class >> - -This removes the metaclass from the symbol table and L's own -bookkeeping. This should probably only be called by L. - =cut diff --git a/lib/Class/MOP/Module.pm b/lib/Class/MOP/Module.pm index 4142dfc..0dd274d 100644 --- a/lib/Class/MOP/Module.pm +++ b/lib/Class/MOP/Module.pm @@ -49,9 +49,27 @@ sub identifier { } sub create { - confess "The Class::MOP::Module->create method has been made a private object method.\n"; + my $class = shift; + my @args = @_; + + unshift @args, 'package' if @args % 2 == 1; + my %options = @args; + + my $package = delete $options{package}; + my $version = delete $options{version}; + my $authority = delete $options{authority}; + + my $meta = $class->SUPER::create($package => %options); + + $meta->_instantiate_module($version, $authority); + + return $meta; } +sub _anon_package_prefix { 'Class::MOP::Module::__ANON__::SERIAL::' } +sub _anon_cache_key { confess "Modules are not cacheable" } + + sub _instantiate_module { my($self, $version, $authority) = @_; my $package_name = $self->name; diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm index f24f9d2..bc5c6ca 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,7 +19,7 @@ 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 @@ -32,6 +33,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 +60,99 @@ 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 =~ /^$prefix/; + } + + sub create_anon { + my ($class, %options) = @_; + + my $cache_ok = delete $options{cache}; + + my $cache_key = $class->_anon_cache_key(%options); + + if ($cache_ok && defined $ANON_PACKAGE_CACHE{$cache_key}) { + return $ANON_PACKAGE_CACHE{$cache_key}; + } + + $options{weaken} = !$cache_ok unless exists $options{weaken}; + + 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. + no warnings 'uninitialized'; + my $current_meta = Class::MOP::get_metaclass_by_name($name); + return if $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; diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 07f5e7e..b3e95e4 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -10,7 +10,7 @@ use Carp qw( confess ); use Data::OptList; use List::Util qw( first ); use List::MoreUtils qw( any all uniq first_index ); -use Scalar::Util 'weaken', 'blessed'; +use Scalar::Util 'blessed'; use Moose::Meta::Method::Overridden; use Moose::Meta::Method::Augmented; @@ -60,25 +60,34 @@ __PACKAGE__->meta->add_attribute('error_class' => ( sub initialize { my $class = shift; - my $pkg = shift; - return Class::MOP::get_metaclass_by_name($pkg) - || $class->SUPER::initialize($pkg, + my @args = @_; + unshift @args, 'package' if @args % 2; + my %opts = @args; + my $package = delete $opts{package}; + return Class::MOP::get_metaclass_by_name($package) + || $class->SUPER::initialize($package, 'attribute_metaclass' => 'Moose::Meta::Attribute', 'method_metaclass' => 'Moose::Meta::Method', 'instance_metaclass' => 'Moose::Meta::Instance', - @_ + %opts, ); } sub create { - my ($class, $package_name, %options) = @_; + my $class = shift; + my @args = @_; + + unshift @args, 'package' if @args % 2 == 1; + my %options = @args; (ref $options{roles} eq 'ARRAY') || $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles}) if exists $options{roles}; - my $roles = delete $options{roles}; - my $new_meta = $class->SUPER::create($package_name, %options); + my $package = delete $options{package}; + my $roles = delete $options{roles}; + + my $new_meta = $class->SUPER::create($package, %options); if ($roles) { Moose::Util::apply_all_roles( $new_meta, @$roles ); @@ -87,40 +96,17 @@ sub create { return $new_meta; } -my %ANON_CLASSES; - -sub create_anon_class { - my ($self, %options) = @_; - - my $cache_ok = delete $options{cache}; - - my $cache_key - = _anon_cache_key( $options{superclasses}, $options{roles} ); - - if ($cache_ok && defined $ANON_CLASSES{$cache_key}) { - return $ANON_CLASSES{$cache_key}; - } - - $options{weaken} = !$cache_ok - unless exists $options{weaken}; - - my $new_class = $self->SUPER::create_anon_class(%options); - - if ($cache_ok) { - $ANON_CLASSES{$cache_key} = $new_class; - weaken($ANON_CLASSES{$cache_key}); - } - - return $new_class; -} - sub _meta_method_class { 'Moose::Meta::Method::Meta' } +sub _anon_package_prefix { 'Moose::Meta::Class::__ANON__::SERIAL::' } + sub _anon_cache_key { + my $class = shift; + my %options = @_; # Makes something like Super::Class|Super::Class::2=Role|Role::1 return join '=' => ( - join( '|', @{ $_[0] || [] } ), - join( '|', sort @{ $_[1] || [] } ), + join( '|', @{ $options{superclasses} || [] } ), + join( '|', sort @{ $options{roles} || [] } ), ); } @@ -130,8 +116,6 @@ sub reinitialize { my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg); - my $cache_key; - my %existing_classes; if ($meta) { %existing_classes = map { $_ => $meta->$_() } qw( @@ -143,31 +127,13 @@ sub reinitialize { destructor_class error_class ); - - $cache_key = _anon_cache_key( - [ $meta->superclasses ], - [ map { $_->name } @{ $meta->roles } ], - ) if $meta->is_anon_class; } - my $new_meta = $self->SUPER::reinitialize( + return $self->SUPER::reinitialize( $pkg, %existing_classes, @_, ); - - return $new_meta unless defined $cache_key; - - my $new_cache_key = _anon_cache_key( - [ $meta->superclasses ], - [ map { $_->name } @{ $meta->roles } ], - ); - - delete $ANON_CLASSES{$cache_key}; - $ANON_CLASSES{$new_cache_key} = $new_meta; - weaken($ANON_CLASSES{$new_cache_key}); - - return $new_meta; } sub add_role { diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm index 28ea3cf..2ee6d1f 100644 --- a/lib/Moose/Meta/Role.pm +++ b/lib/Moose/Meta/Role.pm @@ -162,23 +162,15 @@ $META->add_attribute( # More or less copied from Moose::Meta::Class sub initialize { my $class = shift; - my $pkg = shift; - - if (defined(my $meta = Class::MOP::get_metaclass_by_name($pkg))) { - return $meta; - } - - my %options = @_; - - my $meta = $class->SUPER::initialize( - $pkg, - 'attribute_metaclass' => 'Moose::Meta::Role::Attribute', - %options, - ); - - Class::MOP::weaken_metaclass($pkg) if $options{weaken}; - - return $meta; + my @args = @_; + unshift @args, 'package' if @args % 2; + my %opts = @args; + my $package = delete $opts{package}; + return Class::MOP::get_metaclass_by_name($package) + || $class->SUPER::initialize($package, + 'attribute_metaclass' => 'Moose::Meta::Role::Attribute', + %opts, + ); } sub reinitialize { @@ -516,9 +508,11 @@ sub _role_for_combination { } sub create { - my ( $role, $package_name, %options ) = @_; + my $class = shift; + my @args = @_; - $options{package} = $package_name; + unshift @args, 'package' if @args % 2 == 1; + my %options = @args; (ref $options{attributes} eq 'HASH') || confess "You must pass a HASH ref of attributes" @@ -528,37 +522,29 @@ sub create { || confess "You must pass a HASH ref of methods" if exists $options{methods}; - $options{meta_name} = 'meta' - unless exists $options{meta_name}; - - my (%initialize_options) = %options; - delete @initialize_options{qw( - package - attributes - methods - meta_name - version - authority - )}; - - my $meta = $role->initialize( $package_name => %initialize_options ); + my $package = delete $options{package}; + my $attributes = delete $options{attributes}; + my $methods = delete $options{methods}; + my $meta_name = exists $options{meta_name} + ? delete $options{meta_name} + : 'meta'; - $meta->_instantiate_module( $options{version}, $options{authority} ); + my $meta = $class->SUPER::create($package => %options); - $meta->_add_meta_method($options{meta_name}) - if defined $options{meta_name}; + $meta->_add_meta_method($meta_name) + if defined $meta_name; - if (exists $options{attributes}) { - foreach my $attribute_name (keys %{$options{attributes}}) { - my $attr = $options{attributes}->{$attribute_name}; + if (defined $attributes) { + foreach my $attribute_name (keys %{$attributes}) { + my $attr = $attributes->{$attribute_name}; $meta->add_attribute( $attribute_name => blessed $attr ? $attr : %{$attr} ); } } - if (exists $options{methods}) { - foreach my $method_name (keys %{$options{methods}}) { - $meta->add_method($method_name, $options{methods}->{$method_name}); + if (defined $methods) { + foreach my $method_name (keys %{$methods}) { + $meta->add_method($method_name, $methods->{$method_name}); } } @@ -578,66 +564,19 @@ sub consumers { return @consumers; } -# anonymous roles. most of it is copied straight out of Class::MOP::Class. -# an intrepid hacker might find great riches if he unifies this code with that -# code in Class::MOP::Module or Class::MOP::Package -{ - # 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_ROLE_SERIAL = 0; +# XXX: something more intelligent here? +sub _anon_package_prefix { 'Moose::Meta::Role::__ANON__::SERIAL::' } - # 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. - my $ANON_ROLE_PREFIX = 'Moose::Meta::Role::__ANON__::SERIAL::'; - - sub is_anon_role { - my $self = shift; - no warnings 'uninitialized'; - $self->name =~ /^$ANON_ROLE_PREFIX/; - } +sub create_anon_role { shift->create_anon(@_) } +sub is_anon_role { shift->is_anon(@_) } - sub create_anon_role { - my ($role, %options) = @_; - $options{weaken} = 1 unless exists $options{weaken}; - my $package_name = $ANON_ROLE_PREFIX . ++$ANON_ROLE_SERIAL; - return $role->create($package_name, %options); - } - - 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_role - if $self->is_anon_role; - } - - sub free_anon_role { - my $self = shift; - my $name = $self->name; - - my ($first_fragments, $last_fragment) = ($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. - my $current_meta = Class::MOP::get_metaclass_by_name($self->name); - return if $current_meta ne $self; - - no strict 'refs'; - @{$name . '::ISA'} = (); - %{$name . '::'} = (); - delete ${$first_fragments . '::'}{$last_fragment . '::'}; - - Class::MOP::remove_metaclass_by_name($name); - } +sub _anon_cache_key { + my $class = shift; + my %options = @_; + # Makes something like Role|Role::1 + return join '=' => ( + join( '|', sort @{ $options{roles} || [] } ), + ); } ##################################################################### @@ -1012,15 +951,6 @@ This will return a L instance for this class. =back -=head2 Destruction - -=over 4 - -=item B<< $metarole->free_anon_role >> - -This removes the metarole from the symbol table and L's own -bookkeeping. This should probably only be called by L. - =head1 BUGS See L for details on reporting bugs. diff --git a/t/cmop/self_introspection.t b/t/cmop/self_introspection.t index 6192ba1..e6d00f6 100644 --- a/t/cmop/self_introspection.t +++ b/t/cmop/self_introspection.t @@ -26,7 +26,8 @@ isa_ok($class_mop_module_meta, 'Class::MOP::Module'); my @class_mop_package_methods = qw( _new - initialize reinitialize + initialize reinitialize create create_anon is_anon + _free_anon _anon_cache_key _anon_package_prefix name namespace @@ -38,6 +39,8 @@ my @class_mop_package_methods = qw( _package_stash get_method_map + + DESTROY ); my @class_mop_module_methods = qw( @@ -46,6 +49,8 @@ my @class_mop_module_methods = qw( _instantiate_module version authority identifier create + + _anon_cache_key _anon_package_prefix ); my @class_mop_class_methods = qw( @@ -55,7 +60,8 @@ my @class_mop_class_methods = qw( initialize reinitialize create - create_anon_class is_anon_class free_anon_class + create_anon_class is_anon_class + _anon_cache_key _anon_package_prefix instance_metaclass get_meta_instance _inline_create_instance @@ -115,8 +121,6 @@ my @class_mop_class_methods = qw( _immutable_metaclass immutable_trait immutable_options constructor_name constructor_class destructor_class - - DESTROY ); # check the class ...