X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FMeta%2FClass.pm;h=4f811d96b93b29bbea1e6bb5c80036cc0c6e5c78;hb=8d40c3b80e6e4cebdf951d289d6b5d33b7641338;hp=b973e42c1bc86f276c32182e99884ac539f27f0a;hpb=f3bb863f6a6ef09220bbf51bc4cea3874d862776;p=gitmo%2FMouse.git diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm index b973e42..4f811d9 100644 --- a/lib/Mouse/Meta/Class.pm +++ b/lib/Mouse/Meta/Class.pm @@ -4,7 +4,7 @@ use warnings; use Scalar::Util qw/blessed weaken/; -use Mouse::Util qw/get_linear_isa not_supported/; +use Mouse::Util qw/:meta get_linear_isa not_supported/; use Mouse::Meta::Method::Constructor; use Mouse::Meta::Method::Destructor; @@ -25,10 +25,11 @@ sub _construct_meta { \@{ $args{package} . '::ISA' }; }; - #return Mouse::Meta::Class->initialize($class)->new_object(%args) - # if $class ne __PACKAGE__; - - return bless \%args, ref($class) || $class; + my $self = bless \%args, ref($class) || $class; + if($class ne __PACKAGE__){ + $self->_initialize_object($self, \%args); + } + return $self; } sub create_anon_class{ @@ -103,7 +104,7 @@ sub add_attribute { my $inherited_attr; foreach my $class($self->linearized_isa){ - my $meta = Mouse::Meta::Module::get_metaclass_by_name($class) or next; + my $meta = Mouse::Util::get_metaclass_by_name($class) or next; $inherited_attr = $meta->get_attribute($name) and last; } @@ -125,22 +126,26 @@ sub add_attribute { $self->{attributes}{$attr->name} = $attr; $attr->install_accessors(); - if(!$attr->{associated_methods} && ($attr->{is} || '') ne 'bare'){ + 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?)}); } return $attr; } -sub compute_all_applicable_attributes { shift->get_all_attributes(@_) } +sub compute_all_applicable_attributes { + Carp::cluck('compute_all_applicable_attributes() has been deprecated'); + return shift->get_all_attributes(@_) +} + sub get_all_attributes { my $self = shift; my (@attr, %seen); for my $class ($self->linearized_isa) { - my $meta = $self->_metaclass_cache($class) + my $meta = Mouse::Util::get_metaclass_by_name($class) or next; - for my $name (keys %{ $meta->get_attribute_map }) { + for my $name ($meta->get_attribute_list) { next if $seen{$name}++; push @attr, $meta->get_attribute($name); } @@ -155,14 +160,14 @@ sub new_object { my $self = shift; my %args = (@_ == 1 ? %{$_[0]} : @_); - my $instance = bless {}, $self->name; + my $object = bless {}, $self->name; - $self->_initialize_instance($instance, \%args); - return $instance; + $self->_initialize_object($object, \%args); + return $object; } -sub _initialize_instance{ - my($self, $instance, $args) = @_; +sub _initialize_object{ + my($self, $object, $args) = @_; my @triggers_queue; @@ -171,18 +176,13 @@ sub _initialize_instance{ my $key = $attribute->name; if (defined($from) && exists($args->{$from})) { - $args->{$from} = $attribute->coerce_constraint($args->{$from}) - if $attribute->should_coerce; - - $attribute->verify_against_type_constraint($args->{$from}); - - $instance->{$key} = $args->{$from}; + $object->{$key} = $attribute->_coerce_and_verify($args->{$from}); - weaken($instance->{$key}) - if ref($instance->{$key}) && $attribute->is_weak_ref; + weaken($object->{$key}) + if ref($object->{$key}) && $attribute->is_weak_ref; if ($attribute->has_trigger) { - push @triggers_queue, [ $attribute->trigger, $args->{$from} ]; + push @triggers_queue, [ $attribute->trigger, $object->{$key} ]; } } else { @@ -190,20 +190,15 @@ sub _initialize_instance{ unless ($attribute->is_lazy) { my $default = $attribute->default; my $builder = $attribute->builder; - my $value = $attribute->has_builder - ? $instance->$builder - : ref($default) eq 'CODE' - ? $default->($instance) - : $default; + my $value = $builder ? $object->$builder() + : ref($default) eq 'CODE' ? $object->$default() + : $default; - $value = $attribute->coerce_constraint($value) - if $attribute->should_coerce; - $attribute->verify_against_type_constraint($value); + # XXX: we cannot use $attribute->set_value() because it invokes triggers. + $object->{$key} = $attribute->_coerce_and_verify($value, $object);; - $instance->{$key} = $value; - - weaken($instance->{$key}) - if ref($instance->{$key}) && $attribute->is_weak_ref; + weaken($object->{$key}) + if ref($object->{$key}) && $attribute->is_weak_ref; } } else { @@ -216,41 +211,35 @@ sub _initialize_instance{ foreach my $trigger_and_value(@triggers_queue){ my($trigger, $value) = @{$trigger_and_value}; - $trigger->($instance, $value); + $trigger->($object, $value); } if($self->is_anon_class){ - $instance->{__METACLASS__} = $self; + $object->{__METACLASS__} = $self; } - return $instance; + return $object; } sub clone_object { - my $class = shift; - my $instance = shift; - my %params = (@_ == 1) ? %{$_[0]} : @_; - - (blessed($instance) && $instance->isa($class->name)) - || $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($instance)"); + my $class = shift; + my $object = shift; + my %params = (@_ == 1) ? %{$_[0]} : @_; - my $clone = bless { %$instance }, ref $instance; + (blessed($object) && $object->isa($class->name)) + || $class->throw_error("You must pass an instance of the metaclass (" . $class->name . "), not ($object)"); - foreach my $attr ($class->get_all_attributes()) { - if ( defined( my $init_arg = $attr->init_arg ) ) { - if (exists $params{$init_arg}) { - $clone->{ $attr->name } = $params{$init_arg}; - } - } - } + my $cloned = bless { %$object }, ref $object; + $class->_initialize_object($cloned, \%params); - return $clone; + return $cloned; } sub clone_instance { my ($class, $instance, %params) = @_; - Carp::cluck('clone_instance has been deprecated. Use clone_object instead'); + Carp::cluck('clone_instance has been deprecated. Use clone_object instead') + if _MOUSE_VERBOSE; return $class->clone_object($instance, %params); } @@ -418,7 +407,7 @@ sub does_role { || $self->throw_error("You must supply a role name to look for"); for my $class ($self->linearized_isa) { - my $meta = Mouse::Meta::Module::class_of($class); + my $meta = Mouse::Util::get_metaclass_by_name($class); next unless $meta && $meta->can('roles'); for my $role (@{ $meta->roles }) { @@ -442,7 +431,7 @@ Mouse::Meta::Class - The Mouse class metaclass =head2 C<< initialize(ClassName) -> Mouse::Meta::Class >> -Finds or creates a Mouse::Meta::Class instance for the given ClassName. Only +Finds or creates a C instance for the given ClassName. Only one instance should exist for a given class. =head2 C<< name -> ClassName >> @@ -453,30 +442,55 @@ Returns the name of the owner class. Gets (or sets) the list of superclasses of the owner class. -=head2 C<< add_attribute(name => spec | Mouse::Meta::Attribute) >> +=head2 C<< add_method(name => CodeRef) >> -Begins keeping track of the existing L for the owner -class. +Adds a method to the owner class. -=head2 C<< get_all_attributes -> (Mouse::Meta::Attribute) >> +=head2 C<< has_method(name) -> Bool >> -Returns the list of all L instances associated with -this class and its superclasses. +Returns whether we have a method with the given name. -=head2 C<< get_attribute_list -> { name => Mouse::Meta::Attribute } >> +=head2 C<< get_method(name) -> Mouse::Meta::Method | undef >> -This returns a list of attribute names which are defined in the local -class. If you want a list of all applicable attributes for a class, -use the C method. +Returns a L with the given name. + +Note that you can also use C<< $metaclass->name->can($name) >> for a method body. + +=head2 C<< get_method_list -> Names >> + +Returns a list of method names which are defined in the local class. +If you want a list of all applicable methods for a class, use the +C method. + +=head2 C<< get_all_methods -> (Mouse::Meta::Method) >> + +Return the list of all L instances associated with +the class and its superclasses. + +=head2 C<< add_attribute(name => spec | Mouse::Meta::Attribute) >> + +Begins keeping track of the existing L for the owner +class. =head2 C<< has_attribute(Name) -> Bool >> Returns whether we have a L with the given name. -=head2 get_attribute Name -> Mouse::Meta::Attribute | undef +=head2 C<< get_attribute Name -> Mouse::Meta::Attribute | undef >> Returns the L with the given name. +=head2 C<< get_attribute_list -> Names >> + +Returns a list of attribute names which are defined in the local +class. If you want a list of all applicable attributes for a class, +use the C method. + +=head2 C<< get_all_attributes -> (Mouse::Meta::Attribute) >> + +Returns the list of all L instances associated with +this class and its superclasses. + =head2 C<< linearized_isa -> [ClassNames] >> Returns the list of classes in method dispatch order, with duplicates removed. @@ -487,12 +501,18 @@ Creates a new instance. =head2 C<< clone_object(Instance, Parameters) -> Instance >> -Clones the given C which must be an instance governed by this +Clones the given instance which must be an instance governed by this metaclass. +=head2 C<< throw_error(Message, Parameters) >> + +Throws an error with the given message. + =head1 SEE ALSO L +L + =cut