X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=06914b4584c65a57d3d29a155b94f81e523f33ba;hb=4c1053331a179a6d1dd8e71d49ef05852a81387e;hp=2e51b9f5c300f077e663b18eb17a66f31b1de860;hpb=1a4705beda3d8970cbc37cc9d7a4e4619dd1eb8a;p=gitmo%2FClass-MOP.git

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 2e51b9f..06914b4 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -10,17 +10,12 @@ use Class::MOP::Method::Wrapped;
 
 use Carp         'confess';
 use Scalar::Util 'blessed', 'reftype', 'weaken';
-use Sub::Name    'subname';
 
-our $VERSION   = '0.27';
+our $VERSION   = '0.31';
 our $AUTHORITY = 'cpan:STEVAN';
 
 use base 'Class::MOP::Module';
 
-# Self-introspection
-
-sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) }
-
 # Creation
 
 sub initialize {
@@ -243,6 +238,18 @@ sub create {
                    "(I found an uneven number of params in \@_)";
 
     my (%options) = @_;
+    
+    (ref $options{superclasses} eq 'ARRAY')
+        || confess "You must pass an ARRAY ref of superclasses"
+            if exists $options{superclasses};
+            
+    (ref $options{attributes} eq 'ARRAY')
+        || confess "You must pass an ARRAY ref of attributes"
+            if exists $options{attributes};      
+            
+    (ref $options{methods} eq 'HASH')
+        || confess "You must pass an HASH ref of methods"
+            if exists $options{methods};                  
 
     my $code = "package $package_name;";
     $code .= "\$$package_name\:\:VERSION = '" . $options{version} . "';"
@@ -313,8 +320,11 @@ sub get_method_map {
                         $map->{$symbol}->body == $code;
 
         my ($pkg, $name) = Class::MOP::get_code_info($code);
-        next if ($pkg  || '') ne $class_name &&
-                ($name || '') ne '__ANON__';
+        
+        next if ($pkg  || '') ne $class_name ||
+                (($name || '') ne '__ANON__' && ($pkg  || '') ne $class_name);
+
+        #warn "Checking $pkg against $class_name && $name against __ANON__";
 
         $map->{$symbol} = $method_metaclass->wrap($code);
     }
@@ -396,7 +406,7 @@ sub clone_instance {
 }
 
 sub rebless_instance {
-    my ($self, $instance) = @_;
+    my ($self, $instance, %params) = @_;
 
     my $old_metaclass;
     if ($instance->can('meta')) {
@@ -416,14 +426,14 @@ sub rebless_instance {
     # rebless!
     $meta_instance->rebless_instance_structure($instance, $self);
 
-    my %params;
-
     foreach my $attr ( $self->compute_all_applicable_attributes ) {
         if ( $attr->has_value($instance) ) {
             if ( defined( my $init_arg = $attr->init_arg ) ) {
-                $params{$init_arg} = $attr->get_value($instance);
-            } else {
-                $attr->set_value($instance);
+                $params{$init_arg} = $attr->get_value($instance)
+                    unless exists $params{$init_arg};
+            } 
+            else {
+                $attr->set_value($instance, $attr->get_value($instance));
             }
         }
     }
@@ -431,27 +441,8 @@ sub rebless_instance {
     foreach my $attr ($self->compute_all_applicable_attributes) {
         $attr->initialize_instance_slot($meta_instance, $instance, \%params);
     }
-}
-
-sub get_attribute_values {
-    my ($self, $instance) = @_;
-
-    return +{
-        map { $_->name => $_->get_value($instance) }
-            grep { $_->has_value($instance) }
-                $self->>compute_all_applicable_attributes
-    };
-}
-
-sub get_init_args {
-    my ($self, $instance) = @_;
-
-    return +{
-        map { $_->init_arg => $_->get_value($instance) }
-            grep { $_->has_value($instance) }
-                grep { defined($_->init_arg) } 
-                    $self->compute_all_applicable_attributes
-    };
+    
+    $instance;
 }
 
 # Inheritance
@@ -518,17 +509,12 @@ sub subclasses {
 
 
 sub linearized_isa {
-    if (Class::MOP::IS_RUNNING_ON_5_10()) {
-        return @{ mro::get_linear_isa( (shift)->name ) };
-    }
-    else {
-        my %seen;
-        return grep { !($seen{$_}++) } (shift)->class_precedence_list;
-    }
+    return @{ mro::get_linear_isa( (shift)->name ) };
 }
 
 sub class_precedence_list {
     my $self = shift;
+    my $name = $self->name;
 
     unless (Class::MOP::IS_RUNNING_ON_5_10()) { 
         # NOTE:
@@ -538,15 +524,26 @@ sub class_precedence_list {
         # blow up otherwise. Yes, it's an ugly hack, better
         # suggestions are welcome.        
         # - SL
-        ($self->name || return)->isa('This is a test for circular inheritance') 
+        ($name || return)->isa('This is a test for circular inheritance') 
     }
 
-    (
-        $self->name,
-        map {
-            $self->initialize($_)->class_precedence_list()
-        } $self->superclasses()
-    );
+    # if our mro is c3, we can 
+    # just grab the linear_isa
+    if (mro::get_mro($name) eq 'c3') {
+        return @{ mro::get_linear_isa($name) }
+    }
+    else {
+        # NOTE:
+        # we can't grab the linear_isa for dfs
+        # since it has all the duplicates 
+        # already removed.
+        return (
+            $name,
+            map {
+                $self->initialize($_)->class_precedence_list()
+            } $self->superclasses()
+        );
+    }
 }
 
 ## Methods
@@ -559,17 +556,34 @@ sub add_method {
     my $body;
     if (blessed($method)) {
         $body = $method->body;
+        if ($method->package_name ne $self->name && 
+            $method->name         ne $method_name) {
+            warn "Hello there, got somethig for you." 
+                . " Method says " . $method->package_name . " " . $method->name
+                . " Class says " . $self->name . " " . $method_name;
+            $method = $method->clone(
+                package_name => $self->name,
+                name         => $method_name            
+            ) if $method->can('clone');
+        }
     }
     else {
         $body = $method;
         ('CODE' eq (reftype($body) || ''))
             || confess "Your code block must be a CODE reference";
-        $method = $self->method_metaclass->wrap($body);
+        $method = $self->method_metaclass->wrap(
+            $body => (
+                package_name => $self->name,
+                name         => $method_name
+            )
+        );
     }
     $self->get_method_map->{$method_name} = $method;
-
-    my $full_method_name = ($self->name . '::' . $method_name);
-    $self->add_package_symbol("&${method_name}" => subname $full_method_name => $body);
+    
+    my $full_method_name = ($self->name . '::' . $method_name);    
+    $self->add_package_symbol("&${method_name}" => 
+        Class::MOP::subname($full_method_name => $body)
+    );
     $self->update_package_cache_flag;    
 }
 
@@ -604,7 +618,9 @@ sub add_method {
         (defined $method_name && $method_name)
             || confess "You must pass in a method name";
         my $method = $fetch_and_prepare_method->($self, $method_name);
-        $method->add_before_modifier(subname ':before' => $method_modifier);
+        $method->add_before_modifier(
+            Class::MOP::subname(':before' => $method_modifier)
+        );
     }
 
     sub add_after_method_modifier {
@@ -612,7 +628,9 @@ sub add_method {
         (defined $method_name && $method_name)
             || confess "You must pass in a method name";
         my $method = $fetch_and_prepare_method->($self, $method_name);
-        $method->add_after_modifier(subname ':after' => $method_modifier);
+        $method->add_after_modifier(
+            Class::MOP::subname(':after' => $method_modifier)
+        );
     }
 
     sub add_around_method_modifier {
@@ -620,7 +638,9 @@ sub add_method {
         (defined $method_name && $method_name)
             || confess "You must pass in a method name";
         my $method = $fetch_and_prepare_method->($self, $method_name);
-        $method->add_around_modifier(subname ':around' => $method_modifier);
+        $method->add_around_modifier(
+            Class::MOP::subname(':around' => $method_modifier)
+        );
     }
 
     # NOTE:
@@ -887,6 +907,8 @@ sub is_immutable { 0 }
             print STDERR "# of Metaclass options:      ", keys %IMMUTABLE_OPTIONS;
             print STDERR "# of Immutable transformers: ", keys %IMMUTABLE_TRANSFORMERS;
         }
+        
+        1;
     }
 
     sub make_mutable{
@@ -896,29 +918,41 @@ sub is_immutable { 0 }
         confess "unable to find immutabilizing options" unless ref $options;
         my $transformer = delete $options->{IMMUTABLE_TRANSFORMER};
         $transformer->make_metaclass_mutable($self, $options);
+        1;
     }
 }
 
 sub create_immutable_transformer {
     my $self = shift;
     my $class = Class::MOP::Immutable->new($self, {
-       read_only   => [qw/superclasses/],
-       cannot_call => [qw/
+        read_only   => [qw/superclasses/],
+        cannot_call => [qw/
            add_method
            alias_method
            remove_method
            add_attribute
            remove_attribute
-           add_package_symbol
            remove_package_symbol
-       /],
-       memoize     => {
+        /],
+        memoize     => {
            class_precedence_list             => 'ARRAY',
            linearized_isa                    => 'ARRAY',
            compute_all_applicable_attributes => 'ARRAY',
            get_meta_instance                 => 'SCALAR',
            get_method_map                    => 'SCALAR',
-       }
+        },
+        # NOTE:
+        # this is ugly, but so are typeglobs, 
+        # so whattayahgonnadoboutit
+        # - SL
+        wrapped => { 
+            add_package_symbol => sub {
+                my $original = shift;
+                confess "Cannot add package symbols to an immutable metaclass" 
+                    unless (caller(2))[3] eq 'Class::MOP::Package::get_package_symbol'; 
+                goto $original->body;
+            },
+        },
     });
     return $class;
 }
@@ -1070,7 +1104,8 @@ but in some cases you might want to use it, so it is here.
 
 =item B<reset_package_cache_flag>
 
-Clear this flag, used in Moose.
+Clears the package cache flag to announce to the internals that we need 
+to rebuild the method map.
 
 =back
 
@@ -1083,8 +1118,14 @@ to use them or not.
 
 =item B<instance_metaclass>
 
+Returns the class name of the instance metaclass, see L<Class::MOP::Instance> 
+for more information on the instance metaclasses.
+
 =item B<get_meta_instance>
 
+Returns an instance of L<Class::MOP::Instance> to be used in the construction 
+of a new instance of the class. 
+
 =item B<new_object (%params)>
 
 This is a convience method for creating a new object of the class, and
@@ -1096,12 +1137,9 @@ would call a C<new> this method like so:
       $class->meta->new_object(%params);
   }
 
-Of course the ideal place for this would actually be in C<UNIVERSAL::>
-but that is considered bad style, so we do not do that.
-
 =item B<construct_instance (%params)>
 
-This method is used to construct an instace structure suitable for
+This method is used to construct an instance structure suitable for
 C<bless>-ing into your package of choice. It works in conjunction
 with the Attribute protocol to collect all applicable attributes.
 
@@ -1125,9 +1163,6 @@ class would call a C<clone> this method like so:
       $self->meta->clone_object($self, %params);
   }
 
-Of course the ideal place for this would actually be in C<UNIVERSAL::>
-but that is considered bad style, so we do not do that.
-
 =item B<clone_instance($instance, %params)>
 
 This method is a compliment of C<construct_instance> (which means if
@@ -1146,24 +1181,12 @@ shallow cloning is outside the scope of the meta-object protocol. I
 think Yuval "nothingmuch" Kogman put it best when he said that cloning
 is too I<context-specific> to be part of the MOP.
 
-=item B<get_attribute_values($instance)>
-
-Returns the values of the C<$instance>'s fields keyed by the attribute names.
-
-=item B<get_init_args($instance)>
-
-Returns a hash reference where the keys are all the attributes' C<init_arg>s
-and the values are the instance's fields. Attributes without an C<init_arg>
-will be skipped.
-
-=item B<rebless_instance($instance)>
+=item B<rebless_instance($instance, ?%params)>
 
 This will change the class of C<$instance> to the class of the invoking
 C<Class::MOP::Class>. You may only rebless the instance to a subclass of
-itself. This limitation may be relaxed in the future.
-
-This can be useful in a number of situations, such as when you are writing
-a program that doesn't know everything at object construction time.
+itself. You may pass in optional C<%params> which are like constructor 
+params and will override anything already defined in the instance.
 
 =back
 
@@ -1197,18 +1220,11 @@ This is a read-write attribute which represents the superclass
 relationships of the class the B<Class::MOP::Class> instance is
 associated with. Basically, it can get and set the C<@ISA> for you.
 
-B<NOTE:>
-Perl will occasionally perform some C<@ISA> and method caching, if
-you decide to change your superclass relationship at runtime (which
-is quite insane and very much not recommened), then you should be
-aware of this and the fact that this module does not make any
-attempt to address this issue.
-
 =item B<class_precedence_list>
 
 This computes the a list of all the class's ancestors in the same order
-in which method dispatch will be done. This is similair to
-what B<Class::ISA::super_path> does, but we don't remove duplicate names.
+in which method dispatch will be done. This is similair to what 
+B<Class::ISA::super_path> does, but we don't remove duplicate names.
 
 =item B<linearized_isa>
 
@@ -1217,7 +1233,7 @@ duplicates removed.
 
 =item B<subclasses>
 
-This returns a list of subclasses for this class.
+This returns a list of subclasses for this class. 
 
 =back
 
@@ -1227,8 +1243,13 @@ This returns a list of subclasses for this class.
 
 =item B<get_method_map>
 
+Returns a HASH ref of name to CODE reference mapping for this class.
+
 =item B<method_metaclass>
 
+Returns the class name of the method metaclass, see L<Class::MOP::Method> 
+for more information on the method metaclasses.
+
 =item B<add_method ($method_name, $method)>
 
 This will take a C<$method_name> and CODE reference to that
@@ -1282,7 +1303,7 @@ C<$method_name>, or return undef if that method does not exist.
 The Class::MOP::Method is codifiable, so you can use it like a normal
 CODE reference, see L<Class::MOP::Method> for more information.
 
-=item B<find_method_by_name ($method_name>
+=item B<find_method_by_name ($method_name)>
 
 This will return a CODE reference of the specified C<$method_name>,
 or return undef if that method does not exist.
@@ -1441,9 +1462,14 @@ their own. See L<Class::MOP::Attribute> for more details.
 
 =item B<attribute_metaclass>
 
+Returns the class name of the attribute metaclass, see L<Class::MOP::Attribute> 
+for more information on the attribute metaclasses.
+
 =item B<get_attribute_map>
 
-=item B<add_attribute ($attribute_meta_object | $attribute_name, %attribute_spec)>
+This returns a HASH ref of name to attribute meta-object mapping.
+
+=item B<add_attribute ($attribute_meta_object | ($attribute_name, %attribute_spec))>
 
 This stores the C<$attribute_meta_object> (or creates one from the
 C<$attribute_name> and C<%attribute_spec>) in the B<Class::MOP::Class>