X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FClass.pm;h=7804b2a8264fda1947682f19d94eed9843913b2f;hb=38f1204cd9273901426fa6aaf5050830cbf4085c;hp=a6fa937e841d0f153bbb2ab8f0c4ff967b0afbfe;hpb=6ba6d68c3a6fa915d40a0502e2b6b84a677d6579;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index a6fa937..7804b2a 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -4,41 +4,163 @@ package Moose::Meta::Class; use strict; use warnings; +use Class::MOP; + use Carp 'confess'; -use Scalar::Util 'weaken'; +use Scalar::Util 'weaken', 'blessed', 'reftype'; -our $VERSION = '0.02'; +our $VERSION = '0.06'; use base 'Class::MOP::Class'; +__PACKAGE__->meta->add_attribute('roles' => ( + reader => 'roles', + default => sub { [] } +)); + +sub initialize { + my $class = shift; + my $pkg = shift; + $class->SUPER::initialize($pkg, + ':attribute_metaclass' => 'Moose::Meta::Attribute', + ':instance_metaclass' => 'Moose::Meta::Instance', + @_); +} + +sub add_role { + my ($self, $role) = @_; + (blessed($role) && $role->isa('Moose::Meta::Role')) + || confess "Roles must be instances of Moose::Meta::Role"; + push @{$self->roles} => $role; +} + +sub does_role { + my ($self, $role_name) = @_; + (defined $role_name) + || confess "You must supply a role name to look for"; + foreach my $class ($self->class_precedence_list) { + foreach my $role (@{$class->meta->roles}) { + return 1 if $role->does_role($role_name); + } + } + return 0; +} + +sub excludes_role { + my ($self, $role_name) = @_; + (defined $role_name) + || confess "You must supply a role name to look for"; + foreach my $class ($self->class_precedence_list) { + foreach my $role (@{$class->meta->roles}) { + return 1 if $role->excludes_role($role_name); + } + } + return 0; +} + +sub new_object { + my ($class, %params) = @_; + my $self = $class->SUPER::new_object(%params); + foreach my $attr ($class->compute_all_applicable_attributes()) { + next unless $params{$attr->init_arg} && $attr->can('has_trigger') && $attr->has_trigger; + $attr->trigger->($self, $params{$attr->init_arg}, $attr); + } + return $self; +} + sub construct_instance { my ($class, %params) = @_; - my $instance = $params{'__INSTANCE__'} || {}; + my $meta_instance = $class->get_meta_instance; + # FIXME: + # the code below is almost certainly incorrect + # but this is foreign inheritence, so we might + # have to kludge it in the end. + my $instance = $params{'__INSTANCE__'} || $meta_instance->create_instance(); foreach my $attr ($class->compute_all_applicable_attributes()) { - my $init_arg = $attr->init_arg(); - # try to fetch the init arg from the %params ... - my $val; - $val = $params{$init_arg} if exists $params{$init_arg}; - # if nothing was in the %params, we can use the - # attribute's default value (if it has one) - $val ||= $attr->default($instance) if $attr->has_default; - if (defined $val) { - if ($attr->has_type_constraint) { - if ($attr->should_coerce && $attr->type_constraint->has_coercion) { - $val = $attr->type_constraint->coercion->coerce($val); - } - (defined($attr->type_constraint->check($val))) - || confess "Attribute (" . $attr->name . ") does not pass the type contraint with '$val'"; - } - } - $instance->{$attr->name} = $val; - if (defined $val && $attr->is_weak_ref) { - weaken($instance->{$attr->name}); - } + $attr->initialize_instance_slot($meta_instance, $instance, \%params) } return $instance; } +sub has_method { + my ($self, $method_name) = @_; + (defined $method_name && $method_name) + || confess "You must define a method name"; + + my $sub_name = ($self->name . '::' . $method_name); + + no strict 'refs'; + return 0 if !defined(&{$sub_name}); + my $method = \&{$sub_name}; + + return 1 if blessed($method) && $method->isa('Moose::Meta::Role::Method'); + return $self->SUPER::has_method($method_name); +} + +sub add_override_method_modifier { + my ($self, $name, $method, $_super_package) = @_; + (!$self->has_method($name)) + || confess "Cannot add an override method if a local method is already present"; + # need this for roles ... + $_super_package ||= $self->name; + my $super = $self->find_next_method_by_name($name); + (defined $super) + || confess "You cannot override '$name' because it has no super method"; + $self->add_method($name => bless sub { + my @args = @_; + no strict 'refs'; + no warnings 'redefine'; + local *{$_super_package . '::super'} = sub { $super->(@args) }; + return $method->(@args); + } => 'Moose::Meta::Method::Overriden'); +} + +sub add_augment_method_modifier { + my ($self, $name, $method) = @_; + (!$self->has_method($name)) + || confess "Cannot add an augment method if a local method is already present"; + my $super = $self->find_next_method_by_name($name); + (defined $super) + || confess "You cannot augment '$name' because it has no super method"; + my $_super_package = $super->package_name; + # BUT!,... if this is an overriden method .... + if ($super->isa('Moose::Meta::Method::Overriden')) { + # we need to be sure that we actually + # find the next method, which is not + # an 'override' method, the reason is + # that an 'override' method will not + # be the one calling inner() + my $real_super = $self->_find_next_method_by_name_which_is_not_overridden($name); + $_super_package = $real_super->package_name; + } + $self->add_method($name => sub { + my @args = @_; + no strict 'refs'; + no warnings 'redefine'; + local *{$_super_package . '::inner'} = sub { $method->(@args) }; + return $super->(@args); + }); +} + +sub _find_next_method_by_name_which_is_not_overridden { + my ($self, $name) = @_; + my @methods = $self->find_all_methods_by_name($name); + foreach my $method (@methods) { + return $method->{code} + if blessed($method->{code}) && !$method->{code}->isa('Moose::Meta::Method::Overriden'); + } + return undef; +} + +package Moose::Meta::Method::Overriden; + +use strict; +use warnings; + +our $VERSION = '0.01'; + +use base 'Class::MOP::Method'; + 1; __END__ @@ -63,6 +185,12 @@ to the L documentation. =over 4 +=item B + +=item B + +We override this method to support the C attribute option. + =item B This provides some Moose specific extensions to this method, you @@ -72,6 +200,65 @@ you are doing. This method makes sure to handle the moose weak-ref, type-constraint and type coercion features. +=item B + +This accomidates Moose::Meta::Role::Method instances, which are +aliased, instead of added, but still need to be counted as valid +methods. + +=item B + +This will create an C method modifier for you, and install +it in the package. + +=item B + +This will create an C method modifier for you, and install +it in the package. + +=item B + +This will return an array of C instances which are +attached to this class. + +=item B + +This takes an instance of C in C<$role>, and adds it +to the list of associated roles. + +=item B + +This will test if this class C a given C<$role_name>. It will +not only check it's local roles, but ask them as well in order to +cascade down the role hierarchy. + +=item B + +This will test if this class C a given C<$role_name>. It will +not only check it's local roles, but ask them as well in order to +cascade down the role hierarchy. + +=item B + +This method does the same thing as L, but adds +suport for delegation. + +=back + +=head1 INTERNAL METHODS + +=over 4 + +=item compute_delegation + +=item generate_delegation_list + +=item generate_delgate_method + +=item get_delegatable_methods + +=item filter_delegations + =back =head1 BUGS @@ -93,4 +280,5 @@ L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=cut \ No newline at end of file +=cut +