From: Jesse Luehrs Date: Sat, 30 Apr 2011 03:23:24 +0000 (-0500) Subject: add the (failing) mx-nonmoose test suite X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2279503f62b9c11d69d52465f0fff1fd3bd1ed2e;p=gitmo%2FMoose.git add the (failing) mx-nonmoose test suite --- diff --git a/t/nonmoose/BUILD.t b/t/nonmoose/BUILD.t new file mode 100644 index 0000000..b1c3de8 --- /dev/null +++ b/t/nonmoose/BUILD.t @@ -0,0 +1,69 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +{ + package Foo; + + sub new { + my $class = shift; + bless { foo => 'FOO' }, $class; + } +} + +{ + package Foo::Moose; + use Moose; + + extends 'Foo'; + + has class => ( + is => 'rw', + ); + + has accum => ( + is => 'rw', + isa => 'Str', + default => '', + ); + + sub BUILD { + my $self = shift; + $self->class(ref $self); + $self->accum($self->accum . 'a'); + } +} + +{ + package Foo::Moose::Sub; + use Moose; + + extends 'Foo::Moose'; + + has bar => ( + is => 'rw', + ); + + sub BUILD { + my $self = shift; + $self->bar('BAR'); + $self->accum($self->accum . 'b'); + } +} + +{ + my $foo_moose = Foo::Moose->new; + is($foo_moose->class, 'Foo::Moose', 'BUILD method called properly'); + is($foo_moose->accum, 'a', 'BUILD method called properly'); +} + +{ + my $foo_moose_sub = Foo::Moose::Sub->new; + is($foo_moose_sub->class, 'Foo::Moose::Sub', 'parent BUILD method called'); + is($foo_moose_sub->bar, 'BAR', 'child BUILD method called'); + is($foo_moose_sub->accum, 'ab', + 'BUILD methods called in the correct order'); +} + +done_testing; diff --git a/t/nonmoose/BUILDARGS.t b/t/nonmoose/BUILDARGS.t new file mode 100644 index 0000000..82d8bbf --- /dev/null +++ b/t/nonmoose/BUILDARGS.t @@ -0,0 +1,43 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Foo; + + sub new { + my $class = shift; + bless { name => $_[0] }, $class; + } + + sub name { shift->{name} } +} + +{ + package Foo::Moose; + use Moose; + + extends 'Foo'; + + has foo => ( + is => 'rw', + ); + + sub BUILDARGS { + my $class = shift; + # remove the argument that's only for passing to the superclass + # constructor + shift; + return $class->SUPER::BUILDARGS(@_); + } +} + +with_immutable { + my $foo = Foo::Moose->new('bar', foo => 'baz'); + is($foo->name, 'bar', 'superclass constructor gets the right args'); + is($foo->foo, 'baz', 'subclass constructor gets the right args'); +} 'Foo::Moose'; + +done_testing; diff --git a/t/nonmoose/FOREIGNBUILDARGS.t b/t/nonmoose/FOREIGNBUILDARGS.t new file mode 100644 index 0000000..b6ea979 --- /dev/null +++ b/t/nonmoose/FOREIGNBUILDARGS.t @@ -0,0 +1,78 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Foo; + + sub new { + my $class = shift; + bless { foo_base => $_[0] }, $class; + } + + sub foo_base { shift->{foo_base} } +} + +{ + package Foo::Moose; + use Moose; + + extends 'Foo'; + + has foo => ( + is => 'rw', + ); + + sub FOREIGNBUILDARGS { + my $class = shift; + my %args = @_; + return "$args{foo}_base"; + } +} + +{ + package Bar::Moose; + use Moose; + + extends 'Foo'; + + has bar => ( + is => 'rw', + ); + + sub FOREIGNBUILDARGS { + my $class = shift; + return "$_[0]_base"; + } + + sub BUILDARGS { + my $class = shift; + return { bar => shift }; + } +} + +{ + package Baz::Moose; + use Moose; + extends 'Bar::Moose'; + + has baz => ( + is => 'rw', + ); +} + +with_immutable { + my $foo = Foo::Moose->new(foo => 'bar'); + is($foo->foo, 'bar', 'subclass constructor gets the right args'); + is($foo->foo_base, 'bar_base', 'subclass constructor gets the right args'); + my $bar = Bar::Moose->new('baz'); + is($bar->bar, 'baz', 'subclass constructor gets the right args'); + is($bar->foo_base, 'baz_base', 'subclass constructor gets the right args'); + my $baz = Baz::Moose->new('bazbaz'); + is($baz->bar, 'bazbaz', 'extensions of extensions of the nonmoose class respect BUILDARGS'); + is($baz->foo_base, 'bazbaz_base', 'extensions of extensions of the nonmoose class respect FOREIGNBUILDARGS'); +} qw(Foo::Moose Bar::Moose Baz::Moose); + +done_testing; diff --git a/t/nonmoose/attrs.t b/t/nonmoose/attrs.t new file mode 100644 index 0000000..2d98536 --- /dev/null +++ b/t/nonmoose/attrs.t @@ -0,0 +1,42 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +{ + package Foo; + + sub new { + my $class = shift; + bless { @_ }, $class; + } + + sub foo { + my $self = shift; + return $self->{foo} unless @_; + $self->{foo} = shift; + } +} + +{ + package Foo::Moose; + use Moose; + + extends 'Foo'; + + has bar => ( + is => 'rw', + ); +} + +{ + my $foo_moose = Foo::Moose->new(foo => 'FOO', bar => 'BAR'); + is($foo_moose->foo, 'FOO', 'foo set in constructor'); + is($foo_moose->bar, 'BAR', 'bar set in constructor'); + $foo_moose->foo('BAZ'); + $foo_moose->bar('QUUX'); + is($foo_moose->foo, 'BAZ', 'foo set by accessor'); + is($foo_moose->bar, 'QUUX', 'bar set by accessor'); +} + +done_testing; diff --git a/t/nonmoose/basic.t b/t/nonmoose/basic.t new file mode 100644 index 0000000..7f840d1 --- /dev/null +++ b/t/nonmoose/basic.t @@ -0,0 +1,37 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +{ + package Foo; + + sub new { + my $class = shift; + bless { _class => $class }, $class; + } +} + +{ + package Foo::Moose; + use Moose; + + extends 'Foo'; +} + +{ + my $foo = Foo->new; + my $foo_moose = Foo::Moose->new; + isa_ok($foo, 'Foo'); + is($foo->{_class}, 'Foo', 'Foo gets the correct class'); + isa_ok($foo_moose, 'Foo::Moose'); + isa_ok($foo_moose, 'Foo'); + isa_ok($foo_moose, 'Moose::Object'); + is($foo_moose->{_class}, 'Foo::Moose', 'Foo::Moose gets the correct class'); + my $meta = Foo::Moose->meta; + ok($meta->has_method('new'), 'Foo::Moose has its own constructor'); + my $cc_meta = $meta->constructor_class->meta; + isa_ok($cc_meta, 'Moose::Meta::Class'); +} + +done_testing; diff --git a/t/nonmoose/buggy-constructor-inlining.t b/t/nonmoose/buggy-constructor-inlining.t new file mode 100644 index 0000000..e48d249 --- /dev/null +++ b/t/nonmoose/buggy-constructor-inlining.t @@ -0,0 +1,42 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +my ($Foo, $Bar, $Baz); +{ + package Foo; + + sub new { $Foo++; bless {}, shift } +} + +{ + package Bar; + use Moose; + + extends 'Foo'; + + sub BUILD { $Bar++ } + + __PACKAGE__->meta->make_immutable; +} + +{ + package Baz; + use Moose; + + extends 'Bar'; + + sub BUILD { $Baz++ } +} + +with_immutable { + ($Foo, $Bar, $Baz) = (0, 0, 0); + Baz->new; + is($Foo, 1, "Foo->new is called once"); + is($Bar, 1, "Bar->BUILD is called once"); + is($Baz, 1, "Baz->BUILD is called once"); +} 'Baz'; + +done_testing; diff --git a/t/nonmoose/buggy-constructors.t b/t/nonmoose/buggy-constructors.t new file mode 100644 index 0000000..153cf05 --- /dev/null +++ b/t/nonmoose/buggy-constructors.t @@ -0,0 +1,90 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + package Foo; + + sub new { bless {}, shift } +} + +{ + package Foo::Sub; + use Moose; + + extends 'Foo'; +} + +with_immutable { + my $foo; + is(exception { $foo = Foo::Sub->new }, undef, + "subclassing nonmoose classes with correct constructors works"); + isa_ok($foo, 'Foo'); + isa_ok($foo, 'Foo::Sub'); +} 'Foo::Sub'; + +{ + package BadFoo; + + sub new { bless {} } +} + +{ + package BadFoo::Sub; + use Moose; + + extends 'BadFoo'; +} + +with_immutable { + my $foo; + is(exception { $foo = BadFoo::Sub->new }, undef, + "subclassing nonmoose classes with incorrect constructors works"); + isa_ok($foo, 'BadFoo'); + isa_ok($foo, 'BadFoo::Sub'); +} 'BadFoo::Sub'; + +{ + package BadFoo2; + + sub new { {} } +} + +{ + package BadFoo2::Sub; + use Moose; + + extends 'BadFoo2'; +} + +with_immutable { + my $foo; + like(exception { $foo = BadFoo2::Sub->new; }, + qr/\QThe constructor for BadFoo2 did not return a blessed instance/, + "subclassing nonmoose classes with incorrect constructors dies properly"); +} 'BadFoo2::Sub'; + +{ + package BadFoo3; + + sub new { bless {}, 'Something::Else::Entirely' } +} + +{ + package BadFoo3::Sub; + use Moose; + + extends 'BadFoo3'; +} + +with_immutable { + my $foo; + like(exception { $foo = BadFoo3::Sub->new }, + qr/\QThe constructor for BadFoo3 returned an object whose class is not a parent of BadFoo3::Sub/, + "subclassing nonmoose classes with incorrect constructors dies properly"); +} 'BadFoo3::Sub'; + +done_testing; diff --git a/t/nonmoose/constructor-method-calls.t b/t/nonmoose/constructor-method-calls.t new file mode 100644 index 0000000..b5c719d --- /dev/null +++ b/t/nonmoose/constructor-method-calls.t @@ -0,0 +1,47 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +my ($foo, $foosub); +{ + package Foo; + + sub new { + my $class = shift; + my $obj = bless {}, $class; + $obj->init; + $obj; + } + + sub init { + $foo++ + } +} + +{ + package Foo::Sub; + use base 'Foo'; + + sub init { + $foosub++; + shift->SUPER::init; + } +} + +{ + package Foo::Sub::Sub; + use Moose; + + extends 'Foo::Sub'; +} + +with_immutable { + ($foo, $foosub) = (0, 0); + Foo::Sub::Sub->new; + is($foo, 1, "Foo::init called"); + is($foosub, 1, "Foo::Sub::init called"); +} 'Foo::Sub::Sub'; + +done_testing; diff --git a/t/nonmoose/constructor-name.t b/t/nonmoose/constructor-name.t new file mode 100644 index 0000000..4ad5fba --- /dev/null +++ b/t/nonmoose/constructor-name.t @@ -0,0 +1,104 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + package Foo; + + sub create { + my $class = shift; + my %params = @_; + bless { foo => ($params{foo} || 'FOO') }, $class; + } + + sub foo { shift->{foo} } +} + +{ + package Foo::Sub; + use Moose; + + extends 'Foo' => { -constructor_name => 'create' }; + + has bar => ( + is => 'ro', + isa => 'Str', + default => 'BAR', + ); +} + +with_immutable { + my $foo = Foo::Sub->create; + is($foo->foo, 'FOO', "nonmoose constructor called"); + is($foo->bar, 'BAR', "moose constructor called"); +} 'Foo::Sub'; + +{ + package Foo::BadSub; + use Moose; + + ::like( + ::exception { + extends 'Foo' => { -constructor_name => 'something_else' }; + }, + qr/You specified 'something_else' as the constructor for Foo, but Foo has no method by that name/, + "specifying an incorrect constructor name dies" + ); +} + +{ + package Foo::Mixin; + + sub thing { + return shift->foo . 'BAZ'; + } +} + +{ + package Foo::Sub2; + use Moose; + + extends 'Foo::Mixin', 'Foo' => { -constructor_name => 'create' }; + + has bar => ( + is => 'ro', + isa => 'Str', + default => 'BAR', + ); +} + +with_immutable { + my $foo = Foo::Sub2->create; + is($foo->foo, 'FOO', "nonmoose constructor called"); + is($foo->bar, 'BAR', "moose constructor called"); + is($foo->thing, 'FOOBAZ', "mixin still works"); +} 'Foo::Sub2'; + +{ + package Bar; + + sub make { + my $class = shift; + my %params = @_; + bless { baz => ($params{baz} || 'BAZ') }, $class; + } +} + +{ + package Foo::Bar::Sub; + use Moose; + + ::like( + ::exception { + extends 'Bar' => { -constructor_name => 'make' }, + 'Foo' => { -constructor_name => 'create' }; + }, + qr/You have already specified Bar::make as the parent constructor; Foo::create cannot also be the constructor/, + "can't specify two parent constructors" + ); +} + +done_testing; diff --git a/t/nonmoose/destructor.t b/t/nonmoose/destructor.t new file mode 100644 index 0000000..6899e7c --- /dev/null +++ b/t/nonmoose/destructor.t @@ -0,0 +1,32 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +my ($destroyed, $demolished); +{ + package Foo; + + sub new { bless {}, shift } + + sub DESTROY { $destroyed++ } +} + +{ + package Foo::Sub; + use Moose; + + extends 'Foo'; + + sub DEMOLISH { $demolished++ } +} + +with_immutable { + ($destroyed, $demolished) = (0, 0); + { Foo::Sub->new } + is($destroyed, 1, "non-Moose destructor called"); + is($demolished, 1, "Moose destructor called"); +} 'Foo::Sub'; + +done_testing; diff --git a/t/nonmoose/disable.t b/t/nonmoose/disable.t new file mode 100644 index 0000000..1cd464a --- /dev/null +++ b/t/nonmoose/disable.t @@ -0,0 +1,45 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +{ + package Foo; + + sub new { + my $class = shift; + bless {}, $class; + } +} + +{ + package Foo::Moose; + use Moose; + + extends 'Foo'; +} + +{ + package Foo::Moose2; + use Moose; + + extends 'Foo'; +} + +ok(Foo::Moose->meta->has_method('new'), 'Foo::Moose has a constructor'); + +{ + my $method = Foo::Moose->meta->get_method('new'); + Foo::Moose->meta->make_immutable; + isnt($method, Foo::Moose->meta->get_method('new'), + 'make_immutable replaced the constructor with an inlined version'); +} + +{ + my $method2 = Foo::Moose2->meta->get_method('new'); + Foo::Moose2->meta->make_immutable(inline_constructor => 0); + is($method2, Foo::Moose2->meta->get_method('new'), + 'make_immutable doesn\'t replace the constructor if we ask it not to'); +} + +done_testing; diff --git a/t/nonmoose/extends-moose-object.t b/t/nonmoose/extends-moose-object.t new file mode 100644 index 0000000..a5e049a --- /dev/null +++ b/t/nonmoose/extends-moose-object.t @@ -0,0 +1,34 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +{ + package Foo; + + sub new { bless {}, shift } +} + +{ + package Foo::Sub; + use Moose; + + extends 'Foo'; +} + +{ + package Bar; + use Moose; +} + +{ + package Bar::Sub; + use Moose; + + extends 'Bar'; +} + +is_deeply(\@Foo::Sub::ISA, ['Foo', 'Moose::Object'], "Moose::Object was added"); +is_deeply(\@Bar::Sub::ISA, ['Bar'], "Moose::Object wasn't added"); + +done_testing; diff --git a/t/nonmoose/extends-version.t b/t/nonmoose/extends-version.t new file mode 100644 index 0000000..5aa3a08 --- /dev/null +++ b/t/nonmoose/extends-version.t @@ -0,0 +1,23 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package Foo; + + our $VERSION = '0.02'; + + sub new { bless {}, shift } +} + +{ + package Bar; + use Moose; + + ::is(::exception { extends 'Foo' => { -version => '0.02' } }, undef, + "specifying arguments to superclasses doesn't break"); +} + +done_testing; diff --git a/t/nonmoose/hashref-constructor.t b/t/nonmoose/hashref-constructor.t new file mode 100644 index 0000000..60b9ee1 --- /dev/null +++ b/t/nonmoose/hashref-constructor.t @@ -0,0 +1,66 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package Foo; + + sub new { + my $class = shift; + bless { ref($_[0]) ? %{$_[0]} : @_ }, $class; + } + + sub foo { + my $self = shift; + $self->{foo}; + } +} + +{ + package Bar; + use Moose; + + extends 'Foo'; + + has _bar => ( + init_arg => 'bar', + reader => 'bar', + ); + + __PACKAGE__->meta->make_immutable; +} + +{ + package Baz; + use Moose; + + extends 'Bar'; + + has _baz => ( + init_arg => 'baz', + reader => 'baz', + ); +} + +{ + my $baz; + is(exception { $baz = Baz->new( foo => 1, bar => 2, baz => 3 ) }, undef, + "constructor lives"); + is($baz->foo, 1, "foo set"); + is($baz->bar, 2, "bar set"); + is($baz->baz, 3, "baz set"); + +} + +{ + my $baz; + is(exception { $baz = Baz->new({foo => 1, bar => 2, baz => 3}) }, undef, + "constructor lives (hashref)"); + is($baz->foo, 1, "foo set (hashref)"); + is($baz->bar, 2, "bar set (hashref)"); + is($baz->baz, 3, "baz set (hashref)"); +} + +done_testing; diff --git a/t/nonmoose/immutable.t b/t/nonmoose/immutable.t new file mode 100644 index 0000000..860d9de --- /dev/null +++ b/t/nonmoose/immutable.t @@ -0,0 +1,50 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +{ + package Foo; + + sub new { + my $class = shift; + bless { @_ }, $class; + } + + sub foo { + my $self = shift; + return $self->{foo} unless @_; + $self->{foo} = shift; + } + + sub baz { 'Foo' } + + sub quux { ref(shift) } +} + +{ + package Foo::Moose; + use Moose; + + extends 'Foo'; + + has bar => ( + is => 'rw', + ); + + __PACKAGE__->meta->make_immutable; +} + +{ + my $foo_moose = Foo::Moose->new(foo => 'FOO', bar => 'BAR'); + is($foo_moose->foo, 'FOO', 'foo set in constructor'); + is($foo_moose->bar, 'BAR', 'bar set in constructor'); + $foo_moose->foo('BAZ'); + $foo_moose->bar('QUUX'); + is($foo_moose->foo, 'BAZ', 'foo set by accessor'); + is($foo_moose->bar, 'QUUX', 'bar set by accessor'); + is($foo_moose->baz, 'Foo', 'baz method'); + is($foo_moose->quux, 'Foo::Moose', 'quux method'); +} + +done_testing; diff --git a/t/nonmoose/methods.t b/t/nonmoose/methods.t new file mode 100644 index 0000000..5945970 --- /dev/null +++ b/t/nonmoose/methods.t @@ -0,0 +1,34 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +{ + package Foo; + + sub new { bless {}, shift } + + sub foo { 'Foo' } + + sub bar { 'Foo' } + + sub baz { ref(shift) } +} + +{ + package Foo::Moose; + use Moose; + + extends 'Foo'; + + sub bar { 'Foo::Moose' } +} + +{ + my $foo_moose = Foo::Moose->new; + is($foo_moose->foo, 'Foo', 'Foo::Moose->foo'); + is($foo_moose->bar, 'Foo::Moose', 'Foo::Moose->bar'); + is($foo_moose->baz, 'Foo::Moose', 'Foo::Moose->baz'); +} + +done_testing; diff --git a/t/nonmoose/moose.t b/t/nonmoose/moose.t new file mode 100644 index 0000000..c424502 --- /dev/null +++ b/t/nonmoose/moose.t @@ -0,0 +1,67 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +{ + package Foo; + use Moose; + + has foo => ( + is => 'ro', + default => 'FOO', + ); +} + +{ + package Foo::Sub; + use Moose; + + extends 'Foo'; +} + +{ + my $foo_sub = Foo::Sub->new; + isa_ok($foo_sub, 'Foo'); + is($foo_sub->foo, 'FOO', 'inheritance works'); + ok(!Foo::Sub->meta->has_method('new'), + 'Foo::Sub doesn\'t have its own new method'); +} + +$_->meta->make_immutable for qw(Foo Foo::Sub); + +{ + my $foo_sub = Foo::Sub->new; + isa_ok($foo_sub, 'Foo'); + is($foo_sub->foo, 'FOO', 'inheritance works (immutable)'); + ok(Foo::Sub->meta->has_method('new'), + 'Foo::Sub has its own new method (immutable)'); +} + +{ + package Foo::OtherSub; + use Moose; + + extends 'Foo'; +} + +{ + my $foo_othersub = Foo::OtherSub->new; + isa_ok($foo_othersub, 'Foo'); + is($foo_othersub->foo, 'FOO', + 'inheritance works (immutable when extending)'); + ok(!Foo::OtherSub->meta->has_method('new'), + 'Foo::OtherSub doesn\'t have its own new method (immutable when extending)'); +} + +Foo::OtherSub->meta->make_immutable; + +{ + my $foo_othersub = Foo::OtherSub->new; + isa_ok($foo_othersub, 'Foo'); + is($foo_othersub->foo, 'FOO', 'inheritance works (all immutable)'); + ok(Foo::OtherSub->meta->has_method('new'), + 'Foo::OtherSub has its own new method (all immutable)'); +} + +done_testing; diff --git a/t/nonmoose/moosex-globref.t b/t/nonmoose/moosex-globref.t new file mode 100644 index 0000000..abd27ff --- /dev/null +++ b/t/nonmoose/moosex-globref.t @@ -0,0 +1,89 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +BEGIN { + eval "use MooseX::GlobRef ()"; + plan skip_all => "MooseX::GlobRef is required for this test" if $@; +} + +# XXX: the way the IO modules are loaded means we can't just rely on cmop to +# load these properly/: +use IO::Handle; +use IO::File; + +BEGIN { + require Moose; + + package Foo::Exporter; + use Moose::Exporter; + Moose::Exporter->setup_import_methods(also => ['Moose']); + + sub init_meta { + shift; + my %options = @_; + Moose->init_meta(%options); + Moose::Util::MetaRole::apply_metaroles( + for => $options{for_class}, + class_metaroles => { + instance => + ['MooseX::GlobRef::Role::Meta::Instance'], + }, + ); + return Class::MOP::class_of($options{for_class}); + } +} + +{ + package IO::Handle::Moose; + BEGIN { Foo::Exporter->import } + extends 'IO::Handle'; + + has bar => ( + is => 'rw', + isa => 'Str', + ); + + sub FOREIGNBUILDARGS { return } +} + +{ + package IO::File::Moose; + BEGIN { Foo::Exporter->import } + extends 'IO::File'; + + has baz => ( + is => 'rw', + isa => 'Str', + ); + + sub FOREIGNBUILDARGS { return } +} + +with_immutable { + my $handle = IO::Handle::Moose->new(bar => 'BAR'); + is($handle->bar, 'BAR', 'moose accessor works properly'); + $handle->bar('RAB'); + is($handle->bar, 'RAB', 'moose accessor works properly (setting)'); +} 'IO::Handle::Moose'; + +with_immutable { + SKIP: { + my $fh = IO::File::Moose->new(baz => 'BAZ'); + open $fh, "+>", undef + or skip "couldn't open a temporary file", 3; + is($fh->baz, 'BAZ', "accessor works"); + $fh->baz('ZAB'); + is($fh->baz, 'ZAB', "accessor works (writing)"); + $fh->print("foo\n"); + print $fh "bar\n"; + $fh->seek(0, 0); + my $buf; + $fh->read($buf, 8); + is($buf, "foo\nbar\n", "filehandle still works as normal"); + } +} 'IO::File::Moose'; + +done_testing; diff --git a/t/nonmoose/moosex-insideout.t b/t/nonmoose/moosex-insideout.t new file mode 100644 index 0000000..135575b --- /dev/null +++ b/t/nonmoose/moosex-insideout.t @@ -0,0 +1,83 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +BEGIN { + eval "use MooseX::InsideOut 0.100 ()"; + plan skip_all => "MooseX::InsideOut is required for this test" if $@; +} + +BEGIN { + require Moose; + + package Foo::Exporter; + use Moose::Exporter; + Moose::Exporter->setup_import_methods(also => ['Moose']); + + sub init_meta { + shift; + my %options = @_; + Moose->init_meta(%options); + Moose::Util::MetaRole::apply_metaroles( + for => $options{for_class}, + class_metaroles => { + instance => + ['MooseX::InsideOut::Role::Meta::Instance'], + }, + ); + return Class::MOP::class_of($options{for_class}); + } +} + +{ + package Foo; + + sub new { + my $class = shift; + bless [$_[0]], $class; + } + + sub foo { + my $self = shift; + $self->[0] = shift if @_; + $self->[0]; + } +} + +{ + package Foo::Moose; + BEGIN { Foo::Exporter->import } + extends 'Foo'; + + has bar => ( + is => 'rw', + isa => 'Str', + ); + + sub BUILDARGS { + my $self = shift; + shift; + return $self->SUPER::BUILDARGS(@_); + } +} + +{ + package Foo::Moose::Sub; + use base 'Foo::Moose'; +} + +with_immutable { + my $foo = Foo::Moose->new('FOO', bar => 'BAR'); + is($foo->foo, 'FOO', 'base class accessor works'); + is($foo->bar, 'BAR', 'subclass accessor works'); + $foo->foo('OOF'); + $foo->bar('RAB'); + is($foo->foo, 'OOF', 'base class accessor works (setting)'); + is($foo->bar, 'RAB', 'subclass accessor works (setting)'); + my $sub_foo = eval { Foo::Moose::Sub->new(FOO => bar => 'AHOY') }; + is(eval { $sub_foo->bar }, 'AHOY', 'subclass constructor works'); +} 'Foo::Moose'; + +done_testing; diff --git a/t/nonmoose/multi-level.t b/t/nonmoose/multi-level.t new file mode 100644 index 0000000..cb6e062 --- /dev/null +++ b/t/nonmoose/multi-level.t @@ -0,0 +1,69 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +{ + package Foo; + + sub new { + my $class = shift; + bless { foo => 'FOO' }, $class; + } + + sub foo { shift->{foo} } +} + +{ + package Foo::Moose; + use Moose; + + extends 'Foo'; + + has bar => ( + is => 'ro', + default => 'BAR', + ); +} + +{ + package Foo::Moose::Sub; + use Moose; + extends 'Foo::Moose'; + + has baz => ( + is => 'ro', + default => 'BAZ', + ); +} + +{ + my $foo_moose = Foo::Moose->new; + is($foo_moose->foo, 'FOO', 'Foo::Moose::foo'); + is($foo_moose->bar, 'BAR', 'Foo::Moose::bar'); + isnt(Foo::Moose->meta->get_method('new'), undef, + 'Foo::Moose gets its own constructor'); +} + +{ + my $foo_moose_sub = Foo::Moose::Sub->new; + is($foo_moose_sub->foo, 'FOO', 'Foo::Moose::Sub::foo'); + is($foo_moose_sub->bar, 'BAR', 'Foo::Moose::Sub::bar'); + is($foo_moose_sub->baz, 'BAZ', 'Foo::Moose::Sub::baz'); + is(Foo::Moose::Sub->meta->get_method('new'), undef, + 'Foo::Moose::Sub just uses the constructor for Foo::Moose'); +} + +Foo::Moose->meta->make_immutable; +Foo::Moose::Sub->meta->make_immutable; + +{ + my $foo_moose_sub = Foo::Moose::Sub->new; + is($foo_moose_sub->foo, 'FOO', 'Foo::Moose::Sub::foo (immutable)'); + is($foo_moose_sub->bar, 'BAR', 'Foo::Moose::Sub::bar (immutable)'); + is($foo_moose_sub->baz, 'BAZ', 'Foo::Moose::Sub::baz (immutable)'); + isnt(Foo::Moose::Sub->meta->get_method('new'), undef, + 'Foo::Moose::Sub has an inlined constructor'); +} + +done_testing; diff --git a/t/nonmoose/no-new-constructor-error.t b/t/nonmoose/no-new-constructor-error.t new file mode 100644 index 0000000..f2b795e --- /dev/null +++ b/t/nonmoose/no-new-constructor-error.t @@ -0,0 +1,50 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +{ + package NonMoose; + + sub create { bless {}, shift } + + sub DESTROY { } +} + +{ + package Child; + use Moose; + + extends 'NonMoose'; + + { + my $warning; + local $SIG{__WARN__} = sub { $warning = $_[0] }; + __PACKAGE__->meta->make_immutable; + ::like( + $warning, + qr/Not inlining.*doesn't contain a constructor named 'new'/, + "warning when trying to make_immutable without a superclass 'new'" + ); + } +} + +{ + package ChildTwo; + use Moose; + + extends 'NonMoose'; + + { + my $warning; + local $SIG{__WARN__} = sub { $warning = $_[0] }; + __PACKAGE__->meta->make_immutable(inline_constructor => 0); + ::is( + $warning, + undef, + "no warning when trying to make_immutable(inline_constructor => 0) without a superclass 'new'" + ); + } +} + +done_testing; diff --git a/t/nonmoose/nonmoose-moose-nonmoose.t b/t/nonmoose/nonmoose-moose-nonmoose.t new file mode 100644 index 0000000..befd407 --- /dev/null +++ b/t/nonmoose/nonmoose-moose-nonmoose.t @@ -0,0 +1,95 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Foo; + + sub new { + my $class = shift; + bless {@_}, $class; + } + + sub foo { shift->{name} } +} + +{ + package Foo::Moose; + use Moose; + + extends 'Foo'; + + has foo2 => ( + is => 'rw', + isa => 'Str', + ); +} + +{ + package Foo::Moose::Sub; + use base 'Foo::Moose'; +} + +{ + package Bar; + + sub new { + my $class = shift; + bless {name => $_[0]}, $class; + } + + sub bar { shift->{name} } +} + +{ + package Bar::Moose; + use Moose; + + extends 'Bar'; + + has bar2 => ( + is => 'rw', + isa => 'Str', + ); + + sub FOREIGNBUILDARGS { + my $class = shift; + my %args = @_; + return $args{name}; + } +} + +{ + package Bar::Moose::Sub; + use base 'Bar::Moose'; +} + +with_immutable { + my $foo = Foo::Moose::Sub->new(name => 'foomoosesub', foo2 => 'FOO2'); + isa_ok($foo, 'Foo'); + isa_ok($foo, 'Foo::Moose'); + is($foo->foo, 'foomoosesub', 'got name from nonmoose constructor'); + is($foo->foo2, 'FOO2', 'got attribute value from moose constructor'); + $foo = Foo::Moose->new(name => 'foomoosesub', foo2 => 'FOO2'); + isa_ok($foo, 'Foo'); + isa_ok($foo, 'Foo::Moose'); + is($foo->foo, 'foomoosesub', 'got name from nonmoose constructor'); + is($foo->foo2, 'FOO2', 'got attribute value from moose constructor'); +} 'Foo::Moose'; + +with_immutable { + my $bar = Bar::Moose::Sub->new(name => 'barmoosesub', bar2 => 'BAR2'); + isa_ok($bar, 'Bar'); + isa_ok($bar, 'Bar::Moose'); + is($bar->bar, 'barmoosesub', 'got name from nonmoose constructor'); + is($bar->bar2, 'BAR2', 'got attribute value from moose constructor'); + $bar = Bar::Moose->new(name => 'barmoosesub', bar2 => 'BAR2'); + isa_ok($bar, 'Bar'); + isa_ok($bar, 'Bar::Moose'); + is($bar->bar, 'barmoosesub', 'got name from nonmoose constructor'); + is($bar->bar2, 'BAR2', 'got attribute value from moose constructor'); +} 'Bar::Moose'; + +done_testing; diff --git a/t/nonmoose/replaced-constructor.t b/t/nonmoose/replaced-constructor.t new file mode 100644 index 0000000..2b78719 --- /dev/null +++ b/t/nonmoose/replaced-constructor.t @@ -0,0 +1,91 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +my $foo_constructed; + +{ + package Foo; + + sub new { + my $class = shift; + bless {}, $class; + } +} + +{ + package Foo::Moose; + use Moose; + + extends 'Foo'; + + after new => sub { + $foo_constructed = 1; + }; +} + +{ + package Foo::Moose2; + use Moose; + + extends 'Foo'; + + sub new { + my $class = shift; + $foo_constructed = 1; + return $class->meta->new_object(@_); + } +} + +{ + my $method = Foo::Moose->meta->get_method('new'); + isa_ok($method, 'Class::MOP::Method::Wrapped'); + + { + undef $foo_constructed; + Foo::Moose->new; + ok($foo_constructed, 'method modifier called for the constructor'); + } + + { + # we don't care about the warning that moose isn't going to inline our + # constructor - this is the behavior we're testing + local $SIG{__WARN__} = sub {}; + Foo::Moose->meta->make_immutable; + } + + is($method, Foo::Moose->meta->get_method('new'), + 'make_immutable doesn\'t overwrite constructor with method modifiers'); + + { + undef $foo_constructed; + Foo::Moose->new; + ok($foo_constructed, + 'method modifier called for the constructor (immutable)'); + } +} + +{ + my $method = Foo::Moose2->meta->get_method('new'); + + { + undef $foo_constructed; + Foo::Moose2->new; + ok($foo_constructed, 'custom constructor called'); + } + + # still need to specify inline_constructor => 0 when overriding new + # manually + Foo::Moose2->meta->make_immutable(inline_constructor => 0); + is($method, Foo::Moose2->meta->get_method('new'), + 'make_immutable doesn\'t overwrite custom constructor'); + + { + undef $foo_constructed; + Foo::Moose2->new; + ok($foo_constructed, 'custom constructor called (immutable)'); + } +} + +done_testing;