summaryrefslogtreecommitdiff
path: root/t/immutable
diff options
context:
space:
mode:
Diffstat (limited to 't/immutable')
-rw-r--r--t/immutable/apply_roles_to_immutable.t38
-rw-r--r--t/immutable/buildargs.t45
-rw-r--r--t/immutable/constructor_is_not_moose.t100
-rw-r--r--t/immutable/constructor_is_wrapped.t27
-rw-r--r--t/immutable/default_values.t79
-rw-r--r--t/immutable/definition_context.t82
-rw-r--r--t/immutable/immutable_constructor_error.t30
-rw-r--r--t/immutable/immutable_destroy.t21
-rw-r--r--t/immutable/immutable_meta_class.t25
-rw-r--r--t/immutable/immutable_metaclass_with_traits.t36
-rw-r--r--t/immutable/immutable_moose.t84
-rw-r--r--t/immutable/immutable_roundtrip.t33
-rw-r--r--t/immutable/immutable_trigger_from_constructor.t36
-rw-r--r--t/immutable/inline_close_over.t361
-rw-r--r--t/immutable/inline_fallbacks.t70
-rw-r--r--t/immutable/inlined_constructors_n_types.t60
-rw-r--r--t/immutable/multiple_demolish_inline.t45
17 files changed, 1172 insertions, 0 deletions
diff --git a/t/immutable/apply_roles_to_immutable.t b/t/immutable/apply_roles_to_immutable.t
new file mode 100644
index 0000000..206cd16
--- /dev/null
+++ b/t/immutable/apply_roles_to_immutable.t
@@ -0,0 +1,38 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+
+{
+ package My::Role;
+ use Moose::Role;
+
+ around 'baz' => sub {
+ my $next = shift;
+ 'My::Role::baz(' . $next->(@_) . ')';
+ };
+}
+
+{
+ package Foo;
+ use Moose;
+
+ sub baz { 'Foo::baz' }
+
+ __PACKAGE__->meta->make_immutable(debug => 0);
+}
+
+my $foo = Foo->new;
+isa_ok($foo, 'Foo');
+
+is($foo->baz, 'Foo::baz', '... got the right value');
+
+is( exception {
+ My::Role->meta->apply($foo)
+}, undef, '... successfully applied the role to immutable instance' );
+
+is($foo->baz, 'My::Role::baz(Foo::baz)', '... got the right value');
+
+done_testing;
diff --git a/t/immutable/buildargs.t b/t/immutable/buildargs.t
new file mode 100644
index 0000000..338e520
--- /dev/null
+++ b/t/immutable/buildargs.t
@@ -0,0 +1,45 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+{
+ package Foo;
+ use Moose;
+
+ has bar => ( is => "rw" );
+ has baz => ( is => "rw" );
+
+ sub BUILDARGS {
+ my ( $self, @args ) = @_;
+ unshift @args, "bar" if @args % 2 == 1;
+ return {@args};
+ }
+
+ __PACKAGE__->meta->make_immutable;
+
+ package Bar;
+ use Moose;
+
+ extends qw(Foo);
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+foreach my $class (qw(Foo Bar)) {
+ is( $class->new->bar, undef, "no args" );
+ is( $class->new( bar => 42 )->bar, 42, "normal args" );
+ is( $class->new( 37 )->bar, 37, "single arg" );
+ {
+ my $o = $class->new(bar => 42, baz => 47);
+ is($o->bar, 42, '... got the right bar');
+ is($o->baz, 47, '... got the right bar');
+ }
+ {
+ my $o = $class->new(42, baz => 47);
+ is($o->bar, 42, '... got the right bar');
+ is($o->baz, 47, '... got the right bar');
+ }
+}
+
+done_testing;
diff --git a/t/immutable/constructor_is_not_moose.t b/t/immutable/constructor_is_not_moose.t
new file mode 100644
index 0000000..43e9ec9
--- /dev/null
+++ b/t/immutable/constructor_is_not_moose.t
@@ -0,0 +1,100 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Requires 'Test::Output'; # skip all if not installed
+
+{
+ package NotMoose;
+
+ sub new {
+ my $class = shift;
+
+ return bless { not_moose => 1 }, $class;
+ }
+}
+
+{
+ package Foo;
+ use Moose;
+
+ extends 'NotMoose';
+
+ ::stderr_like(
+ sub { Foo->meta->make_immutable },
+ qr/\QNot inlining 'new' for Foo since it is not inheriting the default Moose::Object::new\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to Foo->meta->make_immutable/,
+ 'got a warning that Foo may not have an inlined constructor'
+ );
+}
+
+is(
+ Foo->meta->find_method_by_name('new')->body,
+ NotMoose->can('new'),
+ 'Foo->new is inherited from NotMoose'
+);
+
+{
+ package Bar;
+ use Moose;
+
+ extends 'NotMoose';
+
+ ::stderr_is(
+ sub { Bar->meta->make_immutable( replace_constructor => 1 ) },
+ q{},
+ 'no warning when replace_constructor is true'
+ );
+}
+
+is(
+ Bar->meta->find_method_by_name('new')->package_name,
+ 'Bar',
+ 'Bar->new is inlined, and not inherited from NotMoose'
+);
+
+{
+ package Baz;
+ use Moose;
+
+ Baz->meta->make_immutable;
+}
+
+{
+ package Quux;
+ use Moose;
+
+ extends 'Baz';
+
+ ::stderr_is(
+ sub { Quux->meta->make_immutable },
+ q{},
+ 'no warning when inheriting from a class that has already made itself immutable'
+ );
+}
+
+{
+ package My::Constructor;
+ use parent 'Moose::Meta::Method::Constructor';
+}
+
+{
+ package CustomCons;
+ use Moose;
+
+ CustomCons->meta->make_immutable( constructor_class => 'My::Constructor' );
+}
+
+{
+ package Subclass;
+ use Moose;
+
+ extends 'CustomCons';
+
+ ::stderr_is(
+ sub { Subclass->meta->make_immutable },
+ q{},
+ 'no warning when inheriting from a class that has already made itself immutable'
+ );
+}
+
+done_testing;
diff --git a/t/immutable/constructor_is_wrapped.t b/t/immutable/constructor_is_wrapped.t
new file mode 100644
index 0000000..820d7e9
--- /dev/null
+++ b/t/immutable/constructor_is_wrapped.t
@@ -0,0 +1,27 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Requires 'Test::Output'; # skip all if not installed
+
+{
+ package ModdedNew;
+ use Moose;
+
+ before 'new' => sub { };
+}
+
+{
+ package Foo;
+ use Moose;
+
+ extends 'ModdedNew';
+
+ ::stderr_like(
+ sub { Foo->meta->make_immutable },
+ qr/\QNot inlining 'new' for Foo since it has method modifiers which would be lost if it were inlined/,
+ 'got a warning that Foo may not have an inlined constructor'
+ );
+}
+
+done_testing;
diff --git a/t/immutable/default_values.t b/t/immutable/default_values.t
new file mode 100644
index 0000000..81c57f7
--- /dev/null
+++ b/t/immutable/default_values.t
@@ -0,0 +1,79 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+{
+
+ package Foo;
+ use Moose;
+
+ has 'foo' => ( is => 'rw', default => q{'} );
+ has 'bar' => ( is => 'rw', default => q{\\} );
+ has 'baz' => ( is => 'rw', default => q{"} );
+ has 'buz' => ( is => 'rw', default => q{"'\\} );
+ has 'faz' => ( is => 'rw', default => qq{\0} );
+
+ ::is( ::exception { __PACKAGE__->meta->make_immutable }, undef, 'no errors making a package immutable when it has default values that could break quoting' );
+}
+
+my $foo = Foo->new;
+is( $foo->foo, q{'},
+ 'default value for foo attr' );
+is( $foo->bar, q{\\},
+ 'default value for bar attr' );
+is( $foo->baz, q{"},
+ 'default value for baz attr' );
+is( $foo->buz, q{"'\\},
+ 'default value for buz attr' );
+is( $foo->faz, qq{\0},
+ 'default value for faz attr' );
+
+
+# Lazy attrs were never broken, but it doesn't hurt to test that they
+# won't be broken by any future changes.
+# Also make sure that attributes stay lazy even after being immutable
+
+{
+
+ package Bar;
+ use Moose;
+
+ has 'foo' => ( is => 'rw', default => q{'}, lazy => 1 );
+ has 'bar' => ( is => 'rw', default => q{\\}, lazy => 1 );
+ has 'baz' => ( is => 'rw', default => q{"}, lazy => 1 );
+ has 'buz' => ( is => 'rw', default => q{"'\\}, lazy => 1 );
+ has 'faz' => ( is => 'rw', default => qq{\0}, lazy => 1 );
+
+ {
+ my $bar = Bar->new;
+ ::ok(!$bar->meta->get_attribute($_)->has_value($bar),
+ "Attribute $_ has no value")
+ for qw(foo bar baz buz faz);
+ }
+
+ ::is( ::exception { __PACKAGE__->meta->make_immutable }, undef, 'no errors making a package immutable when it has lazy default values that could break quoting' );
+
+ {
+ my $bar = Bar->new;
+ ::ok(!$bar->meta->get_attribute($_)->has_value($bar),
+ "Attribute $_ has no value (immutable)")
+ for(qw(foo bar baz buz faz));
+ }
+
+}
+
+my $bar = Bar->new;
+is( $bar->foo, q{'},
+ 'default value for foo attr' );
+is( $bar->bar, q{\\},
+ 'default value for bar attr' );
+is( $bar->baz, q{"},
+ 'default value for baz attr' );
+is( $bar->buz, q{"'\\},
+ 'default value for buz attr' );
+is( $bar->faz, qq{\0},
+ 'default value for faz attr' );
+
+done_testing;
diff --git a/t/immutable/definition_context.t b/t/immutable/definition_context.t
new file mode 100644
index 0000000..71482df
--- /dev/null
+++ b/t/immutable/definition_context.t
@@ -0,0 +1,82 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Fatal;
+
+{
+ use Moose::Util::TypeConstraints;
+ use Carp 'confess';
+ subtype 'Death', as 'Int', where { $_ == 1 };
+ coerce 'Death', from 'Any', via { confess };
+}
+
+{
+ my ($attr_foo_line, $attr_bar_line, $ctor_line);
+ {
+ package Foo;
+ use Moose;
+
+ has foo => (
+ is => 'rw',
+ isa => 'Death',
+ coerce => 1,
+ );
+ $attr_foo_line = __LINE__ - 5;
+
+ has bar => (
+ accessor => 'baz',
+ isa => 'Death',
+ coerce => 1,
+ );
+ $attr_bar_line = __LINE__ - 5;
+
+ __PACKAGE__->meta->make_immutable;
+ $ctor_line = __LINE__ - 1;
+ }
+
+ like(
+ exception { Foo->new(foo => 2) },
+ qr/\Qcalled at constructor Foo::new (defined at $0 line $ctor_line)\E/,
+ "got definition context for the constructor"
+ );
+
+ like(
+ exception { my $f = Foo->new(foo => 1); $f->foo(2) },
+ qr/\Qcalled at accessor Foo::foo (defined at $0 line $attr_foo_line)\E/,
+ "got definition context for the accessor"
+ );
+
+ like(
+ exception { my $f = Foo->new(foo => 1); $f->baz(2) },
+ qr/\Qcalled at accessor Foo::baz of attribute bar (defined at $0 line $attr_bar_line)\E/,
+ "got definition context for the accessor"
+ );
+}
+
+{
+ my ($dtor_line);
+ {
+ package Bar;
+ use Moose;
+
+ # just dying here won't work, because perl's exception handling is
+ # terrible
+ sub DEMOLISH { try { confess } catch { warn $_ } }
+
+ __PACKAGE__->meta->make_immutable;
+ $dtor_line = __LINE__ - 1;
+ }
+
+ {
+ my $warning = '';
+ local $SIG{__WARN__} = sub { $warning .= $_[0] };
+ { Bar->new }
+ like(
+ $warning,
+ qr/\Qcalled at destructor Bar::DESTROY (defined at $0 line $dtor_line)\E/,
+ "got definition context for the destructor"
+ );
+ }
+}
+
+done_testing;
diff --git a/t/immutable/immutable_constructor_error.t b/t/immutable/immutable_constructor_error.t
new file mode 100644
index 0000000..cb22171
--- /dev/null
+++ b/t/immutable/immutable_constructor_error.t
@@ -0,0 +1,30 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+
+=pod
+
+This tests to make sure that we provide the same error messages from
+an immutable constructor as is provided by a non-immutable
+constructor.
+
+=cut
+
+{
+ package Foo;
+ use Moose;
+
+ has 'foo' => (is => 'rw', isa => 'Int');
+
+ Foo->meta->make_immutable(debug => 0);
+}
+
+my $scalar = 1;
+like( exception { Foo->new($scalar) }, qr/\QSingle parameters to new() must be a HASH ref/, 'Non-ref provided to immutable constructor gives useful error message' );
+like( exception { Foo->new(\$scalar) }, qr/\QSingle parameters to new() must be a HASH ref/, 'Scalar ref provided to immutable constructor gives useful error message' );
+like( exception { Foo->new(undef) }, qr/\QSingle parameters to new() must be a HASH ref/, 'undef provided to immutable constructor gives useful error message' );
+
+done_testing;
diff --git a/t/immutable/immutable_destroy.t b/t/immutable/immutable_destroy.t
new file mode 100644
index 0000000..8dfc3d3
--- /dev/null
+++ b/t/immutable/immutable_destroy.t
@@ -0,0 +1,21 @@
+use strict;
+use warnings;
+use Test::More;
+
+{
+ package FooBar;
+ use Moose;
+
+ has 'name' => ( is => 'ro' );
+
+ sub DESTROY { shift->name }
+
+ local $SIG{__WARN__} = sub {};
+ __PACKAGE__->meta->make_immutable;
+}
+
+my $f = FooBar->new( name => 'SUSAN' );
+
+is( $f->DESTROY, 'SUSAN', 'Did moose overload DESTROY?' );
+
+done_testing;
diff --git a/t/immutable/immutable_meta_class.t b/t/immutable/immutable_meta_class.t
new file mode 100644
index 0000000..3c52d92
--- /dev/null
+++ b/t/immutable/immutable_meta_class.t
@@ -0,0 +1,25 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+
+{
+ package My::Meta;
+
+ use Moose;
+
+ extends 'Moose::Meta::Class';
+
+ has 'meta_size' => (
+ is => 'rw',
+ isa => 'Int',
+ );
+}
+
+is( exception {
+ My::Meta->meta()->make_immutable(debug => 0)
+}, undef, '... can make a meta class immutable' );
+
+done_testing;
diff --git a/t/immutable/immutable_metaclass_with_traits.t b/t/immutable/immutable_metaclass_with_traits.t
new file mode 100644
index 0000000..466a7c0
--- /dev/null
+++ b/t/immutable/immutable_metaclass_with_traits.t
@@ -0,0 +1,36 @@
+use strict;
+use warnings;
+use Test::More;
+
+{
+ package FooTrait;
+ use Moose::Role;
+}
+{
+ package Foo;
+ use Moose -traits => ['FooTrait'];
+}
+
+is(Class::MOP::class_of('Foo'), Foo->meta,
+ "class_of and ->meta are the same on Foo");
+my $meta = Foo->meta;
+is(Class::MOP::class_of($meta), $meta->meta,
+ "class_of and ->meta are the same on Foo's metaclass");
+isa_ok(Class::MOP::class_of($meta), 'Moose::Meta::Class');
+isa_ok($meta->meta, 'Moose::Meta::Class');
+ok($meta->is_mutable, "class is mutable");
+ok(Class::MOP::class_of($meta)->is_mutable, "metaclass is mutable");
+ok($meta->meta->does_role('FooTrait'), "does the trait");
+Foo->meta->make_immutable;
+is(Class::MOP::class_of('Foo'), Foo->meta,
+ "class_of and ->meta are the same on Foo (immutable)");
+$meta = Foo->meta;
+isa_ok($meta->meta, 'Moose::Meta::Class');
+ok($meta->is_immutable, "class is immutable");
+ok($meta->meta->is_immutable, "metaclass is immutable (immutable class)");
+is(Class::MOP::class_of($meta), $meta->meta,
+ "class_of and ->meta are the same on Foo's metaclass (immutable)");
+isa_ok(Class::MOP::class_of($meta), 'Moose::Meta::Class');
+ok($meta->meta->does_role('FooTrait'), "still does the trait after immutable");
+
+done_testing;
diff --git a/t/immutable/immutable_moose.t b/t/immutable/immutable_moose.t
new file mode 100644
index 0000000..d77ea37
--- /dev/null
+++ b/t/immutable/immutable_moose.t
@@ -0,0 +1,84 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+use Moose::Meta::Role;
+
+
+{
+ package FooRole;
+ our $VERSION = '0.01';
+ sub foo {'FooRole::foo'}
+}
+
+{
+ package Foo;
+ use Moose;
+
+ #two checks because the inlined methods are different when
+ #there is a TC present.
+ has 'foos' => ( is => 'ro', lazy_build => 1 );
+ has 'bars' => ( isa => 'Str', is => 'ro', lazy_build => 1 );
+ has 'bazes' => ( isa => 'Str', is => 'ro', builder => '_build_bazes' );
+ sub _build_foos {"many foos"}
+ sub _build_bars {"many bars"}
+ sub _build_bazes {"many bazes"}
+}
+
+{
+ my $foo_role = Moose::Meta::Role->initialize('FooRole');
+ my $meta = Foo->meta;
+
+ is( exception { Foo->new }, undef, "lazy_build works" );
+ is( Foo->new->foos, 'many foos',
+ "correct value for 'foos' before inlining constructor" );
+ is( Foo->new->bars, 'many bars',
+ "correct value for 'bars' before inlining constructor" );
+ is( Foo->new->bazes, 'many bazes',
+ "correct value for 'bazes' before inlining constructor" );
+ is( exception { $meta->make_immutable }, undef, "Foo is imutable" );
+ is( exception { $meta->identifier }, undef, "->identifier on metaclass lives" );
+ isnt( exception { $meta->add_role($foo_role) }, undef, "Add Role is locked" );
+ is( exception { Foo->new }, undef, "Inlined constructor works with lazy_build" );
+ is( Foo->new->foos, 'many foos',
+ "correct value for 'foos' after inlining constructor" );
+ is( Foo->new->bars, 'many bars',
+ "correct value for 'bars' after inlining constructor" );
+ is( Foo->new->bazes, 'many bazes',
+ "correct value for 'bazes' after inlining constructor" );
+ is( exception { $meta->make_mutable }, undef, "Foo is mutable" );
+ is( exception { $meta->add_role($foo_role) }, undef, "Add Role is unlocked" );
+
+}
+
+{
+ package Bar;
+
+ use Moose;
+
+ sub BUILD { 'bar' }
+}
+
+{
+ package Baz;
+
+ use Moose;
+
+ extends 'Bar';
+
+ sub BUILD { 'baz' }
+}
+
+is( exception { Bar->meta->make_immutable }, undef, 'Immutable meta with single BUILD' );
+
+is( exception { Baz->meta->make_immutable }, undef, 'Immutable meta with multiple BUILDs' );
+
+=pod
+
+Nothing here yet, but soon :)
+
+=cut
+
+done_testing;
diff --git a/t/immutable/immutable_roundtrip.t b/t/immutable/immutable_roundtrip.t
new file mode 100644
index 0000000..2f1bceb
--- /dev/null
+++ b/t/immutable/immutable_roundtrip.t
@@ -0,0 +1,33 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Requires 'Test::Output'; # skip all if not installed
+
+{
+ package Foo;
+ use Moose;
+ __PACKAGE__->meta->make_immutable;
+}
+
+{
+ package Bar;
+ use Moose;
+
+ extends 'Foo';
+
+ __PACKAGE__->meta->make_immutable;
+ __PACKAGE__->meta->make_mutable;
+
+
+ # This actually is testing for a bug in Class::MOP that cause
+ # Moose::Meta::Method::Constructor to spit out a warning when it
+ # shouldn't have done so. The bug was fixed in CMOP 0.75.
+ ::stderr_unlike(
+ sub { Bar->meta->make_immutable },
+ qr/Not inlining a constructor/,
+ 'no warning that Bar may not have an inlined constructor'
+ );
+}
+
+done_testing;
diff --git a/t/immutable/immutable_trigger_from_constructor.t b/t/immutable/immutable_trigger_from_constructor.t
new file mode 100644
index 0000000..799cecc
--- /dev/null
+++ b/t/immutable/immutable_trigger_from_constructor.t
@@ -0,0 +1,36 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+
+{
+ package AClass;
+
+ use Moose;
+
+ has 'foo' => (is => 'rw', isa => 'Maybe[Str]', trigger => sub {
+ die "Pulling the Foo trigger\n"
+ });
+
+ has 'bar' => (is => 'rw', isa => 'Maybe[Str]');
+
+ has 'baz' => (is => 'rw', isa => 'Maybe[Str]', trigger => sub {
+ die "Pulling the Baz trigger\n"
+ });
+
+ __PACKAGE__->meta->make_immutable; #(debug => 1);
+
+ no Moose;
+}
+
+eval { AClass->new(foo => 'bar') };
+like ($@, qr/^Pulling the Foo trigger/, "trigger from immutable constructor");
+
+eval { AClass->new(baz => 'bar') };
+like ($@, qr/^Pulling the Baz trigger/, "trigger from immutable constructor");
+
+is( exception { AClass->new(bar => 'bar') }, undef, '... no triggers called' );
+
+done_testing;
diff --git a/t/immutable/inline_close_over.t b/t/immutable/inline_close_over.t
new file mode 100644
index 0000000..3b01504
--- /dev/null
+++ b/t/immutable/inline_close_over.t
@@ -0,0 +1,361 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Requires qw(Data::Visitor PadWalker);
+
+use Class::Load 'load_class';
+use Try::Tiny;
+
+my $can_partialdump = try {
+ load_class('Devel::PartialDump', { -version => 0.14 }); 1;
+};
+
+{
+ package Test::Visitor;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+ extends 'Data::Visitor';
+
+ has closed_over => (
+ traits => ['Array'],
+ isa => 'ArrayRef',
+ default => sub { [] },
+ handles => {
+ add_closed_over => 'push',
+ closed_over => 'elements',
+ pass => 'is_empty',
+ },
+ );
+
+ before visit_code => sub {
+ my $self = shift;
+ my ($code) = @_;
+ my $closed_over = PadWalker::closed_over($code);
+ $self->visit_ref($closed_over);
+ };
+
+ after visit => sub {
+ my $self = shift;
+ my ($thing) = @_;
+
+ $self->add_closed_over($thing)
+ unless $self->_is_okay_to_close_over($thing);
+ };
+
+ sub _is_okay_to_close_over {
+ my $self = shift;
+ my ($thing) = @_;
+
+ match_on_type $thing => (
+ 'RegexpRef' => sub { 1 },
+ 'Object' => sub { 0 },
+ 'GlobRef' => sub { 0 },
+ 'FileHandle' => sub { 0 },
+ 'Any' => sub { 1 },
+ );
+ }
+}
+
+sub close_over_ok {
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my ($package, $method) = @_;
+ my $visitor = Test::Visitor->new;
+ my $code = $package->meta->find_method_by_name($method)->body;
+ $visitor->visit($code);
+ if ($visitor->pass) {
+ pass("${package}::${method} didn't close over anything complicated");
+ }
+ else {
+ fail("${package}::${method} closed over some stuff:");
+ my @closed_over = $visitor->closed_over;
+ for my $i (1..10) {
+ last unless @closed_over;
+ my $closed_over = shift @closed_over;
+ if ($can_partialdump) {
+ $closed_over = Devel::PartialDump->new->dump($closed_over);
+ }
+ diag($closed_over);
+ }
+ diag("... and " . scalar(@closed_over) . " more")
+ if @closed_over;
+ }
+}
+
+{
+ package Foo;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ has foo => (
+ is => 'ro',
+ isa => 'Str',
+ );
+
+ has bar => (
+ is => 'ro',
+ isa => 'Int',
+ default => 1,
+ );
+
+ has baz => (
+ is => 'rw',
+ isa => 'ArrayRef[Num]',
+ default => sub { [ 1.2 ] },
+ trigger => sub { warn "blah" },
+ );
+
+ subtype 'Thing',
+ as 'Int',
+ where { $_ < 5 },
+ message { "must be less than 5" };
+ has quux => (
+ is => 'rw',
+ isa => 'Thing',
+ predicate => 'has_quux',
+ clearer => 'clear_quux',
+ );
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+close_over_ok('Foo', $_) for qw(new foo bar baz quux has_quux clear_quux);
+
+{
+ package Foo::Sub;
+ use Moose;
+ extends 'Foo';
+
+ around foo => sub {
+ my $orig = shift;
+ my $self = shift;
+ $self->$orig(@_);
+ };
+
+ after bar => sub { };
+ before baz => sub { };
+ override quux => sub { super };
+
+ sub blah { inner }
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+close_over_ok('Foo::Sub', $_) for qw(new foo bar baz quux blah);
+
+{
+ package Foo::Sub::Sub;
+ use Moose;
+ extends 'Foo::Sub';
+
+ augment blah => { inner };
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+close_over_ok('Foo::Sub::Sub', $_) for qw(new blah);
+
+{
+ my %handles = (
+ Array => {
+ count => 'count',
+ elements => 'elements',
+ is_empty => 'is_empty',
+ push => 'push',
+ push_curried => [ push => 42, 84 ],
+ unshift => 'unshift',
+ unshift_curried => [ unshift => 42, 84 ],
+ pop => 'pop',
+ shift => 'shift',
+ get => 'get',
+ get_curried => [ get => 1 ],
+ set => 'set',
+ set_curried_1 => [ set => 1 ],
+ set_curried_2 => [ set => ( 1, 98 ) ],
+ accessor => 'accessor',
+ accessor_curried_1 => [ accessor => 1 ],
+ accessor_curried_2 => [ accessor => ( 1, 90 ) ],
+ clear => 'clear',
+ delete => 'delete',
+ delete_curried => [ delete => 1 ],
+ insert => 'insert',
+ insert_curried => [ insert => ( 1, 101 ) ],
+ splice => 'splice',
+ splice_curried_1 => [ splice => 1 ],
+ splice_curried_2 => [ splice => 1, 2 ],
+ splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ],
+ sort => 'sort',
+ sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ],
+ sort_in_place => 'sort_in_place',
+ sort_in_place_curried =>
+ [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ],
+ map => 'map',
+ map_curried => [ map => ( sub { $_ + 1 } ) ],
+ grep => 'grep',
+ grep_curried => [ grep => ( sub { $_ < 5 } ) ],
+ first => 'first',
+ first_curried => [ first => ( sub { $_ % 2 } ) ],
+ join => 'join',
+ join_curried => [ join => '-' ],
+ shuffle => 'shuffle',
+ uniq => 'uniq',
+ reduce => 'reduce',
+ reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ],
+ natatime => 'natatime',
+ natatime_curried => [ natatime => 2 ],
+ },
+ Hash => {
+ option_accessor => 'accessor',
+ quantity => [ accessor => 'quantity' ],
+ clear_options => 'clear',
+ num_options => 'count',
+ delete_option => 'delete',
+ is_defined => 'defined',
+ options_elements => 'elements',
+ has_option => 'exists',
+ get_option => 'get',
+ has_no_options => 'is_empty',
+ keys => 'keys',
+ values => 'values',
+ key_value => 'kv',
+ set_option => 'set',
+ },
+ Counter => {
+ inc_counter => 'inc',
+ inc_counter_2 => [ inc => 2 ],
+ dec_counter => 'dec',
+ dec_counter_2 => [ dec => 2 ],
+ reset_counter => 'reset',
+ set_counter => 'set',
+ set_counter_42 => [ set => 42 ],
+ },
+ Number => {
+ abs => 'abs',
+ add => 'add',
+ inc => [ add => 1 ],
+ div => 'div',
+ cut_in_half => [ div => 2 ],
+ mod => 'mod',
+ odd => [ mod => 2 ],
+ mul => 'mul',
+ set => 'set',
+ sub => 'sub',
+ dec => [ sub => 1 ],
+ },
+ Bool => {
+ illuminate => 'set',
+ darken => 'unset',
+ flip_switch => 'toggle',
+ is_dark => 'not',
+ },
+ String => {
+ inc => 'inc',
+ append => 'append',
+ append_curried => [ append => '!' ],
+ prepend => 'prepend',
+ prepend_curried => [ prepend => '-' ],
+ replace => 'replace',
+ replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ],
+ chop => 'chop',
+ chomp => 'chomp',
+ clear => 'clear',
+ match => 'match',
+ match_curried => [ match => qr/\D/ ],
+ length => 'length',
+ substr => 'substr',
+ substr_curried_1 => [ substr => (1) ],
+ substr_curried_2 => [ substr => ( 1, 3 ) ],
+ substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ],
+ },
+ Code => {
+ execute => 'execute',
+ execute_method => 'execute_method',
+ },
+ );
+
+ my %isa = (
+ Array => 'ArrayRef[Str]',
+ Hash => 'HashRef[Int]',
+ Counter => 'Int',
+ Number => 'Num',
+ Bool => 'Bool',
+ String => 'Str',
+ Code => 'CodeRef',
+ );
+
+ my %default = (
+ Array => [],
+ Hash => {},
+ Counter => 0,
+ Number => 0.0,
+ Bool => 1,
+ String => '',
+ Code => sub { },
+ );
+
+ for my $trait (keys %default) {
+ my $class_name = "Native::$trait";
+ my $handles = $handles{$trait};
+ my $attr_class = Moose::Util::with_traits(
+ 'Moose::Meta::Attribute',
+ "Moose::Meta::Attribute::Native::Trait::$trait",
+ );
+ Moose::Meta::Class->create(
+ $class_name,
+ superclasses => ['Moose::Object'],
+ attributes => [
+ $attr_class->new(
+ 'nonlazy',
+ is => 'ro',
+ isa => $isa{$trait},
+ default => sub { $default{$trait} },
+ handles => {
+ map {; "nonlazy_$_" => $handles->{$_} } keys %$handles
+ },
+ ),
+ $attr_class->new(
+ 'lazy',
+ is => 'ro',
+ isa => $isa{$trait},
+ lazy => 1,
+ default => sub { $default{$trait} },
+ handles => {
+ map {; "lazy_$_" => $handles->{$_} } keys %$handles
+ },
+ ),
+ ],
+ );
+ close_over_ok($class_name, $_) for (
+ 'new',
+ map {; "nonlazy_$_", "lazy_$_" } keys %$handles
+ );
+ }
+}
+
+{
+ package WithInitializer;
+ use Moose;
+
+ has foo => (
+ is => 'ro',
+ isa => 'Str',
+ initializer => sub { },
+ );
+
+ has bar => (
+ is => 'ro',
+ isa => 'Str',
+ lazy => 1,
+ default => sub { 'a' },
+ initializer => sub { },
+ );
+
+ __PACKAGE__->meta->make_immutable;
+}
+
+close_over_ok('WithInitializer', 'foo');
+{ local $TODO = "initializer still closes over things";
+close_over_ok('WithInitializer', $_) for qw(new bar);
+}
+
+done_testing;
diff --git a/t/immutable/inline_fallbacks.t b/t/immutable/inline_fallbacks.t
new file mode 100644
index 0000000..362d60e
--- /dev/null
+++ b/t/immutable/inline_fallbacks.t
@@ -0,0 +1,70 @@
+use strict;
+use warnings;
+use Test::More;
+
+{
+ package Foo;
+ use Moose;
+ has foo => (is => 'ro');
+}
+
+{
+ package Foo::Sub;
+ use Moose;
+ extends 'Foo';
+ has bar => (is => 'ro');
+}
+
+{
+ my $foo = Foo::Sub->new(foo => 12, bar => 25);
+ is($foo->foo, 12, 'got right value for foo');
+ is($foo->bar, 25, 'got right value for bar');
+}
+
+Foo->meta->make_immutable;
+
+{
+ package Foo::Sub2;
+ use Moose;
+ extends 'Foo';
+ has baz => (is => 'ro');
+ # not making immutable, inheriting Foo's inlined constructor
+}
+
+{
+ my $foo = Foo::Sub2->new(foo => 42, baz => 27);
+ is($foo->foo, 42, 'got right value for foo');
+ is($foo->baz, 27, 'got right value for baz');
+}
+
+my $BAR = 0;
+{
+ package Bar;
+ use Moose;
+}
+
+{
+ package Bar::Sub;
+ use Moose;
+ extends 'Bar';
+ sub DEMOLISH { $BAR++ }
+}
+
+Bar::Sub->new;
+is($BAR, 1, 'DEMOLISH in subclass was called');
+$BAR = 0;
+
+Bar->meta->make_immutable;
+
+{
+ package Bar::Sub2;
+ use Moose;
+ extends 'Bar';
+ sub DEMOLISH { $BAR++ }
+ # not making immutable, inheriting Bar's inlined destructor
+}
+
+Bar::Sub2->new;
+is($BAR, 1, 'DEMOLISH in subclass was called');
+
+done_testing;
diff --git a/t/immutable/inlined_constructors_n_types.t b/t/immutable/inlined_constructors_n_types.t
new file mode 100644
index 0000000..3df1fb0
--- /dev/null
+++ b/t/immutable/inlined_constructors_n_types.t
@@ -0,0 +1,60 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+=pod
+
+This tests to make sure that the inlined constructor
+has all the type constraints in order, even in the
+cases when there is no type constraint available, such
+as with a Class::MOP::Attribute object.
+
+=cut
+
+{
+ package Foo;
+ use Moose;
+ use Moose::Util::TypeConstraints;
+
+ coerce 'Int' => from 'Str' => via { length $_ ? $_ : 69 };
+
+ has 'foo' => (is => 'rw', isa => 'Int');
+ has 'baz' => (is => 'rw', isa => 'Int');
+ has 'zot' => (is => 'rw', isa => 'Int', init_arg => undef);
+ has 'moo' => (is => 'rw', isa => 'Int', coerce => 1, default => '', required => 1);
+ has 'boo' => (is => 'rw', isa => 'Int', coerce => 1, builder => '_build_boo', required => 1);
+
+ sub _build_boo { '' }
+
+ Foo->meta->add_attribute(
+ Class::MOP::Attribute->new(
+ 'bar' => (
+ accessor => 'bar',
+ )
+ )
+ );
+}
+
+for (1..2) {
+ my $is_immutable = Foo->meta->is_immutable;
+ my $mutable_string = $is_immutable ? 'immutable' : 'mutable';
+ is( exception {
+ my $f = Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => 4);
+ is($f->moo, 69, "Type coercion works as expected on default ($mutable_string)");
+ is($f->boo, 69, "Type coercion works as expected on builder ($mutable_string)");
+ }, undef, "... this passes the constuctor correctly ($mutable_string)" );
+
+ is( exception {
+ Foo->new(foo => 10, bar => "Hello World", baz => 10, zot => "not an int");
+ }, undef, "... the constructor doesn't care about 'zot' ($mutable_string)" );
+
+ isnt( exception {
+ Foo->new(foo => "Hello World", bar => 100, baz => "Hello World");
+ }, undef, "... this fails the constuctor correctly ($mutable_string)" );
+
+ Foo->meta->make_immutable(debug => 0) unless $is_immutable;
+}
+
+done_testing;
diff --git a/t/immutable/multiple_demolish_inline.t b/t/immutable/multiple_demolish_inline.t
new file mode 100644
index 0000000..e9727ac
--- /dev/null
+++ b/t/immutable/multiple_demolish_inline.t
@@ -0,0 +1,45 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+
+
+{
+ package Foo;
+ use Moose;
+
+ has 'foo' => (is => 'rw', isa => 'Int');
+
+ sub DEMOLISH { }
+}
+
+{
+ package Bar;
+ use Moose;
+
+ extends qw(Foo);
+ has 'bar' => (is => 'rw', isa => 'Int');
+
+ sub DEMOLISH { }
+}
+
+is( exception {
+ Bar->new();
+}, undef, 'Bar->new()' );
+
+is( exception {
+ Bar->meta->make_immutable;
+}, undef, 'Bar->meta->make_immutable' );
+
+is( Bar->meta->get_method('DESTROY')->package_name, 'Bar',
+ 'Bar has a DESTROY method in the Bar class (not inherited)' );
+
+is( exception {
+ Foo->meta->make_immutable;
+}, undef, 'Foo->meta->make_immutable' );
+
+is( Foo->meta->get_method('DESTROY')->package_name, 'Foo',
+ 'Foo has a DESTROY method in the Bar class (not inherited)' );
+
+done_testing;
View Lorry Controller Status