use Moose::Meta::Method::Overridden;
use Moose::Meta::Method::Augmented;
use Moose::Error::Default;
+use Moose::Meta::Class::Immutable::Trait;
+use Moose::Meta::Method::Constructor;
+use Moose::Meta::Method::Destructor;
use base 'Class::MOP::Class';
default => sub { [] }
));
+
+__PACKAGE__->meta->add_attribute(
+ Class::MOP::Attribute->new('immutable_trait' => (
+ accessor => "immutable_trait",
+ default => 'Moose::Meta::Class::Immutable::Trait',
+ ))
+);
+
__PACKAGE__->meta->add_attribute('constructor_class' => (
accessor => 'constructor_class',
default => 'Moose::Meta::Method::Constructor',
default => 'Moose::Error::Default',
));
-
sub initialize {
my $class = shift;
my $pkg = shift;
);
}
+sub _immutable_options {
+ my ( $self, @args ) = @_;
+
+ $self->SUPER::_immutable_options(
+ inline_destructor => 1,
+
+ # Moose always does this when an attribute is created
+ inline_accessors => 0,
+
+ @args,
+ );
+}
+
sub create {
my ($self, $package_name, %options) = @_;
## -------------------------------------------------
-use Moose::Meta::Method::Constructor;
-use Moose::Meta::Method::Destructor;
-
-
-sub _default_immutable_transformer_options {
- my $self = shift;
-
- my %options = $self->SUPER::_default_immutable_transformer_options;
-
- # We need to copy the references as we do not want to alter the
- # superclass's references.
- $options{cannot_call} = [ @{ $options{cannot_call} }, 'add_role' ];
- $options{memoize} = {
- %{ $options{memoize} },
- calculate_all_roles => 'ARRAY',
- };
-
- %options = (
- %options,
- constructor_class => $self->constructor_class,
- destructor_class => $self->destructor_class,
- inline_destructor => 1,
-
- # Moose always does this when an attribute is created
- inline_accessors => 0,
- );
-
- return %options
-}
-
our $error_level;
sub throw_error {
--- /dev/null
+package Moose::Meta::Class::Immutable::Trait;
+
+use strict;
+use warnings;
+
+use Class::MOP;
+
+use base 'Class::MOP::Class::Immutable::Trait';
+
+sub add_role { shift->_immutable_cannot_call }
+
+sub calculate_all_roles {
+ @{ $_[0]{__immutable}{calculate_all_roles} ||= [ shift->next::method ] };
+}
+
+1;
use strict;
use warnings;
-use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
+use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr';
our $VERSION = '0.75';
our $AUTHORITY = 'cpan:STEVAN';
'name' => $options{name},
'options' => $options{options},
'associated_metaclass' => $meta,
+ '_expected_method_class' => $options{_expected_method_class} || 'Moose::Object',
} => $class;
# we don't want this creating
return $self;
}
-sub can_be_inlined {
- my $self = shift;
- my $metaclass = $self->associated_metaclass;
-
- my $expected_class = $self->_expected_constructor_class;
-
- # If any of our parents have been made immutable, we are okay to
- # inline our own new method. The assumption is that an inlined new
- # method provided by a parent does not actually get used by
- # children anyway.
- for my $meta (
- grep { $_->is_immutable }
- map { ( ref $metaclass )->initialize($_) }
- grep { $_ ne $expected_class }
- $metaclass->linearized_isa
- ) {
- my $transformer = $meta->immutable_transformer;
-
- # This is actually a false positive if we're in a subclass of
- # this class, _and_ the expected class is not overridden (but
- # should be), and the real expected class is actually
- # immutable itself (see Fey::Object::Table for an example of
- # how this can happen). I'm not sure how to actually handle
- # that case, since it's effectively a bug in the subclass (for
- # not overriding _expected_constructor_class).
- return 1 if $transformer->inlined_constructor;
- }
-
- if ( my $constructor = $metaclass->find_method_by_name( $self->name ) ) {
- my $class = $self->associated_metaclass->name;
-
- if ( $constructor->body != $expected_class->can('new') ) {
- my $warning
- = "Not inlining a constructor for $class since it is not"
- . " inheriting the default $expected_class constructor\n"
- . "If you are certain you don't need to inline your"
- . " constructor, specify inline_constructor => 0 in your"
- . " call to $class->meta->make_immutable\n";
-
- $warning .= " (constructor has method modifiers which would be lost if it were inlined)\n"
- if $constructor->isa('Class::MOP::Method::Wrapped');
-
- warn $warning;
-
- return 0;
- }
- else {
- return 1;
- }
- }
-
- # This would be a rather weird case where we have no constructor
- # in the inheritance chain.
- return 1;
-}
-
# This is here so can_be_inlined can be inherited by MooseX modules.
sub _expected_constructor_class {
return 'Moose::Object';
extends 'NotMoose';
+ warn "oi";
+
::stderr_is(
sub { Foo->meta->make_immutable },
- "Not inlining a constructor for Foo since it is not inheriting the default Moose::Object constructor\nIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to Foo->meta->make_immutable\n",
+ "Not inlining 'new' for Foo since it is not inheriting the default Moose::Object::new\nIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to Foo->meta->make_immutable\n",
'got a warning that Foo may not have an inlined constructor'
);
}
::stderr_is(
sub { Foo->meta->make_immutable },
- "Not inlining a constructor for Foo since it is not inheriting the default Moose::Object constructor\nIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to Foo->meta->make_immutable\n (constructor has method modifiers which would be lost if it were inlined)\n",
+ "Not inlining 'new' for Foo since it is not inheriting the default Moose::Object::new\nIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to Foo->meta->make_immutable\n ('new' has method modifiers which would be lost if it were inlined)\n",
'got a warning that Foo may not have an inlined constructor'
);
}
TODO: {
is( Foo->new->foo, undef, "base class (" . (Foo->meta->is_immutable ? "immutable" : "mutable") . ")" );
is( Bar->new->foo, 42, "around new called on Bar->new (" . (Bar->meta->is_immutable ? "immutable" : "mutable") . ")" );
- local $TODO = 'these tests fail once Gorch is immutable' if Gorch->meta->is_immutable;
is( Gorch->new->foo, 42, "around new called on Gorch->new (" . (Gorch->meta->is_immutable ? "immutable" : "mutable") . ")" );
is( Zoink->new->foo, 42, "around new called Zoink->new (" . (Zoink->meta->is_immutable ? "immutable" : "mutable") . ")" );
}
projects / gitmo/Moose.git / commitdiff