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.82_01';
+our $VERSION = '0.88';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
return if ref($self) eq 'Class::MOP::Class' &&
$self->instance_metaclass eq 'Class::MOP::Instance';
+ return if $self->can('get_mutable_metaclass_name');
+
my @class_list = $self->linearized_isa;
shift @class_list; # shift off $self->name
: 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) . ")";
}
}
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 $class = shift;
my $params = @_ == 1 ? $_[0] : {@_};
my $meta_instance = $class->get_meta_instance();
- my $instance = $meta_instance->create_instance();
+ # 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);
}
# we don't know about
$self->_check_metaclass_compatibility();
- $self->update_meta_instance_dependencies();
+ $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;
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 ) };
$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);
+ $self->get_method_map->{$method_name} = $method;
+
+ 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,
);
}
|| 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)
);
}
|| 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)
);
}
|| 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)
);
}
(defined $method_name && $method_name)
|| confess "You must define a method name";
- exists $self->{methods}{$method_name} || exists $self->get_method_map->{$method_name};
+ exists $self->get_method_map->{$method_name};
}
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};
+ return $self->get_method_map->{$method_name};
}
sub remove_method {
} 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;
# 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);
die $e;
sub is_mutable { 1 }
sub is_immutable { 0 }
-sub immutable_transformer { return }
sub _immutable_options {
my ( $self, @args ) = @_;
}
}
-sub immutable_metaclass {
+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} ) {
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);
+ # 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) );
+ $class_name = join '::', 'Class::MOP::Class::Immutable::CustomTrait',
+ $trait, 'ForMetaClass', ref($self);
}
- if ( Class::MOP::is_class_loaded($class_name) ) {
- if ( $class_name->isa($trait) ) {
- return $class_name;
+ return $class_name
+ if Class::MOP::is_class_loaded($class_name);
+
+ my $meta = Class::MOP::Class->create(
+ $class_name,
+ superclasses => [ ref $self ],
+ );
+
+ Class::MOP::load_class($trait);
+ for my $meth ( Class::MOP::Class->initialize($trait)->get_all_methods ) {
+ next if $meta->has_method( $meth->name );
+
+ if ( $meta->find_method_by_name( $meth->name ) ) {
+ $meta->add_around_method_modifier( $meth->name, $meth->body );
}
else {
- confess
- "$class_name is already defined but does not inherit $trait";
+ $meta->add_method( $meth->name, $meth->clone );
}
}
- else {
- my @super = ( $trait, ref($self) );
- my $meta = Class::MOP::Class->initialize($class_name);
- $meta->superclasses(@super);
-
- $meta->make_immutable;
-
- return $class_name;
- }
-}
-
-sub _rebless_as_immutable {
- my ( $self, @args ) = @_;
-
- $self->{__immutable}{original_class} = ref $self;
-
- bless $self => $self->immutable_metaclass(@args);
+ return $class_name;
}
sub _remove_inlined_code {
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) ) {
+ 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"
sub _inline_destructor {
my ( $self, %args ) = @_;
- ( exists $args{destructor_class} )
+ ( 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);
name => 'DESTROY'
);
- $self->add_method( 'DESTROY' => $destructor );
-
- $self->_add_inlined_method($destructor);
+ if ( $args{replace_destructor} or $destructor->can_be_inlined ) {
+ $self->add_method( 'DESTROY' => $destructor );
+ $self->_add_inlined_method($destructor);
+ }
}
1;
# 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 ...
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 {...},
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 >>
=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
This will return a L<Class::MOP::Attribute> for the specified
C<$attribute_name>. If the class does not have the specified
-attribute, it returns C<undef>
+attribute, it returns C<undef>.
+
+NOTE that get_attribute does not search superclasses, for that you
+need to use C<find_attribute_by_name>.
=item B<< $metaclass->has_attribute($attribute_name) >>
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<get_method_map> and
+C<get_all_attributes>. Methods which would alter the class, such as
+C<add_attribute>, C<add_method>, and so on will throw an error on an
+immutable metaclass object.
+
The immutabilization system in L<Moose> takes much greater advantage
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<Class::MOP::Immutable>
-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
-=item B<< $metaclass->immutable_transformer >>
+These are all booleans indicating whether the specified method(s)
+should be inlined.
-If the class has been made immutable previously, this returns the
-L<Class::MOP::Immutable> object that was created to do the
-transformation.
+By default, accessors and the constructor are inlined, but not the
+destructor.
-If the class was never made immutable, this method will die.
+=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<Class::MOP::Class::Immutable::Trait>.
+
+=item * constructor_name
+
+This is the constructor method name. This defaults to "new".
+
+=item * constructor_class
+
+The name of the method metaclass for constructors. It will be used to
+generate the inlined constructor. This defaults to
+"Class::MOP::Method::Constructor".
+
+=item * replace_constructor
+
+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
projects / gitmo/Class-MOP.git / blobdiff