X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=1482ade88ccffdf5a2c8e07a1801a5a87d74a62c;hb=21ddc881fd1f14d24ac37a1cefb5677d99d5cc48;hp=e2170a84580c252b3d18c2afcec5de240781a4a2;hpb=f5bacdc4274aded74553f6a88c0c8a9998c06511;p=gitmo%2FMoose.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index e2170a8..1482ade 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -13,7 +13,6 @@ use Class::MOP::MiniTrait; use Carp 'confess'; use Scalar::Util 'blessed', 'reftype', 'weaken'; use Sub::Name 'subname'; -use Devel::GlobalDestruction 'in_global_destruction'; use Try::Tiny; use List::MoreUtils 'all'; @@ -408,137 +407,75 @@ sub _remove_generated_metaobjects { } } -## ANON classes - -{ - # NOTE: - # 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 - # need to put it up here for now. - my $ANON_CLASS_PREFIX = 'Class::MOP::Class::__ANON__::SERIAL::'; - - sub is_anon_class { - my $self = shift; - no warnings 'uninitialized'; - $self->name =~ /^$ANON_CLASS_PREFIX/o; - } - - sub create_anon_class { - my ($class, %options) = @_; - $options{weaken} = 1 unless exists $options{weaken}; - 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 - # global destruction and so don't - # really need to be handled explicitly - sub DESTROY { - my $self = shift; - - return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated - - $self->free_anon_class - if $self->is_anon_class; - } - - sub free_anon_class { - my $self = shift; - my $name = $self->name; - - # 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. - no warnings 'uninitialized'; - my $current_meta = Class::MOP::get_metaclass_by_name($name); - return if $current_meta ne $self; - - my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/); - - no strict 'refs'; - @{$name . '::ISA'} = (); - %{$name . '::'} = (); - delete ${$first_fragments . '::'}{$last_fragment . '::'}; - - Class::MOP::remove_metaclass_by_name($name); - } - -} - # creating classes with MOP ... sub create { - my ( $class, @args ) = @_; + my $class = shift; + my @args = @_; unshift @args, 'package' if @args % 2 == 1; - - my (%options) = @args; - my $package_name = $options{package}; + my %options = @args; (ref $options{superclasses} eq 'ARRAY') || confess "You must pass an ARRAY ref of superclasses" if exists $options{superclasses}; - + (ref $options{attributes} eq 'ARRAY') || confess "You must pass an ARRAY ref of attributes" - if exists $options{attributes}; - + if exists $options{attributes}; + (ref $options{methods} eq 'HASH') || confess "You must pass a HASH ref of methods" - if exists $options{methods}; - - $options{meta_name} = 'meta' - unless exists $options{meta_name}; - - my (%initialize_options) = @args; - delete @initialize_options{qw( - package - superclasses - attributes - methods - meta_name - version - authority - )}; - my $meta = $class->initialize( $package_name => %initialize_options ); - - $meta->_instantiate_module( $options{version}, $options{authority} ); - - $meta->_add_meta_method($options{meta_name}) - if defined $options{meta_name}; - - $meta->superclasses(@{$options{superclasses}}) - if exists $options{superclasses}; + if exists $options{methods}; + + my $package = delete $options{package}; + my $superclasses = delete $options{superclasses}; + my $attributes = delete $options{attributes}; + my $methods = delete $options{methods}; + my $meta_name = exists $options{meta_name} + ? delete $options{meta_name} + : 'meta'; + + my $meta = $class->SUPER::create($package => %options); + + $meta->_add_meta_method($meta_name) + if defined $meta_name; + + $meta->superclasses(@{$superclasses}) + if defined $superclasses; # NOTE: # 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. - if (exists $options{attributes}) { - foreach my $attr (@{$options{attributes}}) { + if (defined $attributes) { + foreach my $attr (@{$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}); + if (defined $methods) { + foreach my $method_name (keys %{$methods}) { + $meta->add_method($method_name, $methods->{$method_name}); } } return $meta; } +# XXX: something more intelligent here? +sub _anon_package_prefix { 'Class::MOP::Class::__ANON__::SERIAL::' } + +sub create_anon_class { shift->create_anon(@_) } +sub is_anon_class { shift->is_anon(@_) } + +sub _anon_cache_key { + my $class = shift; + my %options = @_; + # Makes something like Super::Class|Super::Class::2 + return join '=' => ( + join( '|', sort @{ $options{superclasses} || [] } ), + ); +} + # Instance Construction & Cloning sub new_object { @@ -758,6 +695,18 @@ sub _inline_preserve_weak_metaclasses { sub _inline_extra_init { } +sub _eval_environment { + my $self = shift; + + my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes; + + my $defaults = [map { $_->default } @attrs]; + + return { + '$defaults' => \$defaults, + }; +} + sub get_meta_instance { my $self = shift; @@ -778,6 +727,7 @@ sub _create_meta_instance { return $instance; } +# TODO: this is actually not being used! sub _inline_rebless_instance { my $self = shift; @@ -846,7 +796,8 @@ sub _force_rebless_instance { } # rebless! - # we use $_[1] here because of t/306_rebless_overload.t regressions on 5.8.8 + # we use $_[1] here because of t/cmop/rebless_overload.t regressions + # on 5.8.8 $meta_instance->rebless_instance_structure($_[1], $self); $self->_fixup_attributes_after_rebless($instance, $old_metaclass, %params); @@ -1319,14 +1270,18 @@ sub _immutable_options { 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; - } + return unless $self->is_mutable; + + my ($file, $line) = (caller)[1..2]; + + $self->_initialize_immutable( + file => $file, + line => $line, + $self->_immutable_options(@args), + ); + $self->_rebless_as_immutable(@args); + + return $self; } sub make_mutable { @@ -1476,6 +1431,11 @@ sub _inline_constructor { is_inline => 1, package_name => $self->name, name => $name, + definition_context => { + description => "constructor " . $self->name . "::" . $name, + file => $args{file}, + line => $args{line}, + }, ); if ( $args{replace_constructor} or $constructor->can_be_inlined ) { @@ -1508,7 +1468,12 @@ sub _inline_destructor { options => \%args, metaclass => $self, package_name => $self->name, - name => 'DESTROY' + name => 'DESTROY', + definition_context => { + description => "destructor " . $self->name . "::DESTROY", + file => $args{file}, + line => $args{line}, + }, ); if ( $args{replace_destructor} or $destructor->can_be_inlined ) {