X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FClass.pm;h=57d76f5ea83475a3764bbb95ee95d6ab1dc20479;hb=96fec63368aadd66c72d692173f673f1cf21c32f;hp=0e4897c5e09b789bd6d5ee08cd89dabc53c8f08a;hpb=7d4035ae0f917e1ee46855edd971fa2205bc783e;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 0e4897c..57d76f5 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -6,15 +6,11 @@ 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.03'; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; +use Scalar::Util 'blessed'; use Moose::Meta::Method::Overridden; use Moose::Meta::Method::Augmented; @@ -22,75 +18,82 @@ 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 { [] } + default => sub { [] }, + Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('role_applications' => ( reader => '_get_role_applications', - default => sub { [] } + default => sub { [] }, + Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute( Class::MOP::Attribute->new('immutable_trait' => ( accessor => "immutable_trait", default => 'Moose::Meta::Class::Immutable::Trait', + Class::MOP::_definition_context(), )) ); __PACKAGE__->meta->add_attribute('constructor_class' => ( accessor => 'constructor_class', default => 'Moose::Meta::Method::Constructor', + Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('destructor_class' => ( accessor => 'destructor_class', default => 'Moose::Meta::Method::Destructor', + Class::MOP::_definition_context(), )); __PACKAGE__->meta->add_attribute('error_class' => ( accessor => 'error_class', default => 'Moose::Error::Default', + Class::MOP::_definition_context(), )); 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 _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) = @_; + 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 ); @@ -99,44 +102,62 @@ sub create { return $new_meta; } -sub _check_metaclass_compatibility { - my $self = shift; - - if ( my @supers = $self->superclasses ) { - $self->_fix_metaclass_incompatibility(@supers); - } - - $self->SUPER::_check_metaclass_compatibility(@_); -} +sub _meta_method_class { 'Moose::Meta::Method::Meta' } -my %ANON_CLASSES; +sub _anon_package_prefix { 'Moose::Meta::Class::__ANON__::SERIAL::' } -sub create_anon_class { - my ($self, %options) = @_; +sub _anon_cache_key { + my $class = shift; + my %options = @_; - my $cache_ok = delete $options{cache}; + my $superclass_key = join('|', + map { $_->[0] } @{ Data::OptList::mkopt($options{superclasses} || []) } + ); - my $cache_key - = _anon_cache_key( $options{superclasses}, $options{roles} ); + my $roles = Data::OptList::mkopt(($options{roles} || []), { + moniker => 'role', + val_test => sub { ref($_[0]) eq 'HASH' }, + }); + + my @role_keys; + for my $role_spec (@$roles) { + my ($role, $params) = @$role_spec; + $params = { %$params } if $params; + + my $key = blessed($role) ? $role->name : $role; + + if ($params && %$params) { + my $alias = delete $params->{'-alias'} + || delete $params->{'alias'} + || {}; + my $excludes = delete $params->{'-excludes'} + || delete $params->{'excludes'} + || []; + $excludes = [$excludes] unless ref($excludes) eq 'ARRAY'; + + if (%$params) { + warn "Roles with parameters cannot be cached. Consider " + . "applying the parameters before calling " + . "create_anon_class, or using 'weaken => 0' instead"; + return; + } + + my $alias_key = join('%', + map { $_ => $alias->{$_} } sort keys %$alias + ); + my $excludes_key = join('%', + sort @$excludes + ); + $key .= '<' . join('+', 'a', $alias_key, 'e', $excludes_key) . '>'; + } - if ($cache_ok && defined $ANON_CLASSES{$cache_key}) { - return $ANON_CLASSES{$cache_key}; + push @role_keys, $key; } - my $new_class = $self->SUPER::create_anon_class(%options); - - $ANON_CLASSES{$cache_key} = $new_class - if $cache_ok; + my $role_key = join('|', sort @role_keys); - 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] || [] } ), - ); + return join('=', $superclass_key, $role_key); } sub reinitialize { @@ -145,8 +166,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( @@ -158,30 +177,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; - - return $new_meta; } sub add_role { @@ -210,6 +212,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) = @_; @@ -280,6 +292,250 @@ 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_coercions[' . $idx . ']', + '$type_constraint_messages[' . $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_coercions[' . $idx . ']', + '$type_constraint_messages[' . $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 . '\'}) {', + '$triggers->[' . $i . ']->(', + '$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 _eval_environment { + my $self = shift; + + my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes; + + my $triggers = [ + map { $_->can('has_trigger') && $_->has_trigger ? $_->trigger : undef } + @attrs + ]; + + # We need to check if the attribute ->can('type_constraint') + # since we may be trying to immutabilize a Moose meta class, + # which in turn has attributes which are Class::MOP::Attribute + # objects, rather than Moose::Meta::Attribute. And + # Class::MOP::Attribute attributes have no type constraints. + # However we need to make sure we leave an undef value there + # because the inlined code is using the index of the attributes + # to determine where to find the type constraint + + my @type_constraints = map { + $_->can('type_constraint') ? $_->type_constraint : undef + } @attrs; + + my @type_constraint_bodies = map { + defined $_ ? $_->_compiled_type_constraint : undef; + } @type_constraints; + + my @type_coercions = map { + defined $_ && $_->has_coercion + ? $_->coercion->_compiled_type_coercion + : undef + } @type_constraints; + + my @type_constraint_messages = map { + defined $_ + ? ($_->has_message ? $_->message : $_->_default_message) + : undef + } @type_constraints; + + return { + %{ $self->SUPER::_eval_environment }, + ((any { defined && $_->has_initializer } @attrs) + ? ('$attrs' => \[@attrs]) + : ()), + '$triggers' => \$triggers, + '@type_coercions' => \@type_coercions, + '@type_constraint_bodies' => \@type_constraint_bodies, + '@type_constraint_messages' => \@type_constraint_messages, + ( map { defined($_) ? %{ $_->inline_environment } : () } + @type_constraints ), + # pretty sure this is only going to be closed over if you use a custom + # error class at this point, but we should still get rid of this + # at some point + '$meta' => \$self, + }; +} + sub superclasses { my $self = shift; my $supers = Data::OptList::mkopt(\@_); @@ -347,249 +603,76 @@ sub _find_next_method_by_name_which_is_not_overridden { return undef; } -sub _fix_metaclass_incompatibility { - my ($self, @superclasses) = @_; - - $self->_fix_one_incompatible_metaclass($_) - for map { Moose::Meta::Class->initialize($_) } @superclasses; -} - -sub _fix_one_incompatible_metaclass { - my ($self, $meta) = @_; - - 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_meta) = @_; - - next unless $super_meta->isa("Class::MOP::Class"); - - my $super_meta_name - = $super_meta->is_immutable - ? $super_meta->_get_mutable_metaclass_name - : ref($super_meta); - - return 1 - if $self->isa($super_meta_name) - and - $self->instance_metaclass->isa( $super_meta->instance_metaclass ); -} - -# I don't want to have to type this >1 time -my @MetaClassTypes = - qw( attribute_metaclass - method_metaclass - wrapped_method_metaclass - instance_metaclass - constructor_class - destructor_class - error_class ); - -sub _reconcile_with_superclass_meta { - my ($self, $super_meta) = @_; +## Metaclass compatibility - my $super_meta_name - = $super_meta->is_immutable - ? $super_meta->_get_mutable_metaclass_name - : ref($super_meta); - - my $self_metaclass = ref $self; - - # If neither of these is true we have a more serious - # incompatibility that we just cannot fix (yet?). - if ( $super_meta_name->isa( ref $self ) - && all { $super_meta->$_->isa( $self->$_ ) } @MetaClassTypes ) { - $self->_reinitialize_with($super_meta); - } - elsif ( $self->_all_metaclasses_differ_by_roles_only($super_meta) ) { - $self->_reconcile_role_differences($super_meta); +sub _base_metaclasses { + my $self = shift; + my %metaclasses = $self->SUPER::_base_metaclasses; + for my $class (keys %metaclasses) { + $metaclasses{$class} =~ s/^Class::MOP/Moose::Meta/; } -} - -sub _reinitialize_with { - my ( $self, $new_meta ) = @_; - - my $new_self = $new_meta->reinitialize( - $self->name, - attribute_metaclass => $new_meta->attribute_metaclass, - method_metaclass => $new_meta->method_metaclass, - instance_metaclass => $new_meta->instance_metaclass, + return ( + %metaclasses, + error_class => 'Moose::Error::Default', ); - - $new_self->$_( $new_meta->$_ ) - for qw( constructor_class destructor_class error_class ); - - %$self = %$new_self; - - bless $self, ref $new_self; - - # 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. - Class::MOP::store_metaclass_by_name( $self->name, $self ); - Class::MOP::weaken_metaclass( $self->name ) if $self->is_anon_class; } -# In the more complex case, we share a common ancestor with our -# superclass's metaclass, but each metaclass (ours and the parent's) -# has a different set of roles applied. We reconcile this by first -# reinitializing into the parent class, and _then_ applying our own -# roles. -sub _all_metaclasses_differ_by_roles_only { - my ($self, $super_meta) = @_; - - for my $pair ( - [ ref $self, ref $super_meta ], - map { [ $self->$_, $super_meta->$_ ] } @MetaClassTypes - ) { - - next if $pair->[0] eq $pair->[1]; - - my $self_meta_meta = Class::MOP::Class->initialize( $pair->[0] ); - my $super_meta_meta = Class::MOP::Class->initialize( $pair->[1] ); - - my $common_ancestor - = _find_common_ancestor( $self_meta_meta, $super_meta_meta ); - - return unless $common_ancestor; - - return - unless _is_role_only_subclass_of( - $self_meta_meta, - $common_ancestor, - ) - && _is_role_only_subclass_of( - $super_meta_meta, - $common_ancestor, - ); - } - - return 1; -} - -# This, and some other functions, could be called as methods, but -# they're not for two reasons. One, we just end up ignoring the first -# argument, because we can't call these directly on one of the real -# arguments, because one of them could be a Class::MOP::Class object -# and not a Moose::Meta::Class. Second, only a completely insane -# person would attempt to subclass this stuff! -sub _find_common_ancestor { - my ($meta1, $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 _is_role_only_subclass_of { - my ($meta, $ancestor) = @_; - - return 1 if $meta->name eq $ancestor; - - my @roles = _all_roles_until( $meta, $ancestor ); - - my %role_packages = map { $_->name => 1 } @roles; - - my $ancestor_meta = Class::MOP::Class->initialize($ancestor); - - my %shared_ancestors = map { $_ => 1 } $ancestor_meta->linearized_isa; - - for my $method ( $meta->get_all_methods() ) { - next if $method->name eq 'meta'; - next if $method->can('associated_attribute'); - - next - if $role_packages{ $method->original_package_name } - || $shared_ancestors{ $method->original_package_name }; - - return 0; - } - - # 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 ( $meta->get_all_attributes ) { - next if $shared_ancestors{ $attr->associated_class->name }; - - next if any { $_->has_attribute( $attr->name ) } @roles; +sub _fix_class_metaclass_incompatibility { + my $self = shift; + my ($super_meta) = @_; + + $self->SUPER::_fix_class_metaclass_incompatibility(@_); + + 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, + ); - return 0; + $self->_replace_self( $new_self, $class_meta_subclass_meta_name ); } - - return 1; -} - -sub _all_roles { - my $meta = shift; - - return _all_roles_until($meta); } -sub _all_roles_until { - my ($meta, $stop_at_class) = @_; - - return unless $meta->can('calculate_all_roles'); - - my @roles = $meta->calculate_all_roles; - - for my $class ( $meta->linearized_isa ) { - last if $stop_at_class && $stop_at_class eq $class; - - my $meta = Class::MOP::Class->initialize($class); - last unless $meta->can('calculate_all_roles'); +sub _fix_single_metaclass_incompatibility { + my $self = shift; + my ($metaclass_type, $super_meta) = @_; + + $self->SUPER::_fix_single_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, + ); - push @roles, $meta->calculate_all_roles; + $self->_replace_self( $new_self, $super_meta_name ); } - - return uniq @roles; } -sub _reconcile_role_differences { - my ($self, $super_meta) = @_; - - my $self_meta = Class::MOP::class_of($self); - - my %roles; - - if ( my @roles = map { $_->name } _all_roles($self_meta) ) { - $roles{metaclass_roles} = \@roles; - } - - for my $thing (@MetaClassTypes) { - my $name = $self->$thing(); - - my $thing_meta = Class::MOP::Class->initialize($name); - - my @roles = map { $_->name } _all_roles($thing_meta) - or next; - - $roles{ $thing . '_roles' } = \@roles; - } - - $self->_reinitialize_with($super_meta); +sub _replace_self { + my $self = shift; + my ( $new_self, $new_class) = @_; - Moose::Util::MetaRole::apply_metaclass_roles( - for_class => $self->name, - %roles, - ); + %$self = %$new_self; + bless $self, $new_class; - return $self; + # 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 { @@ -626,6 +709,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; @@ -636,11 +752,24 @@ sub throw_error { $self->raise_error($self->create_error(@args)); } +sub _inline_throw_error { + my ( $self, @args ) = @_; + $self->_inline_raise_error($self->_inline_create_error(@args)); +} + sub raise_error { my ( $self, @args ) = @_; die @args; } +sub _inline_raise_error { + my ( $self, $message ) = @_; + + return ( + 'die ' . $message . ';', + ); +} + sub create_error { my ( $self, @args ) = @_; @@ -666,16 +795,44 @@ sub create_error { ); } +sub _inline_create_error { + my ( $self, $msg, $args ) = @_; + # XXX ignore $args for now, nothing currently uses it anyway + + require Carp::Heavy; + + my %args = ( + metaclass => $self, + last_error => $@, + message => $msg, + ); + + my $class = ref $self ? $self->error_class : "Moose::Error::Default"; + + Class::MOP::load_class($class); + + # don't check inheritance here - the intention is that the class needs + # to provide a non-inherited inlining method, because falling back to + # the default inlining method is most likely going to be wrong + # yes, this is a huge hack, but so is the entire error system, so. + return '$meta->create_error(' . $msg . ', ' . $args . ');' + unless $class->meta->has_method('_inline_new'); + + $class->_inline_new( + # XXX ignore this for now too + # Carp::caller_info($args{depth}), + %args + ); +} + 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 @@ -741,8 +898,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) >> @@ -771,6 +928,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 @@ -804,12 +966,12 @@ excludes the named role. This tests both the class and its parents. This overrides the parent's method in order to allow the parameters to be provided as a hash reference. -=item B<< $metaclass->constructor_class ($class_name) >> +=item B<< $metaclass->constructor_class($class_name) >> -=item B<< $metaclass->destructor_class ($class_name) >> +=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. @@ -829,18 +991,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