X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FClass.pm;h=fa5331560d1fb3d61cdbf16d90fd7f56c4a6900b;hb=45160c4b37efc1dce63d008c7a734d8250fb714c;hp=768ebfcb6e3283046378aeb92395fdc9571c836f;hpb=b2df9268ec9fe2dafce9522eefc8d1dcd456fdd1;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 768ebfc..fa53315 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -8,16 +8,19 @@ use Class::MOP; use Carp (); use List::Util qw( first ); -use List::MoreUtils qw( any all uniq ); +use List::MoreUtils qw( any all uniq first_index ); use Scalar::Util 'weaken', 'blessed'; -our $VERSION = '0.72_01'; +our $VERSION = '0.99'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; use Moose::Meta::Method::Overridden; use Moose::Meta::Method::Augmented; use Moose::Error::Default; +use Moose::Meta::Class::Immutable::Trait; +use Moose::Meta::Method::Constructor; +use Moose::Meta::Method::Destructor; use base 'Class::MOP::Class'; @@ -26,6 +29,18 @@ __PACKAGE__->meta->add_attribute('roles' => ( default => sub { [] } )); +__PACKAGE__->meta->add_attribute('role_applications' => ( + reader => '_get_role_applications', + default => sub { [] } +)); + +__PACKAGE__->meta->add_attribute( + Class::MOP::Attribute->new('immutable_trait' => ( + accessor => "immutable_trait", + default => 'Moose::Meta::Class::Immutable::Trait', + )) +); + __PACKAGE__->meta->add_attribute('constructor_class' => ( accessor => 'constructor_class', default => 'Moose::Meta::Method::Constructor', @@ -41,22 +56,34 @@ __PACKAGE__->meta->add_attribute('error_class' => ( default => 'Moose::Error::Default', )); - sub initialize { my $class = shift; my $pkg = shift; - return Class::MOP::get_metaclass_by_name($pkg) + return Class::MOP::get_metaclass_by_name($pkg) || $class->SUPER::initialize($pkg, 'attribute_metaclass' => 'Moose::Meta::Attribute', 'method_metaclass' => 'Moose::Meta::Method', 'instance_metaclass' => 'Moose::Meta::Instance', @_ - ); + ); +} + +sub _immutable_options { + my ( $self, @args ) = @_; + + $self->SUPER::_immutable_options( + inline_destructor => 1, + + # Moose always does this when an attribute is created + inline_accessors => 0, + + @args, + ); } sub create { my ($self, $package_name, %options) = @_; - + (ref $options{roles} eq 'ARRAY') || $self->throw_error("You must pass an ARRAY ref of roles", data => $options{roles}) if exists $options{roles}; @@ -67,7 +94,7 @@ sub create { if ($roles) { Moose::Util::apply_all_roles( $class, @$roles ); } - + return $class; } @@ -87,17 +114,14 @@ sub create_anon_class { my ($self, %options) = @_; my $cache_ok = delete $options{cache}; - - # something like Super::Class|Super::Class::2=Role|Role::1 - my $cache_key = join '=' => ( - join('|', @{$options{superclasses} || []}), - join('|', sort @{$options{roles} || []}), - ); - + + my $cache_key + = _anon_cache_key( $options{superclasses}, $options{roles} ); + if ($cache_ok && defined $ANON_CLASSES{$cache_key}) { return $ANON_CLASSES{$cache_key}; } - + my $new_class = $self->SUPER::create_anon_class(%options); $ANON_CLASSES{$cache_key} = $new_class @@ -106,6 +130,59 @@ sub create_anon_class { return $new_class; } +sub _anon_cache_key { + # Makes something like Super::Class|Super::Class::2=Role|Role::1 + return join '=' => ( + join( '|', @{ $_[0] || [] } ), + join( '|', sort @{ $_[1] || [] } ), + ); +} + +sub reinitialize { + my $self = shift; + my $pkg = shift; + + my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg); + + my $cache_key; + + my %existing_classes; + if ($meta) { + %existing_classes = map { $_ => $meta->$_() } qw( + attribute_metaclass + method_metaclass + wrapped_method_metaclass + instance_metaclass + constructor_class + 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( + $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; + + return $new_meta; +} + sub add_role { my ($self, $role) = @_; (blessed($role) && $role->isa('Moose::Meta::Role')) @@ -113,6 +190,19 @@ sub add_role { push @{$self->roles} => $role; } +sub role_applications { + my ($self) = @_; + + return @{$self->_get_role_applications}; +} + +sub add_role_application { + my ($self, $application) = @_; + (blessed($application) && $application->isa('Moose::Meta::Role::Application::ToClass')) + || $self->throw_error("Role applications must be instances of Moose::Meta::Role::Application::ToClass", data => $application); + push @{$self->_get_role_applications} => $application; +} + sub calculate_all_roles { my $self = shift; my %seen; @@ -121,11 +211,18 @@ sub calculate_all_roles { sub does_role { my ($self, $role_name) = @_; + (defined $role_name) || $self->throw_error("You must supply a role name to look for"); + foreach my $class ($self->class_precedence_list) { - next unless $class->can('meta') && $class->meta->can('roles'); - foreach my $role (@{$class->meta->roles}) { + my $meta = Class::MOP::class_of($class); + # when a Moose metaclass is itself extended with a role, + # this check needs to be done since some items in the + # class_precedence_list might in fact be Class::MOP + # based still. + next unless $meta && $meta->can('roles'); + foreach my $role (@{$meta->roles}) { return 1 if $role->does_role($role_name); } } @@ -134,17 +231,18 @@ sub does_role { sub excludes_role { my ($self, $role_name) = @_; + (defined $role_name) || $self->throw_error("You must supply a role name to look for"); + foreach my $class ($self->class_precedence_list) { - next unless $class->can('meta'); - # NOTE: - # in the pretty rare instance when a Moose metaclass - # is itself extended with a role, this check needs to - # be done since some items in the class_precedence_list - # might in fact be Class::MOP based still. - next unless $class->meta->can('roles'); - foreach my $role (@{$class->meta->roles}) { + my $meta = Class::MOP::class_of($class); + # when a Moose metaclass is itself extended with a role, + # this check needs to be done since some items in the + # class_precedence_list might in fact be Class::MOP + # based still. + next unless $meta && $meta->can('roles'); + foreach my $role (@{$meta->roles}) { return 1 if $role->excludes_role($role_name); } } @@ -173,37 +271,39 @@ sub new_object { ? $attr->get_read_method_ref->($self) : $params->{$init_arg} ), - $attr ); } return $self; } -sub _construct_instance { - my $class = shift; - my $params = @_ == 1 ? $_[0] : {@_}; - my $meta_instance = $class->get_meta_instance; - # FIXME: - # the code below is almost certainly incorrect - # but this is foreign inheritance, so we might - # have to kludge it in the end. - my $instance = $params->{'__INSTANCE__'} || $meta_instance->create_instance(); - foreach my $attr ($class->get_all_attributes()) { - $attr->initialize_instance_slot($meta_instance, $instance, $params); +sub superclasses { + my $self = shift; + my @supers = @_; + foreach my $super (@supers) { + Class::MOP::load_class($super); + my $meta = Class::MOP::class_of($super); + $self->throw_error("You cannot inherit from a Moose Role ($super)") + if $meta && $meta->isa('Moose::Meta::Role') } - return $instance; + return $self->SUPER::superclasses(@supers); } ### --------------------------------------------- sub add_attribute { my $self = shift; - $self->SUPER::add_attribute( + my $attr = (blessed $_[0] && $_[0]->isa('Class::MOP::Attribute') - ? $_[0] - : $self->_process_attribute(@_)) - ); + ? $_[0] + : $self->_process_attribute(@_)); + $self->SUPER::add_attribute($attr); + # it may be a Class::MOP::Attribute, theoretically, which doesn't have + # 'bare' and doesn't implement this method + if ($attr->can('_check_associated_methods')) { + $attr->_check_associated_methods; + } + return $attr; } sub add_override_method_modifier { @@ -246,31 +346,33 @@ sub _find_next_method_by_name_which_is_not_overridden { sub _fix_metaclass_incompatibility { my ($self, @superclasses) = @_; - foreach my $super (@superclasses) { - next if $self->_superclass_meta_is_compatible($super); + $self->_fix_one_incompatible_metaclass($_) + for map { Moose::Meta::Class->initialize($_) } @superclasses; +} - unless ( $self->is_pristine ) { - $self->throw_error( - "Cannot attempt to reinitialize metaclass for " - . $self->name - . ", it isn't pristine" ); - } +sub _fix_one_incompatible_metaclass { + my ($self, $meta) = @_; - $self->_reconcile_with_superclass_meta($super); + return if $self->_superclass_meta_is_compatible($meta); + + unless ( $self->is_pristine ) { + $self->throw_error( + "Cannot attempt to reinitialize metaclass for " + . $self->name + . ", it isn't pristine" ); } + + $self->_reconcile_with_superclass_meta($meta); } sub _superclass_meta_is_compatible { - my ($self, $super) = @_; - - my $super_meta = Class::MOP::Class->initialize($super) - or return 1; + my ($self, $super_meta) = @_; next unless $super_meta->isa("Class::MOP::Class"); my $super_meta_name = $super_meta->is_immutable - ? $super_meta->get_mutable_metaclass_name + ? $super_meta->_get_mutable_metaclass_name : ref($super_meta); return 1 @@ -281,17 +383,20 @@ sub _superclass_meta_is_compatible { # I don't want to have to type this >1 time my @MetaClassTypes = - qw( attribute_metaclass method_metaclass instance_metaclass - constructor_class destructor_class error_class ); + qw( attribute_metaclass + method_metaclass + wrapped_method_metaclass + instance_metaclass + constructor_class + destructor_class + error_class ); sub _reconcile_with_superclass_meta { - my ($self, $super) = @_; - - my $super_meta = $super->meta; + my ($self, $super_meta) = @_; my $super_meta_name = $super_meta->is_immutable - ? $super_meta->get_mutable_metaclass_name + ? $super_meta->_get_mutable_metaclass_name : ref($super_meta); my $self_metaclass = ref $self; @@ -454,7 +559,7 @@ sub _all_roles_until { sub _reconcile_role_differences { my ($self, $super_meta) = @_; - my $self_meta = $self->meta; + my $self_meta = Class::MOP::class_of($self); my %roles; @@ -483,14 +588,6 @@ sub _reconcile_role_differences { return $self; } -# NOTE: -# this was crap anyway, see -# Moose::Util::apply_all_roles -# instead -sub _apply_all_roles { - Carp::croak 'DEPRECATED: use Moose::Util::apply_all_roles($meta, @roles) instead' -} - sub _process_attribute { my ( $self, $name, @args ) = @_; @@ -527,36 +624,6 @@ sub _process_inherited_attribute { ## ------------------------------------------------- -use Moose::Meta::Method::Constructor; -use Moose::Meta::Method::Destructor; - - -sub _default_immutable_transformer_options { - my $self = shift; - - my %options = $self->SUPER::_default_immutable_transformer_options; - - # We need to copy the references as we do not want to alter the - # superclass's references. - $options{cannot_call} = [ @{ $options{cannot_call} }, 'add_role' ]; - $options{memoize} = { - %{ $options{memoize} }, - calculate_all_roles => 'ARRAY', - }; - - %options = ( - %options, - constructor_class => $self->constructor_class, - destructor_class => $self->destructor_class, - inline_destructor => 1, - - # Moose always does this when an attribute is created - inline_accessors => 0, - ); - - return %options -} - our $error_level; sub throw_error { @@ -634,8 +701,9 @@ These all default to the appropriate Moose class. =item B<< Moose::Meta::Class->create($package_name, %options) >> This overrides the parent's method in order to accept a C -option. This should be an array reference containing one more roles -that the class does. +option. This should be an array reference containing roles +that the class does, each optionally followed by a hashref of options +(C<-excludes> and C<-alias>). my $metaclass = Moose::Meta::Class->create( 'New::Class', roles => [...] ); @@ -687,10 +755,23 @@ which are attached to this class. This takes a L object, and adds it to the class's list of roles. This I actually apply the role to the class. -=item B<< $metaclass->does_role($role_name) >> +=item B<< $metaclass->role_applications >> + +Returns a list of L +objects, which contain the arguments to role application. + +=item B<< $metaclass->add_role_application($application) >> + +This takes a L object, and +adds it to the class's list of role applications. This I +actually apply any role to the class; it is only for tracking role +applications. + +=item B<< $metaclass->does_role($role) >> -This returns a boolean indicating whether or not the class does the -specified role. This tests both the class and its parents. +This returns a boolean indicating whether or not the class does the specified +role. The role provided can be either a role name or a L +object. This tests both the class and its parents. =item B<< $metaclass->excludes_role($role_name) >> @@ -725,9 +806,7 @@ Throws the error created by C using C =head1 BUGS -All complex software has bugs lurking in it, and this module is no -exception. If you find a bug please either email me, or add the bug -to cpan-RT. +See L for details on reporting bugs. =head1 AUTHOR @@ -735,7 +814,7 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006-2009 by Infinity Interactive, Inc. +Copyright 2006-2010 by Infinity Interactive, Inc. L