X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=1b4580fb57573debff91009fc48c71f3a6277162;hb=fa16e528c74e94ce28ddd8f6e7d8421e5ec0b3c9;hp=474783b79c1d3b6f6b3559024f0b8d614186bc3e;hpb=96ceced87583646c1396bba4fdfa92d0b6c37058;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 474783b..1b4580f 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -9,7 +9,9 @@ use Scalar::Util 'blessed', 'reftype'; use Sub::Name 'subname'; use B 'svref_2object'; -our $VERSION = '0.06'; +our $VERSION = '0.14'; + +use Class::MOP::Instance; # Self-introspection @@ -22,7 +24,13 @@ sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[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; + + # means of accessing all the metaclasses that have + # been initialized thus far (for mugwumps obj browser) + sub get_all_metaclasses { %METAS } + sub get_all_metaclass_instances { values %METAS } + sub get_all_metaclass_names { keys %METAS } sub initialize { my $class = shift; @@ -44,7 +52,13 @@ sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) } my $package_name = $options{':package'}; (defined $package_name && $package_name) || confess "You must pass a package name"; - return $METAS{$package_name} if exists $METAS{$package_name}; + # NOTE: + # return the metaclass if we have it cached, + # and it is still defined (it has not been + # reaped by DESTROY yet, which can happen + # annoyingly enough during global destruction) + return $METAS{$package_name} + if exists $METAS{$package_name} && defined $METAS{$package_name}; $class = blessed($class) || $class; # now create the metaclass my $meta; @@ -53,7 +67,8 @@ sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) } '$:package' => $package_name, '%:attributes' => {}, '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute', - '$:method_metaclass' => $options{':method_metaclass'} || 'Class::MOP::Method', + '$:method_metaclass' => $options{':method_metaclass'} || 'Class::MOP::Method', + '$:instance_metaclass' => $options{':instance_metaclass'} || 'Class::MOP::Instance', } => $class; } else { @@ -72,7 +87,8 @@ sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) } my $self = shift; # this is always okay ... - return if blessed($self) eq 'Class::MOP::Class'; + return if blessed($self) eq 'Class::MOP::Class' && + $self->instance_metaclass eq 'Class::MOP::Instance'; my @class_list = $self->class_precedence_list; shift @class_list; # shift off $self->name @@ -83,8 +99,15 @@ sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) } || confess $self->name . "->meta => (" . (blessed($self)) . ")" . " is not compatible with the " . $class_name . "->meta => (" . (blessed($meta)) . ")"; + # NOTE: + # we also need to check that instance metaclasses + # are compatabile in the same the class. + ($self->instance_metaclass->isa($meta->instance_metaclass)) + || confess $self->name . "->meta => (" . ($self->instance_metaclass) . ")" . + " is not compatible with the " . + $class_name . "->meta => (" . ($meta->instance_metaclass) . ")"; } - } + } } sub create { @@ -122,6 +145,20 @@ sub create { return $meta; } +{ + # NOTE: + # this should be sufficient, if you have a + # use case where it is not, write a test and + # I will change it. + my $ANON_CLASS_SERIAL = 0; + + sub create_anon_class { + my ($class, %options) = @_; + my $package_name = 'Class::MOP::Class::__ANON__::SERIAL::' . ++$ANON_CLASS_SERIAL; + return $class->create($package_name, '0.00', %options); + } +} + ## Attribute readers # NOTE: @@ -132,6 +169,7 @@ sub name { $_[0]->{'$:package'} } sub get_attribute_map { $_[0]->{'%:attributes'} } sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} } sub method_metaclass { $_[0]->{'$:method_metaclass'} } +sub instance_metaclass { $_[0]->{'$:instance_metaclass'} } # Instance Construction & Cloning @@ -144,25 +182,27 @@ sub new_object { # which will deal with the singletons return $class->construct_class_instance(@_) if $class->name->isa('Class::MOP::Class'); - bless $class->construct_instance(@_) => $class->name; + return $class->construct_instance(@_); } sub construct_instance { my ($class, %params) = @_; - my $instance = {}; + my $meta_instance = $class->get_meta_instance(); + my $instance = $meta_instance->create_instance(); 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(); - $instance->{$attr->name} = $val; + $attr->initialize_instance_slot($meta_instance, $instance, \%params); } return $instance; } +sub get_meta_instance { + my $class = shift; + return $class->instance_metaclass->new( + $class, + $class->compute_all_applicable_attributes() + ); +} + sub clone_object { my $class = shift; my $instance = shift; @@ -173,14 +213,19 @@ sub clone_object { # 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); + $class->clone_instance($instance, @_); } sub clone_instance { my ($class, $instance, %params) = @_; (blessed($instance)) || confess "You can only clone instances, \$self is not a blessed instance"; - my $clone = { %$instance, %params }; + my $meta_instance = $class->get_meta_instance(); + my $clone = $meta_instance->clone_instance($instance); + foreach my $key (%params) { + next unless $meta_instance->is_valid_slot($key); + $meta_instance->set_slot_value($clone, $key, $params{$key}); + } return $clone; } @@ -198,11 +243,19 @@ sub version { sub superclasses { my $self = shift; + no strict 'refs'; if (@_) { my @supers = @_; - @{$self->get_package_variable('@ISA')} = @supers; + @{$self->name . '::ISA'} = @supers; + # NOTE: + # we need to check the metaclass + # compatability here so that we can + # be sure that the superclass is + # not potentially creating an issues + # we don't know about + $self->check_metaclass_compatability(); } - @{$self->get_package_variable('@ISA')}; + @{$self->name . '::ISA'}; } sub class_precedence_list { @@ -212,8 +265,8 @@ sub class_precedence_list { # This will do nothing if all is well, and blow # up otherwise. Yes, it's an ugly hack, better # suggestions are welcome. - { $self->name->isa('This is a test for circular inheritance') } - # ... and no back to our regularly scheduled program + { ($self->name || return)->isa('This is a test for circular inheritance') } + # ... and now back to our regularly scheduled program ( $self->name, map { @@ -233,67 +286,76 @@ sub add_method { || confess "Your code block must be a CODE reference"; my $full_method_name = ($self->name . '::' . $method_name); - $method = $self->method_metaclass->wrap($method) unless blessed($method); - + $method = $self->method_metaclass->wrap($method) unless blessed($method); + no strict 'refs'; no warnings 'redefine'; *{$full_method_name} = subname $full_method_name => $method; } { - my $fetch_and_prepare_method = sub { - my ($self, $method_name) = @_; - # fetch it locally - my $method = $self->get_method($method_name); - # if we dont have local ... - unless ($method) { - # make sure this method even exists ... - ($self->find_next_method_by_name($method_name)) - || confess "The method '$method_name' is not found in the inherience hierarchy for this class"; - # if so, then create a local which just - # calls the next applicable method ... - $self->add_method($method_name => sub { - $self->find_next_method_by_name($method_name)->(@_); - }); - $method = $self->get_method($method_name); - } - - # now make sure we wrap it properly - # (if it isnt already) - unless ($method->isa('Class::MOP::Method::Wrapped')) { - $method = Class::MOP::Method::Wrapped->wrap($method); - $self->add_method($method_name => $method); - } - return $method; - }; - - sub add_before_method_modifier { - my ($self, $method_name, $method_modifier) = @_; - (defined $method_name && $method_name) - || confess "You must pass in a method name"; - my $full_method_modifier_name = ($self->name . '::' . $method_name . ':before'); - my $method = $fetch_and_prepare_method->($self, $method_name); - $method->add_before_modifier(subname $full_method_modifier_name => $method_modifier); - } - - sub add_after_method_modifier { - my ($self, $method_name, $method_modifier) = @_; - (defined $method_name && $method_name) - || confess "You must pass in a method name"; - my $full_method_modifier_name = ($self->name . '::' . $method_name . ':after'); - my $method = $fetch_and_prepare_method->($self, $method_name); - $method->add_after_modifier(subname $full_method_modifier_name => $method_modifier); - } - - sub add_around_method_modifier { - my ($self, $method_name, $method_modifier) = @_; - (defined $method_name && $method_name) - || confess "You must pass in a method name"; - my $full_method_modifier_name = ($self->name . '::' . $method_name . ':around'); - my $method = $fetch_and_prepare_method->($self, $method_name); - $method->add_around_modifier(subname $full_method_modifier_name => $method_modifier); - } + my $fetch_and_prepare_method = sub { + my ($self, $method_name) = @_; + # fetch it locally + my $method = $self->get_method($method_name); + # if we dont have local ... + unless ($method) { + # make sure this method even exists ... + ($self->find_next_method_by_name($method_name)) + || confess "The method '$method_name' is not found in the inherience hierarchy for this class"; + # if so, then create a local which just + # calls the next applicable method ... + $self->add_method($method_name => sub { + $self->find_next_method_by_name($method_name)->(@_); + }); + $method = $self->get_method($method_name); + } + + # now make sure we wrap it properly + # (if it isnt already) + unless ($method->isa('Class::MOP::Method::Wrapped')) { + $method = Class::MOP::Method::Wrapped->wrap($method); + $self->add_method($method_name => $method); + } + return $method; + }; + + sub add_before_method_modifier { + my ($self, $method_name, $method_modifier) = @_; + (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); + } + sub add_after_method_modifier { + my ($self, $method_name, $method_modifier) = @_; + (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); + } + + sub add_around_method_modifier { + my ($self, $method_name, $method_modifier) = @_; + (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); + } + + # NOTE: + # the methods above used to be named like this: + # ${pkg}::${method}:(before|after|around) + # but this proved problematic when using one modifier + # to wrap multiple methods (something which is likely + # to happen pretty regularly IMO). So instead of naming + # it like this, I have chosen to just name them purely + # with their modifier names, like so: + # :(before|after|around) + # The fact is that in a stack trace, it will be fairly + # evident from the context what method they are attached + # to, and so don't need the fully qualified name. } sub alias_method { @@ -305,7 +367,7 @@ sub alias_method { || confess "Your code block must be a CODE reference"; my $full_method_name = ($self->name . '::' . $method_name); - $method = $self->method_metaclass->wrap($method) unless blessed($method); + $method = $self->method_metaclass->wrap($method) unless blessed($method); no strict 'refs'; no warnings 'redefine'; @@ -321,13 +383,13 @@ sub has_method { no strict 'refs'; return 0 if !defined(&{$sub_name}); - my $method = \&{$sub_name}; + my $method = \&{$sub_name}; return 0 if (svref_2object($method)->GV->STASH->NAME || '') ne $self->name && - (svref_2object($method)->GV->NAME || '') ne '__ANON__'; - - # at this point we are relatively sure - # it is our method, so we bless/wrap it - $self->method_metaclass->wrap($method) unless blessed($method); + (svref_2object($method)->GV->NAME || '') ne '__ANON__'; + + # at this point we are relatively sure + # it is our method, so we bless/wrap it + $self->method_metaclass->wrap($method) unless blessed($method); return 1; } @@ -336,7 +398,7 @@ sub get_method { (defined $method_name && $method_name) || confess "You must define a method name"; - return unless $self->has_method($method_name); + return unless $self->has_method($method_name); no strict 'refs'; return \&{$self->name . '::' . $method_name}; @@ -359,7 +421,7 @@ sub remove_method { sub get_method_list { my $self = shift; no strict 'refs'; - grep { $self->has_method($_) } %{$self->name . '::'}; + grep { $self->has_method($_) } keys %{$self->name . '::'}; } sub compute_all_applicable_methods { @@ -415,23 +477,23 @@ sub find_all_methods_by_name { sub find_next_method_by_name { my ($self, $method_name) = @_; (defined $method_name && $method_name) - || confess "You must define a method name to find"; + || confess "You must define a method name to find"; # 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; - my @cpl = $self->class_precedence_list(); - shift @cpl; # discard ourselves + my @cpl = $self->class_precedence_list(); + shift @cpl; # discard ourselves foreach my $class (@cpl) { next if $seen_class{$class}; $seen_class{$class}++; # fetch the meta-class ... my $meta = $self->initialize($class); - return $meta->get_method($method_name) - if $meta->has_method($method_name); + return $meta->get_method($method_name) + if $meta->has_method($method_name); } - return; + return; } ## Attributes @@ -445,8 +507,11 @@ sub add_attribute { ($attribute->isa('Class::MOP::Attribute')) || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)"; $attribute->attach_to_class($self); - $attribute->install_accessors(); + $attribute->install_accessors(); $self->get_attribute_map->{$attribute->name} = $attribute; + + # FIXME + # in theory we have to tell everyone the slot structure may have changed } sub has_attribute { @@ -472,8 +537,8 @@ sub remove_attribute { my $removed_attribute = $self->get_attribute_map->{$attribute_name}; return unless defined $removed_attribute; delete $self->get_attribute_map->{$attribute_name}; - $removed_attribute->remove_accessors(); - $removed_attribute->detach_from_class(); + $removed_attribute->remove_accessors(); + $removed_attribute->detach_from_class(); return $removed_attribute; } @@ -504,6 +569,24 @@ sub compute_all_applicable_attributes { return @attrs; } +sub find_attribute_by_name { + my ($self, $attr_name) = @_; + # 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); + return $meta->get_attribute($attr_name) + if $meta->has_attribute($attr_name); + } + return; +} + # Class attributes sub add_package_variable { @@ -517,8 +600,17 @@ sub add_package_variable { *{$self->name . '::' . $name} = $initial_value; } else { - eval $sigil . $self->name . '::' . $name; - confess "Could not create package variable ($variable) because : $@" if $@; + my $e; + { + # NOTE: + # We HAVE to localize $@ or all + # hell breaks loose. It is not + # good, believe me, not good. + local $@; + eval $sigil . $self->name . '::' . $name; + $e = $@ if $@; + } + confess "Could not create package variable ($variable) because : $e" if $e; } } @@ -536,12 +628,19 @@ sub get_package_variable { (defined $variable && $variable =~ /^[\$\@\%]/) || confess "variable name does not have a sigil"; my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); - no strict 'refs'; - # try to fetch it first,.. see what happens - my $ref = eval '\\' . $sigil . $self->name . '::' . $name; - confess "Could not get the package variable ($variable) because : $@" if $@; + my ($ref, $e); + { + # NOTE: + # We HAVE to localize $@ or all + # hell breaks loose. It is not + # good, believe me, not good. + local $@; + $ref = eval '\\' . $sigil . $self->name . '::' . $name; + $e = $@ if $@; + } + confess "Could not get the package variable ($variable) because : $e" if $e; # if we didn't die, then we can return it - return $ref; + return $ref; } sub remove_package_variable { @@ -565,6 +664,9 @@ Class::MOP::Class - Class Meta Object =head1 SYNOPSIS + # assuming that class Foo + # has been defined, you can + # use this for introspection ... # add a method to Foo ... @@ -616,6 +718,21 @@ 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 of the MOP when subclassing it. +=item B + +This will return an hash of all the metaclass instances that have +been cached by B keyed by the package name. + +=item B + +This will return an array of all the metaclass instances that have +been cached by B. + +=item B + +This will return an array of all the metaclass names that have +been cached by B. + =back =head2 Class construction @@ -640,6 +757,14 @@ C<$package_name> into existence and adding any of the C<$package_version>, C<@superclasses>, C<%methods> and C<%attributes> to it. +=item B ?@superclasses, + methods =E ?%methods, + attributes =E ?%attributes)> + +This will create an anonymous class, it works much like C but +it does not need a C<$package_name>. Instead it will create a suitably +unique package name for you to stash things into. + =item B This initializes and returns returns a B object @@ -670,6 +795,10 @@ to use them or not. =over 4 +=item B + +=item B + =item B This is a convience method for creating a new object of the class, and @@ -1040,6 +1169,12 @@ HASH reference like C because all that same information is discoverable through the attribute meta-object itself. +=item B + +This method will traverse the inheritance heirachy and find the +first attribute whose name matches C<$attr_name>, then return it. +It will return undef if nothing is found. + =back =head2 Package Variables @@ -1088,4 +1223,4 @@ L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=cut \ No newline at end of file +=cutchistian