X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FClass.pm;h=78587363de15fa38f5f56aeb84ab8c9869aaecbd;hb=7e5ab3798d951410bf9aa3c83025d61febe7ffd9;hp=26df0000ea12f456e8bb8dcc4435f71a18003b2c;hpb=648e79aebb6d044198514a10592d9866cbf46589;p=gitmo%2FMoose.git diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 26df000..7858736 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -7,9 +7,9 @@ use warnings; use Class::MOP; use Carp 'confess'; -use Scalar::Util 'weaken', 'blessed'; +use Scalar::Util 'weaken', 'blessed', 'reftype'; -our $VERSION = '0.04'; +our $VERSION = '0.05'; use base 'Class::MOP::Class'; @@ -18,6 +18,15 @@ __PACKAGE__->meta->add_attribute('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')) @@ -35,41 +44,22 @@ sub does_role { 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; + 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; - if (exists $params{$init_arg}) { - $val = $params{$init_arg}; - } - else { - # skip it if it's lazy - next if $attr->is_lazy; - # and die if it is required - confess "Attribute (" . $attr->name . ") is required" - if $attr->is_required - } - # if nothing was in the %params, we can use the - # attribute's default value (if it has one) - if (!defined $val && $attr->has_default) { - $val = $attr->default($instance); - } - 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; } @@ -89,6 +79,118 @@ sub has_method { return $self->SUPER::has_method($method_name); } +sub add_attribute { + my ($self, $name, %params) = @_; + + my @delegations; + if ( my $delegation = delete $params{handles} ) { + my @method_names_or_hashes = $self->compute_delegation( $name, $delegation, \%params ); + @delegations = $self->get_delegatable_methods( @method_names_or_hashes ); + } + + my $ret = $self->SUPER::add_attribute( $name, %params ); + + if ( @delegations ) { + my $attr = $self->get_attribute( $name ); + $self->generate_delgate_method( $attr, $_ ) for $self->filter_delegations( $attr, @delegations ); + } + + return $ret; +} + +sub filter_delegations { + my ( $self, $attr, @delegations ) = @_; + grep { + my $new_name = $_->{new_name} || $_->{name}; + no warnings "uninitialized"; + !$self->name->can( $new_name ) and + $attr->accessor ne $new_name and + $attr->reader ne $new_name and + $attr->writer ne $new_name + } @delegations; +} + +sub generate_delgate_method { + my ( $self, $attr, $method ) = @_; + + # FIXME like generated accessors these methods must be regenerated + # FIXME the reader may not work for subclasses with weird instances + + my $make = $method->{generator} || sub { + my ( $self, $attr, $method ) =@_; + + my $method_name = $method->{name}; + my $reader = $attr->generate_reader_method(); + + return sub { + if ( Scalar::Util::blessed( my $delegate = shift->$reader ) ) { + return $delegate->$method_name( @_ ); + } + return; + }; + }; + + my $new_name = $method->{new_name} || $method->{name}; + $self->add_method( $new_name, $make->( $self, $attr, $method ) ); +} + +sub compute_delegation { + my ( $self, $attr_name, $delegation, $params ) = @_; + + + # either it's a concrete list of method names + return $delegation unless ref $delegation; # single method name + return @$delegation if reftype($delegation) eq "ARRAY"; + + # or it's a generative api + my $delegator_meta = $self->_guess_attr_class_or_role( $attr_name, $params ); + $self->generate_delegation_list( $delegation, $delegator_meta ); +} + +sub get_delegatable_methods { + my ( $self, @names_or_hashes ) = @_; + map { ref($_) ? $_ : { name => $_ } } @names_or_hashes; +} + +sub generate_delegation_list { + my ( $self, $delegation, $delegator_meta ) = @_; + + if ( reftype($delegation) eq "CODE" ) { + return $delegation->( $self, $delegator_meta ); + } elsif ( blessed($delegation) eq "Regexp" ) { + confess "For regular expression support the delegator class/role must use a Class::MOP::Class metaclass" + unless $delegator_meta->isa( "Class::MOP::Class" ); + return grep { $_->{name} =~ /$delegation/ } $delegator_meta->compute_all_applicable_methods(); + } else { + confess "The 'handles' specification '$delegation' is not supported"; + } +} + +sub _guess_attr_class_or_role { + my ( $self, $attr, $params ) = @_; + + my ( $isa, $does ) = @{ $params }{qw/isa does/}; + + confess "Generative delegations must explicitly specify a class or a role for the attribute's type" + unless $isa || $does; + + for (grep { blessed($_) } $isa, $does) { + confess "You must use classes/roles, not type constraints to use delegation ($_)" + unless $_->isa( "Moose::Meta::Class" ); + } + + confess "Cannot have an isa option and a does option if the isa does not do the does" + if $isa and $does and $isa->can("does") and !$isa->does( $does ); + + # if it's a class/role name make it into a meta object + for ($isa, $does) { + $_ = $_->meta if defined and !ref and $_->can("meta"); + } + + $isa = Class::MOP::Class->initialize($isa) if $isa and !ref($isa); + + return $isa || $does; +} sub add_override_method_modifier { my ($self, $name, $method, $_super_package) = @_; @@ -174,6 +276,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 @@ -191,14 +299,49 @@ 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 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 + =back =head1 BUGS @@ -220,4 +363,4 @@ 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