use Class::MOP::MiniTrait;
use Carp 'confess';
+use Class::Load 'is_class_loaded', 'load_class';
use Scalar::Util 'blessed', 'reftype', 'weaken';
use Sub::Name 'subname';
-use Devel::GlobalDestruction 'in_global_destruction';
use Try::Tiny;
use List::MoreUtils 'all';
my $class = shift;
my $package_name;
-
+
if ( @_ % 2 ) {
$package_name = shift;
} else {
}
# and check the metaclass compatibility
- $meta->_check_metaclass_compatibility();
+ $meta->_check_metaclass_compatibility();
Class::MOP::store_metaclass_by_name($package_name, $meta);
}
}
-## 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.
- 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 {
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;
sub _create_meta_instance {
my $self = shift;
-
+
my $instance = $self->instance_metaclass->new(
associated_metaclass => $self,
attributes => [ $self->get_all_attributes() ],
return $instance;
}
+# TODO: this is actually not being used!
sub _inline_rebless_instance {
my $self = shift;
}
# 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);
my $self = shift;
my $name = $self->name;
- unless (Class::MOP::IS_RUNNING_ON_5_10()) {
+ unless (Class::MOP::IS_RUNNING_ON_5_10()) {
# NOTE:
# We need to check for circular inheritance here
- # if we are are not on 5.10, cause 5.8 detects it
- # late. This will do nothing if all is well, and
+ # if we are are not on 5.10, cause 5.8 detects it
+ # late. This will do nothing if all is well, and
# blow up otherwise. Yes, it's an ugly hack, better
- # suggestions are welcome.
+ # suggestions are welcome.
# - SL
- ($name || return)->isa('This is a test for circular inheritance')
+ ($name || return)->isa('This is a test for circular inheritance')
}
- # if our mro is c3, we can
+ # if our mro is c3, we can
# just grab the linear_isa
if (mro::get_mro($name) eq 'c3') {
return @{ mro::get_linear_isa($name) }
else {
# NOTE:
# we can't grab the linear_isa for dfs
- # since it has all the duplicates
+ # since it has all the duplicates
# already removed.
return (
$name,
my ($self, $method_name) = @_;
(defined $method_name && length $method_name)
|| confess "You must define a method name to find";
- foreach my $class ($self->linearized_isa) {
+ foreach my $class ($self->linearized_isa, 'UNIVERSAL') {
my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
return $method if defined $method;
}
my $self = shift;
my %methods;
- for my $class ( reverse $self->linearized_isa ) {
+ for my $class ( 'UNIVERSAL', reverse $self->linearized_isa ) {
my $meta = Class::MOP::Class->initialize($class);
$methods{ $_->name } = $_ for $meta->_get_local_methods;
sub get_all_method_names {
my $self = shift;
- my %uniq;
- return grep { !$uniq{$_}++ } map { Class::MOP::Class->initialize($_)->get_method_list } $self->linearized_isa;
+ map { $_->name } $self->get_all_methods;
}
sub find_all_methods_by_name {
(defined $method_name && length $method_name)
|| confess "You must define a method name to find";
my @methods;
- foreach my $class ($self->linearized_isa) {
+ foreach my $class ($self->linearized_isa, 'UNIVERSAL') {
# fetch the meta-class ...
my $meta = Class::MOP::Class->initialize($class);
push @methods => {
my ($self, $method_name) = @_;
(defined $method_name && length $method_name)
|| confess "You must define a method name to find";
- my @cpl = $self->linearized_isa;
+ my @cpl = ($self->linearized_isa, 'UNIVERSAL');
shift @cpl; # discard ourselves
foreach my $class (@cpl) {
my $method = Class::MOP::Class->initialize($class)->get_method($method_name);
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 {
}
return $class_name
- if Class::MOP::is_class_loaded($class_name);
+ if 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
my $constructor_class = $args{constructor_class};
- Class::MOP::load_class($constructor_class);
+ load_class($constructor_class);
my $constructor = $constructor_class->new(
options => \%args,
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 ) {
my $destructor_class = $args{destructor_class};
- Class::MOP::load_class($destructor_class);
+ load_class($destructor_class);
return unless $destructor_class->is_needed($self);
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 ) {
projects / gitmo/Moose.git / blobdiff