X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=511a499d8d874e5c7e9337f2d53b3b3a27613751;hb=b26fab6dadbb855db6c465b976dd965088499b65;hp=67d903bce6829c0e88c495a5fc883bed4796643b;hpb=e40935996d0c20aa345a46d996b76e771d885400;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 67d903b..511a499 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -8,6 +8,7 @@ use Class::MOP::Instance; use Class::MOP::Method::Wrapped; use Class::MOP::Method::Accessor; use Class::MOP::Method::Constructor; +use Class::MOP::MiniTrait; use Carp 'confess'; use Scalar::Util 'blessed', 'reftype', 'weaken'; @@ -45,6 +46,21 @@ sub initialize { || $class->_construct_class_instance(package => $package_name, @_); } +sub reinitialize { + my ( $class, @args ) = @_; + unshift @args, "package" if @args % 2; + my %options = @args; + my $old_metaclass = blessed($options{package}) + ? $options{package} + : Class::MOP::get_metaclass_by_name($options{package}); + $old_metaclass->_remove_generated_metaobjects + if $old_metaclass && $old_metaclass->isa('Class::MOP::Class'); + my $new_metaclass = $class->SUPER::reinitialize(@args); + $new_metaclass->_restore_metaobjects_from($old_metaclass) + if $old_metaclass && $old_metaclass->isa('Class::MOP::Class'); + return $new_metaclass; +} + # NOTE: (meta-circularity) # this is a special form of _construct_instance # (see below), which is used to construct class @@ -393,6 +409,92 @@ sub _fix_single_metaclass_incompatibility { } } +sub _get_associated_single_metaclass { + my $self = shift; + my ($single_meta_name) = @_; + + my $current_single_meta_name; + if ($single_meta_name->isa('Class::MOP::Method')) { + $current_single_meta_name = $self->method_metaclass; + } + elsif ($single_meta_name->isa('Class::MOP::Attribute')) { + $current_single_meta_name = $self->attribute_metaclass; + } + else { + confess "Can't make $single_meta_name compatible, it isn't an " + . "attribute or method metaclass."; + } + + return $current_single_meta_name; +} + +sub _get_compatible_single_metaclass_by_subclassing { + my $self = shift; + my ($single_meta_name) = @_; + + my $current_single_meta_name = $self->_get_associated_single_metaclass($single_meta_name); + + if ($single_meta_name->isa($current_single_meta_name)) { + return $single_meta_name; + } + elsif ($current_single_meta_name->isa($single_meta_name)) { + return $current_single_meta_name; + } + + return; +} + +sub _get_compatible_single_metaclass { + my $self = shift; + my ($single_meta_name) = @_; + + return $self->_get_compatible_single_metaclass_by_subclassing($single_meta_name); +} + +sub _make_metaobject_compatible { + my $self = shift; + my ($object) = @_; + + my $new_metaclass = $self->_get_compatible_single_metaclass(blessed($object)); + + if (!defined($new_metaclass)) { + confess "Can't make $object compatible with metaclass " + . $self->_get_associated_single_metaclass(blessed($object)); + } + + # XXX: is this sufficient? i think so... we should never lose attributes + # by this process + bless($object, $new_metaclass) + if blessed($object) ne $new_metaclass; + + return $object; +} + +sub _restore_metaobjects_from { + my $self = shift; + my ($old_meta) = @_; + + for my $method ($old_meta->_get_local_methods) { + $self->_make_metaobject_compatible($method); + $self->add_method($method->name => $method); + } + + for my $attr (sort { $a->insertion_order <=> $b->insertion_order } + map { $old_meta->get_attribute($_) } + $old_meta->get_attribute_list) { + $self->_make_metaobject_compatible($attr); + $self->add_attribute($attr); + } +} + +sub _remove_generated_metaobjects { + my $self = shift; + + for my $attr (map { $self->get_attribute($_) } $self->get_attribute_list) { + $attr->remove_accessors; + } +} + ## ANON classes { @@ -483,6 +585,7 @@ sub create { superclasses attributes methods + no_meta version authority )}; @@ -492,8 +595,16 @@ sub create { # FIXME totally lame $meta->add_method('meta' => sub { + if (Class::MOP::DEBUG_NO_META()) { + my ($self) = @_; + if (my $meta = try { $self->SUPER::meta }) { + return $meta if $meta->isa('Class::MOP::Class'); + } + confess "'meta' method called by MOP internals" + if caller =~ /Class::MOP|metaclass/; + } $class->initialize(ref($_[0]) || $_[0]); - }); + }) unless $options{no_meta}; $meta->superclasses(@{$options{superclasses}}) if exists $options{superclasses}; @@ -603,6 +714,18 @@ sub _create_meta_instance { return $instance; } +sub inline_create_instance { + my $self = shift; + + return $self->get_meta_instance->inline_create_instance(@_); +} + +sub inline_rebless_instance { + my $self = shift; + + return $self->get_meta_instance->inline_rebless_instance_structure(@_); +} + sub clone_object { my $class = shift; my $instance = shift; @@ -1168,17 +1291,7 @@ sub _immutable_metaclass { superclasses => [ ref $self ], ); - Class::MOP::load_class($trait); - for my $meth ( Class::MOP::Class->initialize($trait)->get_all_methods ) { - my $meth_name = $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 ); - } - } + Class::MOP::MiniTrait::apply( $immutable_meta, $trait ); $immutable_meta->make_immutable( inline_constructor => 0, @@ -1402,6 +1515,10 @@ hash reference are method names and values are subroutine references. An optional array reference of L objects. +=item * no_meta + +If true, a C method will not be installed into the class. + =back =item B<< Class::MOP::Class->create_anon_class(%options) >> @@ -1513,6 +1630,13 @@ metaclass. Returns an instance of the C to be used in the construction of a new instance of the class. +=item B<< $metaclass->inline_create_instance($class_var) >> + +=item B<< $metaclass->inline_rebless_instance($instance_var, $class_var) >> + +These methods takes variable names, and use them to create an inline snippet +of code that will create a new instance of the class. + =back =head2 Informational predicates