X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=ec534195750e2ad1cf20d808a4663c67b3153de4;hb=af72687d6d45c59be325b4d43c852606c8a2c9c1;hp=3592fef0d0cc9a4bd195c6cd52237d37368a3c9b;hpb=89f660234af3ea76105ad29862b4092d54b06fcf;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 3592fef..ec53419 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -4,14 +4,18 @@ 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 Class::MOP::Class::Immutable::Class::MOP::Class; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; +use Sub::Name 'subname'; +use Devel::GlobalDestruction 'in_global_destruction'; -our $VERSION = '0.78'; +our $VERSION = '0.85'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -39,13 +43,13 @@ sub initialize { } sub construct_class_instance { - warn 'The construct_class_instance method has been made private.' - . " The public version is deprecated and will be removed in a future release.\n"; - goto &_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 @@ -79,15 +83,14 @@ sub _construct_class_instance { # now create the metaclass my $meta; if ($class eq 'Class::MOP::Class') { - no strict 'refs'; - $meta = $class->_new($options) + $meta = $class->_new($options); } else { # NOTE: # it is safe to use meta here because # class will always be a subclass of # Class::MOP::Class, which defines meta - $meta = $class->meta->construct_instance($options) + $meta = $class->meta->_construct_instance($options) } # and check the metaclass compatibility @@ -128,16 +131,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; } @@ -155,9 +169,9 @@ sub update_package_cache_flag { sub check_metaclass_compatibility { - warn 'The check_metaclass_compatibility method has been made private.' - . " The public version is deprecated and will be removed in a future release.\n"; - goto &_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 { @@ -183,16 +197,17 @@ sub _check_metaclass_compatibility { : ref($super_meta); ($self->isa($super_meta_type)) - || confess $self->name . "->meta => (" . (ref($self)) . ")" . - " is not compatible with the " . - $superclass_name . "->meta => (" . ($super_meta_type) . ")"; + || confess "Class::MOP::class_of(" . $self->name . ") => (" + . (ref($self)) . ")" . " is not compatible with the " . + "Class::MOP::class_of(".$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 $self->name . "->meta->instance_metaclass => (" . ($self->instance_metaclass) . ")" . + || confess "Class::MOP::class_of(" . $self->name . ")->instance_metaclass => (" . ($self->instance_metaclass) . ")" . " is not compatible with the " . - $superclass_name . "->meta->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")"; + "Class::MOP::class_of(" . $superclass_name . ")->instance_metaclass => (" . ($super_meta->instance_metaclass) . ")"; } } @@ -233,7 +248,7 @@ 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/; @@ -326,6 +341,10 @@ 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'} } # Instance Construction & Cloning @@ -339,15 +358,21 @@ sub new_object { # which will deal with the singletons 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()) { + foreach my $attr ($class->get_all_attributes()) { $attr->initialize_instance_slot($meta_instance, $instance, $params); } # NOTE: @@ -372,9 +397,9 @@ sub get_meta_instance { } sub create_meta_instance { - warn 'The create_meta_instance method has been made private.' - . " The public version is deprecated and will be removed in a future release.\n"; - goto &_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 { @@ -382,7 +407,7 @@ sub _create_meta_instance { 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() @@ -406,9 +431,9 @@ sub clone_object { } sub clone_instance { - warn 'The clone_instance method has been made private.' - . " The public version is deprecated and will be removed in a future release.\n"; - goto &_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 { @@ -417,7 +442,7 @@ sub _clone_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}); @@ -430,26 +455,22 @@ sub _clone_instance { sub rebless_instance { my ($self, $instance, %params) = @_; - my $old_metaclass; - if ($instance->can('meta')) { - ($instance->meta->isa('Class::MOP::Class')) - || confess 'Cannot rebless instance if ->meta is not an instance of Class::MOP::Class'; - $old_metaclass = $instance->meta; - } - else { - $old_metaclass = $self->initialize(ref($instance)); - } + my $old_metaclass = Class::MOP::class_of($instance); - my $meta_instance = $self->get_meta_instance(); + my $old_class = $old_metaclass ? $old_metaclass->name : blessed($instance); + $self->name->isa($old_class) + || confess "You may rebless only into a subclass of ($old_class), of which (". $self->name .") isn't."; - $self->name->isa($old_metaclass->name) - || confess "You may rebless only into a subclass of (". $old_metaclass->name ."), of which (". $self->name .") isn't."; + $old_metaclass->rebless_instance_away($instance, $self, %params) + if $old_metaclass; + + my $meta_instance = $self->get_meta_instance(); # rebless! # 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) @@ -461,13 +482,17 @@ 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); } $instance; } +sub rebless_instance_away { + # this intentionally does nothing, it is just a hook +} + # Inheritance sub superclasses { @@ -492,61 +517,34 @@ sub superclasses { # we don't know about $self->_check_metaclass_compatibility(); - $self->update_meta_instance_dependencies(); + $self->_superclasses_updated(); } @{$self->get_package_symbol($var_spec)}; } -sub subclasses { +sub _superclasses_updated { my $self = shift; + $self->update_meta_instance_dependencies(); +} +sub subclasses { + my $self = shift; my $super_class = $self->name; - if ( Class::MOP::HAVE_ISAREV() ) { - return @{ $super_class->mro::get_isarev() }; - } else { - my @derived_classes; - - my $find_derived_classes; - $find_derived_classes = sub { - my ($outer_class) = @_; - - my $symbol_table_hashref = do { no strict 'refs'; \%{"${outer_class}::"} }; - - SYMBOL: - for my $symbol ( keys %$symbol_table_hashref ) { - next SYMBOL if $symbol !~ /\A (\w+):: \z/x; - my $inner_class = $1; - - next SYMBOL if $inner_class eq 'SUPER'; # skip '*::SUPER' - - my $class = - $outer_class - ? "${outer_class}::$inner_class" - : $inner_class; - - if ( $class->isa($super_class) and $class ne $super_class ) { - push @derived_classes, $class; - } - - next SYMBOL if $class eq 'main'; # skip 'main::*' - - $find_derived_classes->($class); - } - }; - - my $root_class = q{}; - $find_derived_classes->($root_class); - - undef $find_derived_classes; + return @{ $super_class->mro::get_isarev() }; +} - @derived_classes = sort { $a->isa($b) ? 1 : $b->isa($a) ? -1 : 0 } @derived_classes; +sub direct_subclasses { + my $self = shift; + my $super_class = $self->name; - return @derived_classes; - } + return grep { + grep { + $_ eq $super_class + } Class::MOP::Class->initialize($_)->superclasses + } $self->subclasses; } - sub linearized_isa { return @{ mro::get_linear_isa( (shift)->name ) }; } @@ -626,10 +624,16 @@ sub add_method { # 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 ( $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, ); } @@ -666,7 +670,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) ); } @@ -676,7 +680,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) ); } @@ -686,7 +690,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) ); } @@ -705,9 +709,9 @@ sub add_method { } sub alias_method { - warn "The alias_method method is deprecated. Use add_method instead.\n"; + Carp::cluck("The alias_method method is deprecated. Use add_method instead.\n"); - goto &add_method; + shift->add_method(@_); } sub has_method { @@ -769,8 +773,8 @@ sub get_all_methods { } sub compute_all_applicable_methods { - warn 'The compute_all_applicable_methods method is deprecated.' - . " Use get_all_methods instead.\n"; + Carp::cluck('The compute_all_applicable_methods method is deprecated.' + . " Use get_all_methods instead.\n"); return map { { @@ -844,6 +848,11 @@ sub add_attribute { } 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}) - 1; + $attribute->_set_insertion_order($order + 1); # then onto installing the new accessors $self->get_attribute_map->{$attribute->name} = $attribute; @@ -871,7 +880,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; @@ -956,15 +965,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) { @@ -999,119 +1011,215 @@ sub is_pristine { sub is_mutable { 1 } sub is_immutable { 0 } +sub immutable_transformer { return } + +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, + ); +} -# NOTE: -# Why I changed this (groditi) -# - One Metaclass may have many Classes through many Metaclass instances -# - One Metaclass should only have one Immutable Transformer instance -# - Each Class may have different Immutabilizing options -# - Therefore each Metaclass instance may have different Immutabilizing options -# - We need to store one Immutable Transformer instance per Metaclass -# - We need to store one set of Immutable Transformer options per Class -# - Upon make_mutable we may delete the Immutabilizing options -# - We could clean the immutable Transformer instance when there is no more -# immutable Classes of that type, but we can also keep it in case -# another class with this same Metaclass becomes immutable. It is a case -# of trading of storing an instance to avoid unnecessary instantiations of -# Immutable Transformers. You may view this as a memory leak, however -# Because we have few Metaclasses, in practice it seems acceptable -# - To allow Immutable Transformers instances to be cleaned up we could weaken -# the reference stored in $IMMUTABLE_TRANSFORMERS{$class} and ||= should DWIM +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; + } +} - my %IMMUTABLE_TRANSFORMERS; - my %IMMUTABLE_OPTIONS; +sub make_mutable { + my $self = shift; - sub get_immutable_options { - my $self = shift; - return if $self->is_mutable; - confess "unable to find immutabilizing options" - unless exists $IMMUTABLE_OPTIONS{$self->name}; - my %options = %{$IMMUTABLE_OPTIONS{$self->name}}; - delete $options{IMMUTABLE_TRANSFORMER}; - return \%options; + 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; } +} - sub get_immutable_transformer { - my $self = shift; - if( $self->is_mutable ){ - return $IMMUTABLE_TRANSFORMERS{$self->name} ||= $self->create_immutable_transformer; - } - confess "unable to find transformer for immutable class" - unless exists $IMMUTABLE_OPTIONS{$self->name}; - return $IMMUTABLE_OPTIONS{$self->name}->{IMMUTABLE_TRANSFORMER}; +sub _rebless_as_immutable { + my ( $self, @args ) = @_; + + $self->{__immutable}{original_class} = ref $self; + + bless $self => $self->_immutable_metaclass(@args); +} + +sub _immutable_metaclass { + my ( $self, %args ) = @_; + + if ( my $class = $args{immutable_metaclass} ) { + return $class; } - sub make_immutable { - my $self = shift; - my %options = @_; + my $trait = $args{immutable_trait} = $self->immutable_trait + || confess "no immutable trait specified for $self"; - my $transformer = $self->get_immutable_transformer; - $transformer->make_metaclass_immutable($self, \%options); - $IMMUTABLE_OPTIONS{$self->name} = - { %options, IMMUTABLE_TRANSFORMER => $transformer }; + my $meta_attr = $self->meta->find_attribute_by_name("immutable_trait"); - if( exists $options{debug} && $options{debug} ){ - print STDERR "# of Metaclass options: ", keys %IMMUTABLE_OPTIONS; - print STDERR "# of Immutable transformers: ", keys %IMMUTABLE_TRANSFORMERS; - } + my $class_name; + + if ( $meta_attr and $trait eq $meta_attr->default ) { - 1; + # 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) ); } - sub make_mutable{ - my $self = shift; - return if $self->is_mutable; - my $options = delete $IMMUTABLE_OPTIONS{$self->name}; - confess "unable to find immutabilizing options" unless ref $options; - my $transformer = delete $options->{IMMUTABLE_TRANSFORMER}; - $transformer->make_metaclass_mutable($self, $options); - 1; + if ( Class::MOP::is_class_loaded($class_name) ) { + if ( $class_name->isa($trait) ) { + return $class_name; + } + else { + confess + "$class_name is already defined but does not inherit $trait"; + } + } + else { + my @super = ( $trait, ref($self) ); + + my $meta = Class::MOP::Class->initialize($class_name); + $meta->superclasses(@super); + + $meta->make_immutable; + + return $class_name; } } -sub create_immutable_transformer { +sub _remove_inlined_code { my $self = shift; - my $class = Class::MOP::Immutable->new($self, { - 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', - linearized_isa => 'ARRAY', # FIXME perl 5.10 memoizes this on its own, no need? - get_all_methods => 'ARRAY', - get_all_method_names => 'ARRAY', - #get_all_attributes => 'ARRAY', # it's an alias, no need, but maybe in the future - compute_all_applicable_attributes => 'ARRAY', - get_meta_instance => 'SCALAR', - get_method_map => 'SCALAR', - }, - # 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; - }, - }, - }); - return $class; + + $self->remove_method( $_->name ) for $self->_inlined_methods; + + delete $self->{__immutable}{inlined_methods}; +} + +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; + + 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 ( my $existing = $self->name->can($args{constructor_name}) ) { + # if ( refaddr($existing) == refaddr(\&Moose::Object::new) ) { + + unless ( $args{replace_constructor} + or !$self->has_method($name) ) { + 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} ) + || confess "The 'inline_destructor' option is present, but " + . "no destructor class was specified"; + + 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->add_method( 'DESTROY' => $destructor ); + + $self->_add_inlined_method($destructor); } 1; @@ -1134,12 +1242,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 ... @@ -1148,8 +1256,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 {...}, @@ -1292,6 +1400,12 @@ like constructor parameters and used to initialize the object's attributes. Any existing attributes that are already set will be overwritten. +Before reblessing the instance, this method will call +C on the instance's current metaclass. This method +will be passed the instance, the new metaclass, and any parameters +specified to C. By default, C +does nothing; it is merely a hook. + =item B<< $metaclass->new_object(%params) >> This method is used to create a new object of the metaclass's @@ -1302,7 +1416,7 @@ instance's attributes. Returns the class name of the instance metaclass, see L for more information on the instance -metaclasses. +metaclass. =item B<< $metaclass->get_meta_instance >> @@ -1361,7 +1475,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 @@ -1467,6 +1587,17 @@ track the original source of any methods added from other classes Remove the named method from the class. This method returns the L object for the method. +=item B<< $metaclass->method_metaclass >> + +Returns the class name of the method metaclass, see +L for more information on the method metaclass. + +=item B<< $metaclass->wrapped_method_metaclass >> + +Returns the class name of the wrapped method metaclass, see +L for more information on the wrapped +method metaclass. + =back =head2 Attribute introspection and creation @@ -1506,8 +1637,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 @@ -1576,7 +1705,7 @@ documentation. Calling this method reverse the immutabilization transformation. -=item B<< $metaclass->get_immutable_transformer >> +=item B<< $metaclass->immutable_transformer >> If the class has been made immutable previously, this returns the L object that was created to do the