X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FMeta%2FClass.pm;h=5b0a8e59d2d1871d3369d0718f3fa7c4385776fe;hb=452bac1b88c2bc806fbe285146d050c73e2119b7;hp=70ea64abb6d884cfad56bae852bb2429e0a6e025;hpb=8d82cda075db89d040002bd23247d86ff11d501c;p=gitmo%2FMoose.git

diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index 70ea64a..5b0a8e5 100644
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -57,6 +57,10 @@ sub new_object {
 sub construct_instance {
     my ($class, %params) = @_;
     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()) {
         $attr->initialize_instance_slot($meta_instance, $instance, \%params)
@@ -79,121 +83,6 @@ 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";
-        $_->{no_filter} or (
-            !$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) = @_;
     # need this for roles ...
@@ -344,6 +233,8 @@ suport for delegation.
 
 =item get_delegatable_methods
 
+=item filter_delegations
+
 =back
 
 =head1 BUGS
@@ -366,3 +257,4 @@ This library is free software; you can redistribute it and/or modify
 it under the same terms as Perl itself. 
 
 =cut
+