use strict;
use warnings;
+use Mouse::Meta::Method::Constructor;
use Mouse::Util qw/get_linear_isa blessed/;
use Carp 'confess';
}
-sub make_immutable {}
-sub is_immutable { 0 }
+sub make_immutable {
+ my $self = shift;
+ my $name = $self->name;
+ $self->{is_immutable}++;
+ no strict 'refs';
+ *{"$name\::new"} = Mouse::Meta::Method::Constructor->generate_constructor_method_inline( $self );
+}
+sub make_mutable {
+ Carp::croak "Mouse::Meta::Class->make_mutable does not supported by Mouse";
+}
+sub is_immutable { $_[0]->{is_immutable} }
sub attribute_metaclass { "Mouse::Meta::Class" }
--- /dev/null
+package Mouse::Meta::Method::Constructor;
+use strict;
+use warnings;
+
+sub generate_constructor_method_inline {
+ my ($class, $meta) = @_;
+ my $buildall = $class->_generate_BUILDALL($meta);
+ my $buildargs = $class->_generate_BUILDARGS();
+ my $classname = $meta->name;
+ my $processattrs = $class->_generate_processattrs($meta);
+
+ my $code = <<"...";
+ sub {
+ my \$class = shift;
+ my \$args = $buildargs;
+ my \$instance = bless {}, '$classname';
+ $processattrs;
+ $buildall;
+ return \$instance;
+ }
+...
+ warn $code if $ENV{DEBUG};
+
+ my $res = eval $code;
+ die $@ if $@;
+ $res;
+}
+
+sub _generate_processattrs {
+ my ($class, $meta, ) = @_;
+ my @attrs = $meta->compute_all_applicable_attributes;
+ my @res;
+ for my $attr (@attrs) {
+ my $from = $attr->init_arg;
+ my $key = $attr->name;
+ my $part1 = do {
+ my @code;
+ if ($attr->should_coerce) {
+ push @code, "\$args->{\$from} = \$attr->coerce_constraint( \$args->{\$from} );";
+ }
+ if ($attr->has_type_constraint) {
+ push @code, "\$attr->verify_type_constraint( \$args->{\$from} );";
+ }
+ push @code, "\$instance->{\$key} = \$args->{\$from};";
+ push @code, "weaken( \$instance->{\$key} ) if ref( \$instance->{\$key} ) && \$attr->is_weak_ref;";
+ if ( $attr->has_trigger ) {
+ push @code, "\$attr->trigger->( \$instance, \$args->{\$from}, \$attr );";
+ }
+ join "\n", @code;
+ };
+ my $part2 = do {
+ my @code;
+ if ( $attr->has_default || $attr->has_builder ) {
+ unless ( $attr->is_lazy ) {
+ my $default = $attr->default;
+ my $builder = $attr->builder;
+ if ($attr->has_builder) {
+ push @code, "my \$value = \$instance->$builder;";
+ } elsif (ref($default) eq 'CODE') {
+ push @code, "my \$value = \$attr->default()->();";
+ } else {
+ push @code, "my \$value = \$attr->default();";
+ }
+ if ($attr->should_coerce) {
+ push @code, "\$value = \$attr->coerce_constraint(\$value);";
+ }
+ if ($attr->has_type_constraint) {
+ push @code, "\$attr->verify_type_constraint(\$value);";
+ }
+ push @code, "\$instance->{\$key} = \$value;";
+ if ($attr->is_weak_ref) {
+ push @code, "weaken( \$instance->{\$key} ) if ref( \$instance->{\$key} );";
+ }
+ }
+ join "\n", @code;
+ }
+ else {
+ if ( $attr->is_required ) {
+ q{Carp::confess("Attribute (} . $attr->name . q{) is required");};
+ } else {
+ ""
+ }
+ }
+ };
+ my $code = <<"...";
+ {
+ my \$attr = \$instance->meta->get_attribute_map->{'$key'};
+ my \$from = '$from';
+ my \$key = '$key';
+ if (defined(\$from) && exists(\$args->{\$from})) {
+ $part1;
+ } else {
+ $part2;
+ }
+ }
+...
+ push @res, $code;
+ }
+ return join "\n", @res;
+}
+
+sub _generate_BUILDARGS {
+ <<'...';
+ do {
+ if ( scalar @_ == 1 ) {
+ if ( defined $_[0] ) {
+ ( ref( $_[0] ) eq 'HASH' )
+ || Carp::confess "Single parameters to new() must be a HASH ref";
+ +{ %{ $_[0] } };
+ }
+ else {
+ +{};
+ }
+ }
+ else {
+ +{@_};
+ }
+ };
+...
+}
+
+sub _generate_BUILDALL {
+ my ($class, $meta) = @_;
+ return '' unless $meta->name->can('BUILD');
+
+ my @code = ();
+ push @code, q{no strict 'refs';};
+ push @code, q{no warnings 'once';};
+ no strict 'refs';
+ for my $class ($meta->linearized_isa) {
+ if (*{ $class . '::BUILD' }{CODE}) {
+ push @code, qq{${class}::BUILD->(\$instance, \$args);};
+ }
+ }
+ return join "\n", @code;
+}
+
+1;
for my $attribute ($class->meta->compute_all_applicable_attributes) {
my $from = $attribute->init_arg;
my $key = $attribute->name;
- my $default;
if (defined($from) && exists($args->{$from})) {
$args->{$from} = $attribute->coerce_constraint($args->{$from})
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 15;
+use Test::Exception;
+
+use Mouse::Meta::Role;
+
+
+{
+ package FooRole;
+ our $VERSION = '0.01';
+ sub foo {'FooRole::foo'}
+}
+
+{
+ package Foo;
+ use Mouse;
+
+ #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 = Mouse::Meta::Role->initialize('FooRole');
+ my $meta = Foo->meta;
+
+ lives_ok { Foo->new } "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" );
+ lives_ok { $meta->make_immutable } "Foo is imutable";
+ SKIP: {
+ skip "Mouse doesn't supports ->identifier, add_role", 2;
+ lives_ok { $meta->identifier } "->identifier on metaclass lives";
+ dies_ok { $meta->add_role($foo_role) } "Add Role is locked";
+ };
+ lives_ok { Foo->new } "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" );
+ SKIP: {
+ skip "Mouse doesn't supports make_mutable", 2;
+ lives_ok { $meta->make_mutable } "Foo is mutable";
+ lives_ok { $meta->add_role($foo_role) } "Add Role is unlocked";
+ };
+
+}
+
+{
+ package Bar;
+
+ use Mouse;
+
+ sub BUILD { 'bar' }
+}
+
+{
+ package Baz;
+
+ use Mouse;
+
+ extends 'Bar';
+
+ sub BUILD { 'baz' }
+}
+
+lives_ok { Bar->meta->make_immutable }
+ 'Immutable meta with single BUILD';
+
+lives_ok { Baz->meta->make_immutable }
+ 'Immutable meta with multiple BUILDs';
+
+=pod
+
+Nothing here yet, but soon :)
+
+=cut
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 3;
+use Test::Exception;
+
+
+
+{
+ 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");
+
+lives_ok { AClass->new(bar => 'bar') } '... no triggers called';
+
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+use Test::Exception;
+
+
+
+=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;
+throws_ok { Foo->new($scalar) } qr/\QSingle parameters to new() must be a HASH ref/,
+ 'Non-ref provided to immutable constructor gives useful error message';
+throws_ok { Foo->new(\$scalar) } qr/\QSingle parameters to new() must be a HASH ref/,
+ 'Scalar ref provided to immutable constructor gives useful error message';
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 14;
+
+{
+ 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');
+ }
+}
+
+
--- /dev/null
+use strict;
+use warnings;
+use Test::More tests => 4;
+use t::Exception;
+
+{
+ package HardDog;
+ use Mouse;
+ has bone => (
+ is => 'rw',
+ required => 1,
+ );
+ no Mouse;
+ __PACKAGE__->meta->make_immutable;
+}
+
+{
+ package SoftDog;
+ use Mouse;
+ has bone => (
+ is => 'rw',
+ required => 1,
+ );
+ no Mouse;
+}
+
+lives_ok { SoftDog->new(bone => 'moo') };
+lives_ok { HardDog->new(bone => 'moo') };
+
+throws_ok { SoftDog->new() } qr/\QAttribute (bone) is required/;
+throws_ok { HardDog->new() } qr/\QAttribute (bone) is required/;
+
projects / gitmo/Mouse.git / commitdiff