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';
-our $AUTHORITY = 'cpan:STEVAN';
-
use base 'Class::MOP::Module',
'Class::MOP::Mixin::HasAttributes',
'Class::MOP::Mixin::HasMethods';
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
-
- no warnings 'uninitialized';
- my $name = $self->name;
- return unless $name =~ /^$ANON_CLASS_PREFIX/o;
-
- # 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 ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/o);
- no strict 'refs';
- @{$name . '::ISA'} = ();
- %{$name . '::'} = ();
- delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'};
-
- 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 {
);
push @initial_value, (
- '$attrs->[' . $idx . ']->set_initial_value(',
+ '$attrs[' . $idx . ']->set_initial_value(',
'$instance,',
$attr->_inline_instance_get('$instance'),
');',
my @initial_value = $attr->_inline_set_value('$instance', $default);
push @initial_value, (
- '$attrs->[' . $idx . ']->set_initial_value(',
+ '$attrs[' . $idx . ']->set_initial_value(',
'$instance,',
$attr->_inline_instance_get('$instance'),
');',
# in which case we can just deal with them
# in the code we eval.
if ($attr->is_default_a_coderef) {
- return '$defaults->[' . $index . ']->($instance)';
+ return '$defaults[' . $index . ']->($instance)';
}
else {
- return '$defaults->[' . $index . ']';
+ return '$defaults[' . $index . ']';
}
}
elsif ($attr->has_builder) {
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,
}
}
+sub _method_lookup_order {
+ return (shift->linearized_isa, 'UNIVERSAL');
+}
+
## Methods
{
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->_method_lookup_order) {
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 ( reverse $self->_method_lookup_order ) {
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->_method_lookup_order) {
# 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->_method_lookup_order);
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 $self 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 ) {
=back
+=head2 Overload introspection and creation
+
+These methods provide an API to the core L<overload> functionality.
+
+=over 4
+
+=item B<< $metaclass->is_overloaded >>
+
+Returns true if overloading is enabled for this class. Corresponds to
+L<overload::Overloaded|overload/Public Functions>.
+
+=item B<< $metaclass->get_overloaded_operator($op) >>
+
+Returns the L<Class::MOP::Method::Overload> object corresponding to the
+operator named C<$op>, if one exists for this class.
+
+=item B<< $metaclass->has_overloaded_operator($op) >>
+
+Returns whether or not the operator C<$op> is overloaded for this class.
+
+=item B<< $metaclass->get_overload_list >>
+
+Returns a list of operator names which have been overloaded (see
+L<overload/Overloadable Operations> for the list of valid operator names).
+
+=item B<< $metaclass->get_all_overloaded_operators >>
+
+Returns a list of L<Class::MOP::Method::Overload> objects corresponding to the
+operators that have been overloaded.
+
+=item B<< $metaclass->add_overloaded_operator($op, $impl) >>
+
+Overloads the operator C<$op> for this class, with the implementation C<$impl>.
+C<$impl> can be either a coderef or a method name. Corresponds to
+C<< use overload $op => $impl; >>
+
+=item B<< $metaclass->remove_overloaded_operator($op) >>
+
+Remove overloading for operator C<$op>. Corresponds to C<< no overload $op; >>
+
+=back
+
=head2 Class Immutability
Making a class immutable "freezes" the class definition. You can no
=item B<< $metaclass->make_immutable(%options) >>
This method will create an immutable transformer and use it to make
-the class and its metaclass object immutable.
+the class and its metaclass object immutable, and returns true
+(you should not rely on the details of this value apart from its truth).
This method accepts the following options:
projects / gitmo/Moose.git / blobdiff