X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FClass.pm;h=5649794b6d59bb88e5a50f4fed714fa748bda255;hb=HEAD;hp=ae67045c3f2d83d1dbcaa3b551905735194ea5d2;hpb=ad46f5244f59757c45306c4a41e195b7aa4b0943;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index ae67045..5649794 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -4,15 +4,13 @@ package Moose::Meta::Class; use strict; use warnings; +use Class::Load qw(load_class); use Class::MOP; - 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 $AUTHORITY = 'cpan:STEVAN'; +use Scalar::Util 'blessed'; use Moose::Meta::Method::Overridden; use Moose::Meta::Method::Augmented; @@ -30,57 +28,72 @@ 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 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 ); @@ -89,41 +102,62 @@ sub create { return $new_meta; } -my %ANON_CLASSES; - -sub create_anon_class { - my ($self, %options) = @_; - - my $cache_ok = delete $options{cache}; +sub _meta_method_class { 'Moose::Meta::Method::Meta' } - my $cache_key - = _anon_cache_key( $options{superclasses}, $options{roles} ); +sub _anon_package_prefix { 'Moose::Meta::Class::__ANON__::SERIAL::' } - if ($cache_ok && defined $ANON_CLASSES{$cache_key}) { - return $ANON_CLASSES{$cache_key}; - } +sub _anon_cache_key { + my $class = shift; + my %options = @_; - $options{weaken} = !$cache_ok - unless exists $options{weaken}; + my $superclass_key = join('|', + map { $_->[0] } @{ Data::OptList::mkopt($options{superclasses} || []) } + ); - my $new_class = $self->SUPER::create_anon_class(%options); + 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) { - $ANON_CLASSES{$cache_key} = $new_class; - weaken($ANON_CLASSES{$cache_key}); + push @role_keys, $key; } - return $new_class; -} - -sub _meta_method_class { 'Moose::Meta::Method::Meta' } + my $role_key = join('|', sort @role_keys); -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 { @@ -132,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( @@ -145,31 +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; - weaken($ANON_CLASSES{$new_cache_key}); - - return $new_meta; } sub add_role { @@ -253,14 +267,22 @@ sub new_object { my $params = @_ == 1 ? $_[0] : {@_}; my $object = $self->SUPER::new_object($params); + $self->_call_all_triggers($object, $params); + + $object->BUILDALL($params) if $object->can('BUILDALL'); + + return $object; +} + +sub _call_all_triggers { + my ($self, $object, $params) = @_; + foreach my $attr ( $self->get_all_attributes() ) { next unless $attr->can('has_trigger') && $attr->has_trigger; my $init_arg = $attr->init_arg; - next unless defined $init_arg; - next unless exists $params->{$init_arg}; $attr->trigger->( @@ -272,10 +294,6 @@ sub new_object { ), ); } - - $object->BUILDALL($params) if $object->can('BUILDALL'); - - return $object; } sub _generate_fallback_constructor { @@ -373,7 +391,8 @@ sub _inline_init_attr_from_constructor { '$instance', '$params->{\'' . $attr->init_arg . '\'}', '$type_constraint_bodies[' . $idx . ']', - '$type_constraints[' . $idx . ']', + '$type_coercions[' . $idx . ']', + '$type_constraint_messages[' . $idx . ']', 'for constructor', ); @@ -391,6 +410,7 @@ 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; @@ -400,7 +420,8 @@ sub _inline_init_attr_from_default { '$instance', '$default', '$type_constraint_bodies[' . $idx . ']', - '$type_constraints[' . $idx . ']', + '$type_coercions[' . $idx . ']', + '$type_constraint_messages[' . $idx . ']', 'for constructor', ), ); @@ -438,7 +459,7 @@ sub _inline_triggers { push @trigger_calls, 'if (exists $params->{\'' . $init_arg . '\'}) {', - '$attrs->[' . $i . ']->trigger->(', + '$triggers->[' . $i . ']->(', '$instance,', $attr->_inline_instance_get('$instance') . ',', ');', @@ -462,12 +483,69 @@ sub _inline_BUILDALL { 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(\@_); foreach my $super (@{ $supers }) { my ($name, $opts) = @{ $super }; - Class::MOP::load_class($name, $opts); + load_class($name, $opts); my $meta = Class::MOP::class_of($name); $self->throw_error("You cannot inherit from a Moose Role ($name)") if $meta && $meta->isa('Moose::Meta::Role') @@ -635,6 +713,24 @@ 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 { @@ -650,6 +746,19 @@ sub _immutable_options { ); } +sub _fixup_attributes_after_rebless { + my $self = shift; + my ($instance, $rebless_from, %params) = @_; + + $self->SUPER::_fixup_attributes_after_rebless( + $instance, + $rebless_from, + %params + ); + + $self->_call_all_triggers( $instance, \%params ); +} + ## ------------------------------------------------- our $error_level; @@ -661,8 +770,8 @@ sub throw_error { } sub _inline_throw_error { - my ( $self, $msg, $args ) = @_; - "\$meta->throw_error($msg" . ($args ? ", $args" : "") . ")"; # FIXME makes deparsing *REALLY* hard + my ( $self, @args ) = @_; + $self->_inline_raise_error($self->_inline_create_error(@args)); } sub raise_error { @@ -670,6 +779,12 @@ sub raise_error { die @args; } +sub _inline_raise_error { + my ( $self, $message ) = @_; + + return 'die ' . $message; +} + sub create_error { my ( $self, @args ) = @_; @@ -687,7 +802,7 @@ sub create_error { my $class = ref $self ? $self->error_class : "Moose::Error::Default"; - Class::MOP::load_class($class); + load_class($class); $class->new( Carp::caller_info($args{depth}), @@ -695,6 +810,39 @@ 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"; + + 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 + . ( defined $args ? ', ' . $args : q{} ) . ');' + 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 @@ -762,15 +910,6 @@ required version. The C option also takes the C<-version> as an argument, but the option hash reference can also contain any other role relevant values like exclusions or parameterized role arguments. -=item B<< $metaclass->make_immutable(%options) >> - -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. - -Since Moose always inlines attributes, it sets the C option -to false. - =item B<< $metaclass->new_object(%params) >> This overrides the parent's method in order to add support for