X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FAttribute.pm;h=d7df89572a43c4929063905fcfcb04198cf940ab;hb=4b698b1a547836fd91575b96ab89767c31351f4e;hp=82f0d6ea98445bf4e2a8f17969180588dd92a2ef;hpb=0ef07b3330be07fa9aa59e3b4980023c14ed0e2f;p=gitmo%2FClass-MOP.git

diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm
index 82f0d6e..d7df895 100644
--- a/lib/Class/MOP/Attribute.pm
+++ b/lib/Class/MOP/Attribute.pm
@@ -7,18 +7,13 @@ use warnings;
 use Class::MOP::Method::Accessor;
 
 use Carp         'confess';
-use Scalar::Util 'blessed', 'reftype', 'weaken';
+use Scalar::Util 'blessed', 'weaken';
 
-our $VERSION   = '0.23';
+our $VERSION   = '0.65';
 our $AUTHORITY = 'cpan:STEVAN';
 
 use base 'Class::MOP::Object';
 
-sub meta {
-    require Class::MOP::Class;
-    Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
-}
-
 # NOTE: (meta-circularity)
 # This method will be replaced in the
 # boostrap section of Class::MOP, by
@@ -29,9 +24,12 @@ sub meta {
 # meta-objects.
 #     - Ain't meta-circularity grand? :)
 sub new {
-    my $class   = shift;
-    my $name    = shift;
-    my %options = @_;
+    my ( $class, @args ) = @_;
+
+    unshift @args, "name" if @args % 2 == 1;
+    my %options = @args;
+
+    my $name = $options{name};
 
     (defined $name && $name)
         || confess "You must provide a name for the attribute";
@@ -46,32 +44,36 @@ sub new {
     } else {
         (is_default_a_coderef(\%options))
             || confess("References are not allowed as default values, you must ".
-                       "wrap then in a CODE reference (ex: sub { [] } and not [])")
+                       "wrap the default of '$name' in a CODE reference (ex: sub { [] } and not [])")
                 if exists $options{default} && ref $options{default};
     }
     if( $options{required} and not( defined($options{builder}) || defined($options{init_arg}) || exists $options{default} ) ) {
         confess("A required attribute must have either 'init_arg', 'builder', or 'default'");
     }
+
+    $class->_new(%options);
+}
+
+sub _new {
+    my ( $class, %options ) = @_;
+
     bless {
-        '$!name'      => $name,
-        '$!accessor'  => $options{accessor},
-        '$!reader'    => $options{reader},
-        '$!writer'      => $options{writer},
-        '$!predicate'   => $options{predicate},
-        '$!clearer'     => $options{clearer},
-        '$!builder'     => $options{builder},
-        '$!init_arg'    => $options{init_arg},
-        '$!default'     => $options{default},
-        '$!initializer' => $options{initializer},        
+        'name'        => $options{name},
+        'accessor'    => $options{accessor},
+        'reader'      => $options{reader},
+        'writer'      => $options{writer},
+        'predicate'   => $options{predicate},
+        'clearer'     => $options{clearer},
+        'builder'     => $options{builder},
+        'init_arg'    => $options{init_arg},
+        'default'     => $options{default},
+        'initializer' => $options{initializer},        
         # keep a weakened link to the
         # class we are associated with
-        '$!associated_class' => undef,
+        'associated_class' => undef,
         # and a list of the methods
         # associated with this attr
-        '@!associated_methods' => [],
-        # NOTE:
-        # protect this from silliness
-        init_arg => undef,
+        'associated_methods' => [],
     } => $class;
 }
 
@@ -85,12 +87,13 @@ sub clone {
     my %options = @_;
     (blessed($self))
         || confess "Can only clone an instance";
-    return bless { %{$self}, %options } => blessed($self);
+    return bless { %{$self}, %options } => ref($self);
 }
 
 sub initialize_instance_slot {
     my ($self, $meta_instance, $instance, $params) = @_;
-    my $init_arg = $self->{'$!init_arg'};
+    my $init_arg = $self->{'init_arg'};
+
     # try to fetch the init arg from the %params ...
 
     # if nothing was in the %params, we can use the
@@ -102,14 +105,14 @@ sub initialize_instance_slot {
             $params->{$init_arg},
         );
     } 
-    elsif (defined $self->{'$!default'}) {
+    elsif (defined $self->{'default'}) {
         $self->_set_initial_slot_value(
             $meta_instance, 
             $instance,
             $self->default($instance),
         );
     } 
-    elsif (defined( my $builder = $self->{'$!builder'})) {
+    elsif (defined( my $builder = $self->{'builder'})) {
         if ($builder = $instance->can($builder)) {
             $self->_set_initial_slot_value(
                 $meta_instance, 
@@ -118,7 +121,7 @@ sub initialize_instance_slot {
             );
         } 
         else {
-            confess(blessed($instance)." does not support builder method '". $self->{'$!builder'} ."' for attribute '" . $self->name . "'");
+            confess(ref($instance)." does not support builder method '". $self->{'builder'} ."' for attribute '" . $self->name . "'");
         }
     }
 }
@@ -145,33 +148,36 @@ sub _set_initial_slot_value {
 # the next bunch of methods will get bootstrapped
 # away in the Class::MOP bootstrapping section
 
-sub name { $_[0]->{'$!name'} }
-
-sub associated_class   { $_[0]->{'$!associated_class'}   }
-sub associated_methods { $_[0]->{'@!associated_methods'} }
-
-sub has_accessor    { defined($_[0]->{'$!accessor'})     ? 1 : 0 }
-sub has_reader      { defined($_[0]->{'$!reader'})       ? 1 : 0 }
-sub has_writer      { defined($_[0]->{'$!writer'})       ? 1 : 0 }
-sub has_predicate   { defined($_[0]->{'$!predicate'})    ? 1 : 0 }
-sub has_clearer     { defined($_[0]->{'$!clearer'})      ? 1 : 0 }
-sub has_builder     { defined($_[0]->{'$!builder'})      ? 1 : 0 }
-sub has_init_arg    { defined($_[0]->{'$!init_arg'})     ? 1 : 0 }
-sub has_default     { defined($_[0]->{'$!default'})      ? 1 : 0 }
-sub has_initializer { defined($_[0]->{'$!initializer'})  ? 1 : 0 }
-
-sub accessor    { $_[0]->{'$!accessor'}    }
-sub reader      { $_[0]->{'$!reader'}      }
-sub writer      { $_[0]->{'$!writer'}      }
-sub predicate   { $_[0]->{'$!predicate'}   }
-sub clearer     { $_[0]->{'$!clearer'}     }
-sub builder     { $_[0]->{'$!builder'}     }
-sub init_arg    { $_[0]->{'$!init_arg'}    }
-sub initializer { $_[0]->{'$!initializer'} }
+sub name { $_[0]->{'name'} }
+
+sub associated_class   { $_[0]->{'associated_class'}   }
+sub associated_methods { $_[0]->{'associated_methods'} }
+
+sub has_accessor    { defined($_[0]->{'accessor'}) }
+sub has_reader      { defined($_[0]->{'reader'}) }
+sub has_writer      { defined($_[0]->{'writer'}) }
+sub has_predicate   { defined($_[0]->{'predicate'}) }
+sub has_clearer     { defined($_[0]->{'clearer'}) }
+sub has_builder     { defined($_[0]->{'builder'}) }
+sub has_init_arg    { defined($_[0]->{'init_arg'}) }
+sub has_default     { defined($_[0]->{'default'}) }
+sub has_initializer { defined($_[0]->{'initializer'}) }
+
+sub accessor    { $_[0]->{'accessor'}    }
+sub reader      { $_[0]->{'reader'}      }
+sub writer      { $_[0]->{'writer'}      }
+sub predicate   { $_[0]->{'predicate'}   }
+sub clearer     { $_[0]->{'clearer'}     }
+sub builder     { $_[0]->{'builder'}     }
+sub init_arg    { $_[0]->{'init_arg'}    }
+sub initializer { $_[0]->{'initializer'} }
 
 # end bootstrapped away method section.
 # (all methods below here are kept intact)
 
+sub has_read_method  { $_[0]->has_reader || $_[0]->has_accessor }
+sub has_write_method { $_[0]->has_writer || $_[0]->has_accessor }
+
 sub get_read_method  { 
     my $self   = shift;    
     my $reader = $self->reader || $self->accessor;
@@ -198,7 +204,17 @@ sub get_read_method_ref {
         return $self->associated_class->get_method($reader);
     }
     else {
-        return sub { $self->get_value(@_) };
+        my $code = sub { $self->get_value(@_) };
+        if (my $class = $self->associated_class) {
+            return $class->method_metaclass->wrap(
+                $code,
+                package_name => $class->name,
+                name         => '__ANON__'
+            );
+        }
+        else {
+            return $code;
+        }
     }
 }
 
@@ -208,12 +224,22 @@ sub get_write_method_ref {
         return $self->associated_class->get_method($writer);
     }
     else {
-        return sub { $self->set_value(@_) };
+        my $code = sub { $self->set_value(@_) };
+        if (my $class = $self->associated_class) {
+            return $class->method_metaclass->wrap(
+                $code,
+                package_name => $class->name,
+                name         => '__ANON__'
+            );
+        }
+        else {
+            return $code;
+        }
     }
 }
 
 sub is_default_a_coderef {
-    ('CODE' eq (reftype($_[0]->{'$!default'} || $_[0]->{default}) || ''))
+    ('CODE' eq ref($_[0]->{'default'} || $_[0]->{default}))
 }
 
 sub default {
@@ -223,9 +249,9 @@ sub default {
         # we pass in the instance and default
         # can return a value based on that
         # instance. Somewhat crude, but works.
-        return $self->{'$!default'}->($instance);
+        return $self->{'default'}->($instance);
     }
-    $self->{'$!default'};
+    $self->{'default'};
 }
 
 # slots
@@ -238,19 +264,19 @@ sub attach_to_class {
     my ($self, $class) = @_;
     (blessed($class) && $class->isa('Class::MOP::Class'))
         || confess "You must pass a Class::MOP::Class instance (or a subclass)";
-    weaken($self->{'$!associated_class'} = $class);
+    weaken($self->{'associated_class'} = $class);
 }
 
 sub detach_from_class {
     my $self = shift;
-    $self->{'$!associated_class'} = undef;
+    $self->{'associated_class'} = undef;
 }
 
 # method association
 
 sub associate_method {
     my ($self, $method) = @_;
-    push @{$self->{'@!associated_methods'}} => $method;
+    push @{$self->{'associated_methods'}} => $method;
 }
 
 ## Slot management
@@ -258,7 +284,7 @@ sub associate_method {
 sub set_initial_value {
     my ($self, $instance, $value) = @_;
     $self->_set_initial_slot_value(
-        Class::MOP::Class->initialize(blessed($instance))->get_meta_instance,
+        Class::MOP::Class->initialize(ref($instance))->get_meta_instance,
         $instance,
         $value
     );
@@ -267,7 +293,7 @@ sub set_initial_value {
 sub set_value {
     my ($self, $instance, $value) = @_;
 
-    Class::MOP::Class->initialize(blessed($instance))
+    Class::MOP::Class->initialize(ref($instance))
                      ->get_meta_instance
                      ->set_slot_value($instance, $self->name, $value);
 }
@@ -275,7 +301,7 @@ sub set_value {
 sub get_value {
     my ($self, $instance) = @_;
 
-    Class::MOP::Class->initialize(blessed($instance))
+    Class::MOP::Class->initialize(ref($instance))
                      ->get_meta_instance
                      ->get_slot_value($instance, $self->name);
 }
@@ -283,7 +309,7 @@ sub get_value {
 sub has_value {
     my ($self, $instance) = @_;
 
-    Class::MOP::Class->initialize(blessed($instance))
+    Class::MOP::Class->initialize(ref($instance))
                      ->get_meta_instance
                      ->is_slot_initialized($instance, $self->name);
 }
@@ -291,7 +317,7 @@ sub has_value {
 sub clear_value {
     my ($self, $instance) = @_;
 
-    Class::MOP::Class->initialize(blessed($instance))
+    Class::MOP::Class->initialize(ref($instance))
                      ->get_meta_instance
                      ->deinitialize_slot($instance, $self->name);
 }
@@ -302,11 +328,15 @@ sub accessor_metaclass { 'Class::MOP::Method::Accessor' }
 
 sub process_accessors {
     my ($self, $type, $accessor, $generate_as_inline_methods) = @_;
-    if (reftype($accessor)) {
-        (reftype($accessor) eq 'HASH')
+    if (ref($accessor)) {
+        (ref($accessor) eq 'HASH')
             || confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref";
         my ($name, $method) = %{$accessor};
-        $method = $self->accessor_metaclass->wrap($method);
+        $method = $self->accessor_metaclass->wrap(
+            $method,
+            package_name => $self->associated_class->name,
+            name         => $name,
+        );
         $self->associate_method($method);
         return ($name, $method);
     }
@@ -318,6 +348,8 @@ sub process_accessors {
                 attribute     => $self,
                 is_inline     => $inline_me,
                 accessor_type => $type,
+                package_name  => $self->associated_class->name,
+                name          => $accessor,
             );
         };
         confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@;
@@ -357,12 +389,12 @@ sub install_accessors {
 {
     my $_remove_accessor = sub {
         my ($accessor, $class) = @_;
-        if (reftype($accessor) && reftype($accessor) eq 'HASH') {
+        if (ref($accessor) && ref($accessor) eq 'HASH') {
             ($accessor) = keys %{$accessor};
         }
         my $method = $class->get_method($accessor);
         $class->remove_method($accessor)
-            if (blessed($method) && $method->isa('Class::MOP::Method::Accessor'));
+            if (ref($method) && $method->isa('Class::MOP::Method::Accessor'));
     };
 
     sub remove_accessors {
@@ -394,14 +426,14 @@ Class::MOP::Attribute - Attribute Meta Object
 
 =head1 SYNOPSIS
 
-  Class::MOP::Attribute->new('$foo' => (
+  Class::MOP::Attribute->new( foo => (
       accessor  => 'foo',        # dual purpose get/set accessor
       predicate => 'has_foo'     # predicate check for defined-ness
       init_arg  => '-foo',       # class->new will look for a -foo key
       default   => 'BAR IS BAZ!' # if no -foo key is provided, use this
   ));
 
-  Class::MOP::Attribute->new('$.bar' => (
+  Class::MOP::Attribute->new( bar => (
       reader    => 'bar',        # getter
       writer    => 'set_bar',    # setter
       predicate => 'has_bar'     # predicate check for defined-ness
@@ -487,7 +519,7 @@ so:
 And lastly, if the value of your attribute is dependent upon
 some other aspect of the instance structure, then you can take
 advantage of the fact that when the I<default> value is a CODE
-reference, it is passed the raw (unblessed) instance structure
+reference, it is passed the (as yet unfinished) instance structure
 as it's only argument. So you can do things like this:
 
   Class::MOP::Attribute->new('$object_identity' => (
@@ -511,9 +543,6 @@ slot-setting CODE ref, and the attribute meta-instance.  The slot-setting code
 is provided to make it easy to set the (possibly altered) value on the instance
 without going through several more method calls.
 
-If no initializer is given (as is the common case) initial attribute values are
-set directly, bypassing the writer.
-
 This contrived example shows an initializer that sets the attribute to twice
 the given value.
 
@@ -532,6 +561,9 @@ attribute initialization use the writer:
       initializer => 'some_attr',
   ));
 
+Your writer will simply need to examine it's C<@_> and determine under
+which context it is being called.
+
 =back
 
 The I<accessor>, I<reader>, I<writer>, I<predicate> and I<clearer> keys can
@@ -597,8 +629,15 @@ back to their "unfulfilled" state.
 
 =item B<clone (%options)>
 
+This will return a clone of the attribute instance, allowing the overriding
+of various attributes through the C<%options> supplied.
+
 =item B<initialize_instance_slot ($instance, $params)>
 
+This method is used internally to initialize the approriate slot for this 
+attribute in a given C<$instance>, the C<$params> passed are those that were
+passed to the constructor.
+
 =back
 
 =head2 Value management
@@ -693,9 +732,17 @@ Return the CODE reference of a method suitable for reading / writing the
 value of the attribute in the associated class. Suitable for use whether 
 C<reader> and C<writer> or C<accessor> was specified or not.
 
-NOTE: If not reader/writer/accessor was specified, this will use the 
+NOTE: If no reader/writer/accessor was specified, this will use the 
 attribute get_value/set_value methods, which can be very inefficient.
 
+=item B<has_read_method>
+
+=item B<has_write_method>
+
+Return whether a method exists suitable for reading / writing the value 
+of the attribute in the associated class. Suitable for use whether 
+C<reader> and C<writer> or C<accessor> was used.
+
 =back
 
 =head2 Informational predicates
@@ -772,7 +819,8 @@ used internally by the accessor generator.
 =item B<associated_methods>
 
 This will return the list of methods which have been associated with
-the C<associate_method> methods.
+the C<associate_method> methods. This is a good way of seeing what 
+methods are used to manage a given attribute. 
 
 =item B<install_accessors>
 
@@ -813,7 +861,7 @@ to this class.
 
 It should also be noted that B<Class::MOP> will actually bootstrap
 this module by installing a number of attribute meta-objects into
-it's metaclass. This will allow this class to reap all the benifits
+it's metaclass. This will allow this class to reap all the benefits
 of the MOP when subclassing it.
 
 =back