From: Guillermo Roditi Date: Fri, 1 Jun 2007 22:30:32 +0000 (+0000) Subject: added ability to reverse immutability, sorry about the whitespace issue.. i accidenta... X-Git-Tag: 0_39~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0ac992ee5992b68d0019cf1c1fd16000adf9b71f;p=gitmo%2FClass-MOP.git added ability to reverse immutability, sorry about the whitespace issue.. i accidentally deleted all trailing whitespace, no undo. trailing whitespace is evil anyways --- diff --git a/Changes b/Changes index 0d4da96..917c69d 100644 --- a/Changes +++ b/Changes @@ -1,4 +1,12 @@ Revision history for Perl extension Class-MOP. +0.39 + * Class::MOP::Class::Immutable + - added make_metaclass_mutable + docs (groditi) + - removed unused variable + + * Class::MOP::Class + - Immutability can now be undone, + added make_mutable + tests + docs (groditi) 0.38 Thurs. May 31, 2007 ~~ More documentation updates ~~ diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index db0f538..cbfa745 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -18,17 +18,17 @@ our $AUTHORITY = 'cpan:STEVAN'; use base 'Class::MOP::Module'; -# Self-introspection +# Self-introspection sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) } # Creation - + 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"; + || confess "You must pass a package name and it cannot be blessed"; $class->construct_class_instance('package' => $package_name, @_); } @@ -36,34 +36,34 @@ 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"; + || 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 +} + +# 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 +# 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"; + || 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 + # 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); + if Class::MOP::does_metaclass_exist($package_name); # NOTE: - # we need to deal with the possibility - # of class immutability here, and then + # 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 @@ -74,28 +74,28 @@ sub construct_class_instance { # now create the metaclass my $meta; if ($class =~ /^Class::MOP::Class$/) { - no strict 'refs'; - $meta = bless { + no strict 'refs'; + $meta = bless { # inherited from Class::MOP::Package - '$!package' => $package_name, - + '$!package' => $package_name, + # NOTE: - # since the following attributes will - # actually be loaded from the symbol + # 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 + # should not actually have a value associated # with the slot. - '%!namespace' => \undef, + '%!namespace' => \undef, # inherited from Class::MOP::Module '$!version' => \undef, '$!authority' => \undef, # defined in Class::MOP::Class '@!superclasses' => \undef, - + '%!methods' => {}, - '%!attributes' => {}, + '%!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', @@ -104,103 +104,103 @@ sub construct_class_instance { else { # NOTE: # it is safe to use meta here because - # class will always be a subclass of + # class will always be a subclass of # Class::MOP::Class, which defines meta $meta = $class->meta->construct_instance(%options) } - + # 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; -} - + + $meta; +} + sub check_metaclass_compatability { 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 - foreach my $class_name (@class_list) { + 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 + # 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)); - + : blessed($meta)); + ($self->isa($meta_type)) - || confess $self->name . "->meta => (" . (blessed($self)) . ")" . - " is not compatible with the " . + || 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) . ")"; - } -} + || confess $self->name . "->meta => (" . ($self->instance_metaclass) . ")" . + " is not compatible with the " . + $class_name . "->meta => (" . ($meta->instance_metaclass) . ")"; + } +} ## ANON classes { # NOTE: - # this should be sufficient, if you have a - # use case where it is not, write a test and + # 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 + # 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::'; + 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; + $self->name =~ /^$ANON_CLASS_PREFIX/ ? 1 : 0; } sub create_anon_class { - my ($class, %options) = @_; + 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 + # 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'; + no warnings 'uninitialized'; return unless $self->name =~ /^$ANON_CLASS_PREFIX/; my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/); - no strict 'refs'; + 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 . '::'}; + delete ${'main::' . $ANON_CLASS_PREFIX}{$serial_id . '::'}; } } @@ -210,35 +210,35 @@ sub check_metaclass_compatability { sub create { 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 " . + || 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 = '" . $options{version} . "';" + $code .= "\$$package_name\:\:VERSION = '" . $options{version} . "';" if exists $options{version}; - $code .= "\$$package_name\:\:AUTHORITY = '" . $options{authority} . "';" - if exists $options{authority}; - + $code .= "\$$package_name\:\:AUTHORITY = '" . $options{authority} . "';" + if exists $options{authority}; + eval $code; - confess "creation of $package_name failed : $@" if $@; - + confess "creation of $package_name failed : $@" if $@; + my $meta = $class->initialize($package_name); - - $meta->add_method('meta' => sub { + + $meta->add_method('meta' => sub { $class->initialize(blessed($_[0]) || $_[0]); }); - + $meta->superclasses(@{$options{superclasses}}) if exists $options{superclasses}; # NOTE: - # process attributes first, so that they can + # 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. @@ -246,19 +246,19 @@ sub create { 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; } ## Attribute readers # NOTE: -# all these attribute readers will be bootstrapped +# all these attribute readers will be bootstrapped # away in the Class::MOP bootstrap section sub get_attribute_map { $_[0]->{'%!attributes'} } @@ -268,27 +268,27 @@ sub instance_metaclass { $_[0]->{'$!instance_metaclass'} } # FIXME: # this is a prime canidate for conversion to XS -sub get_method_map { +sub get_method_map { my $self = shift; - my $map = $self->{'%!methods'}; - + 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; - + + 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__'; - + ($gv->NAME || '') ne '__ANON__'; + $map->{$symbol} = $method_metaclass->wrap($code); } - + return $map; } @@ -297,7 +297,7 @@ sub get_method_map { sub new_object { my $class = shift; # NOTE: - # we need to protect the integrity of the + # 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 @@ -313,14 +313,14 @@ sub construct_instance { foreach my $attr ($class->compute_all_applicable_attributes()) { $attr->initialize_instance_slot($meta_instance, $instance, \%params); } - # NOTE: + # NOTE: # this will only work for a HASH instance type if ($class->is_anon_class) { (reftype($instance) eq 'HASH') || confess "Currently only HASH based instances are supported with instance of anon-classes"; # NOTE: # At some point we should make this official - # as a reserved slot name, but right now I am + # as a reserved slot name, but right now I am # going to keep it here. # my $RESERVED_MOP_SLOT = '__MOP__'; $instance->{'__MOP__'} = $class; @@ -331,21 +331,21 @@ sub construct_instance { sub get_meta_instance { my $class = shift; return $class->instance_metaclass->new( - $class, + $class, $class->compute_all_applicable_attributes() ); } sub clone_object { my $class = shift; - my $instance = 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 + # 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'); + return $instance if $instance->isa('Class::MOP::Class'); $class->clone_instance($instance, @_); } @@ -354,13 +354,13 @@ sub clone_instance { (blessed($instance)) || confess "You can only clone instances, \$self is not a blessed instance"; my $meta_instance = $class->get_meta_instance(); - my $clone = $meta_instance->clone_instance($instance); + my $clone = $meta_instance->clone_instance($instance); foreach my $attr ($class->compute_all_applicable_attributes()) { if (exists $params{$attr->init_arg}) { - $meta_instance->set_slot_value($clone, $attr->name, $params{$attr->init_arg}); + $meta_instance->set_slot_value($clone, $attr->name, $params{$attr->init_arg}); } - } - return $clone; + } + return $clone; } # Inheritance @@ -371,10 +371,10 @@ sub superclasses { my @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 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(); } @@ -386,16 +386,16 @@ sub class_precedence_list { # NOTE: # We need to check for ciruclar inheirtance here. # This will do nothing if all is well, and blow - # up otherwise. Yes, it's an ugly hack, better + # up otherwise. Yes, it's an ugly hack, better # suggestions are welcome. { ($self->name || return)->isa('This is a test for circular inheritance') } - # ... and now back to our regularly scheduled program + ( - $self->name, - map { + $self->name, + map { $self->initialize($_)->class_precedence_list() } $self->superclasses() - ); + ); } ## Methods @@ -404,20 +404,20 @@ sub add_method { my ($self, $method_name, $method) = @_; (defined $method_name && $method_name) || confess "You must define a method name"; - + my $body; if (blessed($method)) { - $body = $method->body; + $body = $method->body; } - else { + else { $body = $method; ('CODE' eq (reftype($body) || '')) - || confess "Your code block must be a CODE reference"; - $method = $self->method_metaclass->wrap($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); + + my $full_method_name = ($self->name . '::' . $method_name); $self->add_package_symbol("&${method_name}" => subname $full_method_name => $body); } @@ -433,24 +433,24 @@ sub add_method { # die if it does not exist (defined $method) || confess "The method '$method_name' is not found in the inheritance hierarchy for class " . $self->name; - # and now make sure to wrap it + # 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 + # 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); + 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"; + || 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); } @@ -458,29 +458,29 @@ sub add_method { sub add_after_method_modifier { my ($self, $method_name, $method_modifier) = @_; (defined $method_name && $method_name) - || confess "You must pass in a 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: + # 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 + # 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 + # 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. } @@ -492,17 +492,17 @@ sub alias_method { my $body = (blessed($method) ? $method->body : $method); ('CODE' eq (reftype($body) || '')) - || confess "Your code block must be a CODE reference"; - + || confess "Your code block must be a CODE reference"; + $self->add_package_symbol("&${method_name}" => $body); } sub has_method { my ($self, $method_name) = @_; (defined $method_name && $method_name) - || confess "You must define a method name"; - - return 0 unless exists $self->get_method_map->{$method_name}; + || confess "You must define a method name"; + + return 0 unless exists $self->get_method_map->{$method_name}; return 1; } @@ -510,13 +510,13 @@ sub get_method { my ($self, $method_name) = @_; (defined $method_name && $method_name) || confess "You must define a method name"; - + # NOTE: # I don't really need this here, because - # if the method_map is missing a key it + # 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}; } @@ -524,14 +524,14 @@ 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); - - do { + + my $removed_method = $self->get_method($method_name); + + do { $self->remove_package_symbol("&${method_name}"); delete $self->get_method_map->{$method_name}; } if defined $removed_method; - + return $removed_method; } @@ -543,10 +543,10 @@ sub get_method_list { sub find_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 + # 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(); @@ -555,7 +555,7 @@ sub find_method_by_name { $seen_class{$class}++; # fetch the meta-class ... my $meta = $self->initialize($class); - return $meta->get_method($method_name) + return $meta->get_method($method_name) if $meta->has_method($method_name); } return; @@ -565,8 +565,8 @@ 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 + # 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()) { @@ -574,11 +574,11 @@ sub compute_all_applicable_methods { $seen_class{$class}++; # fetch the meta-class ... my $meta = $self->initialize($class); - foreach my $method_name ($meta->get_method_list()) { + foreach my $method_name ($meta->get_method_list()) { next if exists $seen_method{$method_name}; $seen_method{$method_name}++; push @methods => { - name => $method_name, + name => $method_name, class => $class, code => $meta->get_method($method_name) }; @@ -590,11 +590,11 @@ sub compute_all_applicable_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"; + || 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 + # 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()) { @@ -603,7 +603,7 @@ sub find_all_methods_by_name { # fetch the meta-class ... my $meta = $self->initialize($class); push @methods => { - name => $method_name, + name => $method_name, class => $class, code => $meta->get_method($method_name) } if $meta->has_method($method_name); @@ -614,10 +614,10 @@ 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 + # 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(); @@ -627,7 +627,7 @@ sub find_next_method_by_name { $seen_class{$class}++; # fetch the meta-class ... my $meta = $self->initialize($class); - return $meta->get_method($method_name) + return $meta->get_method($method_name) if $meta->has_method($method_name); } return; @@ -642,20 +642,20 @@ sub add_attribute { my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_); # 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)"; + || 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 + # because it might need certain information # about the class which it is attached to $attribute->attach_to_class($self); - - # then we remove attributes of a conflicting - # name here so that we can properly detach - # the old attr object, and remove any + + # 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; @@ -665,43 +665,43 @@ sub has_attribute { my ($self, $attribute_name) = @_; (defined $attribute_name && $attribute_name) || confess "You must define an attribute name"; - exists $self->get_attribute_map->{$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->get_attribute_map->{$attribute_name} + return $self->get_attribute_map->{$attribute_name} # NOTE: # this will return undef anyway, so no need ... - # if $self->has_attribute($attribute_name); - #return; -} + # if $self->has_attribute($attribute_name); + #return; +} sub remove_attribute { my ($self, $attribute_name) = @_; (defined $attribute_name && $attribute_name) || confess "You must define an attribute name"; - my $removed_attribute = $self->get_attribute_map->{$attribute_name}; + 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(); + delete $self->get_attribute_map->{$attribute_name}; + $removed_attribute->remove_accessors(); $removed_attribute->detach_from_class(); return $removed_attribute; -} +} sub get_attribute_list { my $self = shift; keys %{$self->get_attribute_map}; -} +} 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 + # 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()) { @@ -709,20 +709,20 @@ sub compute_all_applicable_attributes { $seen_class{$class}++; # fetch the meta-class ... my $meta = $self->initialize($class); - foreach my $attr_name ($meta->get_attribute_list()) { + foreach my $attr_name ($meta->get_attribute_list()) { next if exists $seen_attr{$attr_name}; $seen_attr{$attr_name}++; push @attrs => $meta->get_attribute($attr_name); } } - return @attrs; + 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 + # 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()) { @@ -743,15 +743,17 @@ sub is_immutable { 0 } { # NOTE: - # the immutable version of a - # particular metaclass is - # really class-level data so - # we don't want to regenerate + # 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; + my %IMMUTABLE_OPTIONS; sub make_immutable { - my ($self) = @_; - + my $self = shift; + %IMMUTABLE_OPTIONS = @_; + $IMMUTABLE_METACLASS ||= Class::MOP::Immutable->new($self, { read_only => [qw/superclasses/], cannot_call => [qw/ @@ -761,18 +763,25 @@ sub is_immutable { 0 } add_attribute remove_attribute add_package_symbol - remove_package_symbol + remove_package_symbol /], memoize => { class_precedence_list => 'ARRAY', - compute_all_applicable_attributes => 'ARRAY', - get_meta_instance => 'SCALAR', - get_method_map => 'SCALAR', + compute_all_applicable_attributes => 'ARRAY', + get_meta_instance => 'SCALAR', + get_method_map => 'SCALAR', } - }); - - $IMMUTABLE_METACLASS->make_metaclass_immutable(@_) + }); + + $IMMUTABLE_METACLASS->make_metaclass_immutable($self, %IMMUTABLE_OPTIONS); } + + sub make_mutable{ + my $self = shift; + return if $self->is_mutable; + $IMMUTABLE_METACLASS->make_metaclass_mutable($self, %IMMUTABLE_OPTIONS); + } + } 1; @@ -781,48 +790,48 @@ __END__ =pod -=head1 NAME +=head1 NAME Class::MOP::Class - Class Meta Object =head1 SYNOPSIS - # assuming that class Foo + # assuming that class Foo # has been defined, you can - + # use this for introspection ... - + # add a method to Foo ... Foo->meta->add_method('bar' => sub { ... }) - - # get a list of all the classes searched - # the method dispatcher in the correct order + + # get a list of all the classes searched + # the method dispatcher in the correct order Foo->meta->class_precedence_list() - + # remove a method from Foo Foo->meta->remove_method('bar'); - + # or use this to actually create classes ... - + Class::MOP::Class->create('Bar' => ( version => '0.01', superclasses => [ 'Foo' ], attributes => [ Class::MOP:::Attribute->new('$bar'), - Class::MOP:::Attribute->new('$baz'), + Class::MOP:::Attribute->new('$baz'), ], methods => { calculate_bar => sub { ... }, - construct_baz => sub { ... } + construct_baz => sub { ... } } )); =head1 DESCRIPTION -This is the largest and currently most complex part of the Perl 5 -meta-object protocol. It controls the introspection and -manipulation of Perl 5 classes (and it can create them too). The -best way to understand what this module can do, is to read the +This is the largest and currently most complex part of the Perl 5 +meta-object protocol. It controls the introspection and +manipulation of Perl 5 classes (and it can create them too). The +best way to understand what this module can do, is to read the documentation for each of it's methods. =head1 METHODS @@ -833,91 +842,91 @@ documentation for each of it's methods. =item B -This will return a B instance which is related -to this class. Thereby allowing B to actually +This will return a B instance which is related +to this class. Thereby allowing B to actually introspect itself. -As with B, B 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 -of the MOP when subclassing it. +As with B, B 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 +of the MOP when subclassing it. =back =head2 Class construction -These methods will handle creating B objects, -which can be used to both create new classes, and analyze -pre-existing classes. +These methods will handle creating B objects, +which can be used to both create new classes, and analyze +pre-existing classes. -This module will internally store references to all the instances -you create with these methods, so that they do not need to be +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 ?$version, - authority =E ?$authority, - superclasses =E ?@superclasses, - methods =E ?%methods, +=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<$version>, -C<$authority>, C<@superclasses>, C<%methods> and C<%attributes> to +This returns a B object, bringing the specified +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, +=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 +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. -On very important distinction is that anon classes are destroyed once -the metaclass they are attached to goes out of scope. In the DESTROY -method, the created package will be removed from the symbol table. +On very important distinction is that anon classes are destroyed once +the metaclass they are attached to goes out of scope. In the DESTROY +method, the created package will be removed from the symbol table. It is also worth noting that any instances created with an anon-class -will keep a special reference to the anon-meta which will prevent the -anon-class from going out of scope until all instances of it have also -been destroyed. This however only works for HASH based instance types, -as we use a special reserved slot (C<__MOP__>) to store this. +will keep a special reference to the anon-meta which will prevent the +anon-class from going out of scope until all instances of it have also +been destroyed. This however only works for HASH based instance types, +as we use a special reserved slot (C<__MOP__>) to store this. =item B -This initializes and returns returns a B object +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. +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 -here so that we can actually "tie the knot" for B -to use C once all the bootstrapping is done. This +This will construct an instance of B, it is +here so that we can actually "tie the knot" for B +to use C once all the bootstrapping is done. This method is used internally by C and should never be called from outside of that method really. =item B -This method is called as the very last thing in the -C method. This will check that the -metaclass you are creating is compatible with the metaclasses of all -your ancestors. For more inforamtion about metaclass compatibility +This method is called as the very last thing in the +C method. This will check that the +metaclass you are creating is compatible with the metaclasses of all +your ancestors. For more inforamtion about metaclass compatibility see the C section in L. =back =head2 Object instance construction and cloning -These methods are B, it is up to you whether you want +These methods are B, it is up to you whether you want to use them or not. =over 4 @@ -928,37 +937,37 @@ to use them or not. =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 +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 { + sub MyClass::new { my ($class, %param) = @_; $class->meta->new_object(%params); } -Of course the ideal place for this would actually be in C +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 +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, -it will then initialize them using either use the corresponding key -in C<%params> or any default value or initializer found in the +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, +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. This method will call -C, which performs a shallow copy of the object, -see that methods documentation for more details. Ideally your +This is a convience method for cloning an object instance, then +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 { @@ -966,30 +975,30 @@ class would call a C this method like so: $self->meta->clone_object($self, %params); } -Of course the ideal place for this would actually be in C +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 is a compliment of C (which means if +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 +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 +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 +=head2 Informational These are a few predicate methods for asking information about the class. @@ -1015,21 +1024,21 @@ This returns true if the class has been made immutable. =item B -This is a read-write attribute which represents the superclass +This is a read-write attribute which represents the superclass relationships of the class the B instance is associated with. Basically, it can get and set the C<@ISA> for you. B -Perl will occasionally perform some C<@ISA> and method caching, if -you decide to change your superclass relationship at runtime (which -is quite insane and very much not recommened), then you should be -aware of this and the fact that this module does not make any +Perl will occasionally perform some C<@ISA> and method caching, if +you decide to change your superclass relationship at runtime (which +is quite insane and very much not recommened), then you should be +aware of this and the fact that this module does not make any attempt to address this issue. =item B -This computes the a list of all the class's ancestors in the same order -in which method dispatch will be done. This is similair to +This computes the a list of all the class's ancestors in the same order +in which method dispatch will be done. This is similair to what B does, but we don't remove duplicate names. =back @@ -1044,55 +1053,55 @@ what B does, but we don't remove duplicate names. =item B -This will take a C<$method_name> and CODE reference to that -C<$method> and install it into the class's package. +This will take a C<$method_name> and CODE reference to that +C<$method> and install it into the class's package. -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 +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 will take a C<$method_name> and CODE reference to that -C<$method> and alias the method into the class's package. +This will take a C<$method_name> and CODE reference to that +C<$method> and alias the method into the class's package. -B: -Unlike C, this will B try to name the -C<$method> using B, it only aliases the method in -the class's package. +B: +Unlike C, this will B try to name the +C<$method> using B, it only aliases the method in +the class's package. =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 +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 (use C for that). -This will correctly handle functions defined outside of the package +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 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. +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 +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 I think. =item B -This will return a Class::MOP::Method instance related to the specified +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 +The Class::MOP::Method is codifiable, so you can use it like a normal CODE reference, see L for more information. =item B @@ -1104,76 +1113,76 @@ Unlike C this will also look in the superclasses. =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 +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 +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 -respond to, 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 +This will return a list of all the methods names this class will +respond to, 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 +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 +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. =item B -This will return the first method to match a given C<$method_name> in -the superclasses, this is basically equivalent to calling +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. +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 +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 @@ -1182,19 +1191,19 @@ the call tree might looks something like this: 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 +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 +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 +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: @@ -1205,49 +1214,49 @@ All this said, my benchmarks have indicated the following: 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 +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. +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 +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 +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 +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 +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 -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 +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. See L for more details. =over 4 @@ -1259,68 +1268,68 @@ their own. See L for more details. =item B 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 +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 +More details about the attribute meta-objects can be found in the L or the L section. -It should be noted that any accessor, reader/writer or predicate -methods which the C<$attribute_meta_object> has will be installed +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 +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 +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. +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. +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 +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. -It should be noted that any accessor, reader/writer or predicate -methods which the attribute meta-object stored at C<$attribute_name> -has will be removed from the class at this time. This B make -these attributes somewhat inaccessable in previously created -instances. But if you are crazy enough to do this at runtime, then +It should be noted that any accessor, reader/writer or predicate +methods which the attribute meta-object stored at C<$attribute_name> +has will be removed from the class at this time. This B make +these attributes somewhat inaccessable in previously created +instances. But if you are crazy enough to do this at runtime, then you are crazy enough to deal with something like this :). =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, +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 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 +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. =item B -This method will traverse the inheritance heirachy and find the -first attribute whose name matches C<$attr_name>, then return it. +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 @@ -1331,10 +1340,15 @@ It will return undef if nothing is found. =item B -This method will invoke a tranforamtion upon the class which will -make it immutable. Details of this transformation can be found in +This method will invoke a tranforamtion upon the class which will +make it immutable. Details of this transformation can be found in the L documentation. +=item B + +This method will reverse tranforamtion upon the class which +made it immutable. + =back =head1 AUTHORS @@ -1348,6 +1362,6 @@ Copyright 2006, 2007 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +it under the same terms as Perl itself. =cut diff --git a/lib/Class/MOP/Immutable.pm b/lib/Class/MOP/Immutable.pm index 5e6a3a6..1d91c8d 100644 --- a/lib/Class/MOP/Immutable.pm +++ b/lib/Class/MOP/Immutable.pm @@ -12,20 +12,20 @@ use Scalar::Util 'blessed'; our $VERSION = '0.01'; our $AUTHORITY = 'cpan:STEVAN'; -sub new { +sub new { my ($class, $metaclass, $options) = @_; - + my $self = bless { '$!metaclass' => $metaclass, '%!options' => $options, '$!immutable_metaclass' => undef, } => $class; - + # NOTE: - # we initialize the immutable + # we initialize the immutable # version of the metaclass here $self->create_immutable_metaclass; - + return $self; } @@ -37,23 +37,23 @@ sub create_immutable_metaclass { my $self = shift; # NOTE: - # The immutable version of the + # The immutable version of the # metaclass is just a anon-class - # which shadows the methods + # which shadows the methods # appropriately $self->{'$!immutable_metaclass'} = Class::MOP::Class->create_anon_class( superclasses => [ blessed($self->metaclass) ], methods => $self->create_methods_for_immutable_metaclass, - ); + ); } my %DEFAULT_METHODS = ( - meta => sub { + meta => sub { my $self = shift; - # if it is not blessed, then someone is asking + # if it is not blessed, then someone is asking # for the meta of Class::MOP::Class::Immutable return Class::MOP::Class->initialize($self) unless blessed($self); - # otherwise, they are asking for the metaclass + # otherwise, they are asking for the metaclass # which has been made immutable, which is itself return $self; }, @@ -63,107 +63,156 @@ my %DEFAULT_METHODS = ( ); # NOTE: -# this will actually convert the -# existing metaclass to an immutable +# this will actually convert the +# existing metaclass to an immutable # version of itself sub make_metaclass_immutable { my ($self, $metaclass, %options) = @_; - + $options{inline_accessors} = 1 unless exists $options{inline_accessors}; $options{inline_constructor} = 1 unless exists $options{inline_constructor}; - $options{inline_destructor} = 0 unless exists $options{inline_destructor}; + $options{inline_destructor} = 0 unless exists $options{inline_destructor}; $options{constructor_name} = 'new' unless exists $options{constructor_name}; - $options{debug} = 0 unless exists $options{debug}; - + $options{debug} = 0 unless exists $options{debug}; + if ($options{inline_accessors}) { foreach my $attr_name ($metaclass->get_attribute_list) { # inline the accessors $metaclass->get_attribute($attr_name) - ->install_accessors(1); - } + ->install_accessors(1); + } } - if ($options{inline_constructor}) { + if ($options{inline_constructor}) { my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor'; - + $metaclass->add_method( $options{constructor_name}, $constructor_class->new( - options => \%options, - metaclass => $metaclass, + options => \%options, + metaclass => $metaclass, ) ) unless $metaclass->has_method($options{constructor_name}); - } - - if ($options{inline_destructor}) { + } + + if ($options{inline_destructor}) { (exists $options{destructor_class}) || confess "The 'inline_destructor' option is present, but " . "no destructor class was specified"; - + my $destructor_class = $options{destructor_class}; - + my $destructor = $destructor_class->new( options => \%options, metaclass => $metaclass, ); - - $metaclass->add_method('DESTROY' => $destructor) + + $metaclass->add_method('DESTROY' => $destructor) # NOTE: - # we allow the destructor to determine + # we allow the destructor to determine # if it is needed or not, it can perform - # all sorts of checks because it has the - # metaclass instance + # all sorts of checks because it has the + # metaclass instance if $destructor->is_needed; - } - + } + my $memoized_methods = $self->options->{memoize}; foreach my $method_name (keys %{$memoized_methods}) { my $type = $memoized_methods->{$method_name}; - + ($metaclass->can($method_name)) - || confess "Could not find the method '$method_name' in " . $metaclass->name; - - my $memoized_method; + || confess "Could not find the method '$method_name' in " . $metaclass->name; + if ($type eq 'ARRAY') { $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ]; } elsif ($type eq 'HASH') { - $metaclass->{'___' . $method_name} = { $metaclass->$method_name }; + $metaclass->{'___' . $method_name} = { $metaclass->$method_name }; } elsif ($type eq 'SCALAR') { $metaclass->{'___' . $method_name} = $metaclass->$method_name; } - } - $metaclass->{'___original_class'} = blessed($metaclass); + } + + #I'm not sure i understand this, stevan suggested the addition i don't think its actually needed + #my $is_immutable = $metaclass->is_anon_class; + #$self->immutable_metaclass->add_method('is_anon_class' => sub { $is_immutable }); + $metaclass->{'___original_class'} = blessed($metaclass); bless $metaclass => $self->immutable_metaclass->name; } +sub make_metaclass_mutable { + my ($self, $immutable, %options) = @_; + + my $original_class = $immutable->get_mutable_metaclass_name; + delete $immutable->{'___original_class'} ; + bless $immutable => $original_class; + + my $memoized_methods = $self->options->{memoize}; + foreach my $method_name (keys %{$memoized_methods}) { + my $type = $memoized_methods->{$method_name}; + + ($immutable->can($method_name)) + || confess "Could not find the method '$method_name' in " . $immutable->name; + if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) { + delete $immutable->{'___' . $method_name}; + } + } + + if ($options{inline_destructor} && $immutable->has_method('DESTROY')) { + $immutable->remove_method('DESTROY') + if $immutable->get_method('DESTROY')->blessed eq $options{destructor_class}; + } + + #14:01 <@stevan> nah,. you shouldnt + #14:01 <@stevan> they are just inlined + #14:01 <@stevan> which is the default in Moose anyway + #14:02 <@stevan> and adding new attributes will just DWIM + #14:02 <@stevan> and you really cant change an attribute anyway + #if ($options{inline_accessors}) { + # foreach my $attr_name ($immutable->get_attribute_list) { + # my $attr = $immutable->get_attribute($attr_name); + # $attr->remove_accessors; + # $attr->install_accessors(0); + # } + #} + + #14:26 <@stevan> the only user of ::Method::Constructor is immutable + #14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi + #14:27 <@stevan> so I am not worried + $options{constructor_name} = 'new' unless exists $options{constructor_name}; + if ($options{inline_constructor}) { + my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor'; + $immutable->remove_method( $options{constructor_name} ) + if $immutable->get_method($options{constructor_name})->blessed eq $constructor_class; + } +} + sub create_methods_for_immutable_metaclass { my $self = shift; - + my %methods = %DEFAULT_METHODS; - + foreach my $read_only_method (@{$self->options->{read_only}}) { my $method = $self->metaclass->meta->find_method_by_name($read_only_method); - + (defined $method) || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name; - + $methods{$read_only_method} = sub { confess "This method is read-only" if scalar @_ > 1; goto &{$method->body} }; } - + foreach my $cannot_call_method (@{$self->options->{cannot_call}}) { $methods{$cannot_call_method} = sub { confess "This method ($cannot_call_method) cannot be called on an immutable instance"; }; - } - + } + my $memoized_methods = $self->options->{memoize}; - foreach my $method_name (keys %{$memoized_methods}) { my $type = $memoized_methods->{$method_name}; if ($type eq 'ARRAY') { @@ -174,11 +223,11 @@ sub create_methods_for_immutable_metaclass { } elsif ($type eq 'SCALAR') { $methods{$method_name} = sub { $_[0]->{'___' . $method_name} }; - } - } - - $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} }; - + } + } + + $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} }; + return \%methods; } @@ -188,14 +237,14 @@ __END__ =pod -=head1 NAME +=head1 NAME Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses =head1 SYNOPSIS use Class::MOP::Immutable; - + my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, { read_only => [qw/superclasses/], cannot_call => [qw/ @@ -205,26 +254,26 @@ Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses add_attribute remove_attribute add_package_symbol - remove_package_symbol + remove_package_symbol /], memoize => { class_precedence_list => 'ARRAY', - compute_all_applicable_attributes => 'ARRAY', - get_meta_instance => 'SCALAR', - get_method_map => 'SCALAR', + compute_all_applicable_attributes => 'ARRAY', + get_meta_instance => 'SCALAR', + get_method_map => 'SCALAR', } - }); + }); $immutable_metaclass->make_metaclass_immutable(@_) =head1 DESCRIPTION -This is basically a module for applying a transformation on a given -metaclass. Current features include making methods read-only, +This is basically a module for applying a transformation on a given +metaclass. Current features include making methods read-only, making methods un-callable and memoizing methods (in a type specific -way too). +way too). -This module is fairly new to the MOP, and quite possibly will be +This module is fairly new to the MOP, and quite possibly will be expanded and further generalized as the need arises. =head1 METHODS @@ -233,9 +282,9 @@ expanded and further generalized as the need arises. =item B -Given a C<$metaclass> and a set of C<%options> this module will -prepare an immutable version of the C<$metaclass>, which can then -be applied to the C<$metaclass> using the C +Given a C<$metaclass> and a set of C<%options> this module will +prepare an immutable version of the C<$metaclass>, which can then +be applied to the C<$metaclass> using the C method. =item B @@ -256,18 +305,24 @@ Returns the immutable metaclass created within C. =item B -This will create the immutable version of the C<$metaclass>, but will -not actually change the original metaclass. +This will create the immutable version of the C<$metaclass>, but will +not actually change the original metaclass. =item B -This will create all the methods for the immutable metaclass based +This will create all the methods for the immutable metaclass based on the C<%options> passed into C. -=item B +=item B This will actually change the C<$metaclass> into the immutable version. +=item B + +This will change the C<$metaclass> into the mutable version by reversing +the immutable process. C<%options> should be the same options that were +given to make_metaclass_immutable. + =back =head1 AUTHORS @@ -281,6 +336,6 @@ Copyright 2006, 2007 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +it under the same terms as Perl itself. =cut diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index fba4d05..06ae7f0 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -3,14 +3,14 @@ use strict; use warnings; -use Test::More tests => 191; +use Test::More tests => 193; use Test::Exception; BEGIN { use_ok('Class::MOP'); - use_ok('Class::MOP::Class'); - use_ok('Class::MOP::Package'); - use_ok('Class::MOP::Module'); + use_ok('Class::MOP::Class'); + use_ok('Class::MOP::Package'); + use_ok('Class::MOP::Module'); } { @@ -28,66 +28,66 @@ my $class_mop_module_meta = Class::MOP::Module->meta(); isa_ok($class_mop_module_meta, 'Class::MOP::Module'); my @class_mop_package_methods = qw( - meta + meta initialize name namespace - - add_package_symbol get_package_symbol has_package_symbol remove_package_symbol + + add_package_symbol get_package_symbol has_package_symbol remove_package_symbol list_all_package_symbols remove_package_glob - + _deconstruct_variable_name ); my @class_mop_module_methods = qw( - meta + meta version authority identifier ); my @class_mop_class_methods = qw( meta - - initialize reinitialize create - + + initialize reinitialize create + create_anon_class is_anon_class - + instance_metaclass get_meta_instance new_object clone_object construct_instance construct_class_instance clone_instance check_metaclass_compatability - + attribute_metaclass method_metaclass - + superclasses class_precedence_list - + has_method get_method add_method remove_method alias_method - get_method_list get_method_map compute_all_applicable_methods - find_method_by_name find_all_methods_by_name find_next_method_by_name - - add_before_method_modifier add_after_method_modifier add_around_method_modifier + get_method_list get_method_map compute_all_applicable_methods + find_method_by_name find_all_methods_by_name find_next_method_by_name + + add_before_method_modifier add_after_method_modifier add_around_method_modifier has_attribute get_attribute add_attribute remove_attribute get_attribute_list get_attribute_map compute_all_applicable_attributes find_attribute_by_name - - is_mutable is_immutable make_immutable - + + is_mutable is_immutable make_mutable make_immutable + DESTROY ); - -# check the class ... - + +# check the class ... + is_deeply([ sort @class_mop_class_methods ], [ sort $class_mop_class_meta->get_method_list ], '... got the correct method list for class'); foreach my $method_name (@class_mop_class_methods) { ok($class_mop_class_meta->has_method($method_name), '... Class::MOP::Class->has_method(' . $method_name . ')'); { no strict 'refs'; - is($class_mop_class_meta->get_method($method_name)->body, + is($class_mop_class_meta->get_method($method_name)->body, \&{'Class::MOP::Class::' . $method_name}, - '... Class::MOP::Class->get_method(' . $method_name . ') == &Class::MOP::Class::' . $method_name); + '... Class::MOP::Class->get_method(' . $method_name . ') == &Class::MOP::Class::' . $method_name); } } @@ -99,9 +99,9 @@ foreach my $method_name (@class_mop_package_methods) { ok($class_mop_package_meta->has_method($method_name), '... Class::MOP::Package->has_method(' . $method_name . ')'); { no strict 'refs'; - is($class_mop_package_meta->get_method($method_name)->body, + is($class_mop_package_meta->get_method($method_name)->body, \&{'Class::MOP::Package::' . $method_name}, - '... Class::MOP::Package->get_method(' . $method_name . ') == &Class::MOP::Package::' . $method_name); + '... Class::MOP::Package->get_method(' . $method_name . ') == &Class::MOP::Package::' . $method_name); } } @@ -113,9 +113,9 @@ foreach my $method_name (@class_mop_module_methods) { ok($class_mop_module_meta->has_method($method_name), '... Class::MOP::Module->has_method(' . $method_name . ')'); { no strict 'refs'; - is($class_mop_module_meta->get_method($method_name)->body, + is($class_mop_module_meta->get_method($method_name)->body, \&{'Class::MOP::Module::' . $method_name}, - '... Class::MOP::Module->get_method(' . $method_name . ') == &Class::MOP::Module::' . $method_name); + '... Class::MOP::Module->get_method(' . $method_name . ') == &Class::MOP::Module::' . $method_name); } } @@ -128,27 +128,27 @@ foreach my $non_method_name (qw( subname svref_2object )) { - ok(!$class_mop_class_meta->has_method($non_method_name), '... NOT Class::MOP::Class->has_method(' . $non_method_name . ')'); + ok(!$class_mop_class_meta->has_method($non_method_name), '... NOT Class::MOP::Class->has_method(' . $non_method_name . ')'); } # check for the right attributes my @class_mop_package_attributes = ( - '$!package', + '$!package', '%!namespace', ); my @class_mop_module_attributes = ( - '$!version', + '$!version', '$!authority' ); my @class_mop_class_attributes = ( '@!superclasses', - '%!methods', - '%!attributes', - '$!attribute_metaclass', - '$!method_metaclass', + '%!methods', + '%!attributes', + '$!attribute_metaclass', + '$!method_metaclass', '$!instance_metaclass' ); @@ -158,15 +158,15 @@ is_deeply( [ sort @class_mop_class_attributes ], [ sort $class_mop_class_meta->get_attribute_list ], '... got the right list of attributes'); - + is_deeply( [ sort @class_mop_class_attributes ], [ sort keys %{$class_mop_class_meta->get_attribute_map} ], - '... got the right list of attributes'); + '... got the right list of attributes'); foreach my $attribute_name (@class_mop_class_attributes) { - ok($class_mop_class_meta->has_attribute($attribute_name), '... Class::MOP::Class->has_attribute(' . $attribute_name . ')'); - isa_ok($class_mop_class_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); + ok($class_mop_class_meta->has_attribute($attribute_name), '... Class::MOP::Class->has_attribute(' . $attribute_name . ')'); + isa_ok($class_mop_class_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); } # check module @@ -175,32 +175,32 @@ is_deeply( [ sort @class_mop_package_attributes ], [ sort $class_mop_package_meta->get_attribute_list ], '... got the right list of attributes'); - + is_deeply( [ sort @class_mop_package_attributes ], [ sort keys %{$class_mop_package_meta->get_attribute_map} ], - '... got the right list of attributes'); + '... got the right list of attributes'); foreach my $attribute_name (@class_mop_package_attributes) { - ok($class_mop_package_meta->has_attribute($attribute_name), '... Class::MOP::Package->has_attribute(' . $attribute_name . ')'); - isa_ok($class_mop_package_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); + ok($class_mop_package_meta->has_attribute($attribute_name), '... Class::MOP::Package->has_attribute(' . $attribute_name . ')'); + isa_ok($class_mop_package_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); } -# check package +# check package is_deeply( [ sort @class_mop_module_attributes ], [ sort $class_mop_module_meta->get_attribute_list ], '... got the right list of attributes'); - + is_deeply( [ sort @class_mop_module_attributes ], [ sort keys %{$class_mop_module_meta->get_attribute_map} ], - '... got the right list of attributes'); + '... got the right list of attributes'); foreach my $attribute_name (@class_mop_module_attributes) { - ok($class_mop_module_meta->has_attribute($attribute_name), '... Class::MOP::Module->has_attribute(' . $attribute_name . ')'); - isa_ok($class_mop_module_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); + ok($class_mop_module_meta->has_attribute($attribute_name), '... Class::MOP::Module->has_attribute(' . $attribute_name . ')'); + isa_ok($class_mop_module_meta->get_attribute($attribute_name), 'Class::MOP::Attribute'); } ## check the attributes themselves @@ -216,49 +216,49 @@ is($class_mop_package_meta->get_attribute('$!package')->init_arg, 'package', '.. # ... class ok($class_mop_class_meta->get_attribute('%!attributes')->has_reader, '... Class::MOP::Class %!attributes has a reader'); -is_deeply($class_mop_class_meta->get_attribute('%!attributes')->reader, - { 'get_attribute_map' => \&Class::MOP::Class::get_attribute_map }, +is_deeply($class_mop_class_meta->get_attribute('%!attributes')->reader, + { 'get_attribute_map' => \&Class::MOP::Class::get_attribute_map }, '... Class::MOP::Class %!attributes\'s a reader is &get_attribute_map'); - + ok($class_mop_class_meta->get_attribute('%!attributes')->has_init_arg, '... Class::MOP::Class %!attributes has a init_arg'); -is($class_mop_class_meta->get_attribute('%!attributes')->init_arg, - 'attributes', - '... Class::MOP::Class %!attributes\'s a init_arg is attributes'); - +is($class_mop_class_meta->get_attribute('%!attributes')->init_arg, + 'attributes', + '... Class::MOP::Class %!attributes\'s a init_arg is attributes'); + ok($class_mop_class_meta->get_attribute('%!attributes')->has_default, '... Class::MOP::Class %!attributes has a default'); -is_deeply($class_mop_class_meta->get_attribute('%!attributes')->default('Foo'), - {}, - '... Class::MOP::Class %!attributes\'s a default of {}'); +is_deeply($class_mop_class_meta->get_attribute('%!attributes')->default('Foo'), + {}, + '... Class::MOP::Class %!attributes\'s a default of {}'); ok($class_mop_class_meta->get_attribute('$!attribute_metaclass')->has_reader, '... Class::MOP::Class $!attribute_metaclass has a reader'); -is_deeply($class_mop_class_meta->get_attribute('$!attribute_metaclass')->reader, - { 'attribute_metaclass' => \&Class::MOP::Class::attribute_metaclass }, +is_deeply($class_mop_class_meta->get_attribute('$!attribute_metaclass')->reader, + { 'attribute_metaclass' => \&Class::MOP::Class::attribute_metaclass }, '... Class::MOP::Class $!attribute_metaclass\'s a reader is &attribute_metaclass'); - + ok($class_mop_class_meta->get_attribute('$!attribute_metaclass')->has_init_arg, '... Class::MOP::Class $!attribute_metaclass has a init_arg'); -is($class_mop_class_meta->get_attribute('$!attribute_metaclass')->init_arg, - 'attribute_metaclass', - '... Class::MOP::Class $!attribute_metaclass\'s a init_arg is attribute_metaclass'); - +is($class_mop_class_meta->get_attribute('$!attribute_metaclass')->init_arg, + 'attribute_metaclass', + '... Class::MOP::Class $!attribute_metaclass\'s a init_arg is attribute_metaclass'); + ok($class_mop_class_meta->get_attribute('$!attribute_metaclass')->has_default, '... Class::MOP::Class $!attribute_metaclass has a default'); -is($class_mop_class_meta->get_attribute('$!attribute_metaclass')->default, - 'Class::MOP::Attribute', - '... Class::MOP::Class $!attribute_metaclass\'s a default is Class::MOP:::Attribute'); - +is($class_mop_class_meta->get_attribute('$!attribute_metaclass')->default, + 'Class::MOP::Attribute', + '... Class::MOP::Class $!attribute_metaclass\'s a default is Class::MOP:::Attribute'); + ok($class_mop_class_meta->get_attribute('$!method_metaclass')->has_reader, '... Class::MOP::Class $!method_metaclass has a reader'); -is_deeply($class_mop_class_meta->get_attribute('$!method_metaclass')->reader, +is_deeply($class_mop_class_meta->get_attribute('$!method_metaclass')->reader, { 'method_metaclass' => \&Class::MOP::Class::method_metaclass }, - '... Class::MOP::Class $!method_metaclass\'s a reader is &method_metaclass'); - + '... Class::MOP::Class $!method_metaclass\'s a reader is &method_metaclass'); + ok($class_mop_class_meta->get_attribute('$!method_metaclass')->has_init_arg, '... Class::MOP::Class $!method_metaclass has a init_arg'); -is($class_mop_class_meta->get_attribute('$!method_metaclass')->init_arg, - 'method_metaclass', - '... Class::MOP::Class $:method_metaclass\'s init_arg is method_metaclass'); - +is($class_mop_class_meta->get_attribute('$!method_metaclass')->init_arg, + 'method_metaclass', + '... Class::MOP::Class $:method_metaclass\'s init_arg is method_metaclass'); + ok($class_mop_class_meta->get_attribute('$!method_metaclass')->has_default, '... Class::MOP::Class $!method_metaclass has a default'); -is($class_mop_class_meta->get_attribute('$!method_metaclass')->default, - 'Class::MOP::Method', - '... Class::MOP::Class $!method_metaclass\'s a default is Class::MOP:::Method'); +is($class_mop_class_meta->get_attribute('$!method_metaclass')->default, + 'Class::MOP::Method', + '... Class::MOP::Class $!method_metaclass\'s a default is Class::MOP:::Method'); # check the values of some of the methods @@ -266,23 +266,23 @@ is($class_mop_class_meta->name, 'Class::MOP::Class', '... Class::MOP::Class->nam is($class_mop_class_meta->version, $Class::MOP::Class::VERSION, '... Class::MOP::Class->version'); ok($class_mop_class_meta->has_package_symbol('$VERSION'), '... Class::MOP::Class->has_package_symbol($VERSION)'); -is(${$class_mop_class_meta->get_package_symbol('$VERSION')}, - $Class::MOP::Class::VERSION, +is(${$class_mop_class_meta->get_package_symbol('$VERSION')}, + $Class::MOP::Class::VERSION, '... Class::MOP::Class->get_package_symbol($VERSION)'); is_deeply( - [ $class_mop_class_meta->superclasses ], - [ qw/Class::MOP::Module/ ], + [ $class_mop_class_meta->superclasses ], + [ qw/Class::MOP::Module/ ], '... Class::MOP::Class->superclasses == [ Class::MOP::Module ]'); - + is_deeply( - [ $class_mop_class_meta->class_precedence_list ], + [ $class_mop_class_meta->class_precedence_list ], [ qw/ Class::MOP::Class Class::MOP::Module - Class::MOP::Package - Class::MOP::Object - / ], + Class::MOP::Package + Class::MOP::Object + / ], '... Class::MOP::Class->class_precedence_list == [ Class::MOP::Class Class::MOP::Module Class::MOP::Package ]'); is($class_mop_class_meta->attribute_metaclass, 'Class::MOP::Attribute', '... got the right value for attribute_metaclass'); diff --git a/t/070_immutable_metaclass.t b/t/070_immutable_metaclass.t index 5b1a1ca..b0294be 100644 --- a/t/070_immutable_metaclass.t +++ b/t/070_immutable_metaclass.t @@ -12,59 +12,59 @@ BEGIN { { package Foo; - + use strict; use warnings; use metaclass; - + __PACKAGE__->meta->add_attribute('bar'); - + package Bar; - + use strict; use warnings; use metaclass; - + __PACKAGE__->meta->superclasses('Foo'); - __PACKAGE__->meta->add_attribute('baz'); - + __PACKAGE__->meta->add_attribute('baz'); + package Baz; - + use strict; use warnings; use metaclass; - + __PACKAGE__->meta->superclasses('Bar'); - __PACKAGE__->meta->add_attribute('bah'); + __PACKAGE__->meta->add_attribute('bah'); } { my $meta = Foo->meta; is($meta->name, 'Foo', '... checking the Foo metaclass'); - + ok($meta->is_mutable, '... our class is mutable'); - ok(!$meta->is_immutable, '... our class is not immutable'); + ok(!$meta->is_immutable, '... our class is not immutable'); lives_ok { $meta->make_immutable(); } '... changed Foo to be immutable'; - + ok(!$meta->make_immutable, '... make immutable now returns nothing'); - + ok(!$meta->is_mutable, '... our class is no longer mutable'); - ok($meta->is_immutable, '... our class is now immutable'); + ok($meta->is_immutable, '... our class is now immutable'); isa_ok($meta, 'Class::MOP::Class'); - + dies_ok { $meta->add_method() } '... exception thrown as expected'; dies_ok { $meta->alias_method() } '... exception thrown as expected'; dies_ok { $meta->remove_method() } '... exception thrown as expected'; - + dies_ok { $meta->add_attribute() } '... exception thrown as expected'; dies_ok { $meta->remove_attribute() } '... exception thrown as expected'; - + dies_ok { $meta->add_package_symbol() } '... exception thrown as expected'; dies_ok { $meta->remove_package_symbol() } '... exception thrown as expected'; @@ -74,23 +74,23 @@ BEGIN { } '... got the superclasses okay'; dies_ok { $meta->superclasses([ 'UNIVERSAL' ]) } '... but could not set the superclasses okay'; - + my $meta_instance; lives_ok { $meta_instance = $meta->get_meta_instance; } '... got the meta instance okay'; isa_ok($meta_instance, 'Class::MOP::Instance'); is($meta_instance, $meta->get_meta_instance, '... and we know it is cached'); - + my @cpl; lives_ok { @cpl = $meta->class_precedence_list; - } '... got the class precedence list okay'; + } '... got the class precedence list okay'; is_deeply( \@cpl, [ 'Foo' ], '... we just have ourselves in the class precedence list'); - + my @attributes; lives_ok { @attributes = $meta->compute_all_applicable_attributes; @@ -103,29 +103,29 @@ BEGIN { { my $meta = Bar->meta; - is($meta->name, 'Bar', '... checking the Bar metaclass'); - + is($meta->name, 'Bar', '... checking the Bar metaclass'); + ok($meta->is_mutable, '... our class is mutable'); - ok(!$meta->is_immutable, '... our class is not immutable'); + ok(!$meta->is_immutable, '... our class is not immutable'); lives_ok { $meta->make_immutable(); } '... changed Bar to be immutable'; - + ok(!$meta->make_immutable, '... make immutable now returns nothing'); - + ok(!$meta->is_mutable, '... our class is no longer mutable'); - ok($meta->is_immutable, '... our class is now immutable'); + ok($meta->is_immutable, '... our class is now immutable'); isa_ok($meta, 'Class::MOP::Class'); - + dies_ok { $meta->add_method() } '... exception thrown as expected'; dies_ok { $meta->alias_method() } '... exception thrown as expected'; dies_ok { $meta->remove_method() } '... exception thrown as expected'; - + dies_ok { $meta->add_attribute() } '... exception thrown as expected'; dies_ok { $meta->remove_attribute() } '... exception thrown as expected'; - + dies_ok { $meta->add_package_symbol() } '... exception thrown as expected'; dies_ok { $meta->remove_package_symbol() } '... exception thrown as expected'; @@ -135,23 +135,23 @@ BEGIN { } '... got the superclasses okay'; dies_ok { $meta->superclasses([ 'UNIVERSAL' ]) } '... but could not set the superclasses okay'; - + my $meta_instance; lives_ok { $meta_instance = $meta->get_meta_instance; } '... got the meta instance okay'; isa_ok($meta_instance, 'Class::MOP::Instance'); - is($meta_instance, $meta->get_meta_instance, '... and we know it is cached'); - + is($meta_instance, $meta->get_meta_instance, '... and we know it is cached'); + my @cpl; lives_ok { @cpl = $meta->class_precedence_list; - } '... got the class precedence list okay'; + } '... got the class precedence list okay'; is_deeply( \@cpl, [ 'Bar', 'Foo'], '... we just have ourselves in the class precedence list'); - + my @attributes; lives_ok { @attributes = $meta->compute_all_applicable_attributes; @@ -164,29 +164,29 @@ BEGIN { { my $meta = Baz->meta; - is($meta->name, 'Baz', '... checking the Baz metaclass'); - + is($meta->name, 'Baz', '... checking the Baz metaclass'); + ok($meta->is_mutable, '... our class is mutable'); - ok(!$meta->is_immutable, '... our class is not immutable'); + ok(!$meta->is_immutable, '... our class is not immutable'); lives_ok { $meta->make_immutable(); } '... changed Baz to be immutable'; - + ok(!$meta->make_immutable, '... make immutable now returns nothing'); - + ok(!$meta->is_mutable, '... our class is no longer mutable'); - ok($meta->is_immutable, '... our class is now immutable'); + ok($meta->is_immutable, '... our class is now immutable'); isa_ok($meta, 'Class::MOP::Class'); - + dies_ok { $meta->add_method() } '... exception thrown as expected'; dies_ok { $meta->alias_method() } '... exception thrown as expected'; dies_ok { $meta->remove_method() } '... exception thrown as expected'; - + dies_ok { $meta->add_attribute() } '... exception thrown as expected'; dies_ok { $meta->remove_attribute() } '... exception thrown as expected'; - + dies_ok { $meta->add_package_symbol() } '... exception thrown as expected'; dies_ok { $meta->remove_package_symbol() } '... exception thrown as expected'; @@ -196,23 +196,23 @@ BEGIN { } '... got the superclasses okay'; dies_ok { $meta->superclasses([ 'UNIVERSAL' ]) } '... but could not set the superclasses okay'; - + my $meta_instance; lives_ok { $meta_instance = $meta->get_meta_instance; } '... got the meta instance okay'; isa_ok($meta_instance, 'Class::MOP::Instance'); - is($meta_instance, $meta->get_meta_instance, '... and we know it is cached'); - + is($meta_instance, $meta->get_meta_instance, '... and we know it is cached'); + my @cpl; lives_ok { @cpl = $meta->class_precedence_list; - } '... got the class precedence list okay'; + } '... got the class precedence list okay'; is_deeply( \@cpl, [ 'Baz', 'Bar', 'Foo'], '... we just have ourselves in the class precedence list'); - + my @attributes; lives_ok { @attributes = $meta->compute_all_applicable_attributes; diff --git a/t/073_make_mutable.t b/t/073_make_mutable.t new file mode 100644 index 0000000..118bcaf --- /dev/null +++ b/t/073_make_mutable.t @@ -0,0 +1,214 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 101; +use Test::Exception; + +use Scalar::Util; + +BEGIN { + use_ok('Class::MOP'); +} + +{ + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->add_attribute('bar'); + + package Bar; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Foo'); + + __PACKAGE__->meta->add_attribute('baz'); + + package Baz; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Bar'); + + __PACKAGE__->meta->add_attribute('bah'); +} + +{ + my $meta = Baz->meta; + is($meta->name, 'Baz', '... checking the Baz metaclass'); + my @orig_keys = sort keys %$meta; + + lives_ok {$meta->make_immutable() } '... changed Baz to be immutable'; + ok(!$meta->is_mutable, '... our class is no longer mutable'); + ok($meta->is_immutable, '... our class is now immutable'); + ok(!$meta->make_immutable, '... make immutable now returns nothing'); + + lives_ok { $meta->make_mutable() } '... changed Baz to be mutable'; + ok($meta->is_mutable, '... our class is mutable'); + ok(!$meta->is_immutable, '... our class is not immutable'); + ok(!$meta->make_mutable, '... make mutable now returns nothing'); + + my @new_keys = sort keys %$meta; + is_deeply(\@orig_keys, \@new_keys, '... no straneous hashkeys'); + + isa_ok($meta, 'Class::MOP::Class', '... Baz->meta isa Class::MOP::Class'); + + ok( $meta->add_method('xyz', sub{'xxx'}), '... added method'); + is( Baz->xyz, 'xxx', '... method xyz works'); + ok( $meta->alias_method('zxy',sub{'xxx'}),'... aliased method'); + is( Baz->zxy, 'xxx', '... method zxy works'); + ok( $meta->remove_method('xyz'), '... removed method'); + ok( $meta->remove_method('zxy'), '... removed aliased method'); + + ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute'); + ok(Baz->can('fickle'), '... Baz can fickle'); + ok($meta->remove_attribute('fickle'), '... removed attribute'); + + my $reef = \ 'reef'; + ok($meta->add_package_symbol('$ref', $reef), '... added package symbol'); + is($meta->get_package_symbol('$ref'), $reef, '... values match'); + lives_ok { $meta->remove_package_symbol('$ref') } '... removed it'; + isnt($meta->get_package_symbol('$ref'), $reef, '... values match'); + + ok( my @supers = $meta->superclasses, '... got the superclasses okay'); + ok( $meta->superclasses('Foo'), '... set the superclasses'); + is_deeply(['Foo'], [$meta->superclasses], '... set the superclasses okay'); + ok( $meta->superclasses( @supers ), '... reset superclasses'); + is_deeply([@supers], [$meta->superclasses], '... reset the superclasses okay'); + + ok( $meta->$_ , "... ${_} works") + for qw(get_meta_instance compute_all_applicable_attributes + class_precedence_list get_method_map ); +} + +{ + my $meta = Baz->meta; + + lives_ok { $meta->make_immutable() } 'Changed Baz to be immutable'; + lives_ok { $meta->make_mutable() } '... changed Baz to be mutable'; + lives_ok { $meta->make_immutable() } '... changed Baz to be immutable'; + + dies_ok{ $meta->add_method('xyz', sub{'xxx'}) } '... exception thrown as expected'; + dies_ok{ $meta->alias_method('zxy',sub{'xxx'}) } '... exception thrown as expected'; + dies_ok{ $meta->remove_method('zxy') } '... exception thrown as expected'; + + dies_ok { + $meta->add_attribute('fickle', accessor => 'fickle') + } '... exception thrown as expected'; + dies_ok { $meta->remove_attribute('fickle') } '... exception thrown as expected'; + + my $reef = \ 'reef'; + dies_ok { $meta->add_package_symbol('$ref', $reef) } '... exception thrown as expected'; + dies_ok { $meta->remove_package_symbol('$ref') } '... exception thrown as expected'; + + ok( my @supers = $meta->superclasses, '... got the superclasses okay'); + dies_ok { $meta->superclasses('Foo') } '... set the superclasses'; + + ok( $meta->$_ , "... ${_} works") + for qw(get_meta_instance compute_all_applicable_attributes + class_precedence_list get_method_map ); +} + + + +{ + + my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']); + my @orig_keys = sort keys %$meta; + my @orig_meths = sort $meta->compute_all_applicable_methods; + ok($meta->is_anon_class, 'We have an anon metaclass'); + lives_ok {$meta->make_immutable( + inline_accessor => 1, + inline_destructor => 0, + inline_constructor => 1, + ) + } '... changed class to be immutable'; + ok(!$meta->is_mutable, '... our class is no longer mutable'); + ok($meta->is_immutable, '... our class is now immutable'); + ok(!$meta->make_immutable, '... make immutable now returns nothing'); + + lives_ok { $meta->make_mutable } '... changed Baz to be mutable'; + ok($meta->is_mutable, '... our class is mutable'); + ok(!$meta->is_immutable, '... our class is not immutable'); + ok(!$meta->make_mutable, '... make mutable now returns nothing'); + ok($meta->is_anon_class, '... still marked as an anon class'); + my $instance = $meta->new_object; + + my @new_keys = sort keys %$meta; + my @new_meths = sort $meta->compute_all_applicable_methods; + is_deeply(\@orig_keys, \@new_keys, '... no straneous hashkeys'); + is_deeply(\@orig_meths, \@new_meths, '... no straneous methods'); + + isa_ok($meta, 'Class::MOP::Class', '... Anon class isa Class::MOP::Class'); + + ok( $meta->add_method('xyz', sub{'xxx'}), '... added method'); + is( $instance->xyz , 'xxx', '... method xyz works'); + ok( $meta->alias_method('zxy',sub{'xxx'}),'... aliased method'); + is( $instance->zxy, 'xxx', '... method zxy works'); + ok( $meta->remove_method('xyz'), '... removed method'); + ok( $meta->remove_method('zxy'), '... removed aliased method'); + + ok($meta->add_attribute('fickle', accessor => 'fickle'), '... added attribute'); + ok($instance->can('fickle'), '... instance can fickle'); + ok($meta->remove_attribute('fickle'), '... removed attribute'); + + my $reef = \ 'reef'; + ok($meta->add_package_symbol('$ref', $reef), '... added package symbol'); + is($meta->get_package_symbol('$ref'), $reef, '... values match'); + lives_ok { $meta->remove_package_symbol('$ref') } '... removed it'; + isnt($meta->get_package_symbol('$ref'), $reef, '... values match'); + + ok( my @supers = $meta->superclasses, '... got the superclasses okay'); + ok( $meta->superclasses('Foo'), '... set the superclasses'); + is_deeply(['Foo'], [$meta->superclasses], '... set the superclasses okay'); + ok( $meta->superclasses( @supers ), '... reset superclasses'); + is_deeply([@supers], [$meta->superclasses], '... reset the superclasses okay'); + + ok( $meta->$_ , "... ${_} works") + for qw(get_meta_instance compute_all_applicable_attributes + class_precedence_list get_method_map ); +}; + + +#rerun the same tests on an anon class.. just cause we can. +{ + my $meta = Baz->meta->create_anon_class(superclasses => ['Baz']); + + lives_ok {$meta->make_immutable( + inline_accessor => 1, + inline_destructor => 0, + inline_constructor => 1, + ) + } '... changed class to be immutable'; + lives_ok { $meta->make_mutable() } '... changed class to be mutable'; + lives_ok {$meta->make_immutable } '... changed class to be immutable'; + + dies_ok{ $meta->add_method('xyz', sub{'xxx'}) } '... exception thrown as expected'; + dies_ok{ $meta->alias_method('zxy',sub{'xxx'}) } '... exception thrown as expected'; + dies_ok{ $meta->remove_method('zxy') } '... exception thrown as expected'; + + dies_ok { + $meta->add_attribute('fickle', accessor => 'fickle') + } '... exception thrown as expected'; + dies_ok { $meta->remove_attribute('fickle') } '... exception thrown as expected'; + + my $reef = \ 'reef'; + dies_ok { $meta->add_package_symbol('$ref', $reef) } '... exception thrown as expected'; + dies_ok { $meta->remove_package_symbol('$ref') } '... exception thrown as expected'; + + ok( my @supers = $meta->superclasses, '... got the superclasses okay'); + dies_ok { $meta->superclasses('Foo') } '... set the superclasses'; + + ok( $meta->$_ , "... ${_} works") + for qw(get_meta_instance compute_all_applicable_attributes + class_precedence_list get_method_map ); +}