X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=f5e9f8d14079bf7156e831eaa06671e57aedb9be;hb=8203616d0be984d3ca70ee863e75ee3784f894e5;hp=2d577106c020b4544507b271c44f3c0e5e040f45;hpb=a27ae83fc6e52764abc62620a6527d451f44e97c;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 2d57710..f5e9f8d 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -4,103 +4,235 @@ package Class::MOP::Class; use strict; use warnings; +use Class::MOP::Immutable; +use Class::MOP::Instance; +use Class::MOP::Method::Wrapped; + use Carp 'confess'; -use Scalar::Util 'blessed', 'reftype'; +use Scalar::Util 'blessed', 'reftype', 'weaken'; use Sub::Name 'subname'; use B 'svref_2object'; -use Clone (); -our $VERSION = '0.04'; +our $VERSION = '0.21'; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Class::MOP::Module'; # Self-introspection sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) } # Creation - -{ - # Metaclasses are singletons, so we cache them here. - # 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; - sub initialize { - my $class = shift; - my $package_name = shift; - (defined $package_name && $package_name && !blessed($package_name)) - || confess "You must pass a package name and it cannot be blessed"; - $class->construct_class_instance(':package' => $package_name, @_); - } +sub initialize { + my $class = shift; + my $package_name = shift; + (defined $package_name && $package_name && !blessed($package_name)) + || confess "You must pass a package name and it cannot be blessed"; + $class->construct_class_instance('package' => $package_name, @_); +} + +sub reinitialize { + my $class = shift; + my $package_name = shift; + (defined $package_name && $package_name && !blessed($package_name)) + || confess "You must pass a package name and it cannot be blessed"; + Class::MOP::remove_metaclass_by_name($package_name); + $class->construct_class_instance('package' => $package_name, @_); +} - # NOTE: (meta-circularity) - # this is a special form of &construct_instance - # (see below), which is used to construct class - # meta-object instances for any Class::MOP::* - # class. All other classes will use the more - # normal &construct_instance. - sub construct_class_instance { - my $class = shift; - my %options = @_; - 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}; - $class = blessed($class) || $class; - # now create the metaclass - my $meta; - if ($class =~ /^Class::MOP::/) { - $meta = bless { - '$:package' => $package_name, - '%:attributes' => {}, - '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute', - '$:method_metaclass' => $options{':method_metaclass'} || 'Class::MOP::Method', - } => $class; - } - else { +# NOTE: (meta-circularity) +# this is a special form of &construct_instance +# (see below), which is used to construct class +# meta-object instances for any Class::MOP::* +# class. All other classes will use the more +# normal &construct_instance. +sub construct_class_instance { + my $class = shift; + my %options = @_; + my $package_name = $options{'package'}; + (defined $package_name && $package_name) + || confess "You must pass a 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 Class::MOP::get_metaclass_by_name($package_name) + if Class::MOP::does_metaclass_exist($package_name); + + # NOTE: + # we need to deal with the possibility + # of class immutability here, and then + # get the name of the class appropriately + $class = (blessed($class) + ? ($class->is_immutable + ? $class->get_mutable_metaclass_name() + : blessed($class)) + : $class); + + # now create the metaclass + my $meta; + if ($class =~ /^Class::MOP::Class$/) { + no strict 'refs'; + $meta = bless { + # inherited from Class::MOP::Package + '$!package' => $package_name, + # NOTE: - # it is safe to use meta here because - # class will always be a subclass of - # Class::MOP::Class, which defines meta - $meta = bless $class->meta->construct_instance(%options) => $class - } - # and check the metaclass compatibility - $meta->check_metaclass_compatability(); - $METAS{$package_name} = $meta; + # since the following attributes will + # actually be loaded from the symbol + # table, and actually bypass the instance + # entirely, we can just leave these things + # listed here for reference, because they + # should not actually have a value associated + # with the slot. + '%!namespace' => \undef, + # inherited from Class::MOP::Module + '$!version' => \undef, + '$!authority' => \undef, + # defined in Class::MOP::Class + '@!superclasses' => \undef, + + '%!methods' => {}, + '%!attributes' => {}, + '$!attribute_metaclass' => $options{'attribute_metaclass'} || 'Class::MOP::Attribute', + '$!method_metaclass' => $options{'method_metaclass'} || 'Class::MOP::Method', + '$!instance_metaclass' => $options{'instance_metaclass'} || 'Class::MOP::Instance', + } => $class; + } + else { + # NOTE: + # it is safe to use meta here because + # class will always be a subclass of + # Class::MOP::Class, which defines meta + $meta = $class->meta->construct_instance(%options) } - sub check_metaclass_compatability { - my $self = shift; + # and check the metaclass compatibility + $meta->check_metaclass_compatability(); + + Class::MOP::store_metaclass_by_name($package_name, $meta); + + # NOTE: + # we need to weaken any anon classes + # so that they can call DESTROY properly + Class::MOP::weaken_metaclass($package_name) if $meta->is_anon_class; + + $meta; +} + +sub check_metaclass_compatability { + my $self = shift; + + # this is always okay ... + return if blessed($self) eq 'Class::MOP::Class' && + $self->instance_metaclass eq 'Class::MOP::Instance'; - # this is always okay ... - return if blessed($self) eq 'Class::MOP::Class'; + my @class_list = $self->class_precedence_list; + shift @class_list; # shift off $self->name - my @class_list = $self->class_precedence_list; - shift @class_list; # shift off $self->name + foreach my $class_name (@class_list) { + my $meta = Class::MOP::get_metaclass_by_name($class_name) || next; + + # NOTE: + # we need to deal with the possibility + # of class immutability here, and then + # get the name of the class appropriately + my $meta_type = ($meta->is_immutable + ? $meta->get_mutable_metaclass_name() + : blessed($meta)); + + ($self->isa($meta_type)) + || confess $self->name . "->meta => (" . (blessed($self)) . ")" . + " is not compatible with the " . + $class_name . "->meta => (" . ($meta_type) . ")"; + # 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) . ")"; + } +} + +## ANON classes - foreach my $class_name (@class_list) { - my $meta = $METAS{$class_name}; - ($self->isa(blessed($meta))) - || confess $self->name . "->meta => (" . (blessed($self)) . ")" . - " is not compatible with the " . - $class_name . "->meta => (" . (blessed($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; + + # NOTE: + # we need a sufficiently annoying prefix + # this should suffice for now, this is + # used in a couple of places below, so + # need to put it up here for now. + my $ANON_CLASS_PREFIX = 'Class::MOP::Class::__ANON__::SERIAL::'; + + sub is_anon_class { + my $self = shift; + no warnings 'uninitialized'; + $self->name =~ /^$ANON_CLASS_PREFIX/ ? 1 : 0; } + + sub create_anon_class { + my ($class, %options) = @_; + my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL; + return $class->create($package_name, %options); + } + + # NOTE: + # this will only get called for + # anon-classes, all other calls + # are assumed to occur during + # global destruction and so don't + # really need to be handled explicitly + sub DESTROY { + my $self = shift; + no warnings 'uninitialized'; + return unless $self->name =~ /^$ANON_CLASS_PREFIX/; + my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/); + no strict 'refs'; + foreach my $key (keys %{$ANON_CLASS_PREFIX . $serial_id}) { + delete ${$ANON_CLASS_PREFIX . $serial_id}{$key}; + } + delete ${'main::' . $ANON_CLASS_PREFIX}{$serial_id . '::'}; + } + } +# creating classes with MOP ... + sub create { - my ($class, $package_name, $package_version, %options) = @_; + my $class = shift; + my $package_name = shift; + (defined $package_name && $package_name) || confess "You must pass a package name"; + + (scalar @_ % 2 == 0) + || confess "You much pass all parameters as name => value pairs " . + "(I found an uneven number of params in \@_)"; + + my (%options) = @_; + my $code = "package $package_name;"; - $code .= "\$$package_name\:\:VERSION = '$package_version';" - if defined $package_version; + $code .= "\$$package_name\:\:VERSION = '" . $options{version} . "';" + if exists $options{version}; + $code .= "\$$package_name\:\:AUTHORITY = '" . $options{authority} . "';" + if exists $options{authority}; + eval $code; confess "creation of $package_name failed : $@" if $@; + my $meta = $class->initialize($package_name); $meta->add_method('meta' => sub { - Class::MOP::Class->initialize(blessed($_[0]) || $_[0]); + $class->initialize(blessed($_[0]) || $_[0]); }); $meta->superclasses(@{$options{superclasses}}) @@ -129,10 +261,36 @@ sub create { # 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'} } +sub get_attribute_map { $_[0]->{'%!attributes'} } +sub attribute_metaclass { $_[0]->{'$!attribute_metaclass'} } +sub method_metaclass { $_[0]->{'$!method_metaclass'} } +sub instance_metaclass { $_[0]->{'$!instance_metaclass'} } + +# FIXME: +# this is a prime canidate for conversion to XS +sub get_method_map { + my $self = shift; + my $map = $self->{'%!methods'}; + + my $class_name = $self->name; + my $method_metaclass = $self->method_metaclass; + + foreach my $symbol ($self->list_all_package_symbols('CODE')) { + my $code = $self->get_package_symbol('&' . $symbol); + + next if exists $map->{$symbol} && + defined $map->{$symbol} && + $map->{$symbol}->body == $code; + + my $gv = svref_2object($code)->GV; + next if ($gv->STASH->NAME || '') ne $class_name && + ($gv->NAME || '') ne '__ANON__'; + + $map->{$symbol} = $method_metaclass->wrap($code); + } + + return $map; +} # Instance Construction & Cloning @@ -145,25 +303,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; @@ -174,73 +334,39 @@ 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"; - # NOTE: - # This will deep clone, which might - # not be what you always want. So - # the best thing is to write a more - # controled &clone method locally - # in the class (see Class::MOP) - my $clone = {}; + my $meta_instance = $class->get_meta_instance(); + my $clone = $meta_instance->clone_instance($instance); foreach my $attr ($class->compute_all_applicable_attributes()) { - my $init_arg = $attr->init_arg(); - # try to fetch the init arg from the %params ... - # (no sense in cloning if we are overriding it) - if (exists $params{$init_arg}) { - $clone->{$attr->name} = $params{$init_arg} + if ($params{$attr->init_arg}) { + $meta_instance->set_slot_value($clone, $attr->name, $params{$attr->init_arg}); } - else { - # if it is an object ... - if (blessed($instance->{$attr->name})) { - # see if it has a clone method ... - if ($instance->{$attr->name}->can('clone')) { - # if so ,.. call it - $clone->{$attr->name} = $instance->{$attr->name}->clone(); - } - # otherwise we assume that it does - # not wish to be cloned, and just - # copy the reference ... - else { - $clone->{$attr->name} = $instance->{$attr->name}; - } - } - # if it is not an object, then we - # deep clone it ... - else { - $clone->{$attr->name} = Clone::clone($instance->{$attr->name}); - } - } - } + } return $clone; } -# Informational - -# &name should be here too, but it is above -# because it gets bootstrapped away - -sub version { - my $self = shift; - no strict 'refs'; - ${$self->name . '::VERSION'}; -} - # Inheritance sub superclasses { my $self = shift; - no strict 'refs'; if (@_) { my @supers = @_; - @{$self->name . '::ISA'} = @supers; + @{$self->get_package_symbol('@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->name . '::ISA'}; + @{$self->get_package_symbol('@ISA')}; } sub class_precedence_list { @@ -250,8 +376,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 { @@ -266,61 +392,120 @@ 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; + + my $body; + if (blessed($method)) { + $body = $method->body; + } + else { + $body = $method; + ('CODE' eq (reftype($body) || '')) + || confess "Your code block must be a CODE reference"; + $method = $self->method_metaclass->wrap($body); + } + $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 $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) { + # try to find the next method + $method = $self->find_next_method_by_name($method_name); + # die if it does not exist + (defined $method) + || confess "The method '$method_name' is not found in the inherience hierarchy for class " . $self->name; + # and now make sure to wrap it + # even if it is already wrapped + # because we need a new sub ref + $method = Class::MOP::Method::Wrapped->wrap($method); + } + else { + # now make sure we wrap it properly + $method = Class::MOP::Method::Wrapped->wrap($method) + unless $method->isa('Class::MOP::Method::Wrapped'); + } + $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 { 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); + + my $body = (blessed($method) ? $method->body : $method); + ('CODE' eq (reftype($body) || '')) + || confess "Your code block must be a CODE reference"; - no strict 'refs'; - no warnings 'redefine'; - *{$full_method_name} = $method; + $self->add_package_symbol("&${method_name}" => $body); } -{ - - ## 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 } || '' }; - - sub has_method { - my ($self, $method_name) = @_; - (defined $method_name && $method_name) - || confess "You must define a method name"; +sub has_method { + my ($self, $method_name) = @_; + (defined $method_name && $method_name) + || confess "You must define a method name"; - my $sub_name = ($self->name . '::' . $method_name); - - no strict 'refs'; - return 0 if !defined(&{$sub_name}); - return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name && - $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__'; - return 1; - } - + return 0 unless exists $self->get_method_map->{$method_name}; + return 1; } sub get_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 + + # NOTE: + # I don't really need this here, because + # if the method_map is missing a key it + # will just return undef for me now + # return unless $self->has_method($method_name); + + return $self->get_method_map->{$method_name}; } sub remove_method { @@ -330,17 +515,38 @@ sub remove_method { my $removed_method = $self->get_method($method_name); - no strict 'refs'; - delete ${$self->name . '::'}{$method_name} - if defined $removed_method; + do { + $self->remove_package_symbol("&${method_name}"); + delete $self->get_method_map->{$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 . '::'}; + keys %{$self->get_method_map}; +} + +sub find_method_by_name { + my ($self, $method_name) = @_; + (defined $method_name && $method_name) + || 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(); + 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; } sub compute_all_applicable_methods { @@ -383,7 +589,7 @@ sub find_all_methods_by_name { next if $seen_class{$class}; $seen_class{$class}++; # fetch the meta-class ... - my $meta = $self->initialize($class);; + my $meta = $self->initialize($class); push @methods => { name => $method_name, class => $class, @@ -391,7 +597,28 @@ sub find_all_methods_by_name { } if $meta->has_method($method_name); } return @methods; +} +sub find_next_method_by_name { + my ($self, $method_name) = @_; + (defined $method_name && $method_name) + || 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 + 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; } ## Attributes @@ -404,8 +631,21 @@ sub add_attribute { # make sure it is derived from the correct type though ($attribute->isa('Class::MOP::Attribute')) || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)"; + + # first we attach our new attribute + # because it might need certain information + # about the class which it is attached to $attribute->attach_to_class($self); - $attribute->install_accessors(); + + # then we remove attributes of a conflicting + # name here so that we can properly detach + # the old attr object, and remove any + # accessors it would have generated + $self->remove_attribute($attribute->name) + if $self->has_attribute($attribute->name); + + # then onto installing the new accessors + $attribute->install_accessors(); $self->get_attribute_map->{$attribute->name} = $attribute; } @@ -421,8 +661,10 @@ sub get_attribute { (defined $attribute_name && $attribute_name) || confess "You must define an attribute name"; return $self->get_attribute_map->{$attribute_name} - if $self->has_attribute($attribute_name); - return; + # NOTE: + # this will return undef anyway, so no need ... + # if $self->has_attribute($attribute_name); + #return; } sub remove_attribute { @@ -432,8 +674,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; } @@ -464,55 +706,61 @@ sub compute_all_applicable_attributes { return @attrs; } -# Class attributes - -sub add_package_variable { - my ($self, $variable, $initial_value) = @_; - (defined $variable && $variable =~ /^[\$\@\%]/) - || confess "variable name does not have a sigil"; - - my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); - if (defined $initial_value) { - no strict 'refs'; - *{$self->name . '::' . $name} = $initial_value; - } - else { - eval $sigil . $self->name . '::' . $name; - confess "Could not create package variable ($variable) because : $@" if $@; +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; } -sub has_package_variable { - my ($self, $variable) = @_; - (defined $variable && $variable =~ /^[\$\@\%]/) - || confess "variable name does not have a sigil"; - my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); - no strict 'refs'; - defined ${$self->name . '::'}{$name} ? 1 : 0; -} +## Class closing -sub get_package_variable { - my ($self, $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 - eval '\\' . $sigil . $self->name . '::' . $name; - confess "Could not get the package variable ($variable) because : $@" if $@; - # if we didn't die, then we can return it - # NOTE: - # this is not ideal, better suggestions are welcome - eval '\\' . $sigil . $self->name . '::' . $name; -} +sub is_mutable { 1 } +sub is_immutable { 0 } -sub remove_package_variable { - my ($self, $variable) = @_; - (defined $variable && $variable =~ /^[\$\@\%]/) - || confess "variable name does not have a sigil"; - my ($sigil, $name) = ($variable =~ /^(.)(.*)$/); - no strict 'refs'; - delete ${$self->name . '::'}{$name}; +{ + # NOTE: + # the immutable version of a + # particular metaclass is + # really class-level data so + # we don't want to regenerate + # it any more than we need to + my $IMMUTABLE_METACLASS; + sub make_immutable { + my ($self) = @_; + + $IMMUTABLE_METACLASS ||= Class::MOP::Immutable->new($self, { + read_only => [qw/superclasses/], + cannot_call => [qw/ + add_method + alias_method + remove_method + add_attribute + remove_attribute + add_package_symbol + remove_package_symbol + /], + memoize => { + class_precedence_list => 'ARRAY', + compute_all_applicable_attributes => 'ARRAY', + get_meta_instance => 'SCALAR', + get_method_map => 'SCALAR', + } + }); + + $IMMUTABLE_METACLASS->make_metaclass_immutable(@_) + } } 1; @@ -527,6 +775,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 ... @@ -541,7 +792,8 @@ Class::MOP::Class - Class Meta Object # or use this to actually create classes ... - Class::MOP::Class->create('Bar' => '0.01' => ( + Class::MOP::Class->create('Bar' => ( + version => '0.01', superclasses => [ 'Foo' ], attributes => [ Class::MOP:::Attribute->new('$bar'), @@ -592,21 +844,37 @@ created any more than nessecary. Basically, they are singletons. =over 4 -=item B ?$version, + authority =E ?$authority, superclasses =E ?@superclasses, methods =E ?%methods, attributes =E ?%attributes)> This returns a B 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. +C<$package_name> into existence and adding any of the C<$version>, +C<$authority>, C<@superclasses>, C<%methods> and C<%attributes> to +it. + +=item B ?@superclasses, + methods =E ?%methods, + attributes =E ?%attributes)> -=item B +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 for a given a C<$package_name>. +=item B + +This removes the old metaclass, and creates a new one in it's place. +Do B use this unless you really know what you are doing, it could +very easily make a very large mess of your program. + =item B This will construct an instance of B, it is @@ -632,6 +900,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 @@ -662,8 +934,10 @@ 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: +blessing it into the appropriate package. This method will call +C, which performs a shallow copy of the object, +see that methods documentation for more details. Ideally your +class would call a C this method like so: sub MyClass::clone { my ($self, %param) = @_; @@ -676,38 +950,34 @@ 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 in the following -way: - -If the attribute name is in C<%params> it will use that, otherwise it -will attempt to clone the value in that slot. If the value is C -then it will look for a C method. If a C method is found, -then it is called and the return value is added to the clone. If a -C method is B found, then we will respect the object's -encapsulation and not clone it, and just copy the object's pointer. If -the value is not C, then it will be deep-copied using L. +you override C, you need to override this one too), +and clones the instance shallowly. The cloned structure returned is (like with C) an unCed HASH reference, it is your responsibility to then bless this cloned structure into the right class (which C will do for you). +As of 0.11, this method will clone the C<$instance> structure shallowly, +as opposed to the deep cloning implemented in prior versions. After much +thought, research and discussion, I have decided that anything but basic +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 to be part of the MOP. + =back =head2 Informational -=over 4 +These are a few predicate methods for asking information about the class. -=item B +=over 4 -This is a read-only attribute which returns the package name for the -given B instance. +=item B -=item B +=item B -This is a read-only attribute which returns the C<$VERSION> of the -package for the given B instance. +=item B =back @@ -740,6 +1010,8 @@ what B does, but we don't remove duplicate names. =over 4 +=item B + =item B =item B @@ -789,9 +1061,19 @@ C<$method_name> is actually a method. However, it will DWIM about =item B -This will return a CODE reference of the specified C<$method_name>, +This will return a Class::MOP::Method instance related to the specified +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 for more information. + +=item B + +This will return a CODE reference of the specified C<$method_name>, or return undef if that method does not exist. +Unlike C this will also look in the superclasses. + =item B This will attempt to remove a given C<$method_name> from the class. @@ -827,6 +1109,110 @@ 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. +=item B + +This will return the first method to match a given C<$method_name> in +the superclasses, this is basically equivalent to calling +C, but it can be dispatched at runtime. + +=back + +=head2 Method Modifiers + +Method modifiers are a concept borrowed from CLOS, in which a method +can be wrapped with I, I and I method modifiers +that will be called everytime the method is called. + +=head3 How method modifiers work? + +Method modifiers work by wrapping the original method and then replacing +it in the classes symbol table. The wrappers will handle calling all the +modifiers in the appropariate orders and preserving the calling context +for the original method. + +Each method modifier serves a particular purpose, which may not be +obvious to users of other method wrapping modules. To start with, the +return values of I and I modifiers are ignored. This is +because thier purpose is B to filter the input and output of the +primary method (this is done with an I modifier). This may seem +like an odd restriction to some, but doing this allows for simple code +to be added at the begining or end of a method call without jeapordizing +the normal functioning of the primary method or placing any extra +responsibility on the code of the modifier. Of course if you have more +complex needs, then use the I modifier, which uses a variation +of continutation passing style to allow for a high degree of flexibility. + +Before and around modifiers are called in last-defined-first-called order, +while after modifiers are called in first-defined-first-called order. So +the call tree might looks something like this: + + before 2 + before 1 + around 2 + around 1 + primary + after 1 + after 2 + +To see examples of using method modifiers, see the following examples +included in the distribution; F, F, +F and F. There is also a +classic CLOS usage example in the test F<017_add_method_modifier.t>. + +=head3 What is the performance impact? + +Of course there is a performance cost associated with method modifiers, +but we have made every effort to make that cost be directly proportional +to the amount of modifier features you utilize. + +The wrapping method does it's best to B do as much work as it +absolutely needs to. In order to do this we have moved some of the +performance costs to set-up time, where they are easier to amortize. + +All this said, my benchmarks have indicated the following: + + simple wrapper with no modifiers 100% slower + simple wrapper with simple before modifier 400% slower + simple wrapper with simple after modifier 450% slower + simple wrapper with simple around modifier 500-550% slower + simple wrapper with all 3 modifiers 1100% slower + +These numbers may seem daunting, but you must remember, every feature +comes with some cost. To put things in perspective, just doing a simple +C which does nothing but extract the name of the method called +and return it costs about 400% over a normal method call. + +=over 4 + +=item B + +This will wrap the method at C<$method_name> and the supplied C<$code> +will be passed the C<@_> arguments, and called before the original +method is called. As specified above, the return value of the I +method modifiers is ignored, and it's ability to modify C<@_> is +fairly limited. If you need to do either of these things, use an +C method modifier. + +=item B + +This will wrap the method at C<$method_name> so that the original +method will be called, it's return values stashed, and then the +supplied C<$code> will be passed the C<@_> arguments, and called. +As specified above, the return value of the I method +modifiers is ignored, and it cannot modify the return values of +the original method. If you need to do either of these things, use an +C method modifier. + +=item B + +This will wrap the method at C<$method_name> so that C<$code> +will be called and passed the original method as an extra argument +at the begining of the C<@_> argument list. This is a variation of +continuation passing style, where the function prepended to C<@_> +can be considered a continuation. It is up to C<$code> if it calls +the original method or not, there is no restriction on what the +C<$code> can or cannot do. + =back =head2 Attributes @@ -842,13 +1228,13 @@ their own. See L for more details. =item B -=item B +=item B -This stores a C<$attribute_meta_object> in the B -instance associated with the given class, 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). +This stores the C<$attribute_meta_object> (or creates one from the +C<$attribute_name> and C<%attribute_spec>) in the B +instance associated with the given class. 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 or the L section. @@ -857,6 +1243,11 @@ It should be noted that any accessor, reader/writer or predicate methods which the C<$attribute_meta_object> has will be installed into the class at this time. +B +If an attribute already exists for C<$attribute_name>, the old one +will be removed (as well as removing all it's accessors), and then +the new one added. + =item B Checks to see if this class has an attribute by the name of @@ -898,45 +1289,28 @@ HASH reference like C because all that same information is discoverable through the attribute meta-object itself. -=back - -=head2 Package Variables - -Since Perl's classes are built atop the Perl package system, it is -fairly common to use package scoped variables for things like static -class variables. The following methods are convience methods for -the creation and inspection of package scoped variables. - -=over 4 - -=item B - -Given a C<$variable_name>, which must contain a leading sigil, this -method will create that variable within the package which houses the -class. It also takes an optional C<$initial_value>, which must be a -reference of the same type as the sigil of the C<$variable_name> -implies. - -=item B +=item B -This will return a reference to the package variable in -C<$variable_name>. +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. -=item B +=back -Returns true (C<1>) if there is a package variable defined for -C<$variable_name>, and false (C<0>) otherwise. +=head2 Class closing -=item B +=over 4 -This will attempt to remove the package variable at C<$variable_name>. +=item B =back -=head1 AUTHOR +=head1 AUTHORS Stevan Little Estevan@iinteractive.comE +Yuval Kogman Enothingmuch@woobling.comE + =head1 COPYRIGHT AND LICENSE Copyright 2006 by Infinity Interactive, Inc. @@ -946,4 +1320,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 +=cut