use Scalar::Util 'blessed', 'weaken', 'reftype';
use Carp 'confess';
-our $VERSION = '0.05';
+our $VERSION = '0.08';
+use Moose::Meta::Method::Accessor;
use Moose::Util::TypeConstraints ();
use base 'Class::MOP::Attribute';
(defined $type_constraint)
|| confess "Could not find the type constraint '" . $options{isa} . "'";
}
+ # NOTE:
+ # check here to see if the new type
+ # is a subtype of the old one
($type_constraint->is_subtype_of($self->type_constraint->name))
|| confess "New type constraint setting must be a subtype of inherited one"
+ # iff we have a type constraint that is ...
if $self->has_type_constraint;
+ # then we use it :)
$actual_options{type_constraint} = $type_constraint;
delete $options{isa};
}
if (exists $options->{coerce} && $options->{coerce}) {
(exists $options->{type_constraint})
- || confess "You cannot have coercion without specifying a type constraint";
- (!$options->{type_constraint}->isa('Moose::Meta::TypeConstraint::Union'))
- || confess "You cannot have coercion with a type constraint union";
+ || confess "You cannot have coercion without specifying a type constraint";
confess "You cannot have a weak reference to a coerced value"
if $options->{weak_ref};
}
if (exists $options->{auto_deref} && $options->{auto_deref}) {
(exists $options->{type_constraint})
|| confess "You cannot auto-dereference without specifying a type constraint";
- ($options->{type_constraint}->name =~ /^ArrayRef|HashRef$/)
+ ($options->{type_constraint}->is_a_type_of('ArrayRef') ||
+ $options->{type_constraint}->is_a_type_of('HashRef'))
|| confess "You cannot auto-dereference anything other than a ArrayRef or HashRef";
}
if ($self->has_type_constraint) {
my $type_constraint = $self->type_constraint;
if ($self->should_coerce && $type_constraint->has_coercion) {
- $val = $type_constraint->coercion->coerce($val);
+ $val = $type_constraint->coerce($val);
}
(defined($type_constraint->check($val)))
|| confess "Attribute (" .
$self->name .
- ") does not pass the type contraint (" .
+ ") does not pass the type constraint (" .
$type_constraint->name .
") with '$val'";
}
if ref $val && $self->is_weak_ref;
}
+## Accessor inline subroutines
+
sub _inline_check_constraint {
my ($self, $value) = @_;
return '' unless $self->has_type_constraint;
# FIXME - remove 'unless defined($value) - constraint Undef
return sprintf <<'EOF', $value, $value, $value, $value
-defined($attr->type_constraint->check(%s))
- || confess "Attribute (" . $attr->name . ") does not pass the type contraint ("
+defined($type_constraint->(%s))
+ || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("
. $attr->type_constraint->name . ") with " . (defined(%s) ? "'%s'" : "undef")
if defined(%s);
EOF
}
+sub _inline_check_coercion {
+ my $self = shift;
+ return '' unless $self->should_coerce;
+ return 'my $val = $attr->type_constraint->coerce($_[1]);'
+}
+
+sub _inline_check_required {
+ my $self = shift;
+ return '' unless $self->is_required;
+ return 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
+}
+
+sub _inline_check_lazy {
+ my $self = shift;
+ return '' unless $self->is_lazy;
+ if ($self->has_type_constraint) {
+ # NOTE:
+ # this could probably be cleaned
+ # up and streamlined a little more
+ return 'unless (exists $_[0]->{$attr_name}) {' .
+ ' if ($attr->has_default) {' .
+ ' my $default = $attr->default($_[0]);' .
+ ' (defined($type_constraint->($default)))' .
+ ' || confess "Attribute (" . $attr->name . ") does not pass the type constraint ("' .
+ ' . $attr->type_constraint->name . ") with " . (defined($default) ? "\'$default\'" : "undef")' .
+ ' if defined($default);' .
+ ' $_[0]->{$attr_name} = $default; ' .
+ ' }' .
+ ' else {' .
+ ' $_[0]->{$attr_name} = undef;' .
+ ' }' .
+ '}';
+ }
+ return '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
+ . 'unless exists $_[0]->{$attr_name};';
+}
+
+
sub _inline_store {
my ($self, $instance, $value) = @_;
return $ref_value unless $self->should_auto_deref;
- my $type = $self->type_constraint->name;
+ my $type_constraint = $self->type_constraint;
my $sigil;
- if ($type eq "ArrayRef") {
+ if ($type_constraint->is_a_type_of('ArrayRef')) {
$sigil = '@';
}
- elsif ($type eq 'HashRef') {
+ elsif ($type_constraint->is_a_type_of('HashRef')) {
$sigil = '%';
}
else {
- confess "Can not auto de-reference the type constraint '$type'";
+ confess "Can not auto de-reference the type constraint '" . $type_constraint->name . "'";
}
"(wantarray() ? $sigil\{ ( $ref_value ) || return } : ( $ref_value ) )";
my $inv = '$_[0]';
my $code = 'sub { '
. 'if (scalar(@_) == 2) {'
- . ($attr->is_required ?
- 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
- : '')
- . ($attr->should_coerce ?
- 'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
- : '')
+ . $attr->_inline_check_required
+ . $attr->_inline_check_coercion
. $attr->_inline_check_constraint($value_name)
. $attr->_inline_store($inv, $value_name)
. $attr->_inline_trigger($inv, $value_name)
. ' }'
- . ($attr->is_lazy ?
- '$_[0]->{$attr_name} = ($attr->has_default ? $attr->default($_[0]) : undef)'
- . 'unless exists $_[0]->{$attr_name};'
- : '')
+ . $attr->_inline_check_lazy
. 'return ' . $attr->_inline_auto_deref($attr->_inline_get($inv))
. ' }';
+
+ # NOTE:
+ # set up the environment
+ my $type_constraint = $attr->type_constraint
+ ? $attr->type_constraint->_compiled_type_constraint
+ : undef;
+
my $sub = eval $code;
- warn "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
confess "Could not create accessor for '$attr_name' because $@ \n code: $code" if $@;
return $sub;
}
my $value_name = $attr->should_coerce ? '$val' : '$_[1]';
my $inv = '$_[0]';
my $code = 'sub { '
- . ($attr->is_required ?
- 'defined($_[1]) || confess "Attribute ($attr_name) is required, so cannot be set to undef";'
- : '')
- . ($attr->should_coerce ?
- 'my $val = $attr->type_constraint->coercion->coerce($_[1]);'
- : '')
+ . $attr->_inline_check_required
+ . $attr->_inline_check_coercion
. $attr->_inline_check_constraint($value_name)
. $attr->_inline_store($inv, $value_name)
. $attr->_inline_trigger($inv, $value_name)
. ' }';
+
+ # NOTE:
+ # set up the environment
+ my $type_constraint = $attr->type_constraint
+ ? $attr->type_constraint->_compiled_type_constraint
+ : undef;
+
my $sub = eval $code;
confess "Could not create writer for '$attr_name' because $@ \n code: $code" if $@;
return $sub;
}
sub generate_reader_method {
- my $self = shift;
- my $attr_name = $self->slots;
+ my $attr = shift;
+ my $attr_name = $attr->slots;
my $code = 'sub {'
. 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
- . ($self->is_lazy ?
- '$_[0]->{$attr_name} = ($self->has_default ? $self->default($_[0]) : undef)'
- . 'unless exists $_[0]->{$attr_name};'
- : '')
- . 'return ' . $self->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
+ . $attr->_inline_check_lazy
+ . 'return ' . $attr->_inline_auto_deref( '$_[0]->{$attr_name}' ) . ';'
. '}';
my $sub = eval $code;
confess "Could not create reader for '$attr_name' because $@ \n code: $code" if $@;
}
else {
$associated_class->add_method($handle => sub {
+ # FIXME
+ # we should check for lack of
+ # a callable return value from
+ # the accessor here
((shift)->$accessor_name())->$method_to_call(@_);
});
}
my $self = shift;
my $meta = $self->_find_delegate_metaclass;
if ($meta->isa('Class::MOP::Class')) {
- return map { $_->{name} }
- grep { $_->{class} ne 'Moose::Object' }
+ return map { $_->{name} } # NOTE: !never! delegate &meta
+ grep { $_->{class} ne 'Moose::Object' && $_->{name} ne 'meta' }
$meta->compute_all_applicable_methods;
}
elsif ($meta->isa('Moose::Meta::Role')) {
=item B<new>
-=item B<clone_and_inherit_options>
-
=item B<initialize_instance_slot>
=item B<generate_accessor_method>
=head2 Additional Moose features
-Moose attributes support type-contstraint checking, weak reference
+Moose attributes support type-constraint checking, weak reference
creation and type coercion.
=over 4
+=item B<clone_and_inherit_options>
+
+This is to support the C<has '+foo'> feature, it clones an attribute
+from a superclass and allows a very specific set of changes to be made
+to the attribute.
+
=item B<has_type_constraint>
Returns true if this meta-attribute has a type constraint.
projects / gitmo/Moose.git / blobdiff