use Moose::Util::TypeConstraints;
-BEGIN {
- subtype 'Foo' => as 'Object' => where { blessed($_) && $_->isa('Foo') };
-
- coerce 'Foo'
- => from 'ArrayRef'
- => via { Foo->new(@{$_}) };
-}
-
{
package Foo;
use Moose;
+ Foo->meta->make_immutable(debug => 0);
}
+coerce 'Foo'
+ => from 'ArrayRef'
+ => via { Foo->new(@{$_}) };
+
{
package Foo::Normal;
use Moose;
Foo::Normal->new(
required => 'BAR',
type_constraint => $foo,
- #coercion => [],
+ coercion => [],
+ weak_ref => {},
);
},
'immutable' => sub {
Foo::Immutable->new(
required => 'BAR',
type_constraint => $foo,
- #coercion => [],
+ coercion => [],
+ weak_ref => {},
);
},
}
#has 'boo' => (is => 'rw', isa => type 'CustomFoo' => where { blessed($_) && $_->isa('Foo') });
}
+{
+ package Bar;
+
+ sub new { bless {} => __PACKAGE__ }
+ sub bar {
+ my $self = shift;
+ $self->{bar} = shift if @_;
+ $self->{bar};
+ }
+}
+
my $foo = Foo->new;
+my $bar = Bar->new;
cmpthese(200_000,
{
+ 'hand coded' => sub {
+ $bar->bar($bar);
+ },
'w/out_constraint' => sub {
$foo->baz($foo);
},
subtype $class
=> as 'Object'
=> where { $_->isa($class) }
+ => optimize_as { blessed($_[0]) && $_[0]->isa($class) }
unless find_type_constraint($class);
my $meta;
return 0;
}
+## make 'em all immutable
+
+$_->meta->make_immutable(
+ inline_constructor => 0,
+ inline_accessors => 0,
+) for (
+ 'Moose::Meta::Attribute',
+ 'Moose::Meta::Class',
+ 'Moose::Meta::Instance',
+
+ 'Moose::Meta::TypeConstraint',
+ 'Moose::Meta::TypeConstraint::Union',
+ 'Moose::Meta::TypeCoercion',
+
+ 'Moose::Meta::Method',
+ 'Moose::Meta::Method::Accessor',
+ 'Moose::Meta::Method::Constructor',
+ 'Moose::Meta::Method::Overriden',
+);
+
1;
__END__
foreach my $super (@superclasses) {
# don't bother if it does not have a meta.
next unless $super->can('meta');
+ # get the name, make sure we take
+ # immutable classes into account
+ my $super_meta_name = ($super->meta->is_immutable
+ ? $super->meta->get_mutable_metaclass_name
+ : blessed($super->meta));
# if it's meta is a vanilla Moose,
- # then we can safely ignore it.
- next if blessed($super->meta) eq 'Moose::Meta::Class';
+ # then we can safely ignore it.
+ next if $super_meta_name eq 'Moose::Meta::Class';
# but if we have anything else,
# we need to check it out ...
unless (# see if of our metaclass is incompatible
- ($self->isa(blessed($super->meta)) &&
+ ($self->isa($super_meta_name) &&
# and see if our instance metaclass is incompatible
$self->instance_metaclass->isa($super->meta->instance_metaclass)) &&
# ... and if we are just a vanilla Moose
return $sub;
}
+*generate_reader_method = \&generate_reader_method_inline;
+*generate_writer_method = \&generate_writer_method_inline;
+*generate_accessor_method = \&generate_accessor_method_inline;
+
## ... private helpers
sub _inline_check_constraint {
=over 4
+=item B<generate_accessor_method>
+
+=item B<generate_reader_method>
+
+=item B<generate_writer_method>
+
=item B<generate_accessor_method_inline>
=item B<generate_reader_method_inline>
my $self = shift;
my @BUILD_calls;
foreach my $method ($self->associated_metaclass->find_all_methods_by_name('BUILD')) {
- push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD(\%params);';
+ push @BUILD_calls => '$instance->' . $method->{class} . '::BUILD(\%params)';
}
return join "\n" => @BUILD_calls;
}
'|| confess "Attribute (' . $attr->name . ') is required";');
}
- push @source => 'if ($params{\'' . $attr->init_arg . '\'}) {';
-
- push @source => ('my $val = $params{\'' . $attr->init_arg . '\'};');
- if ($attr->has_type_constraint) {
- push @source => ('my $type_constraint = $attrs->[' . $index . ']->type_constraint;');
-
- if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
- push @source => $self->_generate_type_coercion($attr, '$type_constraint', '$val', '$val');
- }
- push @source => $self->_generate_type_constraint_check($attr, '$type_constraint', '$val');
- }
- push @source => $self->_generate_slot_assignment($attr, '$val');
-
if ($attr->has_default && !$attr->is_lazy) {
+ push @source => 'if (exists $params{\'' . $attr->init_arg . '\'}) {';
+
+ push @source => ('my $val = $params{\'' . $attr->init_arg . '\'};');
+ if ($attr->has_type_constraint) {
+ push @source => ('my $type_constraint = $attrs->[' . $index . ']->type_constraint;');
+
+ if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
+ push @source => $self->_generate_type_coercion($attr, '$type_constraint', '$val', '$val');
+ }
+ push @source => $self->_generate_type_constraint_check($attr, '$type_constraint', '$val');
+ }
+ push @source => $self->_generate_slot_assignment($attr, '$val');
+
+
push @source => "} else {";
my $default = $self->_generate_default_value($attr, $index);
push @source => "}";
}
else {
+ push @source => '(exists $params{\'' . $attr->init_arg . '\'}) && do {';
+
+ push @source => ('my $val = $params{\'' . $attr->init_arg . '\'};');
+ if ($attr->has_type_constraint) {
+ push @source => ('my $type_constraint = $attrs->[' . $index . ']->type_constraint;');
+
+ if ($attr->should_coerce && $attr->type_constraint->has_coercion) {
+ push @source => $self->_generate_type_coercion($attr, '$type_constraint', '$val', '$val');
+ }
+ push @source => $self->_generate_type_constraint_check($attr, '$type_constraint', '$val');
+ }
+ push @source => $self->_generate_slot_assignment($attr, '$val');
+
push @source => "}";
}
accessor => '_compiled_type_constraint'
));
+__PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
+ init_arg => 'optimized',
+ accessor => 'hand_optimized_type_constraint',
+ predicate => 'has_hand_optimized_type_constraint',
+));
+
sub new {
my $class = shift;
my $self = $class->meta->new_object(@_);
my @parents;
my $current = $self->parent;
while (defined $current) {
- unshift @parents => $current;
+ push @parents => $current;
$current = $current->parent;
}
return @parents;
sub compile_type_constraint {
my $self = shift;
+
+ if ($self->has_hand_optimized_type_constraint) {
+ my $type_constraint = $self->hand_optimized_type_constraint;
+ $self->_compiled_type_constraint(sub {
+ return undef unless $type_constraint->($_[0]);
+ return 1;
+ });
+ return;
+ }
+
my $check = $self->constraint;
(defined $check)
|| confess "Could not compile type constraint '" . $self->name . "' because no constraint check";
# we have a subtype ...
# so we gather all the parents in order
# and grab their constraints ...
- my @parents = map { $_->constraint } $self->_collect_all_parents;
+ my @parents;
+ foreach my $parent ($self->_collect_all_parents) {
+ if ($parent->has_hand_optimized_type_constraint) {
+ unshift @parents => $parent->hand_optimized_type_constraint;
+ last;
+ }
+ else {
+ unshift @parents => $parent->constraint;
+ }
+ }
+
# then we compile them to run without
# having to recurse as we did before
$self->_compiled_type_constraint(subname $self->name => sub {
}
return undef unless $check->($_[0]);
1;
- });
-
+ });
}
else {
# we have a type ....
=item B<coercion>
+=item B<hand_optimized_type_constraint>
+
+=item B<has_hand_optimized_type_constraint>
+
=back
=over 4
use Moose::Meta::TypeCoercion;
my @exports = qw/
- type subtype as where message
+ type subtype as where message optimize_as
coerce from via
enum
find_type_constraint
Data::Dumper::Dumper(\%TYPES);
}
- sub _create_type_constraint ($$$;$) {
- my ($name, $parent, $check, $message) = @_;
+ sub _create_type_constraint ($$$;$$) {
+ my $name = shift;
+ my $parent = shift;
+ my $check = shift;;
+
+ my ($message, $optimized);
+ for (@_) {
+ $message = $_->{message} if exists $_->{message};
+ $optimized = $_->{optimized} if exists $_->{optimized};
+ }
+
my $pkg_defined_in = scalar(caller(1));
($TYPES{$name}->[0] eq $pkg_defined_in)
|| confess "The type constraint '$name' has already been created "
parent => $parent,
constraint => $check,
message => $message,
+ optimized => $optimized,
);
$TYPES{$name} = [ $pkg_defined_in, $constraint ] if defined $name;
return $constraint;
_create_type_constraint($name, undef, $check);
}
-sub subtype ($$;$$) {
- unshift @_ => undef if scalar @_ <= 2;
+sub subtype ($$;$$$) {
+ unshift @_ => undef if scalar @_ <= 2;
goto &_create_type_constraint;
}
sub from ($) { $_[0] }
sub where (&) { $_[0] }
sub via (&) { $_[0] }
-sub message (&) { $_[0] }
+
+sub message (&) { +{ message => $_[0] } }
+sub optimize_as (&) { +{ optimized => $_[0] } }
sub enum ($;@) {
my ($type_name, @values) = @_;
subtype 'Undef' => as 'Item' => where { !defined($_) };
subtype 'Defined' => as 'Item' => where { defined($_) };
-subtype 'Bool' => as 'Item' => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
-
-subtype 'Value' => as 'Defined' => where { !ref($_) };
-subtype 'Ref' => as 'Defined' => where { ref($_) };
+subtype 'Bool'
+ => as 'Item'
+ => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
-subtype 'Str' => as 'Value' => where { 1 };
-
-subtype 'Num' => as 'Value' => where { Scalar::Util::looks_like_number($_) };
-subtype 'Int' => as 'Num' => where { "$_" =~ /^-?[0-9]+$/ };
-
-subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' };
-subtype 'ArrayRef' => as 'Ref' => where { ref($_) eq 'ARRAY' };
-subtype 'HashRef' => as 'Ref' => where { ref($_) eq 'HASH' };
-subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' };
-subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' };
-subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' };
+subtype 'Value'
+ => as 'Defined'
+ => where { !ref($_) }
+ => optimize_as { defined($_[0]) && !ref($_[0]) };
+
+subtype 'Ref'
+ => as 'Defined'
+ => where { ref($_) }
+ => optimize_as { ref($_[0]) };
+
+subtype 'Str'
+ => as 'Value'
+ => where { 1 }
+ => optimize_as { defined($_[0]) && !ref($_[0]) };
+
+subtype 'Num'
+ => as 'Value'
+ => where { Scalar::Util::looks_like_number($_) }
+ => optimize_as { !ref($_[0]) && Scalar::Util::looks_like_number($_[0]) };
+
+subtype 'Int'
+ => as 'Num'
+ => where { "$_" =~ /^-?[0-9]+$/ }
+ => optimize_as { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ };
+
+subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } => optimize_as { ref($_[0]) eq 'SCALAR' };
+subtype 'ArrayRef' => as 'Ref' => where { ref($_) eq 'ARRAY' } => optimize_as { ref($_[0]) eq 'ARRAY' };
+subtype 'HashRef' => as 'Ref' => where { ref($_) eq 'HASH' } => optimize_as { ref($_[0]) eq 'HASH' };
+subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' } => optimize_as { ref($_[0]) eq 'CODE' };
+subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } => optimize_as { ref($_[0]) eq 'Regexp' };
+subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' } => optimize_as { ref($_[0]) eq 'GLOB' };
# NOTE:
# scalar filehandles are GLOB refs,
# but a GLOB ref is not always a filehandle
-subtype 'FileHandle' => as 'GlobRef' => where { Scalar::Util::openhandle($_) };
+subtype 'FileHandle'
+ => as 'GlobRef'
+ => where { Scalar::Util::openhandle($_) }
+ => optimize_as { ref($_[0]) eq 'GLOB' && Scalar::Util::openhandle($_[0]) };
# NOTE:
# blessed(qr/.../) returns true,.. how odd
-subtype 'Object' => as 'Ref' => where { blessed($_) && blessed($_) ne 'Regexp' };
+subtype 'Object'
+ => as 'Ref'
+ => where { blessed($_) && blessed($_) ne 'Regexp' }
+ => optimize_as { blessed($_[0]) && blessed($_[0]) ne 'Regexp' };
-subtype 'Role' => as 'Object' => where { $_->can('does') };
+subtype 'Role'
+ => as 'Object'
+ => where { $_->can('does') }
+ => optimize_as { blessed($_[0]) && $_[0]->can('does') };
1;
This is just sugar for the type constraint construction syntax.
+=item B<optimize_as>
+
=back
=head2 Type Coercion Constructors
my $super = $class->SUPER::new(@_);
return $class->meta->new_object('__INSTANCE__' => $super, @_);
}
+
+ __PACKAGE__->meta->make_immutable(debug => 0);
}
my $foo_moose = Foo::Moose->new();
'FooRole::blau -> ' . $c->();
};
+}{
package BarClass;
use Moose;
sub boo { 'BarClass::boo' }
sub foo { 'BarClass::foo' } # << the role overrides this ...
+
+ __PACKAGE__->meta->make_immutable(debug => 0);
+}{
package FooClass;
use Moose;
sub blau { 'FooClass::blau' }
sub goo { 'FooClass::goo' } # << overrides the one from the role ...
+
+ __PACKAGE__->meta->make_immutable(debug => 0);
}
my $foo_class_meta = FooClass->meta;
}
package Moose::POOP::Meta::Class;
- use Moose;
+ use Moose;
extends 'Moose::Meta::Class';
projects / gitmo/Moose.git / commitdiff