X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FMeta%2FClass.pm;h=f813660e5199d6c9f31ffa3daea40894980674a3;hb=1f6046f098167a6bc7699ad8d844d1b72c49f634;hp=df95ad6bf69f5a4d6beb265fca5e5ea65bba75b6;hpb=a5c683f611022dcabb13169162fa2f57ba72b200;p=gitmo%2FMouse.git diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm index df95ad6..f813660 100644 --- a/lib/Mouse/Meta/Class.pm +++ b/lib/Mouse/Meta/Class.pm @@ -3,15 +3,17 @@ use Mouse::Util qw/:meta get_linear_isa not_supported/; # enables strict and war use Scalar::Util qw/blessed weaken/; -use Mouse::Meta::Method::Destructor; use Mouse::Meta::Module; our @ISA = qw(Mouse::Meta::Module); -sub method_metaclass() { 'Mouse::Meta::Method' } -sub attribute_metaclass() { 'Mouse::Meta::Attribute' } +our @CARP_NOT = qw(Mouse); # trust Mouse + +sub attribute_metaclass; +sub method_metaclass; + +sub constructor_class; +sub destructor_class; -sub constructor_class(); -sub destructor_class(); sub _construct_meta { my($class, %args) = @_; @@ -55,15 +57,84 @@ sub superclasses { foreach my $super(@_){ Mouse::Util::load_class($super); my $meta = Mouse::Util::get_metaclass_by_name($super); + + next if not defined $meta; + if(Mouse::Util::is_a_metarole($meta)){ $self->throw_error("You cannot inherit from a Mouse Role ($super)"); } + + next if $self->isa(ref $meta); # _superclass_meta_is_compatible + + $self->_reconcile_with_superclass_meta($meta); } @{ $self->{superclasses} } = @_; } return @{ $self->{superclasses} }; } +my @MetaClassTypes = ( + 'attribute', # Mouse::Meta::Attribute + 'method', # Mouse::Meta::Method + 'constructor', # Mouse::Meta::Method::Constructor + 'destructor', # Mouse::Meta::Method::Destructor +); + +sub _reconcile_with_superclass_meta { + my($self, $other) = @_; + + # find incompatible traits + my %metaroles; + foreach my $metaclass_type(@MetaClassTypes){ + my $accessor = $self->can($metaclass_type . '_metaclass') + || $self->can($metaclass_type . '_class'); + + my $other_c = $other->$accessor(); + my $self_c = $self->$accessor(); + + if(!$self_c->isa($other_c)){ + $metaroles{$metaclass_type} + = [ $self_c->meta->_collect_roles($other_c->meta) ]; + } + } + + $metaroles{class} = [$self->meta->_collect_roles($other->meta)]; + + #use Data::Dumper; print Data::Dumper->new([\%metaroles], ['*metaroles'])->Indent(1)->Dump; + + require Mouse::Util::MetaRole; + $_[0] = Mouse::Util::MetaRole::apply_metaroles( + for => $self, + class_metaroles => \%metaroles, + ); + return; +} + +sub _collect_roles { + my ($self, $other) = @_; + + # find common ancestor + my @self_lin_isa = $self->linearized_isa; + my @other_lin_isa = $other->linearized_isa; + + my(@self_anon_supers, @other_anon_supers); + push @self_anon_supers, shift @self_lin_isa while $self_lin_isa[0]->meta->is_anon_class; + push @other_anon_supers, shift @other_lin_isa while $other_lin_isa[0]->meta->is_anon_class; + + my $common_ancestor = $self_lin_isa[0] eq $other_lin_isa[0] && $self_lin_isa[0]; + + if(!$common_ancestor){ + $self->throw_error(sprintf '%s cannot have %s as a super class because of their metaclass incompatibility', + $self->name, $other->name); + } + + my %seen; + return sort grep { !$seen{$_}++ } ## no critic + (map{ $_->name } map{ $_->meta->calculate_all_roles } @self_anon_supers), + (map{ $_->name } map{ $_->meta->calculate_all_roles } @other_anon_supers), + ; +} + sub find_method_by_name{ my($self, $method_name) = @_; @@ -141,75 +212,76 @@ sub add_attribute { $self->{attributes}{$attr->name} = $attr; $attr->install_accessors(); - if(_MOUSE_VERBOSE && !$attr->{associated_methods} && ($attr->{is} || '') ne 'bare'){ - Carp::cluck(qq{Attribute (}.$attr->name.qq{) of class }.$self->name.qq{ has no associated methods (did you mean to provide an "is" argument?)}); + if(!$attr->{associated_methods} && ($attr->{is} || '') ne 'bare'){ + Carp::carp(qq{Attribute ($name) of class }.$self->name + .qq{ has no associated methods (did you mean to provide an "is" argument?)}); } return $attr; } -sub compute_all_applicable_attributes { - Carp::cluck('compute_all_applicable_attributes() has been deprecated') - if _MOUSE_VERBOSE; +sub compute_all_applicable_attributes { # DEPRECATED + Carp::cluck('compute_all_applicable_attributes() has been deprecated. Use get_all_attributes() instead'); + return shift->get_all_attributes(@_) } sub linearized_isa; -sub new_object { - my $self = shift; - my %args = (@_ == 1 ? %{$_[0]} : @_); - - my $object = bless {}, $self->name; - - $self->_initialize_object($object, \%args); - return $object; -} +sub new_object; sub clone_object { my $class = shift; my $object = shift; - my %params = (@_ == 1) ? %{$_[0]} : @_; + my $args = $object->Mouse::Object::BUILDARGS(@_); (blessed($object) && $object->isa($class->name)) || $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($object)"); my $cloned = bless { %$object }, ref $object; - $class->_initialize_object($cloned, \%params); + $class->_initialize_object($cloned, $args); return $cloned; } -sub clone_instance { +sub clone_instance { # DEPRECATED my ($class, $instance, %params) = @_; - Carp::cluck('clone_instance has been deprecated. Use clone_object instead') - if _MOUSE_VERBOSE; + Carp::cluck('clone_instance() has been deprecated. Use clone_object() instead'); + return $class->clone_object($instance, %params); } -sub make_immutable { - my $self = shift; - my %args = ( + +sub immutable_options { + my ( $self, @args ) = @_; + + return ( inline_constructor => 1, inline_destructor => 1, constructor_name => 'new', - @_, + @args, ); +} + + +sub make_immutable { + my $self = shift; + my %args = $self->immutable_options(@_); $self->{is_immutable}++; + $self->{strict_constructor} = $args{strict_constructor}; + if ($args{inline_constructor}) { - my $c = $self->constructor_class; - Mouse::Util::load_class($c); $self->add_method($args{constructor_name} => - $c->_generate_constructor($self, \%args)); + Mouse::Util::load_class($self->constructor_class) + ->_generate_constructor($self, \%args)); } if ($args{inline_destructor}) { - my $c = $self->destructor_class; - Mouse::Util::load_class($c); $self->add_method(DESTROY => - $c->_generate_destructor($self, \%args)); + Mouse::Util::load_class($self->destructor_class) + ->_generate_destructor($self, \%args)); } # Moose's make_immutable returns true allowing calling code to skip setting an explicit true value @@ -217,10 +289,14 @@ sub make_immutable { return 1; } -sub make_mutable { not_supported } +sub make_mutable { + my($self) = @_; + $self->{is_immutable} = 0; + return; +} -sub is_immutable { $_[0]->{is_immutable} } -sub is_mutable { !$_[0]->{is_immutable} } +sub is_immutable; +sub is_mutable { !$_[0]->is_immutable } sub _install_modifier_pp{ my( $self, $type, $name, $code ) = @_; @@ -294,7 +370,7 @@ sub _install_modifier { # load Class::Method::Modifiers first my $no_cmm_fast = do{ local $@; - eval q{ require Class::Method::Modifiers::Fast }; + eval q{ use Class::Method::Modifiers::Fast 0.041 () }; $@; }; @@ -303,16 +379,13 @@ sub _install_modifier { $impl = \&_install_modifier_pp; } else{ - my $install_modifier = Class::Method::Modifiers::Fast->can('_install_modifier'); + my $install_modifier = Class::Method::Modifiers::Fast->can('install_modifier'); $impl = sub { my ( $self, $type, $name, $code ) = @_; my $into = $self->name; $install_modifier->($into, $type, $name, $code); - $self->add_method($name => do{ - no strict 'refs'; - \&{ $into . '::' . $name }; - }); + $self->add_method($name => Mouse::Util::get_code_ref($into, $name)); return; }; } @@ -389,6 +462,8 @@ sub does_role { (defined $role_name) || $self->throw_error("You must supply a role name to look for"); + $role_name = $role_name->name if ref $role_name; + for my $class ($self->linearized_isa) { my $meta = Mouse::Util::get_metaclass_by_name($class) or next; @@ -411,7 +486,7 @@ Mouse::Meta::Class - The Mouse class metaclass =head1 VERSION -This document describes Mouse version 0.40_05 +This document describes Mouse version 0.51 =head1 METHODS @@ -496,6 +571,8 @@ Throws an error with the given message. =head1 SEE ALSO +L + L L