sub throw_error {
my $self = shift;
- my $inv = $self->_error_thrower;
- unshift @_, "message" if @_ % 2 == 1;
- unshift @_, attr => $self if ref $self;
- unshift @_, $inv;
- my $handler = $inv->can("throw_error"); # to avoid incrementing depth by 1
- goto $handler;
+ Moose::Util::throw(@_);
}
sub _inline_throw_error {
# XXX ugh
$inv = 'Moose::Meta::Class' unless $inv->can('_inline_throw_error');
- # XXX ugh ugh UGH
- my $class = $self->associated_class;
- if ($class) {
- my $class_name = B::perlstring($class->name);
- my $attr_name = B::perlstring($self->name);
- $args = 'attr => Class::MOP::class_of(' . $class_name . ')'
- . '->find_attribute_by_name(' . $attr_name . '), '
- . (defined $args ? $args : '');
- }
-
return $inv->_inline_throw_error($msg, $args)
}
sub new {
my ($class, $name, %options) = @_;
$class->_process_options($name, \%options) unless $options{__hack_no_process_options}; # used from clone()... YECHKKK FIXME ICKY YUCK GROSS
-
+
delete $options{__hack_no_process_options};
my %attrs =
$type_constraint = $options{isa};
}
else {
- $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa});
+ $type_constraint = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($options{isa}, { package_defined_in => $options{definition_context}->{package} });
(defined $type_constraint)
|| $self->throw_error("Could not find the type constraint '" . $options{isa} . "'", data => $options{isa});
}
$type_constraint = $options{does};
}
else {
- $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does});
+ $type_constraint = Moose::Util::TypeConstraints::find_or_create_does_type_constraint($options{does}, { package_defined_in => $options{definition_context}->{package} });
(defined $type_constraint)
|| $self->throw_error("Could not find the type constraint '" . $options{does} . "'", data => $options{does});
}
else {
$options->{type_constraint}
= Moose::Util::TypeConstraints::find_or_create_isa_type_constraint(
- $options->{isa} );
+ $options->{isa},
+ { package_defined_in => $options->{definition_context}->{package} }
+ );
}
}
else {
$options->{type_constraint}
= Moose::Util::TypeConstraints::find_or_create_does_type_constraint(
- $options->{does} );
+ $options->{does},
+ { package_defined_in => $options->{definition_context}->{package} }
+ );
}
}
. 'do { local $_ = ' . $value . '; '
. $message . '->(' . $value . ')'
. '}',
- 'data => ' . $value
+ 'class => "Moose::Exception::TypeConstraint"',
+ 'attribute_name => ' . $self->name,
+ 'type_name => ' . $self->type_constraint->name,
+ 'value => ' . $value,
) . ';',
'}',
);
. 'do { local $_ = ' . $value . '; '
. $message . '->(' . $value . ')'
. '}',
- 'data => ' . $value
+ 'class => "Moose::Exception::TypeConstraint"',
+ 'attribute_name => ' . $self->name,
+ 'type_name => ' . $self->type_constraint->name,
+ 'value => ' . $value,
) . ';',
'}',
);
my $mi = $self->associated_class->get_meta_instance;
return (
- $mi->inline_weaken_slot_value($instance, $self->name, $value),
+ $mi->inline_weaken_slot_value($instance, $self->name),
'if ref ' . $value . ';',
);
}
$value = $self->_coerce_and_verify( $value, $instance );
$self->set_initial_value($instance, $value);
+
+ if ( ref $value && $self->is_weak_ref ) {
+ $self->_weaken_value($instance);
+ }
}
}
$self->_inline_check_constraint($default, $tc, $message, $for_lazy))
: (),
$self->_inline_init_slot($instance, $default),
+ $self->_inline_weaken_value($instance, $default),
);
}
if (
$method
+ && !$method->is_stub
&& !$method->isa('Class::MOP::Method::Accessor')
&& ( !$self->definition_context
|| $method->package_name eq $self->definition_context->{package} )
my $class_name = $associated_class->name;
my $name = "${class_name}::${handle}";
- (!$associated_class->has_method($handle))
- || $self->throw_error("You cannot overwrite a locally defined method ($handle) with a delegation", method_name => $handle);
+ if ( my $method = $associated_class->get_method($handle) ) {
+ $self->throw_error(
+ "You cannot overwrite a locally defined method ($handle) with a delegation",
+ method_name => $handle
+ ) unless $method->is_stub;
+ }
# NOTE:
# handles is not allowed to delegate
my $type_constraint = $self->type_constraint;
$type_constraint->check($val)
- || $self->throw_error("Attribute ("
+ || $self->throw_error(
+ superclass => 'Moose::Exception::TypeConstraint',
+ message => "Attribute ("
. $self->name
. ") does not pass the type constraint because: "
- . $type_constraint->get_message($val), data => $val, @_);
+ . $type_constraint->get_message($val),
+ value => $val,
+ attribute_name => $self->name,
+ type_name => $type_constraint->name,
+ @_);
}
package Moose::Meta::Attribute::Custom::Moose;
Before setting the value, a check is made on the type constraint of
the attribute, if it has one, to see if the value passes it. If the
-value fails to pass, the set operation dies with a L</throw_error>.
+value fails to pass, the set operation dies.
Any coercion to convert values is done before checking the type constraint.
To check a value against a type constraint before setting it, fetch the
attribute instance using L<Class::MOP::Class/find_attribute_by_name>,
fetch the type_constraint from the attribute using L<Moose::Meta::Attribute/type_constraint>
-and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Recipe4>
+and call L<Moose::Meta::TypeConstraint/check>. See L<Moose::Cookbook::Basics::Company_Subtypes>
for an example.
=back