X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FClass.pm;h=07f5e7e3b4cafc43bb470701f707cdb1d6d3ac6f;hb=462bdc732ebe32abf5b9f3cd40033540a5f1388f;hp=28713b0043ec86725fb6a6e6b495452c4bce51fb;hpb=f6df97aedcf7e635cfcc0ebcfe514fbc4ae6c6c1;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 28713b0..07f5e7e 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -6,25 +6,26 @@ use warnings; use Class::MOP; -use Carp (); +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'; -our $VERSION = '1.04'; -$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 Moose::Meta::Method::Meta; +use Moose::Util; +use Class::MOP::MiniTrait; use base 'Class::MOP::Class'; +Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait'); + __PACKAGE__->meta->add_attribute('roles' => ( reader => 'roles', default => sub { [] } @@ -69,19 +70,6 @@ sub initialize { ); } -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 ($class, $package_name, %options) = @_; @@ -113,14 +101,21 @@ sub create_anon_class { return $ANON_CLASSES{$cache_key}; } + $options{weaken} = !$cache_ok + unless exists $options{weaken}; + my $new_class = $self->SUPER::create_anon_class(%options); - $ANON_CLASSES{$cache_key} = $new_class - if $cache_ok; + 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_cache_key { # Makes something like Super::Class|Super::Class::2=Role|Role::1 return join '=' => ( @@ -170,6 +165,7 @@ sub reinitialize { delete $ANON_CLASSES{$cache_key}; $ANON_CLASSES{$new_cache_key} = $new_meta; + weaken($ANON_CLASSES{$new_cache_key}); return $new_meta; } @@ -200,6 +196,16 @@ sub calculate_all_roles { grep { !$seen{$_->name}++ } map { $_->calculate_all_roles } @{ $self->roles }; } +sub calculate_all_roles_with_inheritance { + my $self = shift; + my %seen; + grep { !$seen{$_->name}++ } + map { Class::MOP::class_of($_)->can('calculate_all_roles') + ? Class::MOP::class_of($_)->calculate_all_roles + : () } + $self->linearized_isa; +} + sub does_role { my ($self, $role_name) = @_; @@ -270,6 +276,191 @@ sub new_object { return $object; } +sub _generate_fallback_constructor { + my $self = shift; + my ($class) = @_; + return $class . '->Moose::Object::new(@_)' +} + +sub _inline_params { + my $self = shift; + my ($params, $class) = @_; + return ( + 'my ' . $params . ' = ', + $self->_inline_BUILDARGS($class, '@_'), + ';', + ); +} + +sub _inline_BUILDARGS { + my $self = shift; + my ($class, $args) = @_; + + my $buildargs = $self->find_method_by_name("BUILDARGS"); + + if ($args eq '@_' + && (!$buildargs or $buildargs->body == \&Moose::Object::BUILDARGS)) { + return ( + 'do {', + 'my $params;', + 'if (scalar @_ == 1) {', + 'if (!defined($_[0]) || ref($_[0]) ne \'HASH\') {', + $self->_inline_throw_error( + '"Single parameters to new() must be a HASH ref"', + 'data => $_[0]', + ) . ';', + '}', + '$params = { %{ $_[0] } };', + '}', + 'elsif (@_ % 2) {', + 'Carp::carp(', + '"The new() method for ' . $class . ' expects a ' + . 'hash reference or a key/value list. You passed an ' + . 'odd number of arguments"', + ');', + '$params = {@_, undef};', + '}', + 'else {', + '$params = {@_};', + '}', + '$params;', + '}', + ); + } + else { + return $class . '->BUILDARGS(' . $args . ')'; + } +} + +sub _inline_slot_initializer { + my $self = shift; + my ($attr, $idx) = @_; + + return ( + '## ' . $attr->name, + $self->_inline_check_required_attr($attr), + $self->SUPER::_inline_slot_initializer(@_), + ); +} + +sub _inline_check_required_attr { + my $self = shift; + my ($attr) = @_; + + return unless defined $attr->init_arg; + return unless $attr->can('is_required') && $attr->is_required; + return if $attr->has_default || $attr->has_builder; + + return ( + 'if (!exists $params->{\'' . $attr->init_arg . '\'}) {', + $self->_inline_throw_error( + '"Attribute (' . quotemeta($attr->name) . ') is required"' + ) . ';', + '}', + ); +} + +# XXX: these two are duplicated from cmop, because we have to pass the tc stuff +# through to _inline_set_value - this should probably be fixed, but i'm not +# quite sure how. -doy +sub _inline_init_attr_from_constructor { + my $self = shift; + my ($attr, $idx) = @_; + + my @initial_value = $attr->_inline_set_value( + '$instance', + '$params->{\'' . $attr->init_arg . '\'}', + '$type_constraint_bodies[' . $idx . ']', + '$type_constraints[' . $idx . ']', + 'for constructor', + ); + + push @initial_value, ( + '$attrs->[' . $idx . ']->set_initial_value(', + '$instance,', + $attr->_inline_instance_get('$instance'), + ');', + ) if $attr->has_initializer; + + return @initial_value; +} + +sub _inline_init_attr_from_default { + my $self = shift; + my ($attr, $idx) = @_; + + return if $attr->can('is_lazy') && $attr->is_lazy; + my $default = $self->_inline_default_value($attr, $idx); + return unless $default; + + my @initial_value = ( + 'my $default = ' . $default . ';', + $attr->_inline_set_value( + '$instance', + '$default', + '$type_constraint_bodies[' . $idx . ']', + '$type_constraints[' . $idx . ']', + 'for constructor', + ), + ); + + push @initial_value, ( + '$attrs->[' . $idx . ']->set_initial_value(', + '$instance,', + $attr->_inline_instance_get('$instance'), + ');', + ) if $attr->has_initializer; + + return @initial_value; +} + +sub _inline_extra_init { + my $self = shift; + return ( + $self->_inline_triggers, + $self->_inline_BUILDALL, + ); +} + +sub _inline_triggers { + my $self = shift; + my @trigger_calls; + + my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes; + for my $i (0 .. $#attrs) { + my $attr = $attrs[$i]; + + next unless $attr->can('has_trigger') && $attr->has_trigger; + + my $init_arg = $attr->init_arg; + next unless defined $init_arg; + + push @trigger_calls, + 'if (exists $params->{\'' . $init_arg . '\'}) {', + '$attrs->[' . $i . ']->trigger->(', + '$instance,', + $attr->_inline_instance_get('$instance') . ',', + ');', + '}'; + } + + return @trigger_calls; +} + +sub _inline_BUILDALL { + my $self = shift; + + my @methods = reverse $self->find_all_methods_by_name('BUILD'); + my @BUILD_calls; + + foreach my $method (@methods) { + push @BUILD_calls, + '$instance->' . $method->{class} . '::BUILD($params);'; + } + + return @BUILD_calls; +} + sub superclasses { my $self = shift; my $supers = Data::OptList::mkopt(\@_); @@ -351,189 +542,62 @@ sub _base_metaclasses { ); } -sub _find_common_base { - my $self = shift; - my ($meta1, $meta2) = map { Class::MOP::class_of($_) } @_; - return unless defined($meta1) && defined($meta2); - - # FIXME? This doesn't account for multiple inheritance (not sure - # if it needs to though). For example, is somewhere in $meta1's - # history it inherits from both ClassA and ClassB, and $meta2 - # inherits from ClassB & ClassA, does it matter? And what crazy - # fool would do that anyway? - - my %meta1_parents = map { $_ => 1 } $meta1->linearized_isa; - - return first { $meta1_parents{$_} } $meta2->linearized_isa; -} - -sub _get_ancestors_until { - my $self = shift; - my ($start, $until) = @_; - - my @ancestors; - for my $ancestor (Class::MOP::class_of($start)->linearized_isa) { - last if $ancestor eq $until; - push @ancestors, $ancestor; - } - return @ancestors; -} - -sub _is_role_only_subclass { - my $self = shift; - my ($class) = @_; - my $meta = Class::MOP::Class->initialize($class); - my @parents = $meta->superclasses; - - # XXX: don't feel like messing with multiple inheritance here... what would - # that even do? - return unless @parents == 1; - my ($parent) = @parents; - my $parent_meta = Class::MOP::Class->initialize($parent); - - # loop over all methods that are a part of the current class - # (not inherited) - for my $method (map { $meta->meta->get_method($_) } $meta->meta->get_method_list) { - # always ignore meta - next if $method->name eq 'meta'; - # we'll deal with attributes below - next if $method->isa('Class::MOP::Method::Accessor'); - # if the method comes from a role we consumed, ignore it - next if $meta->meta->can('does_role') - && $meta->meta->does_role($method->original_package_name); - - return 0; - } - - # loop over all attributes that are a part of the current class - # (not inherited) - # FIXME - this really isn't right. Just because an attribute is - # defined in a role doesn't mean it isn't _also_ defined in the - # subclass. - for my $attr (map { $meta->meta->get_attribute($_) } $meta->meta->get_attribute_list) { - next if any { $_->has_attribute($attr->name) } - map { $_->meta->can('calculate_all_roles') - ? $_->meta->calculate_all_roles - : () } - $meta->linearized_isa; - - return 0; - } - - return 1; -} - -sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation { +sub _fix_class_metaclass_incompatibility { my $self = shift; my ($super_meta) = @_; - my $common_base = $self->_find_common_base($self, $super_meta); - # if they're not both moose metaclasses, and the cmop fixing couldn't - # do anything, there's nothing more we can do - return unless defined($common_base); - return unless $common_base->isa('Moose::Meta::Class'); - - my @superclass_ancestors = $self->_get_ancestors_until($super_meta, $common_base); - my @ancestors = $self->_get_ancestors_until($self, $common_base); - # we're only dealing with roles here - return unless all { $self->_is_role_only_subclass($_) } - (@superclass_ancestors, @ancestors); - - return 1; -} - -sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation { - my $self = shift; - my ($metaclass_type, $super_metaclass) = @_; - - my $meta = $self->$metaclass_type; - return unless $super_metaclass->can($metaclass_type); - my $super_meta = $super_metaclass->$metaclass_type; - my %metaclasses = $self->_base_metaclasses; - - my $common_base = $self->_find_common_base($meta, $super_meta); - # if they're not both moose metaclasses, and the cmop fixing couldn't - # do anything, there's nothing more we can do - return unless defined($common_base); - return unless $common_base->isa($metaclasses{$metaclass_type}); - - my @superclass_ancestors = $self->_get_ancestors_until($super_meta, $common_base); - my @ancestors = $self->_get_ancestors_until($meta, $common_base); - # we're only dealing with roles here - return unless all { $self->_is_role_only_subclass($_) } - (@superclass_ancestors, @ancestors); - - return 1; -} - -sub _role_differences { - my $self = shift; - my ($meta, $super_meta) = @_; - my @super_roles = $super_meta->meta->calculate_all_roles; - my @roles = $meta->meta->calculate_all_roles; - my @differences; - for my $role (@super_roles) { - push @differences, $role unless any { $_->name eq $role->name } @roles; - } - return @differences; -} - -sub _reconcile_roles_for_metaclass { - my $self = shift; - my ($meta, $super_meta, $base_class) = @_; - - my @role_differences = $self->_role_differences($meta, $super_meta); - return $self->meta->create_anon_class( - superclasses => [$super_meta], - roles => \@role_differences, - cache => 1, - ); -} - -sub _can_fix_metaclass_incompatibility_by_role_reconciliation { - my $self = shift; - my ($super_meta) = @_; + $self->SUPER::_fix_class_metaclass_incompatibility(@_); - return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta); + if ($self->_class_metaclass_can_be_made_compatible($super_meta)) { + ($self->is_pristine) + || confess "Can't fix metaclass incompatibility for " + . $self->name + . " because it is not pristine."; + my $super_meta_name = $super_meta->_real_ref_name; + my $class_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass(blessed($self), $super_meta_name); + my $new_self = $class_meta_subclass_meta_name->reinitialize( + $self->name, + ); - my %base_metaclass = $self->_base_metaclasses; - for my $metaclass_type (keys %base_metaclass) { - next unless defined $self->$metaclass_type; - return 1 if $self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta); + $self->_replace_self( $new_self, $class_meta_subclass_meta_name ); } - - return; } -sub _can_fix_metaclass_incompatibility { +sub _fix_single_metaclass_incompatibility { my $self = shift; - return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_); - return $self->SUPER::_can_fix_metaclass_incompatibility(@_); -} + my ($metaclass_type, $super_meta) = @_; -sub _fix_class_metaclass_incompatibility { - my $self = shift; - my ($super_meta) = @_; + $self->SUPER::_fix_single_metaclass_incompatibility(@_); - $self->SUPER::_fix_class_metaclass_incompatibility(@_); + if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) { + ($self->is_pristine) + || confess "Can't fix metaclass incompatibility for " + . $self->name + . " because it is not pristine."; + my $super_meta_name = $super_meta->_real_ref_name; + my $class_specific_meta_subclass_meta_name = Moose::Util::_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type); + my $new_self = $super_meta->reinitialize( + $self->name, + $metaclass_type => $class_specific_meta_subclass_meta_name, + ); - if ($self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta)) { - my $subclass = $self->_reconcile_roles_for_metaclass($self, $super_meta, 'Moose::Meta::Class'); - $subclass->meta->rebless_instace($self); + $self->_replace_self( $new_self, $super_meta_name ); } } -sub _fix_single_metaclass_incompatibility { - my $self = shift; - my ($metaclass_type, $super_meta) = @_; +sub _replace_self { + my $self = shift; + my ( $new_self, $new_class) = @_; - $self->SUPER::_fix_single_metaclass_incompatibility(@_); + %$self = %$new_self; + bless $self, $new_class; - if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) { - my %metaclasses = $self->_base_metaclasses; - my $subclass = $self->_reconcile_roles_for_metaclass($self->$metaclass_type, $super_meta->$metaclass_type, $metaclasses{$metaclass_type}); - $self->$metaclass_type($subclass->name); - } + # We need to replace the cached metaclass instance or else when it goes + # out of scope Class::MOP::Class destroy's the namespace for the + # metaclass's class, causing much havoc. + my $weaken = Class::MOP::metaclass_is_weak( $self->name ); + Class::MOP::store_metaclass_by_name( $self->name, $self ); + Class::MOP::weaken_metaclass( $self->name ) if $weaken; } sub _process_attribute { @@ -570,6 +634,39 @@ sub _process_inherited_attribute { } } +# reinitialization support + +sub _restore_metaobjects_from { + my $self = shift; + my ($old_meta) = @_; + + $self->SUPER::_restore_metaobjects_from($old_meta); + + for my $role ( @{ $old_meta->roles } ) { + $self->add_role($role); + } + + for my $application ( @{ $old_meta->_get_role_applications } ) { + $application->class($self); + $self->add_role_application ($application); + } +} + +## Immutability + +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, + ); +} + ## ------------------------------------------------- our $error_level; @@ -580,6 +677,11 @@ sub throw_error { $self->raise_error($self->create_error(@args)); } +sub _inline_throw_error { + my ( $self, $msg, $args ) = @_; + "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard +} + sub raise_error { my ( $self, @args ) = @_; die @args; @@ -612,14 +714,12 @@ sub create_error { 1; +# ABSTRACT: The Moose metaclass + __END__ =pod -=head1 NAME - -Moose::Meta::Class - The Moose metaclass - =head1 DESCRIPTION This class is a subclass of L that provides @@ -685,8 +785,8 @@ This overrides the parent's method to add a few options. Specifically, it uses the Moose-specific constructor and destructor classes, and enables inlining the destructor. -Also, since Moose always inlines attributes, it sets the -C option to false. +Since Moose always inlines attributes, it sets the C option +to false. =item B<< $metaclass->new_object(%params) >> @@ -715,6 +815,11 @@ This adds an C method modifier to the package. This will return a unique array of C instances which are attached to this class. +=item B<< $metaclass->calculate_all_roles_with_inheritance >> + +This will return a unique array of C instances +which are attached to this class, and each of this class's ancestors. + =item B<< $metaclass->add_role($role) >> This takes a L object, and adds it to the class's @@ -752,8 +857,8 @@ be provided as a hash reference. =item B<< $metaclass->destructor_class($class_name) >> -These are the names of classes used when making a class -immutable. These default to L and +These are the names of classes used when making a class immutable. These +default to L and L respectively. These accessors are read-write, so you can use them to change the class name. @@ -773,18 +878,5 @@ Throws the error created by C using C See L for details on reporting bugs. -=head1 AUTHOR - -Stevan Little Estevan@iinteractive.comE - -=head1 COPYRIGHT AND LICENSE - -Copyright 2006-2010 by Infinity Interactive, Inc. - -L - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - =cut