my $attr = $self->associated_attribute;
my $attr_name = $attr->name;
my $inv = '$_[0]';
- my $slot_access = $self->_inline_get($inv, $attr_name);
+ my $slot_access = $self->_inline_access($inv, $attr_name);
my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
- my $code = 'sub { '
- . $self->_inline_pre_body(@_)
- . 'if (scalar(@_) == 2) {'
- . $self->_inline_check_required
- . $self->_inline_check_coercion
- . $self->_inline_check_constraint($value_name)
- . $self->_inline_store($inv, $value_name)
- . $self->_inline_trigger($inv, $value_name)
- . ' }'
- . $self->_inline_check_lazy
- . $self->_inline_post_body(@_)
- . 'return ' . $self->_inline_auto_deref($self->_inline_get($inv))
+ my $code = 'sub { ' . "\n"
+ . $self->_inline_pre_body(@_) . "\n"
+ . 'if (scalar(@_) == 2) {' . "\n"
+ . $self->_inline_check_required . "\n"
+ . $self->_inline_check_coercion . "\n"
+ . $self->_inline_check_constraint($value_name) . "\n"
+ . $self->_inline_store($inv, $value_name) . "\n"
+ . $self->_inline_trigger($inv, $value_name) . "\n"
+ . ' }' . "\n"
+ . $self->_inline_check_lazy . "\n"
+ . $self->_inline_post_body(@_) . "\n"
+ . 'return ' . $self->_inline_auto_deref($self->_inline_get($inv)) . "\n"
. ' }';
# NOTE:
return '' unless $attr->is_lazy;
my $inv = '$_[0]';
- my $slot_access = $self->_inline_get($inv, $attr->name);
-
+ my $slot_access = $self->_inline_access($inv, $attr->name);
+ my $slot_exists = $self->_inline_has($inv, $attr->name);
if ($attr->has_type_constraint) {
# NOTE:
# this could probably be cleaned
# up and streamlined a little more
- return 'unless (exists ' . $slot_access . ') {' .
+ return 'unless (' . $slot_exists . ') {' .
' if ($attr->has_default || $attr->has_builder ) {' .
' my $default; '.
' $default = $attr->default(' . $inv . ') if $attr->has_default;' .
'}';
}
- return 'unless (exists ' . $slot_access . ') {' .
+ return 'unless ( ' . $slot_exists . ') {' .
' if ($attr->has_default) { ' . $slot_access . ' = $attr->default(' . $inv . '); }' .
' elsif ($attr->has_builder) { '.
' my $builder = $attr->builder; ' .
return $mi->inline_get_slot_value($instance, $slot_name);
}
+sub _inline_access {
+ my ($self, $instance) = @_;
+ my $attr = $self->associated_attribute;
+
+ my $mi = $attr->associated_class->get_meta_instance;
+ my $slot_name = sprintf "'%s'", $attr->slots;
+
+ return $mi->inline_slot_access($instance, $slot_name);
+}
+
+sub _inline_has {
+ my ($self, $instance) = @_;
+ my $attr = $self->associated_attribute;
+
+ my $mi = $attr->associated_class->get_meta_instance;
+ my $slot_name = sprintf "'%s'", $attr->slots;
+
+ return $mi->inline_is_slot_initialized($instance, $slot_name);
+}
+
sub _inline_auto_deref {
my ( $self, $ref_value ) = @_;
my $attr = $self->associated_attribute;
__PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
init_arg => 'optimized',
accessor => 'hand_optimized_type_constraint',
- predicate => 'has_hand_optimized_type_constraint',
+ predicate => 'has_hand_optimized_type_constraint',
));
# private accessors
accessor => '_package_defined_in'
));
-sub new {
+sub new {
my $class = shift;
my $self = $class->meta->new_object(@_);
$self->compile_type_constraint()
sub coerce { ((shift)->coercion || confess "Cannot coerce without a type coercion")->coerce(@_) }
sub check { $_[0]->_compiled_type_constraint->($_[1]) }
-sub validate {
+sub validate {
my ($self, $value) = @_;
if ($self->_compiled_type_constraint->($value)) {
return undef;
sub _actually_compile_type_constraint {
my $self = shift;
-
+
return $self->_compile_hand_optimized_type_constraint
if $self->has_hand_optimized_type_constraint;
-
+
my $check = $self->constraint;
(defined $check)
- || confess "Could not compile type constraint '"
- . $self->name
+ || confess "Could not compile type constraint '"
+ . $self->name
. "' because no constraint check";
-
+
return $self->_compile_subtype($check)
if $self->has_parent;
-
+
return $self->_compile_type($check);
}
sub _compile_hand_optimized_type_constraint {
my $self = shift;
-
+
my $type_constraint = $self->hand_optimized_type_constraint;
-
+
return sub {
+ confess unless ref $type_constraint;
return undef unless $type_constraint->($_[0]);
return 1;
- };
+ };
}
sub _compile_subtype {
my ($self, $check) = @_;
-
+
# so we gather all the parents in order
# and grab their constraints ...
my @parents;
foreach my $parent ($self->_collect_all_parents) {
if ($parent->has_hand_optimized_type_constraint) {
unshift @parents => $parent->hand_optimized_type_constraint;
- last;
+ last;
}
else {
unshift @parents => $parent->constraint;
}
}
-
+
# then we compile them to run without
# having to recurse as we did before
- return subname $self->name => sub {
- local $_ = $_[0];
+ return subname $self->name => sub {
+ local $_ = $_[0];
foreach my $parent (@parents) {
return undef unless $parent->($_[0]);
}
- return undef unless $check->($_[0]);
- 1;
- };
+ return undef unless $check->($_[0]);
+ 1;
+ };
}
sub _compile_type {
my ($self, $check) = @_;
- return subname $self->name => sub {
- local $_ = $_[0];
- return undef unless $check->($_[0]);
- 1;
- };
+ return subname $self->name => sub {
+ local $_ = $_[0];
+ return undef unless $check->($_[0]);
+ 1;
+ };
}
## other utils ...
=head1 DESCRIPTION
-For the most part, the only time you will ever encounter an
-instance of this class is if you are doing some serious deep
-introspection. This API should not be considered final, but
-it is B<highly unlikely> that this will matter to a regular
+For the most part, the only time you will ever encounter an
+instance of this class is if you are doing some serious deep
+introspection. This API should not be considered final, but
+it is B<highly unlikely> that this will matter to a regular
Moose user.
-If you wish to use features at this depth, please come to the
+If you wish to use features at this depth, please come to the
#moose IRC channel on irc.perl.org and we can talk :)
=head1 METHODS
=item B<is_a_type_of ($type_name)>
-This checks the current type name, and if it does not match,
+This checks the current type name, and if it does not match,
checks if it is a subtype of it.
=item B<is_subtype_of ($type_name)>
=item B<check ($value)>
-This method will return a true (C<1>) if the C<$value> passes the
+This method will return a true (C<1>) if the C<$value> passes the
constraint, and false (C<0>) otherwise.
=item B<validate ($value)>
-This method is similar to C<check>, but it deals with the error
-message. If the C<$value> passes the constraint, C<undef> will be
-returned. If the C<$value> does B<not> pass the constraint, then
-the C<message> will be used to construct a custom error message.
+This method is similar to C<check>, but it deals with the error
+message. If the C<$value> passes the constraint, C<undef> will be
+returned. If the C<$value> does B<not> pass the constraint, then
+the C<message> will be used to construct a custom error message.
=item B<name>
=head1 BUGS
-All complex software has bugs lurking in it, and this module is no
+All complex software has bugs lurking in it, and this module is no
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
L<http://www.iinteractive.com>
This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
+it under the same terms as Perl itself.
=cut
projects / gitmo/Moose.git / commitdiff