X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FClass.pm;h=52c9676ce247da93b6d0d300d0a4445b7556ba9d;hb=83dcb8665835751e1c79b6e44df247d25cd256fd;hp=5183e80bee4a6c6b41f3f3eeb6d0f699338d2aad;hpb=d27828133036cdd69923572453faad3920fd7c0e;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 5183e80..52c9676 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -10,11 +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'; - -our $VERSION = '1.14'; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; +use Scalar::Util 'blessed'; use Moose::Meta::Method::Overridden; use Moose::Meta::Method::Augmented; @@ -22,6 +18,7 @@ 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; @@ -63,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 ); @@ -90,34 +96,57 @@ sub create { return $new_meta; } -my %ANON_CLASSES; - -sub create_anon_class { - my ($self, %options) = @_; +sub _meta_method_class { 'Moose::Meta::Method::Meta' } - my $cache_ok = delete $options{cache}; +sub _anon_package_prefix { 'Moose::Meta::Class::__ANON__::SERIAL::' } - my $cache_key - = _anon_cache_key( $options{superclasses}, $options{roles} ); +sub _anon_cache_key { + my $class = shift; + my %options = @_; - if ($cache_ok && defined $ANON_CLASSES{$cache_key}) { - return $ANON_CLASSES{$cache_key}; - } + 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; + } + + $key .= '<' . join('+', 'a', join('%', %$alias), + 'e', join('%', @$excludes)) . '>'; + } - $ANON_CLASSES{$cache_key} = $new_class - if $cache_ok; + push @role_keys, $key; + } - return $new_class; -} + my $role_key = join('|', @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 { @@ -126,8 +155,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( @@ -139,30 +166,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 { @@ -271,6 +281,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(\@_); @@ -352,61 +547,13 @@ sub _base_metaclasses { ); } -sub _can_fix_metaclass_incompatibility { - my $self = shift; - return 1 if $self->_can_fix_metaclass_incompatibility_by_role_reconciliation(@_); - return $self->SUPER::_can_fix_metaclass_incompatibility(@_); -} - -sub _can_fix_metaclass_incompatibility_by_role_reconciliation { - my $self = shift; - my ($super_meta) = @_; - - return 1 if $self->_can_fix_class_metaclass_incompatibility_by_role_reconciliation($super_meta); - - 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); - } - - return; -} - -sub _can_fix_class_metaclass_incompatibility_by_role_reconciliation { - my $self = shift; - my ($super_meta) = @_; - - my $super_meta_name = $super_meta->_real_ref_name; - - return Moose::Util::_classes_differ_by_roles_only( - blessed($self), - $super_meta_name, - ); -} - -sub _can_fix_single_metaclass_incompatibility_by_role_reconciliation { - my $self = shift; - my ($metaclass_type, $super_meta) = @_; - - my $class_specific_meta_name = $self->$metaclass_type; - return unless $super_meta->can($metaclass_type); - my $super_specific_meta_name = $super_meta->$metaclass_type; - my %metaclasses = $self->_base_metaclasses; - - return Moose::Util::_classes_differ_by_roles_only( - $class_specific_meta_name, - $super_specific_meta_name, - ); -} - sub _fix_class_metaclass_incompatibility { my $self = shift; my ($super_meta) = @_; $self->SUPER::_fix_class_metaclass_incompatibility(@_); - 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 @@ -427,7 +574,7 @@ sub _fix_single_metaclass_incompatibility { $self->SUPER::_fix_single_metaclass_incompatibility(@_); - if ($self->_can_fix_single_metaclass_incompatibility_by_role_reconciliation($metaclass_type, $super_meta)) { + if ($self->_single_metaclass_can_be_made_compatible($super_meta, $metaclass_type)) { ($self->is_pristine) || confess "Can't fix metaclass incompatibility for " . $self->name @@ -453,8 +600,9 @@ sub _replace_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 $self->is_anon_class; + Class::MOP::weaken_metaclass( $self->name ) if $weaken; } sub _process_attribute { @@ -491,6 +639,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 { @@ -516,6 +682,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; @@ -548,14 +719,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 @@ -714,18 +883,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