--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
projects / gitmo/Moose.git / commitdiff