X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=82b4744daa960a94f9a26ff6df3cbb154d0ccffb;hb=cbd9f94236f2c6be75aafbf52b796c754bc4d941;hp=277a2127166c519c2136b3015eba8fd5e8749c93;hpb=bfe4d0fc35c0b24b568cf6a0b4620a0df2aed649;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 277a212..82b4744 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -11,6 +11,10 @@ use B 'svref_2object'; our $VERSION = '0.01'; +# Self-introspection + +sub meta { $_[0]->initialize($_[0]) } + # Creation { @@ -23,7 +27,10 @@ our $VERSION = '0.01'; my ($class, $package_name) = @_; (defined $package_name && $package_name) || confess "You must pass a package name"; - $METAS{$package_name} ||= bless \$package_name => blessed($class) || $class; + $METAS{$package_name} ||= bless { + '$:pkg' => $package_name, + '%:attrs' => {} + } => blessed($class) || $class; } } @@ -39,17 +46,48 @@ sub create { my $meta = $class->initialize($package_name); $meta->superclasses(@{$options{superclasses}}) if exists $options{superclasses}; + # NOTE: + # process attributes first, so that they can + # install accessors, but locally defined methods + # can then overwrite them. It is maybe a little odd, but + # I think this should be the order of things. + if (exists $options{attributes}) { + foreach my $attr (@{$options{attributes}}) { + $meta->add_attribute($attr); + } + } if (exists $options{methods}) { foreach my $method_name (keys %{$options{methods}}) { $meta->add_method($method_name, $options{methods}->{$method_name}); } - } + } return $meta; } +# Instance Construction + +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; + # 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() if $attr->has_default(); + # now add this to the instance structure + $instance->{$attr->name} = $val; + } + return $instance; +} + # Informational -sub name { ${$_[0]} } +sub name { $_[0]->{'$:pkg'} } sub version { my $self = shift; @@ -92,22 +130,24 @@ sub add_method { my ($self, $method_name, $method) = @_; (defined $method_name && $method_name) || confess "You must define a method name"; + # use reftype here to allow for blessed subs ... (reftype($method) && reftype($method) eq 'CODE') || confess "Your code block must be a CODE reference"; my $full_method_name = ($self->name . '::' . $method_name); no strict 'refs'; + no warnings 'redefine'; *{$full_method_name} = subname $full_method_name => $method; } { ## private utility functions for has_method - my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } }; - my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } }; + my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' }; + my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' }; sub has_method { - my ($self, $method_name, $method) = @_; + my ($self, $method_name) = @_; (defined $method_name && $method_name) || confess "You must define a method name"; @@ -123,16 +163,155 @@ sub add_method { } sub get_method { - my ($self, $method_name, $method) = @_; + my ($self, $method_name) = @_; (defined $method_name && $method_name) || confess "You must define a method name"; no strict 'refs'; return \&{$self->name . '::' . $method_name} if $self->has_method($method_name); - return; # <--- make sure to return undef + return; # <- make sure to return undef +} + +sub remove_method { + my ($self, $method_name) = @_; + (defined $method_name && $method_name) + || confess "You must define a method name"; + + my $removed_method = $self->get_method($method_name); + + no strict 'refs'; + delete ${$self->name . '::'}{$method_name} + if defined $removed_method; + + return $removed_method; +} + +sub get_method_list { + my $self = shift; + no strict 'refs'; + grep { $self->has_method($_) } %{$self->name . '::'}; +} + +sub compute_all_applicable_methods { + my $self = shift; + my @methods; + # keep a record of what we have seen + # here, this will handle all the + # inheritence issues because we are + # using the &class_precedence_list + my (%seen_class, %seen_method); + foreach my $class ($self->class_precedence_list()) { + next if $seen_class{$class}; + $seen_class{$class}++; + # fetch the meta-class ... + my $meta = $self->initialize($class); + foreach my $method_name ($meta->get_method_list()) { + next if exists $seen_method{$method_name}; + $seen_method{$method_name}++; + push @methods => { + name => $method_name, + class => $class, + code => $meta->get_method($method_name) + }; + } + } + return @methods; +} + +sub find_all_methods_by_name { + my ($self, $method_name) = @_; + (defined $method_name && $method_name) + || confess "You must define a method name to find"; + my @methods; + # keep a record of what we have seen + # here, this will handle all the + # inheritence issues because we are + # using the &class_precedence_list + my %seen_class; + foreach my $class ($self->class_precedence_list()) { + next if $seen_class{$class}; + $seen_class{$class}++; + # fetch the meta-class ... + my $meta = $self->initialize($class); + push @methods => { + name => $method_name, + class => $class, + code => $meta->get_method($method_name) + } if $meta->has_method($method_name); + } + return @methods; + +} + +## Attributes + +sub add_attribute { + my ($self,$attribute) = @_; + (blessed($attribute) && $attribute->isa('Class::MOP::Attribute')) + || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)"; + $attribute->install_accessors($self); + $self->{'%:attrs'}->{$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; +} + +sub get_attribute { + my ($self, $attribute_name) = @_; + (defined $attribute_name && $attribute_name) + || confess "You must define an attribute name"; + return $self->{'%:attrs'}->{$attribute_name} + if $self->has_attribute($attribute_name); +} + +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} + if defined $removed_attribute; + $removed_attribute->remove_accessors($self); + return $removed_attribute; +} + +sub get_attribute_list { + my $self = shift; + keys %{$self->{'%:attrs'}}; +} + +sub compute_all_applicable_attributes { + my $self = shift; + my @attrs; + # keep a record of what we have seen + # here, this will handle all the + # inheritence issues because we are + # using the &class_precedence_list + my (%seen_class, %seen_attr); + foreach my $class ($self->class_precedence_list()) { + next if $seen_class{$class}; + $seen_class{$class}++; + # fetch the meta-class ... + my $meta = $self->initialize($class); + 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) + }; + } + } + return @attrs; +} + + 1; __END__ @@ -147,6 +326,226 @@ Class::MOP::Class - Class Meta Object =head1 DESCRIPTION +=head1 METHODS + +=head2 Self Introspection + +=over 4 + +=item B + +This allows Class::MOP::Class to actually introspect itself. + +=back + +=head2 Class construction + +These methods handle creating Class objects, which can be used to +both create new classes, and analyze pre-existing ones. + +This module will internally store references to all the instances +you create with these methods, so that they do not need to be +created any more than nessecary. Basically, they are singletons. + +=over 4 + +=item B ?@superclasses, + methods => ?%methods, + attributes => ?%attributes)> + +This returns the basic Class object, bringing the specified +C<$package_name> into existence and adding any of the +C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes> +to it. + +=item B + +This initializes a Class object for a given a C<$package_name>. + +=back + +=head2 Instance construction + +=over 4 + +=item B + +This will construct and instance using a HASH ref as storage +(currently only HASH references are supported). This will collect all +the applicable attribute meta-objects and layout out the fields in the +HASH ref, 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. + +=back + +=head2 Informational + +=over 4 + +=item B + +This is a read-only attribute which returns the package name that +the Class is stored in. + +=item B + +This is a read-only attribute which returns the C<$VERSION> of the +package the Class is stored in. + +=back + +=head2 Inheritance Relationships + +=over 4 + +=item B + +This is a read-write attribute which represents the superclass +relationships of this Class. Basically, it can get and set the +C<@ISA> for you. + +=item B + +This computes the a list of the Class's ancestors in the same order +in which method dispatch will be done. + +=back + +=head2 Methods + +=over 4 + +=item B + +This will take a C<$method_name> and CODE reference to that +C<$method> and install it into the Class. + +B : This does absolutely nothing special to C<$method> +other than use B to make sure it is tagged with the +correct name, and therefore show up correctly in stack traces and +such. + +=item B + +This just provides a simple way to check if the Class implements +a specific C<$method_name>. It will I however, attempt to check +if the class inherits the method. + +This will correctly handle functions defined outside of the package +that use a fully qualified name (C). + +This will correctly handle functions renamed with B and +installed using the symbol tables. However, if you are naming the +subroutine outside of the package scope, you must use the fully +qualified name, including the package name, for C to +correctly identify it. + +This will attempt to correctly ignore functions imported from other +packages using B. It breaks down if the function imported +is an C<__ANON__> sub (such as with C), which very well +may be a valid method being applied to the class. + +In short, this method cannot always be trusted to determine if the +C<$method_name> is actually a method. However, it will DWIM about +90% of the time, so it's a small trade off IMO. + +=item B + +This will return a CODE reference of the specified C<$method_name>, +or return undef if that method does not exist. + +=item B + +This will attempt to remove a given C<$method_name> from the Class. +It will return the CODE reference that it has removed, and will +attempt to use B to clear the methods associated name. + +=item B + +This will return a list of method names for all I defined +methods. It does B provide a list of all applicable methods, +including any inherited ones. If you want a list of all applicable +methods, use the C method. + +=item B + +This will return a list of all the methods names this Class will +support, taking into account inheritance. The list will be a list of +HASH references, each one containing the following information; method +name, the name of the class in which the method lives and a CODE +reference for the actual method. + +=item B + +This will traverse the inheritence hierarchy and locate all methods +with a given C<$method_name>. Similar to +C it returns a list of HASH references +with the following information; method name (which will always be the +same as C<$method_name>), the name of the class in which the method +lives and a CODE reference for the actual method. + +The list of methods produced is a distinct list, meaning there are no +duplicates in it. This is especially useful for things like object +initialization and destruction where you only want the method called +once, and in the correct order. + +=back + +=head2 Attributes + +It should be noted that since there is no one consistent way to define +the attributes of a class in Perl 5. These methods can only work with +the information given, and can not easily discover information on +their own. + +=over 4 + +=item B + +This stores a C<$attribute_meta_object> in the Class object and +associates it with the C<$attribute_name>. Unlike methods, attributes +within the MOP are stored as meta-information only. They will be used +later to construct instances from (see C above). +More details about the attribute meta-objects can be found in the +L section of this document. + +=item B + +Checks to see if this Class has an attribute by the name of +C<$attribute_name> and returns a boolean. + +=item B + +Returns the attribute meta-object associated with C<$attribute_name>, +if none is found, it will return undef. + +=item B + +This will remove the attribute meta-object stored at +C<$attribute_name>, then return the removed attribute meta-object. + +B Removing an attribute will only affect future instances of +the class, it will not make any attempt to remove the attribute from +any existing instances of the class. + +=item B + +This returns a list of attribute names which are defined in the local +class. If you want a list of all applicable attributes for a class, +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. + +=back + =head1 AUTHOR Stevan Little Estevan@iinteractive.comE