X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=d01da0fa4a141f0cc0d5127ed2caa2c79fb64d38;hb=812d58f9517c19217fd09da63a6a87d80c202f11;hp=275b9aceec40a4b105c156e0138009673fd96bdc;hpb=ffd0984599ac2aae5fabb0759c313b85f7455003;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 275b9ac..d01da0f 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -4,14 +4,17 @@ package Class::MOP::Class; use strict; use warnings; -use Class::MOP::Immutable; use Class::MOP::Instance; use Class::MOP::Method::Wrapped; +use Class::MOP::Method::Accessor; +use Class::MOP::Method::Constructor; use Carp 'confess'; -use Scalar::Util 'blessed', 'weaken'; +use Scalar::Util 'blessed', 'reftype', 'weaken'; +use Sub::Name 'subname'; +use Devel::GlobalDestruction 'in_global_destruction'; -our $VERSION = '0.79'; +our $VERSION = '0.89'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -31,20 +34,26 @@ sub initialize { $package_name = $options{package}; } - (defined $package_name && $package_name && !ref($package_name)) + ($package_name && !ref($package_name)) || confess "You must pass a package name and it cannot be blessed"; return Class::MOP::get_metaclass_by_name($package_name) - || $class->construct_class_instance(package => $package_name, @_); + || $class->_construct_class_instance(package => $package_name, @_); +} + +sub construct_class_instance { + Carp::cluck('The construct_class_instance method has been made private.' + . " The public version is deprecated and will be removed in a future release.\n"); + shift->_construct_class_instance(@_); } # NOTE: (meta-circularity) -# this is a special form of &construct_instance +# this is a special form of _construct_instance # (see below), which is used to construct class # meta-object instances for any Class::MOP::* # class. All other classes will use the more # normal &construct_instance. -sub construct_class_instance { +sub _construct_class_instance { my $class = shift; my $options = @_ == 1 ? $_[0] : {@_}; my $package_name = $options->{package}; @@ -80,11 +89,11 @@ sub construct_class_instance { # it is safe to use meta here because # class will always be a subclass of # Class::MOP::Class, which defines meta - $meta = $class->meta->construct_instance($options) + $meta = $class->meta->_construct_instance($options) } # and check the metaclass compatibility - $meta->check_metaclass_compatibility(); + $meta->_check_metaclass_compatibility(); Class::MOP::store_metaclass_by_name($package_name, $meta); @@ -98,9 +107,13 @@ sub construct_class_instance { sub _new { my $class = shift; + + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + my $options = @_ == 1 ? $_[0] : {@_}; - bless { + return bless { # inherited from Class::MOP::Package 'package' => $options->{package}, @@ -121,16 +134,27 @@ sub _new { # defined in Class::MOP::Class 'superclasses' => \undef, - 'methods' => {}, - 'attributes' => {}, - 'attribute_metaclass' => $options->{'attribute_metaclass'} - || 'Class::MOP::Attribute', - 'method_metaclass' => $options->{'method_metaclass'} - || 'Class::MOP::Method', - 'wrapped_method_metaclass' => $options->{'wrapped_method_metaclass'} - || 'Class::MOP::Method::Wrapped', - 'instance_metaclass' => $options->{'instance_metaclass'} - || 'Class::MOP::Instance', + 'methods' => {}, + 'attributes' => {}, + 'attribute_metaclass' => + ( $options->{'attribute_metaclass'} || 'Class::MOP::Attribute' ), + 'method_metaclass' => + ( $options->{'method_metaclass'} || 'Class::MOP::Method' ), + 'wrapped_method_metaclass' => ( + $options->{'wrapped_method_metaclass'} + || 'Class::MOP::Method::Wrapped' + ), + 'instance_metaclass' => + ( $options->{'instance_metaclass'} || 'Class::MOP::Instance' ), + 'immutable_trait' => ( + $options->{'immutable_trait'} + || 'Class::MOP::Class::Immutable::Trait' + ), + 'constructor_name' => ( $options->{constructor_name} || 'new' ), + 'constructor_class' => ( + $options->{constructor_class} || 'Class::MOP::Method::Constructor' + ), + 'destructor_class' => $options->{destructor_class}, }, $class; } @@ -146,7 +170,14 @@ sub update_package_cache_flag { $self->{'_package_cache_flag'} = Class::MOP::check_package_cache_flag($self->name); } + sub check_metaclass_compatibility { + Carp::cluck('The check_metaclass_compatibility method has been made private.' + . " The public version is deprecated and will be removed in a future release.\n"); + shift->_check_metaclass_compatibility(@_); +} + +sub _check_metaclass_compatibility { my $self = shift; # this is always okay ... @@ -169,17 +200,17 @@ sub check_metaclass_compatibility { : ref($super_meta); ($self->isa($super_meta_type)) - || confess "Class::MOP::class_of(" . $self->name . ") => (" + || confess "The metaclass of " . $self->name . " (" . (ref($self)) . ")" . " is not compatible with the " . - "Class::MOP::class_of(".$superclass_name . ") => (" + "metaclass of its superclass, ".$superclass_name . " (" . ($super_meta_type) . ")"; # NOTE: # we also need to check that instance metaclasses # are compatibile in the same the class. ($self->instance_metaclass->isa($super_meta->instance_metaclass)) - || confess "Class::MOP::class_of(" . $self->name . ")->instance_metaclass => (" . ($self->instance_metaclass) . ")" . + || confess "The instance metaclass for " . $self->name . " (" . ($self->instance_metaclass) . ")" . " is not compatible with the " . - "Class::MOP::class_of(" . $superclass_name . ")->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")"; + "instance metaclass of its superclass, " . $superclass_name . " (" . ($super_meta->instance_metaclass) . ")"; } } @@ -202,7 +233,7 @@ sub check_metaclass_compatibility { sub is_anon_class { my $self = shift; no warnings 'uninitialized'; - $self->name =~ /^$ANON_CLASS_PREFIX/; + $self->name =~ /^$ANON_CLASS_PREFIX/o; } sub create_anon_class { @@ -220,24 +251,26 @@ sub check_metaclass_compatibility { sub DESTROY { my $self = shift; - return if Class::MOP::in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated + return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated no warnings 'uninitialized'; - return unless $self->name =~ /^$ANON_CLASS_PREFIX/; + my $name = $self->name; + return unless $name =~ /^$ANON_CLASS_PREFIX/o; # Moose does a weird thing where it replaces the metaclass for # class when fixing metaclass incompatibility. In that case, # we don't want to clean out the namespace now. We can detect # that because Moose will explicitly update the singleton # cache in Class::MOP. - my $current_meta = Class::MOP::get_metaclass_by_name($self->name); + my $current_meta = Class::MOP::get_metaclass_by_name($name); return if $current_meta ne $self; - my ($serial_id) = ($self->name =~ /^$ANON_CLASS_PREFIX(\d+)/); + my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/o); 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 . '::'}; + @{$name . '::ISA'} = (); + %{$name . '::'} = (); + delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'}; + + Class::MOP::remove_metaclass_by_name($name); } } @@ -264,8 +297,6 @@ sub create { || confess "You must pass a HASH ref of methods" if exists $options{methods}; - $class->SUPER::create(%options); - my (%initialize_options) = @args; delete @initialize_options{qw( package @@ -277,6 +308,8 @@ sub create { )}; my $meta = $class->initialize( $package_name => %initialize_options ); + $meta->_instantiate_module( $options{version}, $options{authority} ); + # FIXME totally lame $meta->add_method('meta' => sub { $class->initialize(ref($_[0]) || $_[0]); @@ -313,6 +346,12 @@ sub attribute_metaclass { $_[0]->{'attribute_metaclass'} } sub method_metaclass { $_[0]->{'method_metaclass'} } sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'} } sub instance_metaclass { $_[0]->{'instance_metaclass'} } +sub immutable_trait { $_[0]->{'immutable_trait'} } +sub constructor_class { $_[0]->{'constructor_class'} } +sub constructor_name { $_[0]->{'constructor_name'} } +sub destructor_class { $_[0]->{'destructor_class'} } + +sub _method_map { $_[0]->{'methods'} } # Instance Construction & Cloning @@ -324,23 +363,33 @@ sub new_object { # Class::MOP::Class singletons here, so we # delegate this to &construct_class_instance # which will deal with the singletons - return $class->construct_class_instance(@_) + return $class->_construct_class_instance(@_) if $class->name->isa('Class::MOP::Class'); - return $class->construct_instance(@_); + return $class->_construct_instance(@_); } sub construct_instance { + Carp::cluck('The construct_instance method has been made private.' + . " The public version is deprecated and will be removed in a future release.\n"); + shift->_construct_instance(@_); +} + +sub _construct_instance { my $class = shift; my $params = @_ == 1 ? $_[0] : {@_}; my $meta_instance = $class->get_meta_instance(); - my $instance = $meta_instance->create_instance(); - foreach my $attr ($class->compute_all_applicable_attributes()) { + # FIXME: + # the code below is almost certainly incorrect + # but this is foreign inheritance, so we might + # have to kludge it in the end. + my $instance = $params->{__INSTANCE__} || $meta_instance->create_instance(); + foreach my $attr ($class->get_all_attributes()) { $attr->initialize_instance_slot($meta_instance, $instance, $params); } # NOTE: # this will only work for a HASH instance type if ($class->is_anon_class) { - (Scalar::Util::reftype($instance) eq 'HASH') + (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 @@ -355,15 +404,21 @@ sub construct_instance { sub get_meta_instance { my $self = shift; - $self->{'_meta_instance'} ||= $self->create_meta_instance(); + $self->{'_meta_instance'} ||= $self->_create_meta_instance(); } sub create_meta_instance { + Carp::cluck('The create_meta_instance method has been made private.' + . " The public version is deprecated and will be removed in a future release.\n"); + shift->_create_meta_instance(@_); +} + +sub _create_meta_instance { my $self = shift; my $instance = $self->instance_metaclass->new( associated_metaclass => $self, - attributes => [ $self->compute_all_applicable_attributes() ], + attributes => [ $self->get_all_attributes() ], ); $self->add_meta_instance_dependencies() @@ -383,16 +438,22 @@ sub clone_object { # Class::MOP::Class singletons here, they # should not be cloned. return $instance if $instance->isa('Class::MOP::Class'); - $class->clone_instance($instance, @_); + $class->_clone_instance($instance, @_); } sub clone_instance { + Carp::cluck('The clone_instance method has been made private.' + . " The public version is deprecated and will be removed in a future release.\n"); + shift->_clone_instance(@_); +} + +sub _clone_instance { my ($class, $instance, %params) = @_; (blessed($instance)) || confess "You can only clone instances, ($instance) is not a blessed instance"; my $meta_instance = $class->get_meta_instance(); my $clone = $meta_instance->clone_instance($instance); - foreach my $attr ($class->compute_all_applicable_attributes()) { + foreach my $attr ($class->get_all_attributes()) { if ( defined( my $init_arg = $attr->init_arg ) ) { if (exists $params{$init_arg}) { $attr->set_value($clone, $params{$init_arg}); @@ -420,7 +481,7 @@ sub rebless_instance { # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8 $meta_instance->rebless_instance_structure($_[1], $self); - foreach my $attr ( $self->compute_all_applicable_attributes ) { + foreach my $attr ( $self->get_all_attributes ) { if ( $attr->has_value($instance) ) { if ( defined( my $init_arg = $attr->init_arg ) ) { $params{$init_arg} = $attr->get_value($instance) @@ -432,7 +493,7 @@ sub rebless_instance { } } - foreach my $attr ($self->compute_all_applicable_attributes) { + foreach my $attr ($self->get_all_attributes) { $attr->initialize_instance_slot($meta_instance, $instance, \%params); } @@ -466,12 +527,17 @@ sub superclasses { # not potentially creating an issues # we don't know about - $self->check_metaclass_compatibility(); - $self->update_meta_instance_dependencies(); + $self->_check_metaclass_compatibility(); + $self->_superclasses_updated(); } @{$self->get_package_symbol($var_spec)}; } +sub _superclasses_updated { + my $self = shift; + $self->update_meta_instance_dependencies(); +} + sub subclasses { my $self = shift; my $super_class = $self->name; @@ -479,6 +545,16 @@ sub subclasses { return @{ $super_class->mro::get_isarev() }; } +sub direct_subclasses { + my $self = shift; + my $super_class = $self->name; + + return grep { + grep { + $_ eq $super_class + } Class::MOP::Class->initialize($_)->superclasses + } $self->subclasses; +} sub linearized_isa { return @{ mro::get_linear_isa( (shift)->name ) }; @@ -546,23 +622,27 @@ sub add_method { name => $method_name ) if $method->can('clone'); } + + $method->attach_to_class($self); + $self->_method_map->{$method_name} = $method; } else { + # If a raw code reference is supplied, its method object is not created. + # The method object won't be created until required. $body = $method; - $method = $self->wrap_method_body( body => $body, name => $method_name ); } - $method->attach_to_class($self); - # This used to call get_method_map, which meant we would build all - # the method objects for the class just because we added one - # method. This is hackier, but quicker too. - $self->{methods}{$method_name} = $method; - - my $full_method_name = ($self->name . '::' . $method_name); + my ( $current_package, $current_name ) = Class::MOP::get_code_info($body); + + if ( !defined $current_name || $current_name eq '__ANON__' ) { + my $full_method_name = ($self->name . '::' . $method_name); + subname($full_method_name => $body); + } + $self->add_package_symbol( - { sigil => '&', type => 'CODE', name => $method_name }, - Class::MOP::subname($full_method_name => $body) + { sigil => '&', type => 'CODE', name => $method_name }, + $body, ); } @@ -599,7 +679,7 @@ sub add_method { || confess "You must pass in a method name"; my $method = $fetch_and_prepare_method->($self, $method_name); $method->add_before_modifier( - Class::MOP::subname(':before' => $method_modifier) + subname(':before' => $method_modifier) ); } @@ -609,7 +689,7 @@ sub add_method { || confess "You must pass in a method name"; my $method = $fetch_and_prepare_method->($self, $method_name); $method->add_after_modifier( - Class::MOP::subname(':after' => $method_modifier) + subname(':after' => $method_modifier) ); } @@ -619,7 +699,7 @@ sub add_method { || confess "You must pass in a method name"; my $method = $fetch_and_prepare_method->($self, $method_name); $method->add_around_modifier( - Class::MOP::subname(':around' => $method_modifier) + subname(':around' => $method_modifier) ); } @@ -638,9 +718,18 @@ sub add_method { } sub alias_method { - my $self = shift; + Carp::cluck("The alias_method method is deprecated. Use add_method instead.\n"); - $self->add_method(@_); + shift->add_method(@_); +} + +sub _code_is_mine { + my ( $self, $code ) = @_; + + my ( $code_package, $code_name ) = Class::MOP::get_code_info($code); + + return $code_package && $code_package eq $self->name + || ( $code_package eq 'constant' && $code_name eq '__ANON__' ); } sub has_method { @@ -648,7 +737,7 @@ sub has_method { (defined $method_name && $method_name) || confess "You must define a method name"; - exists $self->{methods}{$method_name} || exists $self->get_method_map->{$method_name}; + return defined($self->get_method($method_name)); } sub get_method { @@ -656,7 +745,30 @@ sub get_method { (defined $method_name && $method_name) || confess "You must define a method name"; - return $self->{methods}{$method_name} || $self->get_method_map->{$method_name}; + my $method_map = $self->_method_map; + my $method_object = $method_map->{$method_name}; + my $code = $self->get_package_symbol({ + name => $method_name, + sigil => '&', + type => 'CODE', + }); + + unless ( $method_object && $method_object->body == ( $code || 0 ) ) { + if ( $code && $self->_code_is_mine($code) ) { + $method_object = $method_map->{$method_name} + = $self->wrap_method_body( + body => $code, + name => $method_name, + associated_metaclass => $self, + ); + } + else { + delete $method_map->{$method_name}; + return undef; + } + } + + return $method_object; } sub remove_method { @@ -679,7 +791,7 @@ sub remove_method { sub get_method_list { my $self = shift; - keys %{$self->get_method_map}; + return grep { $self->has_method($_) } keys %{ $self->namespace }; } sub find_method_by_name { @@ -701,8 +813,10 @@ sub get_all_methods { return values %methods; } -# compatibility sub compute_all_applicable_methods { + Carp::cluck('The compute_all_applicable_methods method is deprecated.' + . " Use get_all_methods instead.\n"); + return map { { name => $_->name, @@ -715,7 +829,7 @@ sub compute_all_applicable_methods { sub get_all_method_names { my $self = shift; my %uniq; - grep { $uniq{$_}++ == 0 } map { $_->name } $self->get_all_methods; + return grep { !$uniq{$_}++ } map { $self->initialize($_)->get_method_list } $self->linearized_isa; } sub find_all_methods_by_name { @@ -766,23 +880,35 @@ sub add_attribute { # about the class which it is attached to $attribute->attach_to_class($self); + my $attr_name = $attribute->name; + # 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 - if ( $self->has_attribute($attribute->name) ) { - $self->remove_attribute($attribute->name); + if ( $self->has_attribute($attr_name) ) { + $self->remove_attribute($attr_name); } else { $self->invalidate_meta_instances(); } + + # get our count of previously inserted attributes and + # increment by one so this attribute knows its order + my $order = (scalar keys %{$self->get_attribute_map}); + $attribute->_set_insertion_order($order); # then onto installing the new accessors - $self->get_attribute_map->{$attribute->name} = $attribute; + $self->get_attribute_map->{$attr_name} = $attribute; # invalidate package flag here - my $e = do { local $@; eval { $attribute->install_accessors() }; $@ }; + my $e = do { + local $@; + local $SIG{__DIE__}; + eval { $attribute->install_accessors() }; + $@; + }; if ( $e ) { - $self->remove_attribute($attribute->name); + $self->remove_attribute($attr_name); die $e; } @@ -802,7 +928,7 @@ sub add_meta_instance_dependencies { $self->remove_meta_instance_dependencies; - my @attrs = $self->compute_all_applicable_attributes(); + my @attrs = $self->get_all_attributes(); my %seen; my @classes = grep { not $seen{$_->name}++ } map { $_->associated_class } @attrs; @@ -887,15 +1013,18 @@ sub get_attribute_list { } sub get_all_attributes { - shift->compute_all_applicable_attributes(@_); -} - -sub compute_all_applicable_attributes { my $self = shift; my %attrs = map { %{ $self->initialize($_)->get_attribute_map } } reverse $self->linearized_isa; return values %attrs; } +sub compute_all_applicable_attributes { + Carp::cluck('The compute_all_applicable_attributes method has been deprecated.' + . " Use get_all_attributes instead.\n"); + + shift->get_all_attributes(@_); +} + sub find_attribute_by_name { my ($self, $attr_name) = @_; foreach my $class ($self->linearized_isa) { @@ -931,87 +1060,233 @@ sub is_pristine { sub is_mutable { 1 } sub is_immutable { 0 } -sub immutable_transformer { $_[0]->{immutable_transformer} } -sub _set_immutable_transformer { $_[0]->{immutable_transformer} = $_[1] } +sub _immutable_options { + my ( $self, @args ) = @_; + + return ( + inline_accessors => 1, + inline_constructor => 1, + inline_destructor => 0, + debug => 0, + immutable_trait => $self->immutable_trait, + constructor_name => $self->constructor_name, + constructor_class => $self->constructor_class, + destructor_class => $self->destructor_class, + @args, + ); +} sub make_immutable { + my ( $self, @args ) = @_; + + if ( $self->is_mutable ) { + $self->_initialize_immutable( $self->_immutable_options(@args) ); + $self->_rebless_as_immutable(@args); + return $self; + } + else { + return; + } +} + +sub make_mutable { my $self = shift; - return if $self->is_immutable; + if ( $self->is_immutable ) { + my @args = $self->immutable_options; + $self->_rebless_as_mutable(); + $self->_remove_inlined_code(@args); + delete $self->{__immutable}; + return $self; + } + else { + return; + } +} - my $transformer = $self->immutable_transformer - || $self->_make_immutable_transformer(@_); +sub _rebless_as_immutable { + my ( $self, @args ) = @_; - $self->_set_immutable_transformer($transformer); + $self->{__immutable}{original_class} = ref $self; - $transformer->make_metaclass_immutable; + bless $self => $self->_immutable_metaclass(@args); } -{ - my %Default_Immutable_Options = ( - read_only => [qw/superclasses/], - cannot_call => [ - qw( - add_method - alias_method - remove_method - add_attribute - remove_attribute - remove_package_symbol - ) - ], - memoize => { - class_precedence_list => 'ARRAY', - # FIXME perl 5.10 memoizes this on its own, no need? - linearized_isa => 'ARRAY', - get_all_methods => 'ARRAY', - get_all_method_names => 'ARRAY', - compute_all_applicable_attributes => 'ARRAY', - get_meta_instance => 'SCALAR', - get_method_map => 'SCALAR', - }, +sub _immutable_metaclass { + my ( $self, %args ) = @_; - # NOTE: - # this is ugly, but so are typeglobs, - # so whattayahgonnadoboutit - # - SL - wrapped => { - add_package_symbol => sub { - my $original = shift; - confess "Cannot add package symbols to an immutable metaclass" - unless ( caller(2) )[3] eq - 'Class::MOP::Package::get_package_symbol'; - - # This is a workaround for a bug in 5.8.1 which thinks that - # goto $original->body - # is trying to go to a label - my $body = $original->body; - goto $body; - }, - }, + if ( my $class = $args{immutable_metaclass} ) { + return $class; + } + + my $trait = $args{immutable_trait} = $self->immutable_trait + || confess "no immutable trait specified for $self"; + + my $meta = $self->meta; + my $meta_attr = $meta->find_attribute_by_name("immutable_trait"); + + my $class_name; + + if ( $meta_attr and $trait eq $meta_attr->default ) { + # if the trait is the same as the default we try and pick a + # predictable name for the immutable metaclass + $class_name = 'Class::MOP::Class::Immutable::' . ref($self); + } + else { + $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait', + $trait, 'ForMetaClass', ref($self); + } + + return $class_name + if Class::MOP::is_class_loaded($class_name); + + # If the metaclass is a subclass of CMOP::Class which has had + # metaclass roles applied (via Moose), then we want to make sure + # that we preserve that anonymous class (see Fey::ORM for an + # example of where this matters). + my $meta_name + = $meta->is_immutable + ? $meta->get_mutable_metaclass_name + : ref $meta; + + my $immutable_meta = $meta_name->create( + $class_name, + superclasses => [ ref $self ], ); - sub _default_immutable_transformer_options { - return %Default_Immutable_Options; + Class::MOP::load_class($trait); + for my $meth ( Class::MOP::Class->initialize($trait)->get_all_methods ) { + my $meth_name = $meth->name; + next if $immutable_meta->has_method( $meth_name ); + + if ( $immutable_meta->find_method_by_name( $meth_name ) ) { + $immutable_meta->add_around_method_modifier( $meth_name, $meth->body ); + } + else { + $immutable_meta->add_method( $meth_name, $meth->clone ); + } } + + $immutable_meta->make_immutable( + inline_constructor => 0, + inline_accessors => 0, + ); + + return $class_name; } -sub _make_immutable_transformer { +sub _remove_inlined_code { my $self = shift; - Class::MOP::Immutable->new( - $self, - $self->_default_immutable_transformer_options, - @_ - ); + $self->remove_method( $_->name ) for $self->_inlined_methods; + + delete $self->{__immutable}{inlined_methods}; } -sub make_mutable { +sub _inlined_methods { @{ $_[0]{__immutable}{inlined_methods} || [] } } + +sub _add_inlined_method { + my ( $self, $method ) = @_; + + push @{ $self->{__immutable}{inlined_methods} ||= [] }, $method; +} + +sub _initialize_immutable { + my ( $self, %args ) = @_; + + $self->{__immutable}{options} = \%args; + $self->_install_inlined_code(%args); +} + +sub _install_inlined_code { + my ( $self, %args ) = @_; + + # FIXME + $self->_inline_accessors(%args) if $args{inline_accessors}; + $self->_inline_constructor(%args) if $args{inline_constructor}; + $self->_inline_destructor(%args) if $args{inline_destructor}; +} + +sub _rebless_as_mutable { + my $self = shift; + + bless $self, $self->get_mutable_metaclass_name; + + return $self; +} + +sub _inline_accessors { my $self = shift; - return if $self->is_mutable; + foreach my $attr_name ( $self->get_attribute_list ) { + $self->get_attribute($attr_name)->install_accessors(1); + } +} + +sub _inline_constructor { + my ( $self, %args ) = @_; + + my $name = $args{constructor_name}; + + if ( $self->has_method($name) && !$args{replace_constructor} ) { + my $class = $self->name; + warn "Not inlining a constructor for $class since it defines" + . " its own constructor.\n" + . "If you are certain you don't need to inline your" + . " constructor, specify inline_constructor => 0 in your" + . " call to $class->meta->make_immutable\n"; + return; + } + + my $constructor_class = $args{constructor_class}; + + Class::MOP::load_class($constructor_class); + + my $constructor = $constructor_class->new( + options => \%args, + metaclass => $self, + is_inline => 1, + package_name => $self->name, + name => $name, + ); + + if ( $args{replace_constructor} or $constructor->can_be_inlined ) { + $self->add_method( $name => $constructor ); + $self->_add_inlined_method($constructor); + } +} + +sub _inline_destructor { + my ( $self, %args ) = @_; + + ( exists $args{destructor_class} && defined $args{destructor_class} ) + || confess "The 'inline_destructor' option is present, but " + . "no destructor class was specified"; + + if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) { + my $class = $self->name; + warn "Not inlining a destructor for $class since it defines" + . " its own destructor.\n"; + return; + } + + my $destructor_class = $args{destructor_class}; + + Class::MOP::load_class($destructor_class); + + return unless $destructor_class->is_needed($self); + + my $destructor = $destructor_class->new( + options => \%args, + metaclass => $self, + package_name => $self->name, + name => 'DESTROY' + ); - $self->immutable_transformer->make_metaclass_mutable; + if ( $args{replace_destructor} or $destructor->can_be_inlined ) { + $self->add_method( 'DESTROY' => $destructor ); + $self->_add_inlined_method($destructor); + } } 1; @@ -1034,12 +1309,12 @@ Class::MOP::Class - Class Meta Object # 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 - Foo->meta->class_precedence_list() + # 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'); + # remove a method from Foo + Foo->meta->remove_method('bar'); # or use this to actually create classes ... @@ -1048,8 +1323,8 @@ Class::MOP::Class - Class Meta Object version => '0.01', superclasses => ['Foo'], attributes => [ - Class::MOP:: : Attribute->new('$bar'), - Class::MOP:: : Attribute->new('$baz'), + Class::MOP::Attribute->new('$bar'), + Class::MOP::Attribute->new('$baz'), ], methods => { calculate_bar => sub {...}, @@ -1110,11 +1385,7 @@ hash reference are method names, and values are subroutine references. =item * attributes -An optional array reference of attributes. - -An attribute can be passed as an existing L -object, I or as a hash reference of options which will be passed -to the attribute metaclass's constructor. +An optional array reference of L objects. =back @@ -1202,7 +1473,11 @@ does nothing; it is merely a hook. This method is used to create a new object of the metaclass's class. Any parameters you provide are used to initialize the -instance's attributes. +instance's attributes. A special C<__INSTANCE__> key can be passed to +provide an already generated instance, rather than having Class::MOP +generate it for you. This is mostly useful for using Class::MOP with +foreign classes, which generally generate instances using their own +constructor. =item B<< $metaclass->instance_metaclass >> @@ -1267,7 +1542,13 @@ duplicates removed. =item B<< $metaclass->subclasses >> -This returns a list of subclasses for this class. +This returns a list of all subclasses for this class, even indirect +subclasses. + +=item B<< $metaclass->direct_subclasses >> + +This returns a list of immediate subclasses for this class, which does not +include indirect subclasses. =back @@ -1399,7 +1680,10 @@ attributes which are defined in terms of "regular" Perl 5 methods. This will return a L for the specified C<$attribute_name>. If the class does not have the specified -attribute, it returns C +attribute, it returns C. + +NOTE that get_attribute does not search superclasses, for that you +need to use C. =item B<< $metaclass->has_attribute($attribute_name) >> @@ -1423,8 +1707,6 @@ defined in this class. This will traverse the inheritance hierarchy and return a list of all the L objects for this class and its parents. -This method can also be called as C. - =item B<< $metaclass->find_attribute_by_name($attribute_name) >> This will return a L for the specified @@ -1476,6 +1758,12 @@ Making a class immutable lets us optimize the class by inlining some methods, and also allows us to optimize some methods on the metaclass object itself. +After immutabilization, the metaclass object will cache most +informational methods such as C and +C. Methods which would alter the class, such as +C, C, and so on will throw an error on an +immutable metaclass object. + The immutabilization system in L takes much greater advantage of the inlining features than Class::MOP itself does. @@ -1486,20 +1774,62 @@ of the inlining features than Class::MOP itself does. This method will create an immutable transformer and uses it to make the class and its metaclass object immutable. -Details of how immutabilization works are in L -documentation. +This method accepts the following options: -=item B<< $metaclass->make_mutable >> +=over 8 -Calling this method reverse the immutabilization transformation. +=item * inline_accessors + +=item * inline_constructor + +=item * inline_destructor + +These are all booleans indicating whether the specified method(s) +should be inlined. + +By default, accessors and the constructor are inlined, but not the +destructor. + +=item * immutable_trait + +The name of a class which will be used as a parent class for the +metaclass object being made immutable. This "trait" implements the +post-immutability functionality of the metaclass (but not the +transformation itself). + +This defaults to L. + +=item * constructor_name + +This is the constructor method name. This defaults to "new". + +=item * constructor_class -=item B<< $metaclass->immutable_transformer >> +The name of the method metaclass for constructors. It will be used to +generate the inlined constructor. This defaults to +"Class::MOP::Method::Constructor". -If the class has been made immutable previously, this returns the -L object that was created to do the -transformation. +=item * replace_constructor -If the class was never made immutable, this method will die. +This is a boolean indicating whether an existing constructor should be +replaced when inlining a constructor. This defaults to false. + +=item * destructor_class + +The name of the method metaclass for destructors. It will be used to +generate the inlined destructor. This defaults to +"Class::MOP::Method::Denstructor". + +=item * replace_destructor + +This is a boolean indicating whether an existing destructor should be +replaced when inlining a destructor. This defaults to false. + +=back + +=item B<< $metaclass->make_mutable >> + +Calling this method reverse the immutabilization transformation. =back