X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=7863468c157867a831b95d838ff2ea59acef162e;hb=5659d76e5bb87873fa7c80efdf1cce8c40d40237;hp=6ebd6d121bcd1765f70e37079e64a4f4f8f8f90f;hpb=2e41896ef928bb97cd490b03cd77f0280d802384;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 6ebd6d1..7863468 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -6,14 +6,15 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'reftype'; +use Hash::Util 'lock_keys'; use Sub::Name 'subname'; use B 'svref_2object'; -our $VERSION = '0.02'; +our $VERSION = '0.03'; # Self-introspection -sub meta { $_[0]->initialize($_[0]) } +sub meta { Class::MOP::Class->initialize($_[0]) } # Creation @@ -22,13 +23,16 @@ sub meta { $_[0]->initialize($_[0]) } # there is no need to worry about destruction though # because they should die only when the program dies. # After all, do package definitions even get reaped? - my %METAS; + my %METAS; + sub initialize { - my ($class, $package_name) = @_; + my $class = shift; + my $package_name = shift; (defined $package_name && $package_name) - || confess "You must pass a package name"; - return $METAS{$package_name} if exists $METAS{$package_name}; - $METAS{$package_name} = $class->construct_class_instance($package_name); + || confess "You must pass a package name"; + # make sure the package name is not blessed + $package_name = blessed($package_name) || $package_name; + $class->construct_class_instance(':package' => $package_name, @_); } # NOTE: (meta-circularity) @@ -38,18 +42,27 @@ sub meta { $_[0]->initialize($_[0]) } # class. All other classes will use the more # normal &construct_instance. sub construct_class_instance { - my ($class, $package_name) = @_; + my $class = shift; + my %options = @_; + my $package_name = $options{':package'}; (defined $package_name && $package_name) - || confess "You must pass a package name"; + || confess "You must pass a package name"; + return $METAS{$package_name} if exists $METAS{$package_name}; $class = blessed($class) || $class; if ($class =~ /^Class::MOP::/) { - bless { - '$:pkg' => $package_name, - '%:attrs' => {} + $METAS{$package_name} = bless { + '$:package' => $package_name, + '%:attributes' => {}, + '$:attribute_metaclass' => 'Class::MOP::Attribute', + '$:method_metaclass' => 'Class::MOP::Method', } => $class; } else { - bless $class->meta->construct_instance(':pkg' => $package_name) => $class + # NOTE: + # it is safe to use meta here because + # class will always be a subclass of + # Class::MOP::Class, which defines meta + $METAS{$package_name} = bless $class->meta->construct_instance(%options) => $class } } } @@ -84,30 +97,140 @@ sub create { return $meta; } -# Instance Construction +## Attribute readers + +# NOTE: +# all these attribute readers will be bootstrapped +# away in the Class::MOP bootstrap section + +sub name { $_[0]->{'$:package'} } +sub get_attribute_map { $_[0]->{'%:attributes'} } +sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} } +sub method_metaclass { $_[0]->{'$:method_metaclass'} } + +# Instance Construction & Cloning + +sub new_object { + my $class = shift; + # NOTE: + # we need to protect the integrity of the + # Class::MOP::Class singletons here, so we + # delegate this to &construct_class_instance + # which will deal with the singletons + return $class->construct_class_instance(@_) + if $class->name->isa('Class::MOP::Class'); + bless $class->construct_instance(@_) => $class->name; +} sub construct_instance { my ($class, %params) = @_; my $instance = {}; - foreach my $attr (map { $_->{attribute} } $class->compute_all_applicable_attributes()) { - # if the attr has an init_arg, use that, otherwise, - # use the attributes name itself as the init_arg - my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name; + 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(); - # now add this to the instance structure + $val ||= $attr->default($instance) if $attr->has_default(); $instance->{$attr->name} = $val; } return $instance; } +sub clone_object { + my $class = shift; + my $instance = shift; + (blessed($instance) && $instance->isa($class->name)) + || confess "You must pass an instance ($instance) of the metaclass (" . $class->name . ")"; + # NOTE: + # we need to protect the integrity of the + # Class::MOP::Class singletons here, they + # should not be cloned + return $instance if $instance->isa('Class::MOP::Class'); + bless $class->clone_instance($instance, @_) => blessed($instance); +} + +#{ +# sub _deep_clone { +# my ($object, $cache) = @_; +# return $object unless ref($object); +# # check for an active cache +# return _deep_clone_ref($object, ($cache = {}), 'HASH') if not defined $cache; +# # if we have it in the cache them return the cached clone +# return $cache->{$object} if exists $cache->{$object}; +# # now try it as an object, which will in +# # turn try it as ref if its not an object +# # and store it in case we run into a circular ref +# $cache->{$object} = _deep_clone_object($object, $cache); +# } +# +# sub _deep_clone_object { +# my ($object, $cache) = @_; +# # check to see if its an object, with a clone method +# # or if we have an object, with no clone method, then +# # we will respect its encapsulation, and not muck with +# # its internals. Basically, we assume it does not want +# # to be cloned +# return $cache->{$object} = ($object->can('clone') ? $object->clone() : $object) +# if blessed($object); +# return $cache->{$object} = _deep_clone_ref($object, $cache); +# } +# +# sub _deep_clone_ref { +# my ($object, $cache, $ref_type) = @_; +# $ref_type ||= ref($object); +# my ($clone, $tied); +# if ($ref_type eq 'HASH') { +# $clone = {}; +# tie %{$clone}, ref $tied if $tied = tied(%{$object}); +# %{$clone} = map { ref($_) ? _deep_clone($_, $cache) : $_ } %{$object}; +# } +# elsif ($ref_type eq 'ARRAY') { +# $clone = []; +# tie @{$clone}, ref $tied if $tied = tied(@{$object}); +# @{$clone} = map { ref($_) ? _deep_clone($_, $cache) : $_ } @{$object}; +# } +# elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR') { +# my $var = ""; +# $clone = \$var; +# tie ${$clone}, ref $tied if $tied = tied(${$object}); +# ${$clone} = _deep_clone(${$object}, $cache); +# } +# else { +# # shallow copy reference to code, glob, regex +# $clone = $object; +# } +# # store it in our cache +# $cache->{$object} = $clone; +# # and return the clone +# return $clone; +# } +#} + +sub clone_instance { + my ($class, $instance, %params) = @_; + (blessed($instance)) + || confess "You can only clone instances, \$self is not a blessed instance"; + # NOTE: + # this should actually do a deep clone + # instead of this cheap hack. I will + # add that in later. + # (use the Class::Cloneable::Util code) + my $clone = { %{$instance} }; #_deep_clone($instance); + foreach my $attr ($class->compute_all_applicable_attributes()) { + my $init_arg = $attr->init_arg(); + # try to fetch the init arg from the %params ... + $clone->{$attr->name} = $params{$init_arg} + if exists $params{$init_arg}; + } + return $clone; +} + # Informational -sub name { $_[0]->{'$:pkg'} } +# &name should be here too, but it is above +# because it gets bootstrapped away sub version { my $self = shift; @@ -146,9 +269,6 @@ sub class_precedence_list { ## Methods -# un-used right now ... -sub method_metaclass { 'Class::MOP::Method' } - sub add_method { my ($self, $method_name, $method) = @_; (defined $method_name && $method_name) @@ -269,8 +389,6 @@ sub find_all_methods_by_name { ## Attributes -sub attribute_metaclass { 'Class::MOP::Attribute' } - sub add_attribute { my $self = shift; # either we have an attribute object already @@ -281,21 +399,21 @@ sub add_attribute { || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)"; $attribute->attach_to_class($self); $attribute->install_accessors(); - $self->{'%:attrs'}->{$attribute->name} = $attribute; + $self->get_attribute_map->{$attribute->name} = $attribute; } sub has_attribute { my ($self, $attribute_name) = @_; (defined $attribute_name && $attribute_name) || confess "You must define an attribute name"; - exists $self->{'%:attrs'}->{$attribute_name} ? 1 : 0; + exists $self->get_attribute_map->{$attribute_name} ? 1 : 0; } sub get_attribute { my ($self, $attribute_name) = @_; (defined $attribute_name && $attribute_name) || confess "You must define an attribute name"; - return $self->{'%:attrs'}->{$attribute_name} + return $self->get_attribute_map->{$attribute_name} if $self->has_attribute($attribute_name); } @@ -303,8 +421,8 @@ sub remove_attribute { my ($self, $attribute_name) = @_; (defined $attribute_name && $attribute_name) || confess "You must define an attribute name"; - my $removed_attribute = $self->{'%:attrs'}->{$attribute_name}; - delete $self->{'%:attrs'}->{$attribute_name} + my $removed_attribute = $self->get_attribute_map->{$attribute_name}; + delete $self->get_attribute_map->{$attribute_name} if defined $removed_attribute; $removed_attribute->remove_accessors(); $removed_attribute->detach_from_class(); @@ -313,7 +431,7 @@ sub remove_attribute { sub get_attribute_list { my $self = shift; - keys %{$self->{'%:attrs'}}; + keys %{$self->get_attribute_map}; } sub compute_all_applicable_attributes { @@ -332,11 +450,7 @@ sub compute_all_applicable_attributes { foreach my $attr_name ($meta->get_attribute_list()) { next if exists $seen_attr{$attr_name}; $seen_attr{$attr_name}++; - push @attrs => { - name => $attr_name, - class => $class, - attribute => $meta->get_attribute($attr_name) - }; + push @attrs => $meta->get_attribute($attr_name); } } return @attrs; @@ -490,7 +604,7 @@ to it. This initializes and returns returns a B object for a given a C<$package_name>. -=item B +=item B This will construct an instance of B, it is here so that we can actually "tie the knot" for B @@ -500,19 +614,33 @@ from outside of that method really. =back -=head2 Object instance construction +=head2 Object instance construction and cloning -This method is used to construct an instace structure suitable for -C-ing into your package of choice. It works in conjunction -with the Attribute protocol to collect all applicable attributes. - -This method is B, it is up to you whether you want -to use it or not. +These methods are B, it is up to you whether you want +to use them or not. =over 4 +=item B + +This is a convience method for creating a new object of the class, and +blessing it into the appropriate package as well. Ideally your class +would call a C this method like so: + + sub MyClass::new { + my ($class, %param) = @_; + $class->meta->new_object(%params); + } + +Of course the ideal place for this would actually be in C +but that is considered bad style, so we do not do that. + =item B +This method is used to construct an instace structure suitable for +C-ing into your package of choice. It works in conjunction +with the Attribute protocol to collect all applicable attributes. + This will construct and instance using a HASH ref as storage (currently only HASH references are supported). This will collect all the applicable attributes and layout out the fields in the HASH ref, @@ -520,6 +648,32 @@ it will then initialize them using either use the corresponding key in C<%params> or any default value or initializer found in the attribute meta-object. +=item B + +This is a convience method for cloning an object instance, then +blessing it into the appropriate package. Ideally your class +would call a C this method like so: + + sub MyClass::clone { + my ($self, %param) = @_; + $self->meta->clone_object($self, %params); + } + +Of course the ideal place for this would actually be in C +but that is considered bad style, so we do not do that. + +=item B + +This method is a compliment of C (which means if +you override C, you need to override this one too). + +This method will clone the C<$instance> structure created by the +C method, and apply any C<%params> passed to it +to change the attribute values. The structure returned is (like with +C) an unCed HASH reference, it is your +responsibility to then bless this cloned structure into the right +class. + =back =head2 Informational @@ -657,6 +811,8 @@ their own. See L for more details. =item B +=item B + =item B This stores a C<$attribute_meta_object> in the B @@ -707,11 +863,11 @@ use the C method. =item B -This will traverse the inheritance heirachy and return a list of HASH -references for all the applicable attributes for this class. The HASH -references will contain the following information; the attribute name, -the class which the attribute is associated with and the actual -attribute meta-object. +This will traverse the inheritance heirachy and return a list of all +the applicable attributes for this class. It does not construct a +HASH reference like C because all +that same information is discoverable through the attribute +meta-object itself. =back