Skip to content

Instantly share code, notes, and snippets.

@dakkar

dakkar/.gitignore

Forked from chizmw/.gitignore
Created August 15, 2012 11:43
Show Gist options
  • Save dakkar/3359425 to your computer and use it in GitHub Desktop.
Save dakkar/3359425 to your computer and use it in GitHub Desktop.
Download ZIP
MooseX::Types::Structured validation example
Raw
Attribute.pm
package Moose::Meta::Attribute;
BEGIN {
$Moose::Meta::Attribute::AUTHORITY = 'cpan:STEVAN';
}
{
$Moose::Meta::Attribute::VERSION = '2.0603';
}
use strict;
use warnings;
use B ();
use Class::Load qw(is_class_loaded load_class);
use Scalar::Util 'blessed', 'weaken';
use List::MoreUtils 'any';
use Try::Tiny;
use overload ();
use Moose::Deprecated;
use Moose::Meta::Method::Accessor;
use Moose::Meta::Method::Delegation;
use Moose::Util ();
use Moose::Util::TypeConstraints ();
use Class::MOP::MiniTrait;
use base 'Class::MOP::Attribute', 'Moose::Meta::Mixin::AttributeCore';
Class::MOP::MiniTrait::apply(__PACKAGE__, 'Moose::Meta::Object::Trait');
__PACKAGE__->meta->add_attribute('traits' => (
reader => 'applied_traits',
predicate => 'has_applied_traits',
Class::MOP::_definition_context(),
));
# we need to have a ->does method in here to
# more easily support traits, and the introspection
# of those traits. We extend the does check to look
# for metatrait aliases.
sub does {
my ($self, $role_name) = @_;
my $name = try {
Moose::Util::resolve_metatrait_alias(Attribute => $role_name)
};
return 0 if !defined($name); # failed to load class
return $self->Moose::Object::does($name);
}
sub _error_thrower {
my $self = shift;
require Moose::Meta::Class;
( ref $self && $self->associated_class ) || "Moose::Meta::Class";
}
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;
}
sub _inline_throw_error {
my ( $self, $msg, $args ) = @_;
my $inv = $self->_error_thrower;
# 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 =
( map { $_ => 1 }
grep { defined }
map { $_->init_arg() }
$class->meta()->get_all_attributes()
);
my @bad = sort grep { ! $attrs{$_} } keys %options;
if (@bad)
{
Carp::cluck "Found unknown argument(s) passed to '$name' attribute constructor in '$class': @bad";
}
return $class->SUPER::new($name, %options);
}
sub interpolate_class_and_new {
my ($class, $name, %args) = @_;
my ( $new_class, @traits ) = $class->interpolate_class(\%args);
$new_class->new($name, %args, ( scalar(@traits) ? ( traits => \@traits ) : () ) );
}
sub interpolate_class {
my ($class, $options) = @_;
$class = ref($class) || $class;
if ( my $metaclass_name = delete $options->{metaclass} ) {
my $new_class = Moose::Util::resolve_metaclass_alias( Attribute => $metaclass_name );
if ( $class ne $new_class ) {
if ( $new_class->can("interpolate_class") ) {
return $new_class->interpolate_class($options);
} else {
$class = $new_class;
}
}
}
my @traits;
if (my $traits = $options->{traits}) {
my $i = 0;
my $has_foreign_options = 0;
while ($i < @$traits) {
my $trait = $traits->[$i++];
next if ref($trait); # options to a trait we discarded
$trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait)
|| $trait;
next if $class->does($trait);
push @traits, $trait;
# are there options?
if ($traits->[$i] && ref($traits->[$i])) {
$has_foreign_options = 1
if any { $_ ne '-alias' && $_ ne '-excludes' } keys %{ $traits->[$i] };
push @traits, $traits->[$i++];
}
}
if (@traits) {
my %options = (
superclasses => [ $class ],
roles => [ @traits ],
);
if ($has_foreign_options) {
$options{weaken} = 0;
}
else {
$options{cache} = 1;
}
my $anon_class = Moose::Meta::Class->create_anon_class(%options);
$class = $anon_class->name;
}
}
return ( wantarray ? ( $class, @traits ) : $class );
}
# ...
# method-generating options shouldn't be overridden
sub illegal_options_for_inheritance {
qw(reader writer accessor clearer predicate)
}
# NOTE/TODO
# This method *must* be able to handle
# Class::MOP::Attribute instances as
# well. Yes, I know that is wrong, but
# apparently we didn't realize it was
# doing that and now we have some code
# which is dependent on it. The real
# solution of course is to push this
# feature back up into Class::MOP::Attribute
# but I not right now, I am too lazy.
# However if you are reading this and
# looking for something to do,.. please
# be my guest.
# - stevan
sub clone_and_inherit_options {
my ($self, %options) = @_;
# NOTE:
# we may want to extends a Class::MOP::Attribute
# in which case we need to be able to use the
# core set of legal options that have always
# been here. But we allows Moose::Meta::Attribute
# instances to changes them.
# - SL
my @illegal_options = $self->can('illegal_options_for_inheritance')
? $self->illegal_options_for_inheritance
: ();
my @found_illegal_options = grep { exists $options{$_} && exists $self->{$_} ? $_ : undef } @illegal_options;
(scalar @found_illegal_options == 0)
|| $self->throw_error("Illegal inherited options => (" . (join ', ' => @found_illegal_options) . ")", data => \%options);
if ($options{isa}) {
my $type_constraint;
if (blessed($options{isa}) && $options{isa}->isa('Moose::Meta::TypeConstraint')) {
$type_constraint = $options{isa};
}
else {
$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});
}
$options{type_constraint} = $type_constraint;
}
if ($options{does}) {
my $type_constraint;
if (blessed($options{does}) && $options{does}->isa('Moose::Meta::TypeConstraint')) {
$type_constraint = $options{does};
}
else {
$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});
}
$options{type_constraint} = $type_constraint;
}
# NOTE:
# this doesn't apply to Class::MOP::Attributes,
# so we can ignore it for them.
# - SL
if ($self->can('interpolate_class')) {
( $options{metaclass}, my @traits ) = $self->interpolate_class(\%options);
my %seen;
my @all_traits = grep { $seen{$_}++ } @{ $self->applied_traits || [] }, @traits;
$options{traits} = \@all_traits if @all_traits;
}
# This method can be called on a CMOP::Attribute object, so we need to
# make sure we can call this method.
$self->_process_lazy_build_option( $self->name, \%options )
if $self->can('_process_lazy_build_option');
$self->clone(%options);
}
sub clone {
my ( $self, %params ) = @_;
my $class = delete $params{metaclass} || ref $self;
my ( @init, @non_init );
foreach my $attr ( grep { $_->has_value($self) } Class::MOP::class_of($self)->get_all_attributes ) {
push @{ $attr->has_init_arg ? \@init : \@non_init }, $attr;
}
my %new_params = ( ( map { $_->init_arg => $_->get_value($self) } @init ), %params );
my $name = delete $new_params{name};
my $clone = $class->new($name, %new_params, __hack_no_process_options => 1 );
foreach my $attr ( @non_init ) {
$attr->set_value($clone, $attr->get_value($self));
}
return $clone;
}
sub _process_options {
my ( $class, $name, $options ) = @_;
$class->_process_is_option( $name, $options );
$class->_process_isa_option( $name, $options );
$class->_process_does_option( $name, $options );
$class->_process_coerce_option( $name, $options );
$class->_process_trigger_option( $name, $options );
$class->_process_auto_deref_option( $name, $options );
$class->_process_lazy_build_option( $name, $options );
$class->_process_lazy_option( $name, $options );
$class->_process_required_option( $name, $options );
}
sub _process_is_option {
my ( $class, $name, $options ) = @_;
return unless $options->{is};
### -------------------------
## is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before
## is => rw, writer => _foo # turns into (reader => foo, writer => _foo)
## is => rw, accessor => _foo # turns into (accessor => _foo)
## is => ro, accessor => _foo # error, accesor is rw
### -------------------------
if ( $options->{is} eq 'ro' ) {
$class->throw_error(
"Cannot define an accessor name on a read-only attribute, accessors are read/write",
data => $options )
if exists $options->{accessor};
$options->{reader} ||= $name;
}
elsif ( $options->{is} eq 'rw' ) {
if ( $options->{writer} ) {
$options->{reader} ||= $name;
}
else {
$options->{accessor} ||= $name;
}
}
elsif ( $options->{is} eq 'bare' ) {
return;
# do nothing, but don't complain (later) about missing methods
}
else {
$class->throw_error( "I do not understand this option (is => "
. $options->{is}
. ") on attribute ($name)", data => $options->{is} );
}
}
sub _process_isa_option {
my ( $class, $name, $options ) = @_;
return unless exists $options->{isa};
if ( exists $options->{does} ) {
if ( try { $options->{isa}->can('does') } ) {
( $options->{isa}->does( $options->{does} ) )
|| $class->throw_error(
"Cannot have an isa option and a does option if the isa does not do the does on attribute ($name)",
data => $options );
}
else {
$class->throw_error(
"Cannot have an isa option which cannot ->does() on attribute ($name)",
data => $options );
}
}
# allow for anon-subtypes here ...
if ( blessed( $options->{isa} )
&& $options->{isa}->isa('Moose::Meta::TypeConstraint') ) {
$options->{type_constraint} = $options->{isa};
}
else {
$options->{type_constraint}
= Moose::Util::TypeConstraints::find_or_create_isa_type_constraint(
$options->{isa},
{ package_defined_in => $options->{definition_context}->{package} }
);
}
}
sub _process_does_option {
my ( $class, $name, $options ) = @_;
return unless exists $options->{does} && ! exists $options->{isa};
# allow for anon-subtypes here ...
if ( blessed( $options->{does} )
&& $options->{does}->isa('Moose::Meta::TypeConstraint') ) {
$options->{type_constraint} = $options->{does};
}
else {
$options->{type_constraint}
= Moose::Util::TypeConstraints::find_or_create_does_type_constraint(
$options->{does},
{ package_defined_in => $options->{definition_context}->{package} }
);
}
}
sub _process_coerce_option {
my ( $class, $name, $options ) = @_;
return unless $options->{coerce};
( exists $options->{type_constraint} )
|| $class->throw_error(
"You cannot have coercion without specifying a type constraint on attribute ($name)",
data => $options );
$class->throw_error(
"You cannot have a weak reference to a coerced value on attribute ($name)",
data => $options )
if $options->{weak_ref};
unless ( $options->{type_constraint}->has_coercion ) {
my $type = $options->{type_constraint}->name;
Moose::Deprecated::deprecated(
feature => 'coerce without coercion',
message =>
"You cannot coerce an attribute ($name) unless its type ($type) has a coercion"
);
}
}
sub _process_trigger_option {
my ( $class, $name, $options ) = @_;
return unless exists $options->{trigger};
( 'CODE' eq ref $options->{trigger} )
|| $class->throw_error("Trigger must be a CODE ref on attribute ($name)", data => $options->{trigger});
}
sub _process_auto_deref_option {
my ( $class, $name, $options ) = @_;
return unless $options->{auto_deref};
( exists $options->{type_constraint} )
|| $class->throw_error(
"You cannot auto-dereference without specifying a type constraint on attribute ($name)",
data => $options );
( $options->{type_constraint}->is_a_type_of('ArrayRef')
|| $options->{type_constraint}->is_a_type_of('HashRef') )
|| $class->throw_error(
"You cannot auto-dereference anything other than a ArrayRef or HashRef on attribute ($name)",
data => $options );
}
sub _process_lazy_build_option {
my ( $class, $name, $options ) = @_;
return unless $options->{lazy_build};
$class->throw_error(
"You can not use lazy_build and default for the same attribute ($name)",
data => $options )
if exists $options->{default};
$options->{lazy} = 1;
$options->{builder} ||= "_build_${name}";
if ( $name =~ /^_/ ) {
$options->{clearer} ||= "_clear${name}";
$options->{predicate} ||= "_has${name}";
}
else {
$options->{clearer} ||= "clear_${name}";
$options->{predicate} ||= "has_${name}";
}
}
sub _process_lazy_option {
my ( $class, $name, $options ) = @_;
return unless $options->{lazy};
( exists $options->{default} || defined $options->{builder} )
|| $class->throw_error(
"You cannot have a lazy attribute ($name) without specifying a default value for it",
data => $options );
}
sub _process_required_option {
my ( $class, $name, $options ) = @_;
if (
$options->{required}
&& !(
( !exists $options->{init_arg} || defined $options->{init_arg} )
|| exists $options->{default}
|| defined $options->{builder}
)
) {
$class->throw_error(
"You cannot have a required attribute ($name) without a default, builder, or an init_arg",
data => $options );
}
}
sub initialize_instance_slot {
my ($self, $meta_instance, $instance, $params) = @_;
my $init_arg = $self->init_arg();
# try to fetch the init arg from the %params ...
my $val;
my $value_is_set;
if ( defined($init_arg) and exists $params->{$init_arg}) {
$val = $params->{$init_arg};
$value_is_set = 1;
}
else {
# skip it if it's lazy
return if $self->is_lazy;
# and die if it's required and doesn't have a default value
$self->throw_error("Attribute (" . $self->name . ") is required", object => $instance, data => $params)
if $self->is_required && !$self->has_default && !$self->has_builder;
# if nothing was in the %params, we can use the
# attribute's default value (if it has one)
if ($self->has_default) {
$val = $self->default($instance);
$value_is_set = 1;
}
elsif ($self->has_builder) {
$val = $self->_call_builder($instance);
$value_is_set = 1;
}
}
return unless $value_is_set;
$val = $self->_coerce_and_verify( $val, $instance );
$self->set_initial_value($instance, $val);
if ( ref $val && $self->is_weak_ref ) {
$self->_weaken_value($instance);
}
}
sub _call_builder {
my ( $self, $instance ) = @_;
my $builder = $self->builder();
return $instance->$builder()
if $instance->can( $self->builder );
$self->throw_error( blessed($instance)
. " does not support builder method '"
. $self->builder
. "' for attribute '"
. $self->name
. "'",
object => $instance,
);
}
## Slot management
sub _make_initializer_writer_callback {
my $self = shift;
my ($meta_instance, $instance, $slot_name) = @_;
my $old_callback = $self->SUPER::_make_initializer_writer_callback(@_);
return sub {
$old_callback->($self->_coerce_and_verify($_[0], $instance));
};
}
sub set_value {
my ($self, $instance, @args) = @_;
my $value = $args[0];
my $attr_name = quotemeta($self->name);
if ($self->is_required and not @args) {
$self->throw_error("Attribute ($attr_name) is required", object => $instance);
}
$value = $self->_coerce_and_verify( $value, $instance );
my @old;
if ( $self->has_trigger && $self->has_value($instance) ) {
@old = $self->get_value($instance, 'for trigger');
}
$self->SUPER::set_value($instance, $value);
if ( ref $value && $self->is_weak_ref ) {
$self->_weaken_value($instance);
}
if ($self->has_trigger) {
$self->trigger->($instance, $value, @old);
}
}
sub _inline_set_value {
my $self = shift;
my ($instance, $value, $tc, $coercion, $message, $for_constructor) = @_;
my $old = '@old';
my $copy = '$val';
$tc ||= '$type_constraint';
$coercion ||= '$type_coercion';
$message ||= '$type_message';
my @code;
if ($self->_writer_value_needs_copy) {
push @code, $self->_inline_copy_value($value, $copy);
$value = $copy;
}
# constructors already handle required checks
push @code, $self->_inline_check_required
unless $for_constructor;
push @code, $self->_inline_tc_code($value, $tc, $coercion, $message);
# constructors do triggers all at once at the end
push @code, $self->_inline_get_old_value_for_trigger($instance, $old)
unless $for_constructor;
push @code, (
$self->SUPER::_inline_set_value($instance, $value),
$self->_inline_weaken_value($instance, $value),
);
# constructors do triggers all at once at the end
push @code, $self->_inline_trigger($instance, $value, $old)
unless $for_constructor;
return @code;
}
sub _writer_value_needs_copy {
my $self = shift;
return $self->should_coerce;
}
sub _inline_copy_value {
my $self = shift;
my ($value, $copy) = @_;
return 'my ' . $copy . ' = ' . $value . ';'
}
sub _inline_check_required {
my $self = shift;
return unless $self->is_required;
my $attr_name = quotemeta($self->name);
return (
'if (@_ < 2) {',
$self->_inline_throw_error(
'"Attribute (' . $attr_name . ') is required, so cannot '
. 'be set to undef"' # defined $_[1] is not good enough
) . ';',
'}',
);
}
sub _inline_tc_code {
my $self = shift;
my ($value, $tc, $coercion, $message, $is_lazy) = @_;
#warn '2 _inline_check_constraint ' . $self->name;
#$DB::single = 1 if $self->name eq 'payload';
return (
$self->_inline_check_coercion(
$value, $tc, $coercion, $is_lazy,
),
$self->_inline_check_constraint(
$value, $tc, $message, $is_lazy,
),
);
}
sub _inline_check_coercion {
my $self = shift;
my ($value, $tc, $coercion) = @_;
return unless $self->should_coerce && $self->type_constraint->has_coercion;
if ( $self->type_constraint->can_be_inlined ) {
return (
'if (! (' . $self->type_constraint->_inline_check($value) . ')) {',
$value . ' = ' . $coercion . '->(' . $value . ');',
'}',
);
}
else {
return (
'if (!' . $tc . '->(' . $value . ')) {',
$value . ' = ' . $coercion . '->(' . $value . ');',
'}',
);
}
}
sub _inline_check_constraint {
my $self = shift;
my ($value, $tc, $message) = @_;
return unless $self->has_type_constraint;
my $attr_name = quotemeta($self->name);
if ( $self->type_constraint->can_be_inlined ) {
return (
'if (! (' . $self->type_constraint->_inline_check($value) . ')) {',
$self->_inline_throw_error(
'"Attribute (' . $attr_name . ') 1does not pass the type '
. 'constraint because: " . '
. 'do { local $_ = ' . $value . '; '
. $message . '->(' . $value . ')'
. '}',
'data => ' . $value
) . ';',
'}',
);
}
else {
return (
'if (!' . $tc . '->(' . $value . ')) {',
$self->_inline_throw_error(
'"Attribute (' . $attr_name . ') 2does not pass the type '
. 'constraint because: " . '
. 'do { local $_ = ' . $value . '; '
. $message . '->(' . $value . ')'
. '}',
'data => ' . $value
) . ';',
'}',
);
}
}
sub _inline_get_old_value_for_trigger {
my $self = shift;
my ($instance, $old) = @_;
return unless $self->has_trigger;
return (
'my ' . $old . ' = ' . $self->_inline_instance_has($instance),
'? ' . $self->_inline_instance_get($instance),
': ();',
);
}
sub _inline_weaken_value {
my $self = shift;
my ($instance, $value) = @_;
return unless $self->is_weak_ref;
my $mi = $self->associated_class->get_meta_instance;
return (
$mi->inline_weaken_slot_value($instance, $self->name),
'if ref ' . $value . ';',
);
}
sub _inline_trigger {
my $self = shift;
my ($instance, $value, $old) = @_;
return unless $self->has_trigger;
return '$trigger->(' . $instance . ', ' . $value . ', ' . $old . ');';
}
sub _eval_environment {
my $self = shift;
my $env = { };
$env->{'$trigger'} = \($self->trigger)
if $self->has_trigger;
$env->{'$attr_default'} = \($self->default)
if $self->has_default;
if ($self->has_type_constraint) {
my $tc_obj = $self->type_constraint;
$env->{'$type_constraint'} = \(
$tc_obj->_compiled_type_constraint
) unless $tc_obj->can_be_inlined;
# these two could probably get inlined versions too
$env->{'$type_coercion'} = \(
$tc_obj->coercion->_compiled_type_coercion
) if $tc_obj->has_coercion;
$env->{'$type_message'} = \(
$tc_obj->has_message ? $tc_obj->message : $tc_obj->_default_message
);
$env = { %$env, %{ $tc_obj->inline_environment } };
}
# XXX ugh, fix these
$env->{'$attr'} = \$self
if $self->has_initializer && $self->is_lazy;
# pretty sure this is only going to be closed over if you use a custom
# error class at this point, but we should still get rid of this
# at some point
$env->{'$meta'} = \($self->associated_class);
return $env;
}
sub _weaken_value {
my ( $self, $instance ) = @_;
my $meta_instance = Class::MOP::Class->initialize( blessed($instance) )
->get_meta_instance;
$meta_instance->weaken_slot_value( $instance, $self->name );
}
sub get_value {
my ($self, $instance, $for_trigger) = @_;
if ($self->is_lazy) {
unless ($self->has_value($instance)) {
my $value;
if ($self->has_default) {
$value = $self->default($instance);
} elsif ( $self->has_builder ) {
$value = $self->_call_builder($instance);
}
$value = $self->_coerce_and_verify( $value, $instance );
$self->set_initial_value($instance, $value);
if ( ref $value && $self->is_weak_ref ) {
$self->_weaken_value($instance);
}
}
}
if ( $self->should_auto_deref && ! $for_trigger ) {
my $type_constraint = $self->type_constraint;
if ($type_constraint->is_a_type_of('ArrayRef')) {
my $rv = $self->SUPER::get_value($instance);
return unless defined $rv;
return wantarray ? @{ $rv } : $rv;
}
elsif ($type_constraint->is_a_type_of('HashRef')) {
my $rv = $self->SUPER::get_value($instance);
return unless defined $rv;
return wantarray ? %{ $rv } : $rv;
}
else {
$self->throw_error("Can not auto de-reference the type constraint '" . $type_constraint->name . "'", object => $instance, type_constraint => $type_constraint);
}
}
else {
return $self->SUPER::get_value($instance);
}
}
sub _inline_get_value {
my $self = shift;
my ($instance, $tc, $coercion, $message) = @_;
my $slot_access = $self->_inline_instance_get($instance);
$tc ||= '$type_constraint';
$coercion ||= '$type_coercion';
$message ||= '$type_message';
return (
$self->_inline_check_lazy($instance, $tc, $coercion, $message),
$self->_inline_return_auto_deref($slot_access),
);
}
sub _inline_check_lazy {
my $self = shift;
my ($instance, $tc, $coercion, $message) = @_;
return unless $self->is_lazy;
my $slot_exists = $self->_inline_instance_has($instance);
return (
'if (!' . $slot_exists . ') {',
$self->_inline_init_from_default($instance, '$default', $tc, $coercion, $message, 'lazy'),
'}',
);
}
sub _inline_init_from_default {
my $self = shift;
my ($instance, $default, $tc, $coercion, $message, $for_lazy) = @_;
if (!($self->has_default || $self->has_builder)) {
$self->throw_error(
'You cannot have a lazy attribute '
. '(' . $self->name . ') '
. 'without specifying a default value for it',
attr => $self,
);
}
return (
$self->_inline_generate_default($instance, $default),
# intentionally not using _inline_tc_code, since that can be overridden
# to do things like possibly only do member tc checks, which isn't
# appropriate for checking the result of a default
$self->has_type_constraint
? ($self->_inline_check_coercion($default, $tc, $coercion, $for_lazy),
$self->_inline_check_constraint($default, $tc, $message, $for_lazy))
: (),
$self->_inline_init_slot($instance, $default),
$self->_inline_weaken_value($instance, $default),
);
}
sub _inline_generate_default {
my $self = shift;
my ($instance, $default) = @_;
if ($self->has_default) {
my $source = 'my ' . $default . ' = $attr_default';
$source .= '->(' . $instance . ')'
if $self->is_default_a_coderef;
return $source . ';';
}
elsif ($self->has_builder) {
my $builder = B::perlstring($self->builder);
my $builder_str = quotemeta($self->builder);
my $attr_name_str = quotemeta($self->name);
return (
'my ' . $default . ';',
'if (my $builder = ' . $instance . '->can(' . $builder . ')) {',
$default . ' = ' . $instance . '->$builder;',
'}',
'else {',
'my $class = ref(' . $instance . ') || ' . $instance . ';',
$self->_inline_throw_error(
'"$class does not support builder method '
. '\'' . $builder_str . '\' for attribute '
. '\'' . $attr_name_str . '\'"'
) . ';',
'}',
);
}
else {
$self->throw_error(
"Can't generate a default for " . $self->name
. " since no default or builder was specified"
);
}
}
sub _inline_init_slot {
my $self = shift;
my ($inv, $value) = @_;
if ($self->has_initializer) {
return '$attr->set_initial_value(' . $inv . ', ' . $value . ');';
}
else {
return $self->_inline_instance_set($inv, $value) . ';';
}
}
sub _inline_return_auto_deref {
my $self = shift;
return 'return ' . $self->_auto_deref(@_) . ';';
}
sub _auto_deref {
my $self = shift;
my ($ref_value) = @_;
return $ref_value unless $self->should_auto_deref;
my $type_constraint = $self->type_constraint;
my $sigil;
if ($type_constraint->is_a_type_of('ArrayRef')) {
$sigil = '@';
}
elsif ($type_constraint->is_a_type_of('HashRef')) {
$sigil = '%';
}
else {
$self->throw_error(
'Can not auto de-reference the type constraint \''
. $type_constraint->name
. '\'',
type_constraint => $type_constraint,
);
}
return 'wantarray '
. '? ' . $sigil . '{ (' . $ref_value . ') || return } '
. ': (' . $ref_value . ')';
}
## installing accessors
sub accessor_metaclass { 'Moose::Meta::Method::Accessor' }
sub install_accessors {
my $self = shift;
$self->SUPER::install_accessors(@_);
$self->install_delegation if $self->has_handles;
return;
}
sub _check_associated_methods {
my $self = shift;
unless (
@{ $self->associated_methods }
|| ($self->_is_metadata || '') eq 'bare'
) {
Carp::cluck(
'Attribute (' . $self->name . ') of class '
. $self->associated_class->name
. ' has no associated methods'
. ' (did you mean to provide an "is" argument?)'
. "\n"
)
}
}
sub _process_accessors {
my $self = shift;
my ($type, $accessor, $generate_as_inline_methods) = @_;
$accessor = ( keys %$accessor )[0] if ( ref($accessor) || '' ) eq 'HASH';
my $method = $self->associated_class->get_method($accessor);
if ( $method
&& $method->isa('Class::MOP::Method::Accessor')
&& $method->associated_attribute->name ne $self->name ) {
my $other_attr_name = $method->associated_attribute->name;
my $name = $self->name;
Carp::cluck(
"You are overwriting an accessor ($accessor) for the $other_attr_name attribute"
. " with a new accessor method for the $name attribute" );
}
if (
$method
&& !$method->is_stub
&& !$method->isa('Class::MOP::Method::Accessor')
&& ( !$self->definition_context
|| $method->package_name eq $self->definition_context->{package} )
) {
Carp::cluck(
"You are overwriting a locally defined method ($accessor) with "
. "an accessor" );
}
if ( !$self->associated_class->has_method($accessor)
&& $self->associated_class->has_package_symbol( '&' . $accessor ) ) {
Carp::cluck(
"You are overwriting a locally defined function ($accessor) with "
. "an accessor" );
}
$self->SUPER::_process_accessors(@_);
}
sub remove_accessors {
my $self = shift;
$self->SUPER::remove_accessors(@_);
$self->remove_delegation if $self->has_handles;
return;
}
sub install_delegation {
my $self = shift;
# NOTE:
# Here we canonicalize the 'handles' option
# this will sort out any details and always
# return an hash of methods which we want
# to delagate to, see that method for details
my %handles = $self->_canonicalize_handles;
# install the delegation ...
my $associated_class = $self->associated_class;
foreach my $handle (sort keys %handles) {
my $method_to_call = $handles{$handle};
my $class_name = $associated_class->name;
my $name = "${class_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
# any of these methods, as they will
# override the ones in your class, which
# is almost certainly not what you want.
# FIXME warn when $handle was explicitly specified, but not if the source is a regex or something
#cluck("Not delegating method '$handle' because it is a core method") and
next if $class_name->isa("Moose::Object") and $handle =~ /^BUILD|DEMOLISH$/ || Moose::Object->can($handle);
my $method = $self->_make_delegation_method($handle, $method_to_call);
$self->associated_class->add_method($method->name, $method);
$self->associate_method($method);
}
}
sub remove_delegation {
my $self = shift;
my %handles = $self->_canonicalize_handles;
my $associated_class = $self->associated_class;
foreach my $handle (keys %handles) {
next unless any { $handle eq $_ }
map { $_->name }
@{ $self->associated_methods };
$self->associated_class->remove_method($handle);
}
}
# private methods to help delegation ...
sub _canonicalize_handles {
my $self = shift;
my $handles = $self->handles;
if (my $handle_type = ref($handles)) {
if ($handle_type eq 'HASH') {
return %{$handles};
}
elsif ($handle_type eq 'ARRAY') {
return map { $_ => $_ } @{$handles};
}
elsif ($handle_type eq 'Regexp') {
($self->has_type_constraint)
|| $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
return map { ($_ => $_) }
grep { /$handles/ } $self->_get_delegate_method_list;
}
elsif ($handle_type eq 'CODE') {
return $handles->($self, $self->_find_delegate_metaclass);
}
elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::DuckType')) {
return map { $_ => $_ } @{ $handles->methods };
}
elsif (blessed($handles) && $handles->isa('Moose::Meta::TypeConstraint::Role')) {
$handles = $handles->role;
}
else {
$self->throw_error("Unable to canonicalize the 'handles' option with $handles", data => $handles);
}
}
load_class($handles);
my $role_meta = Class::MOP::class_of($handles);
(blessed $role_meta && $role_meta->isa('Moose::Meta::Role'))
|| $self->throw_error("Unable to canonicalize the 'handles' option with $handles because its metaclass is not a Moose::Meta::Role", data => $handles);
return map { $_ => $_ }
map { $_->name }
grep { !$_->isa('Class::MOP::Method::Meta') } (
$role_meta->_get_local_methods,
$role_meta->get_required_method_list,
);
}
sub _get_delegate_method_list {
my $self = shift;
my $meta = $self->_find_delegate_metaclass;
if ($meta->isa('Class::MOP::Class')) {
return map { $_->name } # NOTE: !never! delegate &meta
grep { $_->package_name ne 'Moose::Object' && !$_->isa('Class::MOP::Method::Meta') }
$meta->get_all_methods;
}
elsif ($meta->isa('Moose::Meta::Role')) {
return $meta->get_method_list;
}
else {
$self->throw_error("Unable to recognize the delegate metaclass '$meta'", data => $meta);
}
}
sub _find_delegate_metaclass {
my $self = shift;
if (my $class = $self->_isa_metadata) {
unless ( is_class_loaded($class) ) {
$self->throw_error(
sprintf(
'The %s attribute is trying to delegate to a class which has not been loaded - %s',
$self->name, $class
)
);
}
# we might be dealing with a non-Moose class,
# and need to make our own metaclass. if there's
# already a metaclass, it will be returned
return Class::MOP::Class->initialize($class);
}
elsif (my $role = $self->_does_metadata) {
unless ( is_class_loaded($class) ) {
$self->throw_error(
sprintf(
'The %s attribute is trying to delegate to a role which has not been loaded - %s',
$self->name, $role
)
);
}
return Class::MOP::class_of($role);
}
else {
$self->throw_error("Cannot find delegate metaclass for attribute " . $self->name);
}
}
sub delegation_metaclass { 'Moose::Meta::Method::Delegation' }
sub _make_delegation_method {
my ( $self, $handle_name, $method_to_call ) = @_;
my @curried_arguments;
($method_to_call, @curried_arguments) = @$method_to_call
if 'ARRAY' eq ref($method_to_call);
return $self->delegation_metaclass->new(
name => $handle_name,
package_name => $self->associated_class->name,
attribute => $self,
delegate_to_method => $method_to_call,
curried_arguments => \@curried_arguments,
);
}
sub _coerce_and_verify {
my $self = shift;
my $val = shift;
my $instance = shift;
return $val unless $self->has_type_constraint;
$val = $self->type_constraint->coerce($val)
if $self->should_coerce && $self->type_constraint->has_coercion;
$self->verify_against_type_constraint($val, instance => $instance);
return $val;
}
sub verify_against_type_constraint {
my $self = shift;
my $val = shift;
return 1 if !$self->has_type_constraint;
my $type_constraint = $self->type_constraint;
$type_constraint->check($val)
|| $self->throw_error("Attribute ("
. $self->name
. ") 3does not pass the type constraint because: "
. $type_constraint->get_message($val), data => $val, @_);
}
package Moose::Meta::Attribute::Custom::Moose;
BEGIN {
$Moose::Meta::Attribute::Custom::Moose::AUTHORITY = 'cpan:STEVAN';
}
{
$Moose::Meta::Attribute::Custom::Moose::VERSION = '2.0603';
}
sub register_implementation { 'Moose::Meta::Attribute' }
1;
# ABSTRACT: The Moose attribute metaclass
=pod
=head1 NAME
Moose::Meta::Attribute - The Moose attribute metaclass
=head1 VERSION
version 2.0603
=head1 DESCRIPTION
This class is a subclass of L<Class::MOP::Attribute> that provides
additional Moose-specific functionality.
To really understand this class, you will need to start with the
L<Class::MOP::Attribute> documentation. This class can be understood
as a set of additional features on top of the basic feature provided
by that parent class.
=head1 INHERITANCE
C<Moose::Meta::Attribute> is a subclass of L<Class::MOP::Attribute>.
=head1 METHODS
Many of the documented below override methods in
L<Class::MOP::Attribute> and add Moose specific features.
=head2 Creation
=over 4
=item B<< Moose::Meta::Attribute->new(%options) >>
This method overrides the L<Class::MOP::Attribute> constructor.
Many of the options below are described in more detail in the
L<Moose::Manual::Attributes> document.
It adds the following options to the constructor:
=over 8
=item * is => 'ro', 'rw', 'bare'
This provides a shorthand for specifying the C<reader>, C<writer>, or
C<accessor> names. If the attribute is read-only ('ro') then it will
have a C<reader> method with the same attribute as the name.
If it is read-write ('rw') then it will have an C<accessor> method
with the same name. If you provide an explicit C<writer> for a
read-write attribute, then you will have a C<reader> with the same
name as the attribute, and a C<writer> with the name you provided.
Use 'bare' when you are deliberately not installing any methods
(accessor, reader, etc.) associated with this attribute; otherwise,
Moose will issue a deprecation warning when this attribute is added to a
metaclass.
=item * isa => $type
This option accepts a type. The type can be a string, which should be
a type name. If the type name is unknown, it is assumed to be a class
name.
This option can also accept a L<Moose::Meta::TypeConstraint> object.
If you I<also> provide a C<does> option, then your C<isa> option must
be a class name, and that class must do the role specified with
C<does>.
=item * does => $role
This is short-hand for saying that the attribute's type must be an
object which does the named role.
=item * coerce => $bool
This option is only valid for objects with a type constraint
(C<isa>) that defined a coercion. If this is true, then coercions will be applied whenever
this attribute is set.
You can make both this and the C<weak_ref> option true.
=item * trigger => $sub
This option accepts a subroutine reference, which will be called after
the attribute is set.
=item * required => $bool
An attribute which is required must be provided to the constructor. An
attribute which is required can also have a C<default> or C<builder>,
which will satisfy its required-ness.
A required attribute must have a C<default>, C<builder> or a
non-C<undef> C<init_arg>
=item * lazy => $bool
A lazy attribute must have a C<default> or C<builder>. When an
attribute is lazy, the default value will not be calculated until the
attribute is read.
=item * weak_ref => $bool
If this is true, the attribute's value will be stored as a weak
reference.
=item * auto_deref => $bool
If this is true, then the reader will dereference the value when it is
called. The attribute must have a type constraint which defines the
attribute as an array or hash reference.
=item * lazy_build => $bool
Setting this to true makes the attribute lazy and provides a number of
default methods.
has 'size' => (
is => 'ro',
lazy_build => 1,
);
is equivalent to this:
has 'size' => (
is => 'ro',
lazy => 1,
builder => '_build_size',
clearer => 'clear_size',
predicate => 'has_size',
);
If your attribute name starts with an underscore (C<_>), then the clearer
and predicate will as well:
has '_size' => (
is => 'ro',
lazy_build => 1,
);
becomes:
has '_size' => (
is => 'ro',
lazy => 1,
builder => '_build__size',
clearer => '_clear_size',
predicate => '_has_size',
);
Note the doubled underscore in the builder name. Internally, Moose
simply prepends the attribute name with "_build_" to come up with the
builder name.
=item * documentation
An arbitrary string that can be retrieved later by calling C<<
$attr->documentation >>.
=back
=item B<< $attr->clone(%options) >>
This creates a new attribute based on attribute being cloned. You must
supply a C<name> option to provide a new name for the attribute.
The C<%options> can only specify options handled by
L<Class::MOP::Attribute>.
=back
=head2 Value management
=over 4
=item B<< $attr->initialize_instance_slot($meta_instance, $instance, $params) >>
This method is used internally to initialize the attribute's slot in
the object C<$instance>.
This overrides the L<Class::MOP::Attribute> method to handle lazy
attributes, weak references, and type constraints.
=item B<get_value>
=item B<set_value>
eval { $point->meta->get_attribute('x')->set_value($point, 'forty-two') };
if($@) {
print "Oops: $@\n";
}
I<Attribute (x) does not pass the type constraint (Int) with 'forty-two'>
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.
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::Company_Subtypes>
for an example.
=back
=head2 Attribute Accessor generation
=over 4
=item B<< $attr->install_accessors >>
This method overrides the parent to also install delegation methods.
If, after installing all methods, the attribute object has no associated
methods, it throws an error unless C<< is => 'bare' >> was passed to the
attribute constructor. (Trying to add an attribute that has no associated
methods is almost always an error.)
=item B<< $attr->remove_accessors >>
This method overrides the parent to also remove delegation methods.
=item B<< $attr->inline_set($instance_var, $value_var) >>
This method return a code snippet suitable for inlining the relevant
operation. It expect strings containing variable names to be used in the
inlining, like C<'$self'> or C<'$_[1]'>.
=item B<< $attr->install_delegation >>
This method adds its delegation methods to the attribute's associated
class, if it has any to add.
=item B<< $attr->remove_delegation >>
This method remove its delegation methods from the attribute's
associated class.
=item B<< $attr->accessor_metaclass >>
Returns the accessor metaclass name, which defaults to
L<Moose::Meta::Method::Accessor>.
=item B<< $attr->delegation_metaclass >>
Returns the delegation metaclass name, which defaults to
L<Moose::Meta::Method::Delegation>.
=back
=head2 Additional Moose features
These methods are not found in the superclass. They support features
provided by Moose.
=over 4
=item B<< $attr->does($role) >>
This indicates whether the I<attribute itself> does the given
role. The role can be given as a full class name, or as a resolvable
trait name.
Note that this checks the attribute itself, not its type constraint,
so it is checking the attribute's metaclass and any traits applied to
the attribute.
=item B<< Moose::Meta::Class->interpolate_class_and_new($name, %options) >>
This is an alternate constructor that handles the C<metaclass> and
C<traits> options.
Effectively, this method is a factory that finds or creates the
appropriate class for the given C<metaclass> and/or C<traits>.
Once it has the appropriate class, it will call C<< $class->new($name,
%options) >> on that class.
=item B<< $attr->clone_and_inherit_options(%options) >>
This method supports the C<has '+foo'> feature. It does various bits
of processing on the supplied C<%options> before ultimately calling
the C<clone> method.
One of its main tasks is to make sure that the C<%options> provided
does not include the options returned by the
C<illegal_options_for_inheritance> method.
=item B<< $attr->illegal_options_for_inheritance >>
This returns a blacklist of options that can not be overridden in a
subclass's attribute definition.
This exists to allow a custom metaclass to change or add to the list
of options which can not be changed.
=item B<< $attr->type_constraint >>
Returns the L<Moose::Meta::TypeConstraint> object for this attribute,
if it has one.
=item B<< $attr->has_type_constraint >>
Returns true if this attribute has a type constraint.
=item B<< $attr->verify_against_type_constraint($value) >>
Given a value, this method returns true if the value is valid for the
attribute's type constraint. If the value is not valid, it throws an
error.
=item B<< $attr->handles >>
This returns the value of the C<handles> option passed to the
constructor.
=item B<< $attr->has_handles >>
Returns true if this attribute performs delegation.
=item B<< $attr->is_weak_ref >>
Returns true if this attribute stores its value as a weak reference.
=item B<< $attr->is_required >>
Returns true if this attribute is required to have a value.
=item B<< $attr->is_lazy >>
Returns true if this attribute is lazy.
=item B<< $attr->is_lazy_build >>
Returns true if the C<lazy_build> option was true when passed to the
constructor.
=item B<< $attr->should_coerce >>
Returns true if the C<coerce> option passed to the constructor was
true.
=item B<< $attr->should_auto_deref >>
Returns true if the C<auto_deref> option passed to the constructor was
true.
=item B<< $attr->trigger >>
This is the subroutine reference that was in the C<trigger> option
passed to the constructor, if any.
=item B<< $attr->has_trigger >>
Returns true if this attribute has a trigger set.
=item B<< $attr->documentation >>
Returns the value that was in the C<documentation> option passed to
the constructor, if any.
=item B<< $attr->has_documentation >>
Returns true if this attribute has any documentation.
=item B<< $attr->applied_traits >>
This returns an array reference of all the traits which were applied
to this attribute. If none were applied, this returns C<undef>.
=item B<< $attr->has_applied_traits >>
Returns true if this attribute has any traits applied.
=back
=head1 BUGS
See L<Moose/BUGS> for details on reporting bugs.
=head1 AUTHOR
Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2012 by Infinity Interactive, Inc..
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
Raw
mts.pl
#!/usr/bin/env perl
# initially from: http://blogs.perl.org/users/chisel/2011/05/moosextypesstructured---how-i-detest-thee.html
package NAP {
use MooseX::Types -declare => [qw(ArrayRef)];
use Sub::Exporter -setup => [ qw(ArrayRef) ];
use Moose::Util::TypeConstraints;
use MooseX::Meta::TypeConstraint::Structured ();
use Carp;
my $IsType = sub {
my ($obj, $type) = @_;
return $obj->can('equals')
? $obj->equals($type)
: undef;
};
my $CompiledTC = sub {
my ($obj) = @_;
my $method = '_compiled_type_constraint';
return(
$obj->$IsType('Any') ? undef
: $obj->can($method) ? $obj->$method
: sub { $obj->check(shift) },
);
};
Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
MooseX::Meta::TypeConstraint::Structured->new(
name => 'NAP::ArrayRef' ,
parent => find_type_constraint('ArrayRef'),
constraint_generator=> sub {
## Get the constraints and values to check
my ($self, $type_constraints) = @_;
$type_constraints = $self->type_constraints;
my @constraints = defined $type_constraints ? @$type_constraints : ();
Carp::confess( "too many args for NAP::ArrayRef type" ) if @constraints > 1;
my $value_type = $constraints[0];
my ($value_check, $is_compiled);
return sub {
my ($value, $err) = @_;
unless ($is_compiled) {
$value_check = $value_type->$CompiledTC;
$is_compiled++;
}
## Perform the checking
if ($value_check) {
foreach my $v (@$value) {
unless ($value_check->($v)) {
if($err) {
my $message = $value_type->validate($v,$err);
$err->add_message({message=>$message,level=>$err->level});
}
return;
}
}
}
return 1;
};
},
)
);
}
package Thingy;
use Moose;
use MooseX::Types::Moose qw(Str Int HashRef ArrayRef);
#BEGIN { NAP->import('ArrayRef') }
use MooseX::Types::Structured qw(Dict Tuple Optional);
sub Moose::Meta::TypeConstraint::Parameterized::get_message {
my ($self,$value) = @_;
return $self->parameterized_from->message->($value,$self->type_parameter);
}
ArrayRef->message(sub{
my ($value,$inner_type) = @_;
my $msg = ArrayRef->_default_message->($value);
$msg .= $inner_type->validate($value->[0]);
return $msg;
});
our $tc = ArrayRef[
Dict[
some_id => Int,
another_id => Int,
some_colour => Str,
yet_another_id => Optional[Int],
]
];
has payload => (
is => 'rw',
isa=> $tc,
);
package main;
use TryCatch;
use Data::Dump qw(pp);
my $value = [
{ some_id => 'Ten' },
];
print $Thingy::tc->validate($value);
exit(0);
my $thingy = Thingy->new;
try {
$thingy->payload($value);
}
catch($err) {
use File::Basename; my $base=basename($0);
warn "error in $base: $err";
}
warn "Moose: $Moose::VERSION";
warn "MooseX::Types::Structured: $MooseX::Types::Structured::VERSION";
Raw
Structured.pm
package ## Hide from PAUSE
MooseX::Meta::TypeConstraint::Structured;
# ABSTRACT: MooseX::Meta::TypeConstraint::Structured - Structured type constraints.
use Moose;
use Devel::PartialDump;
use Moose::Util::TypeConstraints ();
use MooseX::Meta::TypeCoercion::Structured;
extends 'Moose::Meta::TypeConstraint';
has 'type_constraints' => (
is=>'ro',
isa=>'Ref',
predicate=>'has_type_constraints',
);
has 'constraint_generator' => (
is=>'ro',
isa=>'CodeRef',
predicate=>'has_constraint_generator',
);
has coercion => (
is => 'ro',
isa => 'Object',
builder => '_build_coercion',
);
sub _build_coercion {
my ($self) = @_;
return MooseX::Meta::TypeCoercion::Structured->new(
type_constraint => $self,
);
}
sub _clean_message {
my $message = shift @_;
$message =~s/MooseX::Types::Structured:://g;
return $message;
}
override 'validate' => sub {
my ($self, $value, $message_stack) = @_;
warn 'override validate';
unless ($message_stack) {
$message_stack = MooseX::Types::Structured::MessageStack->new();
}
$message_stack->inc_level;
if ($self->_compiled_type_constraint->($value, $message_stack)) {
## Everything is good, no error message to return
return undef;
} else {
## Whoops, need to figure out the right error message
my $args = Devel::PartialDump::dump($value);
$message_stack->dec_level;
if($message_stack->has_messages) {
if($message_stack->level) {
## we are inside a deeply structured constraint
return $self->get_message($args);
} else {
my $message_str = $message_stack->as_string;
return _clean_message($self->get_message("$args, Internal Validation Error is: $message_str"));
}
} else {
return $self->get_message($args);
}
}
};
sub generate_constraint_for {
my ($self, $type_constraints) = @_;
return $self->constraint_generator->($self, $type_constraints);
}
sub parameterize {
my ($self, @type_constraints) = @_;
my $class = ref $self;
my $name = $self->name .'['. join(',', map {"$_"} @type_constraints) .']';
my $constraint_generator = $self->__infer_constraint_generator;
return $class->new(
name => $name,
parent => $self,
type_constraints => \@type_constraints,
constraint_generator => $constraint_generator,
);
}
sub __infer_constraint_generator {
my ($self) = @_;
if($self->has_constraint_generator) {
return $self->constraint_generator;
} else {
return sub {
## I'm not sure about this stuff but everything seems to work
my $tc = shift @_;
my $merged_tc = [@$tc, @{$self->parent->type_constraints}];
$self->constraint->($merged_tc, @_);
};
}
}
around 'compile_type_constraint' => sub {
my ($compile_type_constraint, $self, @args) = @_;
if($self->has_type_constraints) {
my $type_constraints = $self->type_constraints;
my $constraint = $self->generate_constraint_for($type_constraints);
$self->_set_constraint($constraint);
}
return $self->$compile_type_constraint(@args);
};
around 'create_child_type' => sub {
my ($create_child_type, $self, %opts) = @_;
return $self->$create_child_type(
%opts,
constraint_generator => $self->__infer_constraint_generator,
);
};
sub equals {
my ( $self, $type_or_name ) = @_;
my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name)
or return;
return unless $other->isa(__PACKAGE__);
return (
$self->parent->equals($other->parent)
and
$self->type_constraints_equals($other)
);
}
sub is_a_type_of {
my ( $self, $type_or_name ) = @_;
my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name)
or return;
if ( $other->isa(__PACKAGE__) and @{ $other->type_constraints || [] }) {
if ( $self->parent->is_a_type_of($other->parent) ) {
return $self->_type_constraints_op_all($other, "is_a_type_of");
} elsif ( $self->parent->is_a_type_of($other) ) {
return 1;
# FIXME compare?
} else {
return 0;
}
} else {
return $self->SUPER::is_a_type_of($other);
}
}
sub is_subtype_of {
my ( $self, $type_or_name ) = @_;
my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name)
or return;
if ( $other->isa(__PACKAGE__) ) {
if ( $other->type_constraints and $self->type_constraints ) {
if ( $self->parent->is_a_type_of($other->parent) ) {
return (
$self->_type_constraints_op_all($other, "is_a_type_of")
and
$self->_type_constraints_op_any($other, "is_subtype_of")
);
} elsif ( $self->parent->is_a_type_of($other) ) {
return 1;
# FIXME compare?
} else {
return 0;
}
} else {
if ( $self->type_constraints ) {
if ( $self->SUPER::is_subtype_of($other) ) {
return 1;
} else {
return;
}
} else {
return $self->parent->is_subtype_of($other->parent);
}
}
} else {
return $self->SUPER::is_subtype_of($other);
}
}
sub type_constraints_equals {
my ( $self, $other ) = @_;
$self->_type_constraints_op_all($other, "equals");
}
sub _type_constraints_op_all {
my ($self, $other, $op) = @_;
return unless $other->isa(__PACKAGE__);
my @self_type_constraints = @{$self->type_constraints||[]};
my @other_type_constraints = @{$other->type_constraints||[]};
return unless @self_type_constraints == @other_type_constraints;
## Incoming ay be either arrayref or hashref, need top compare both
while(@self_type_constraints) {
my $self_type_constraint = shift @self_type_constraints;
my $other_type_constraint = shift @other_type_constraints;
$_ = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_)
for $self_type_constraint, $other_type_constraint;
my $result = $self_type_constraint->$op($other_type_constraint);
return unless $result;
}
return 1; ##If we get this far, everything is good.
}
sub _type_constraints_op_any {
my ($self, $other, $op) = @_;
return unless $other->isa(__PACKAGE__);
my @self_type_constraints = @{$self->type_constraints||[]};
my @other_type_constraints = @{$other->type_constraints||[]};
return unless @self_type_constraints == @other_type_constraints;
## Incoming ay be either arrayref or hashref, need top compare both
while(@self_type_constraints) {
my $self_type_constraint = shift @self_type_constraints;
my $other_type_constraint = shift @other_type_constraints;
$_ = Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($_)
for $self_type_constraint, $other_type_constraint;
return 1 if $self_type_constraint->$op($other_type_constraint);
}
return 0;
}
around 'get_message' => sub {
my ($get_message, $self, $value) = @_;
$value = Devel::PartialDump::dump($value)
if ref $value;
return $self->$get_message($value);
};
__PACKAGE__->meta->make_immutable(inline_constructor => 0);
__END__
=pod
=encoding utf-8
=head1 NAME
MooseX::Meta::TypeConstraint::Structured - MooseX::Meta::TypeConstraint::Structured - Structured type constraints.
=head1 DESCRIPTION
A structure is a set of L<Moose::Meta::TypeConstraint> that are 'aggregated' in
such a way as that they are all applied to an incoming list of arguments. The
idea here is that a Type Constraint could be something like, "An Int followed by
an Int and then a Str" and that this could be done so with a declaration like:
Tuple[Int,Int,Str]; ## Example syntax
So a structure is a list of Type constraints (the "Int,Int,Str" in the above
example) which are intended to function together.
=head1 ATTRIBUTES
=head2 type_constraints
A list of L<Moose::Meta::TypeConstraint> objects.
=head2 constraint_generator
A subref or closure that contains the way we validate incoming values against
a set of type constraints.
=head1 METHODS
=head2 validate
Messing with validate so that we can support niced error messages.
=head2 generate_constraint_for ($type_constraints)
Given some type constraints, use them to generate validation rules for an ref
of values (to be passed at check time)
=head2 parameterize (@type_constraints)
Given a ref of type constraints, create a structured type.
=head2 __infer_constraint_generator
This returns a CODEREF which generates a suitable constraint generator. Not
user servicable, you'll never call this directly.
=head2 compile_type_constraint
hook into compile_type_constraint so we can set the correct validation rules.
=head2 create_child_type
modifier to make sure we get the constraint_generator
=head2 is_a_type_of
=head2 is_subtype_of
=head2 equals
Override the base class behavior.
=head2 type_constraints_equals
Checks to see if the internal type constraints are equal.
=head2 get_message
Give you a better peek into what's causing the error. For now we stringify the
incoming deep value with L<Devel::PartialDump> and pass that on to either your
custom error message or the default one. In the future we'll try to provide a
more complete stack trace of the actual offending elements
=head1 SEE ALSO
The following modules or resources may be of interest.
L<Moose>, L<Moose::Meta::TypeConstraint>
=head1 AUTHORS
=over 4
=item *
John Napiorkowski <[email protected]>
=item *
Florian Ragwitz <[email protected]>
=item *
Yuval Kogman <[email protected]>
=item *
Tomas Doran <[email protected]>
=item *
Robert Sedlacek <[email protected]>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2011 by John Napiorkowski.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
Raw
Structured.pm
package MooseX::Types::Structured;
BEGIN {
$MooseX::Types::Structured::AUTHORITY = 'cpan:JJNAPIORK';
}
{
$MooseX::Types::Structured::VERSION = '0.28';
}
# ABSTRACT: MooseX::Types::Structured - Structured Type Constraints for Moose
use 5.008;
use Moose::Util::TypeConstraints 1.06;
use MooseX::Meta::TypeConstraint::Structured;
use MooseX::Meta::TypeConstraint::Structured::Optional;
use MooseX::Types::Structured::OverflowHandler;
use MooseX::Types::Structured::MessageStack;
use MooseX::Types 0.22 -declare => [qw(Dict Map Tuple Optional)];
use Sub::Exporter 0.982 -setup => [ qw(Dict Map Tuple Optional slurpy) ];
use Devel::PartialDump 0.10;
use Scalar::Util qw(blessed);
my $global_err = MooseX::Types::Structured::MessageStack->new;
END {
warn $global_err->as_string;
#warn $global_err->get_message;
}
my $Optional = MooseX::Meta::TypeConstraint::Structured::Optional->new(
name => 'MooseX::Types::Structured::Optional',
package_defined_in => __PACKAGE__,
parent => find_type_constraint('Item'),
constraint => sub { 1 },
constraint_generator => sub {
my ($type_parameter, @args) = @_;
my $check = $type_parameter->_compiled_type_constraint();
return sub {
my (@args) = @_;
## Does the arg exist? Something exists if it's a 'real' value
## or if it is set to undef.
if(exists($args[0])) {
## If it exists, we need to validate it
$check->($args[0]);
} else {
## But it's is okay if the value doesn't exists
return 1;
}
}
}
);
my $IsType = sub {
my ($obj, $type) = @_;
return $obj->can('equals')
? $obj->equals($type)
: undef;
};
my $CompiledTC = sub {
my ($obj) = @_;
my $method = '_compiled_type_constraint';
return(
$obj->$IsType('Any') ? undef
: $obj->can($method) ? $obj->$method
: sub { $obj->check(shift) },
);
};
Moose::Util::TypeConstraints::register_type_constraint($Optional);
Moose::Util::TypeConstraints::add_parameterizable_type($Optional);
Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
MooseX::Meta::TypeConstraint::Structured->new(
name => "MooseX::Types::Structured::Tuple" ,
parent => find_type_constraint('ArrayRef'),
constraint_generator=> sub {
## Get the constraints and values to check
my ($self, $type_constraints) = @_;
$type_constraints ||= $self->type_constraints;
my @type_constraints = defined $type_constraints ?
@$type_constraints : ();
my $overflow_handler;
if($type_constraints[-1] && blessed $type_constraints[-1]
&& $type_constraints[-1]->isa('MooseX::Types::Structured::OverflowHandler')) {
$overflow_handler = pop @type_constraints;
}
my $length = $#type_constraints;
foreach my $idx (0..$length) {
unless(blessed $type_constraints[$idx]) {
($type_constraints[$idx] = find_type_constraint($type_constraints[$idx]))
|| die "$type_constraints[$idx] is not a registered type";
}
}
my (@checks, @optional, $o_check, $is_compiled);
return sub {
my ($values, $err) = @_;
$err //= $global_err;
my @values = defined $values ? @$values : ();
## initialise on first time run
unless ($is_compiled) {
@checks = map { $_->$CompiledTC } @type_constraints;
@optional = map { $_->is_subtype_of($Optional) } @type_constraints;
$o_check = $overflow_handler->$CompiledTC
if $overflow_handler;
$is_compiled++;
}
## Perform the checking
VALUE:
for my $type_index (0 .. $#checks) {
my $type_constraint = $checks[ $type_index ];
if(@values) {
my $value = shift @values;
next VALUE
unless $type_constraint;
unless($type_constraint->($value)) {
if($err) {
my $message = $type_constraints[ $type_index ]->validate($value,$err);
$err->add_message({message=>$message,level=>$err->level});
}
return;
}
} else {
## Test if the TC supports null values
unless ($optional[ $type_index ]) {
if($err) {
my $message = $type_constraints[ $type_index ]->get_message('NULL',$err);
$err->add_message({message=>$message,level=>$err->level});
}
return;
}
}
}
## Make sure there are no leftovers.
if(@values) {
if($overflow_handler) {
return $o_check->([@values], $err);
} else {
if($err) {
my $message = "More values than Type Constraints!";
$err->add_message({message=>$message,level=>$err->level});
}
return;
}
} else {
return 1;
}
};
}
)
);
Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
MooseX::Meta::TypeConstraint::Structured->new(
name => "MooseX::Types::Structured::Dict",
parent => find_type_constraint('HashRef'),
constraint_generator => sub {
## Get the constraints and values to check
my ($self, $type_constraints) = @_;
$type_constraints = $self->type_constraints;
my @type_constraints = defined $type_constraints ?
@$type_constraints : ();
my $overflow_handler;
if($type_constraints[-1] && blessed $type_constraints[-1]
&& $type_constraints[-1]->isa('MooseX::Types::Structured::OverflowHandler')) {
$overflow_handler = pop @type_constraints;
}
my %type_constraints = @type_constraints;
foreach my $key (keys %type_constraints) {
unless(blessed $type_constraints{$key}) {
($type_constraints{$key} = find_type_constraint($type_constraints{$key}))
|| die "$type_constraints{$key} is not a registered type";
}
}
my (%check, %optional, $o_check, $is_compiled);
return sub {
my ($values, $err) = @_;
$err //= $global_err;
#use Carp; Carp::cluck("This is how we got here!");
my %values = defined $values ? %$values: ();
unless ($is_compiled) {
%check = map { ($_ => $type_constraints{ $_ }->$CompiledTC) } keys %type_constraints;
%optional = map { ($_ => $type_constraints{ $_ }->is_subtype_of($Optional)) } keys %type_constraints;
$o_check = $overflow_handler->$CompiledTC
if $overflow_handler;
$is_compiled++;
}
## Perform the checking
KEY:
for my $key (keys %check) {
my $type_constraint = $check{ $key };
if(exists $values{$key}) {
my $value = $values{$key};
delete $values{$key};
next KEY
unless $type_constraint;
unless($type_constraint->($value)) {
if($err) {
$DB::single = 1;
my $message = "$key: " . $type_constraints{ $key }->get_message($value, $err);
$err->add_message({message=>$message,level=>$err->level});
}
else {
my $message = "$key: " . $type_constraints{ $key }->get_message($value, $err);
warn $message;
}
return;
}
} else {
## Test to see if the TC supports null values
unless ($optional{ $key }) {
my $message = $type_constraints{ $key }->get_message('NULL',$err);
if($err) {
my $message = $type_constraints{ $key }->get_message('NULL',$err);
$err->add_message({message=>$message,level=>$err->level});
}
return;
}
}
}
## Make sure there are no leftovers.
if(%values) {
if($overflow_handler) {
return $o_check->(+{%values});
} else {
if($err) {
my $message = "More values than Type Constraints!";
$err->add_message({message=>$message,level=>$err->level});
}
return;
}
} else {
return 1;
}
}
},
)
);
Moose::Util::TypeConstraints::get_type_constraint_registry->add_type_constraint(
MooseX::Meta::TypeConstraint::Structured->new(
name => "MooseX::Types::Structured::Map",
parent => find_type_constraint('HashRef'),
constraint_generator=> sub {
## Get the constraints and values to check
my ($self, $type_constraints) = @_;
$type_constraints = $self->type_constraints;
my @constraints = defined $type_constraints ? @$type_constraints : ();
Carp::confess( "too many args for Map type" ) if @constraints > 2;
my ($key_type, $value_type) = @constraints == 2 ? @constraints
: @constraints == 1 ? (undef, @constraints)
: ();
my ($key_check, $value_check, $is_compiled);
return sub {
my ($values, $err) = @_;
$err //= $global_err;
my %values = defined $values ? %$values: ();
unless ($is_compiled) {
($key_check, $value_check)
= map { $_ ? $_->$CompiledTC : undef }
$key_type, $value_type;
$is_compiled++;
}
## Perform the checking
if ($value_check) {
for my $value (values %$values) {
unless ($value_check->($value)) {
if($err) {
my $message = $value_type->validate($value,$err);
$err->add_message({message=>$message,level=>$err->level});
}
return;
}
}
}
if ($key_check) {
for my $key (keys %$values) {
unless ($key_check->($key)) {
if($err) {
my $message = $key_type->validate($key,$err);
$err->add_message({message=>$message,level=>$err->level});
}
return;
}
}
}
return 1;
};
},
)
);
sub slurpy ($) {
my ($tc) = @_;
return MooseX::Types::Structured::OverflowHandler->new(
type_constraint => $tc,
);
}
1;
__END__
=pod
=encoding utf-8
=head1 NAME
MooseX::Types::Structured - MooseX::Types::Structured - Structured Type Constraints for Moose
=head1 SYNOPSIS
The following is example usage for this module.
package Person;
use Moose;
use MooseX::Types::Moose qw(Str Int HashRef);
use MooseX::Types::Structured qw(Dict Tuple Optional);
## A name has a first and last part, but middle names are not required
has name => (
isa=>Dict[
first => Str,
last => Str,
middle => Optional[Str],
],
);
## description is a string field followed by a HashRef of tagged data.
has description => (
isa=>Tuple[
Str,
Optional[HashRef],
],
);
## Remainder of your class attributes and methods
Then you can instantiate this class with something like:
my $john = Person->new(
name => {
first => 'John',
middle => 'James'
last => 'Napiorkowski',
},
description => [
'A cool guy who loves Perl and Moose.', {
married_to => 'Vanessa Li',
born_in => 'USA',
};
]
);
Or with:
my $vanessa = Person->new(
name => {
first => 'Vanessa',
last => 'Li'
},
description => ['A great student!'],
);
But all of these would cause a constraint error for the 'name' attribute:
## Value for 'name' not a HashRef
Person->new( name => 'John' );
## Value for 'name' has incorrect hash key and missing required keys
Person->new( name => {
first_name => 'John'
});
## Also incorrect keys
Person->new( name => {
first_name => 'John',
age => 39,
});
## key 'middle' incorrect type, should be a Str not a ArrayRef
Person->new( name => {
first => 'Vanessa',
middle => [1,2],
last => 'Li',
});
And these would cause a constraint error for the 'description' attribute:
## Should be an ArrayRef
Person->new( description => 'Hello I am a String' );
## First element must be a string not a HashRef.
Person->new (description => [{
tag1 => 'value1',
tag2 => 'value2'
}]);
Please see the test cases for more examples.
=head1 DESCRIPTION
A structured type constraint is a standard container L<Moose> type constraint,
such as an ArrayRef or HashRef, which has been enhanced to allow you to
explicitly name all the allowed type constraints inside the structure. The
generalized form is:
TypeConstraint[@TypeParameters or %TypeParameters]
Where 'TypeParameters' is an array reference or hash references of
L<Moose::Meta::TypeConstraint> objects.
This type library enables structured type constraints. It is built on top of the
L<MooseX::Types> library system, so you should review the documentation for that
if you are not familiar with it.
=head2 Comparing Parameterized types to Structured types
Parameterized constraints are built into core Moose and you are probably already
familiar with the type constraints 'HashRef' and 'ArrayRef'. Structured types
have similar functionality, so their syntax is likewise similar. For example,
you could define a parameterized constraint like:
subtype ArrayOfInts,
as ArrayRef[Int];
which would constrain a value to something like [1,2,3,...] and so on. On the
other hand, a structured type constraint explicitly names all it's allowed
'internal' type parameter constraints. For the example:
subtype StringFollowedByInt,
as Tuple[Str,Int];
would constrain it's value to things like ['hello', 111] but ['hello', 'world']
would fail, as well as ['hello', 111, 'world'] and so on. Here's another
example:
package MyApp::Types;
use MooseX::Types -declare [qw(StringIntOptionalHashRef)];
use MooseX::Types::Moose qw(Str Int);
use MooseX::Types::Structured qw(Tuple Optional);
subtype StringIntOptionalHashRef,
as Tuple[
Str, Int,
Optional[HashRef]
];
This defines a type constraint that validates values like:
['Hello', 100, {key1 => 'value1', key2 => 'value2'}];
['World', 200];
Notice that the last type constraint in the structure is optional. This is
enabled via the helper Optional type constraint, which is a variation of the
core Moose type constraint 'Maybe'. The main difference is that Optional type
constraints are required to validate if they exist, while 'Maybe' permits
undefined values. So the following example would not validate:
StringIntOptionalHashRef->validate(['Hello Undefined', 1000, undef]);
Please note the subtle difference between undefined and null. If you wish to
allow both null and undefined, you should use the core Moose 'Maybe' type
constraint instead:
package MyApp::Types;
use MooseX::Types -declare [qw(StringIntMaybeHashRef)];
use MooseX::Types::Moose qw(Str Int Maybe);
use MooseX::Types::Structured qw(Tuple);
subtype StringIntMaybeHashRef,
as Tuple[
Str, Int, Maybe[HashRef]
];
This would validate the following:
['Hello', 100, {key1 => 'value1', key2 => 'value2'}];
['World', 200, undef];
['World', 200];
Structured constraints are not limited to arrays. You can define a structure
against a HashRef with the 'Dict' type constaint as in this example:
subtype FirstNameLastName,
as Dict[
firstname => Str,
lastname => Str,
];
This would constrain a HashRef that validates something like:
{firstname => 'Christopher', lastname => 'Parsons'};
but all the following would fail validation:
## Incorrect keys
{first => 'Christopher', last => 'Parsons'};
## Too many keys
{firstname => 'Christopher', lastname => 'Parsons', middlename => 'Allen'};
## Not a HashRef
['Christopher', 'Parsons'];
These structures can be as simple or elaborate as you wish. You can even
combine various structured, parameterized and simple constraints all together:
subtype Crazy,
as Tuple[
Int,
Dict[name=>Str, age=>Int],
ArrayRef[Int]
];
Which would match:
[1, {name=>'John', age=>25},[10,11,12]];
Please notice how the type parameters can be visually arranged to your liking
and to improve the clarity of your meaning. You don't need to run then
altogether onto a single line. Additionally, since the 'Dict' type constraint
defines a hash constraint, the key order is not meaningful. For example:
subtype AnyKeyOrder,
as Dict[
key1=>Int,
key2=>Str,
key3=>Int,
];
Would validate both:
{key1 => 1, key2 => "Hi!", key3 => 2};
{key2 => "Hi!", key1 => 100, key3 => 300};
As you would expect, since underneath its just a plain old Perl hash at work.
=head2 Alternatives
You should exercise some care as to whether or not your complex structured
constraints would be better off contained by a real object as in the following
example:
package MyApp::MyStruct;
use Moose;
## lazy way to make a bunch of attributes
has $_ for qw(full_name age_in_years);
package MyApp::MyClass;
use Moose;
has person => (isa => 'MyApp::MyStruct');
my $instance = MyApp::MyClass->new(
person=>MyApp::MyStruct->new(
full_name => 'John',
age_in_years => 39,
),
);
This method may take some additional time to setup but will give you more
flexibility. However, structured constraints are highly compatible with this
method, granting some interesting possibilities for coercion. Try:
package MyApp::MyClass;
use Moose;
use MyApp::MyStruct;
## It's recommended your type declarations live in a separate class in order
## to promote reusability and clarity. Inlined here for brevity.
use MooseX::Types::DateTime qw(DateTime);
use MooseX::Types -declare [qw(MyStruct)];
use MooseX::Types::Moose qw(Str Int);
use MooseX::Types::Structured qw(Dict);
## Use class_type to create an ISA type constraint if your object doesn't
## inherit from Moose::Object.
class_type 'MyApp::MyStruct';
## Just a shorter version really.
subtype MyStruct,
as 'MyApp::MyStruct';
## Add the coercions.
coerce MyStruct,
from Dict[
full_name=>Str,
age_in_years=>Int
], via {
MyApp::MyStruct->new(%$_);
},
from Dict[
lastname=>Str,
firstname=>Str,
dob=>DateTime
], via {
my $name = $_->{firstname} .' '. $_->{lastname};
my $age = DateTime->now - $_->{dob};
MyApp::MyStruct->new(
full_name=>$name,
age_in_years=>$age->years,
);
};
has person => (isa=>MyStruct);
This would allow you to instantiate with something like:
my $obj = MyApp::MyClass->new( person => {
full_name=>'John Napiorkowski',
age_in_years=>39,
});
Or even:
my $obj = MyApp::MyClass->new( person => {
lastname=>'John',
firstname=>'Napiorkowski',
dob=>DateTime->new(year=>1969),
});
If you are not familiar with how coercions work, check out the L<Moose> cookbook
entry L<Moose::Cookbook::Recipe5> for an explanation. The section L</Coercions>
has additional examples and discussion.
=head2 Subtyping a Structured type constraint
You need to exercise some care when you try to subtype a structured type as in
this example:
subtype Person,
as Dict[name => Str];
subtype FriendlyPerson,
as Person[
name => Str,
total_friends => Int,
];
This will actually work BUT you have to take care that the subtype has a
structure that does not contradict the structure of it's parent. For now the
above works, but I will clarify the syntax for this at a future point, so
it's recommended to avoid (should not really be needed so much anyway). For
now this is supported in an EXPERIMENTAL way. Your thoughts, test cases and
patches are welcomed for discussion. If you find a good use for this, please
let me know.
=head2 Coercions
Coercions currently work for 'one level' deep. That is you can do:
subtype Person,
as Dict[
name => Str,
age => Int
];
subtype Fullname,
as Dict[
first => Str,
last => Str
];
coerce Person,
## Coerce an object of a particular class
from BlessedPersonObject, via {
+{
name=>$_->name,
age=>$_->age,
};
},
## Coerce from [$name, $age]
from ArrayRef, via {
+{
name=>$_->[0],
age=>$_->[1],
},
},
## Coerce from {fullname=>{first=>...,last=>...}, dob=>$DateTimeObject}
from Dict[fullname=>Fullname, dob=>DateTime], via {
my $age = $_->dob - DateTime->now;
my $firstn = $_->{fullname}->{first};
my $lastn = $_->{fullname}->{last}
+{
name => $_->{fullname}->{first} .' '. ,
age =>$age->years
}
};
And that should just work as expected. However, if there are any 'inner'
coercions, such as a coercion on 'Fullname' or on 'DateTime', that coercion
won't currently get activated.
Please see the test '07-coerce.t' for a more detailed example. Discussion on
extending coercions to support this welcome on the Moose development channel or
mailing list.
=head2 Recursion
Newer versions of L<MooseX::Types> support recursive type constraints. That is
you can include a type constraint as a contained type constraint of itself. For
example:
subtype Person,
as Dict[
name=>Str,
friends=>Optional[
ArrayRef[Person]
],
];
This would declare a Person subtype that contains a name and an optional
ArrayRef of Persons who are friends as in:
{
name => 'Mike',
friends => [
{ name => 'John' },
{ name => 'Vincent' },
{
name => 'Tracey',
friends => [
{ name => 'Stephenie' },
{ name => 'Ilya' },
],
},
],
};
Please take care to make sure the recursion node is either Optional, or declare
a Union with an non recursive option such as:
subtype Value
as Tuple[
Str,
Str|Tuple,
];
Which validates:
[
'Hello', [
'World', [
'Is', [
'Getting',
'Old',
],
],
],
];
Otherwise you will define a subtype thatis impossible to validate since it is
infinitely recursive. For more information about defining recursive types,
please see the documentation in L<MooseX::Types> and the test cases.
=head1 TYPE CONSTRAINTS
This type library defines the following constraints.
=head2 Tuple[@constraints]
This defines an ArrayRef based constraint which allows you to validate a specific
list of contained constraints. For example:
Tuple[Int,Str]; ## Validates [1,'hello']
Tuple[Str|Object, Int]; ## Validates ['hello', 1] or [$object, 2]
The Values of @constraints should ideally be L<MooseX::Types> declared type
constraints. We do support 'old style' L<Moose> string based constraints to a
limited degree but these string type constraints are considered deprecated.
There will be limited support for bugs resulting from mixing string and
L<MooseX::Types> in your structures. If you encounter such a bug and really
need it fixed, we will required a detailed test case at the minimum.
=head2 Dict[%constraints]
This defines a HashRef based constraint which allowed you to validate a specific
hashref. For example:
Dict[name=>Str, age=>Int]; ## Validates {name=>'John', age=>39}
The keys in %constraints follow the same rules as @constraints in the above
section.
=head2 Map[ $key_constraint, $value_constraint ]
This defines a HashRef based constraint in which both the keys and values are
required to meet certain constraints. For example, to map hostnames to IP
addresses, you might say:
Map[ HostName, IPAddress ]
The type constraint would only be met if every key was a valid HostName and
every value was a valid IPAddress.
=head2 Optional[$constraint]
This is primarily a helper constraint for Dict and Tuple type constraints. What
this allows is for you to assert that a given type constraint is allowed to be
null (but NOT undefined). If the value is null, then the type constraint passes
but if the value is defined it must validate against the type constraint. This
makes it easy to make a Dict where one or more of the keys doesn't have to exist
or a tuple where some of the values are not required. For example:
subtype Name() => as Dict[
first=>Str,
last=>Str,
middle=>Optional[Str],
];
Creates a constraint that validates against a hashref with the keys 'first' and
'last' being strings and required while an optional key 'middle' is must be a
string if it appears but doesn't have to appear. So in this case both the
following are valid:
{first=>'John', middle=>'James', last=>'Napiorkowski'}
{first=>'Vanessa', last=>'Li'}
If you use the 'Maybe' type constraint instead, your values will also validate
against 'undef', which may be incorrect for you.
=head1 EXPORTABLE SUBROUTINES
This type library makes available for export the following subroutines
=head2 slurpy
Structured type constraints by their nature are closed; that is validation will
depend on an exact match between your structure definition and the arguments to
be checked. Sometimes you might wish for a slightly looser amount of validation.
For example, you may wish to validate the first 3 elements of an array reference
and allow for an arbitrary number of additional elements. At first thought you
might think you could do it this way:
# I want to validate stuff like: [1,"hello", $obj, 2,3,4,5,6,...]
subtype AllowTailingArgs,
as Tuple[
Int,
Str,
Object,
ArrayRef[Int],
];
However what this will actually validate are structures like this:
[10,"Hello", $obj, [11,12,13,...] ]; # Notice element 4 is an ArrayRef
In order to allow structured validation of, "and then some", arguments, you can
use the L</slurpy> method against a type constraint. For example:
use MooseX::Types::Structured qw(Tuple slurpy);
subtype AllowTailingArgs,
as Tuple[
Int,
Str,
Object,
slurpy ArrayRef[Int],
];
This will now work as expected, validating ArrayRef structures such as:
[1,"hello", $obj, 2,3,4,5,6,...]
A few caveats apply. First, the slurpy type constraint must be the last one in
the list of type constraint parameters. Second, the parent type of the slurpy
type constraint must match that of the containing type constraint. That means
that a Tuple can allow a slurpy ArrayRef (or children of ArrayRefs, including
another Tuple) and a Dict can allow a slurpy HashRef (or children/subtypes of
HashRef, also including other Dict constraints).
Please note the the technical way this works 'under the hood' is that the
slurpy keyword transforms the target type constraint into a coderef. Please do
not try to create your own custom coderefs; always use the slurpy method. The
underlying technology may change in the future but the slurpy keyword will be
supported.
=head1 ERROR MESSAGES
Error reporting has been improved to return more useful debugging messages. Now
I will stringify the incoming check value with L<Devel::PartialDump> so that you
can see the actual structure that is tripping up validation. Also, I report the
'internal' validation error, so that if a particular element inside the
Structured Type is failing validation, you will see that. There's a limit to
how deep this internal reporting goes, but you shouldn't see any of the "failed
with ARRAY(XXXXXX)" that we got with earlier versions of this module.
This support is continuing to expand, so it's best to use these messages for
debugging purposes and not for creating messages that 'escape into the wild'
such as error messages sent to the user.
Please see the test '12-error.t' for a more lengthy example. Your thoughts and
preferable tests or code patches very welcome!
=head1 EXAMPLES
Here are some additional example usage for structured types. All examples can
be found also in the 't/examples.t' test. Your contributions are also welcomed.
=head2 Normalize a HashRef
You need a hashref to conform to a canonical structure but are required accept a
bunch of different incoming structures. You can normalize using the Dict type
constraint and coercions. This example also shows structured types mixed which
other MooseX::Types libraries.
package Test::MooseX::Meta::TypeConstraint::Structured::Examples::Normalize;
use Moose;
use DateTime;
use MooseX::Types::Structured qw(Dict Tuple);
use MooseX::Types::DateTime qw(DateTime);
use MooseX::Types::Moose qw(Int Str Object);
use MooseX::Types -declare => [qw(Name Age Person)];
subtype Person,
as Dict[
name=>Str,
age=>Int,
];
coerce Person,
from Dict[
first=>Str,
last=>Str,
years=>Int,
], via { +{
name => "$_->{first} $_->{last}",
age => $_->{years},
}},
from Dict[
fullname=>Dict[
last=>Str,
first=>Str,
],
dob=>DateTime,
],
## DateTime needs to be inside of single quotes here to disambiguate the
## class package from the DataTime type constraint imported via the
## line "use MooseX::Types::DateTime qw(DateTime);"
via { +{
name => "$_->{fullname}{first} $_->{fullname}{last}",
age => ($_->{dob} - 'DateTime'->now)->years,
}};
has person => (is=>'rw', isa=>Person, coerce=>1);
And now you can instantiate with all the following:
__PACKAGE__->new(
person=>{
name=>'John Napiorkowski',
age=>39,
},
);
__PACKAGE__->new(
person=>{
first=>'John',
last=>'Napiorkowski',
years=>39,
},
);
__PACKAGE__->new(
person=>{
fullname => {
first=>'John',
last=>'Napiorkowski'
},
dob => 'DateTime'->new(
year=>1969,
month=>2,
day=>13
),
},
);
This technique is a way to support various ways to instantiate your class in a
clean and declarative way.
=head1 SEE ALSO
The following modules or resources may be of interest.
L<Moose>, L<MooseX::Types>, L<Moose::Meta::TypeConstraint>,
L<MooseX::Meta::TypeConstraint::Structured>
=head1 AUTHORS
=over 4
=item *
John Napiorkowski <[email protected]>
=item *
Florian Ragwitz <[email protected]>
=item *
Yuval Kogman <[email protected]>
=item *
Tomas Doran <[email protected]>
=item *
Robert Sedlacek <[email protected]>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2011 by John Napiorkowski.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
Raw
TypeConstraint.pm
package Moose::Meta::TypeConstraint;
BEGIN {
$Moose::Meta::TypeConstraint::AUTHORITY = 'cpan:STEVAN';
}
{
$Moose::Meta::TypeConstraint::VERSION = '2.0401';
}
use strict;
use warnings;
use metaclass;
use overload '0+' => sub { refaddr(shift) }, # id an object
'""' => sub { shift->name }, # stringify to tc name
bool => sub { 1 },
fallback => 1;
use Carp qw(confess);
use Class::Load qw(load_class);
use Eval::Closure;
use Scalar::Util qw(blessed refaddr);
use Sub::Name qw(subname);
use Try::Tiny;
use base qw(Class::MOP::Object);
__PACKAGE__->meta->add_attribute('name' => (
reader => 'name',
Class::MOP::_definition_context(),
));
__PACKAGE__->meta->add_attribute('parent' => (
reader => 'parent',
predicate => 'has_parent',
Class::MOP::_definition_context(),
));
my $null_constraint = sub { 1 };
__PACKAGE__->meta->add_attribute('constraint' => (
reader => 'constraint',
writer => '_set_constraint',
default => sub { $null_constraint },
Class::MOP::_definition_context(),
));
__PACKAGE__->meta->add_attribute('message' => (
accessor => 'message',
predicate => 'has_message',
Class::MOP::_definition_context(),
));
__PACKAGE__->meta->add_attribute('_default_message' => (
accessor => '_default_message',
Class::MOP::_definition_context(),
));
# can't make this a default because it has to close over the type name, and
# cmop attributes don't have lazy
my $_default_message_generator = sub {
my $name = shift;
sub {
my $value = shift;
# have to load it late like this, since it uses Moose itself
my $can_partialdump = try {
# versions prior to 0.14 had a potential infinite loop bug
load_class('Devel::PartialDump', { -version => 0.14 });
1;
};
if ($can_partialdump) {
$value = Devel::PartialDump->new->dump($value);
}
else {
$value = (defined $value ? overload::StrVal($value) : 'undef');
}
return "Validation failed for '" . $name . "' with value $value";
}
};
__PACKAGE__->meta->add_attribute('coercion' => (
accessor => 'coercion',
predicate => 'has_coercion',
Class::MOP::_definition_context(),
));
__PACKAGE__->meta->add_attribute('hand_optimized_type_constraint' => (
init_arg => 'optimized',
accessor => 'hand_optimized_type_constraint',
predicate => 'has_hand_optimized_type_constraint',
Class::MOP::_definition_context(),
));
__PACKAGE__->meta->add_attribute('inlined' => (
init_arg => 'inlined',
accessor => 'inlined',
predicate => '_has_inlined_type_constraint',
Class::MOP::_definition_context(),
));
__PACKAGE__->meta->add_attribute('inline_environment' => (
init_arg => 'inline_environment',
accessor => '_inline_environment',
default => sub { {} },
Class::MOP::_definition_context(),
));
sub parents {
my $self = shift;
$self->parent;
}
# private accessors
__PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
accessor => '_compiled_type_constraint',
predicate => '_has_compiled_type_constraint',
Class::MOP::_definition_context(),
));
__PACKAGE__->meta->add_attribute('package_defined_in' => (
accessor => '_package_defined_in',
Class::MOP::_definition_context(),
));
sub new {
my $class = shift;
my ($first, @rest) = @_;
my %args = ref $first ? %$first : $first ? ($first, @rest) : ();
$args{name} = $args{name} ? "$args{name}" : "__ANON__";
if ( $args{optimized} ) {
Moose::Deprecated::deprecated(
feature => 'optimized type constraint sub ref',
message =>
'Providing an optimized subroutine ref for type constraints is deprecated.'
. ' Use the inlining feature (inline_as) instead.'
);
}
if ( exists $args{message}
&& (!ref($args{message}) || ref($args{message}) ne 'CODE') ) {
confess("The 'message' parameter must be a coderef");
}
my $self = $class->_new(%args);
$self->compile_type_constraint()
unless $self->_has_compiled_type_constraint;
$self->_default_message($_default_message_generator->($self->name))
unless $self->has_message;
return $self;
}
sub coerce {
my $self = shift;
my $coercion = $self->coercion;
unless ($coercion) {
require Moose;
Moose->throw_error("Cannot coerce without a type coercion");
}
return $_[0] if $self->check($_[0]);
return $coercion->coerce(@_);
}
sub assert_coerce {
my $self = shift;
my $coercion = $self->coercion;
unless ($coercion) {
require Moose;
Moose->throw_error("Cannot coerce without a type coercion");
}
return $_[0] if $self->check($_[0]);
my $result = $coercion->coerce(@_);
$self->assert_valid($result);
return $result;
}
sub check {
my ($self, @args) = @_;
my $constraint_subref = $self->_compiled_type_constraint;
return $constraint_subref->(@args) ? 1 : undef;
}
sub validate {
my ($self, $value) = @_;
if ($self->_compiled_type_constraint->($value)) {
return undef;
}
else {
$self->get_message($value);
}
}
sub can_be_inlined {
my $self = shift;
if ( $self->has_parent && $self->constraint == $null_constraint ) {
return $self->parent->can_be_inlined;
}
return $self->_has_inlined_type_constraint;
}
sub _inline_check {
my $self = shift;
unless ( $self->can_be_inlined ) {
require Moose;
Moose->throw_error( 'Cannot inline a type constraint check for ' . $self->name );
}
if ( $self->has_parent && $self->constraint == $null_constraint ) {
return $self->parent->_inline_check(@_);
}
return '( do { ' . $self->inlined->( $self, @_ ) . ' } )';
}
sub inline_environment {
my $self = shift;
if ( $self->has_parent && $self->constraint == $null_constraint ) {
return $self->parent->inline_environment;
}
return $self->_inline_environment;
}
sub assert_valid {
my ($self, $value) = @_;
my $error = $self->validate($value);
return 1 if ! defined $error;
require Moose;
Moose->throw_error($error);
}
sub get_message {
my ($self, $value) = @_;
my $msg = $self->has_message
? $self->message
: $self->_default_message;
local $_ = $value;
return $msg->($value);
}
## type predicates ...
sub equals {
my ( $self, $type_or_name ) = @_;
my $other = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
return 1 if $self == $other;
if ( $self->has_hand_optimized_type_constraint and $other->has_hand_optimized_type_constraint ) {
return 1 if $self->hand_optimized_type_constraint == $other->hand_optimized_type_constraint;
}
return unless $self->constraint == $other->constraint;
if ( $self->has_parent ) {
return unless $other->has_parent;
return unless $self->parent->equals( $other->parent );
} else {
return if $other->has_parent;
}
return;
}
sub is_a_type_of {
my ($self, $type_or_name) = @_;
my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
($self->equals($type) || $self->is_subtype_of($type));
}
sub is_subtype_of {
my ($self, $type_or_name) = @_;
my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name) or return;
my $current = $self;
while (my $parent = $current->parent) {
return 1 if $parent->equals($type);
$current = $parent;
}
return 0;
}
## compiling the type constraint
sub compile_type_constraint {
my $self = shift;
$self->_compiled_type_constraint($self->_actually_compile_type_constraint);
}
## type compilers ...
sub _actually_compile_type_constraint {
my $self = shift;
return $self->_compile_hand_optimized_type_constraint
if $self->has_hand_optimized_type_constraint;
if ( $self->can_be_inlined ) {
return eval_closure(
source => 'sub { ' . $self->_inline_check('$_[0]') . ' }',
environment => $self->inline_environment,
);
}
my $check = $self->constraint;
unless ( defined $check ) {
require Moose;
Moose->throw_error( "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;
unless ( ref $type_constraint ) {
require Moose;
Moose->throw_error("Hand optimized type constraint is not a code reference");
}
return $type_constraint;
}
sub _compile_subtype {
my ($self, $check) = @_;
# gather all the parent constraintss in order
my @parents;
my $optimized_parent;
foreach my $parent ($self->_collect_all_parents) {
# if a parent is optimized, the optimized constraint already includes
# all of its parents tcs, so we can break the loop
if ($parent->has_hand_optimized_type_constraint) {
push @parents => $optimized_parent = $parent->hand_optimized_type_constraint;
last;
}
else {
push @parents => $parent->constraint;
}
}
@parents = grep { $_ != $null_constraint } reverse @parents;
unless ( @parents ) {
return $self->_compile_type($check);
} elsif( $optimized_parent and @parents == 1 ) {
# the case of just one optimized parent is optimized to prevent
# looping and the unnecessary localization
if ( $check == $null_constraint ) {
return $optimized_parent;
} else {
return subname($self->name, sub {
return undef unless $optimized_parent->($_[0]);
my (@args) = @_;
local $_ = $args[0];
$check->(@args);
});
}
} else {
# general case, check all the constraints, from the first parent to ourselves
my @checks = @parents;
push @checks, $check if $check != $null_constraint;
return subname($self->name => sub {
my (@args) = @_;
local $_ = $args[0];
foreach my $check (@checks) {
$DB::single = 1 unless $check->(@args);
return undef unless $check->(@args);
}
return 1;
});
}
}
sub _compile_type {
my ($self, $check) = @_;
return $check if $check == $null_constraint; # Item, Any
return subname($self->name => sub {
my (@args) = @_;
local $_ = $args[0];
$check->(@args);
});
}
## other utils ...
sub _collect_all_parents {
my $self = shift;
my @parents;
my $current = $self->parent;
while (defined $current) {
push @parents => $current;
$current = $current->parent;
}
return @parents;
}
sub create_child_type {
my ($self, %opts) = @_;
my $class = ref $self;
return $class->new(%opts, parent => $self);
}
1;
# ABSTRACT: The Moose Type Constraint metaclass
=pod
=head1 NAME
Moose::Meta::TypeConstraint - The Moose Type Constraint metaclass
=head1 VERSION
version 2.0401
=head1 DESCRIPTION
This class represents a single type constraint. Moose's built-in type
constraints, as well as constraints you define, are all stored in a
L<Moose::Meta::TypeConstraint::Registry> object as objects of this
class.
=head1 INHERITANCE
C<Moose::Meta::TypeConstraint> is a subclass of L<Class::MOP::Object>.
=head1 METHODS
=over 4
=item B<< Moose::Meta::TypeConstraint->new(%options) >>
This creates a new type constraint based on the provided C<%options>:
=over 8
=item * name
The constraint name. If a name is not provided, it will be set to
"__ANON__".
=item * parent
A C<Moose::Meta::TypeConstraint> object which is the parent type for
the type being created. This is optional.
=item * constraint
This is the subroutine reference that implements the actual constraint
check. This defaults to a subroutine which always returns true.
=item * message
A subroutine reference which is used to generate an error message when
the constraint fails. This is optional.
=item * coercion
A L<Moose::Meta::TypeCoercion> object representing the coercions to
the type. This is optional.
=item * inlined
A subroutine which returns a string suitable for inlining this type
constraint. It will be called as a method on the type constraint object, and
will receive a single additional parameter, a variable name to be tested
(usually C<"$_"> or C<"$_[0]">.
This is optional.
=item * inline_environment
A hash reference of variables to close over. The keys are variables names, and
the values are I<references> to the variables.
=item * optimized
B<This option is deprecated.>
This is a variant of the C<constraint> parameter that is somehow
optimized. Typically, this means incorporating both the type's
constraint and all of its parents' constraints into a single
subroutine reference.
=back
=item B<< $constraint->equals($type_name_or_object) >>
Returns true if the supplied name or type object is the same as the
current type.
=item B<< $constraint->is_subtype_of($type_name_or_object) >>
Returns true if the supplied name or type object is a parent of the
current type.
=item B<< $constraint->is_a_type_of($type_name_or_object) >>
Returns true if the given type is the same as the current type, or is
a parent of the current type. This is a shortcut for checking
C<equals> and C<is_subtype_of>.
=item B<< $constraint->coerce($value) >>
This will attempt to coerce the value to the type. If the type does not
have any defined coercions this will throw an error.
If no coercion can produce a value matching C<$constraint>, the original
value is returned.
=item B<< $constraint->assert_coerce($value) >>
This method behaves just like C<coerce>, but if the result is not valid
according to C<$constraint>, an error is thrown.
=item B<< $constraint->check($value) >>
Returns true if the given value passes the constraint for the type.
=item B<< $constraint->validate($value) >>
This is similar to C<check>. However, if the type I<is valid> then the
method returns an explicit C<undef>. If the type is not valid, we call
C<< $self->get_message($value) >> internally to generate an error
message.
=item B<< $constraint->assert_valid($value) >>
Like C<check> and C<validate>, this method checks whether C<$value> is
valid under the constraint. If it is, it will return true. If it is not,
an exception will be thrown with the results of
C<< $self->get_message($value) >>.
=item B<< $constraint->name >>
Returns the type's name, as provided to the constructor.
=item B<< $constraint->parent >>
Returns the type's parent, as provided to the constructor, if any.
=item B<< $constraint->has_parent >>
Returns true if the type has a parent type.
=item B<< $constraint->parents >>
Returns all of the types parents as an list of type constraint objects.
=item B<< $constraint->constraint >>
Returns the type's constraint, as provided to the constructor.
=item B<< $constraint->get_message($value) >>
This generates a method for the given value. If the type does not have
an explicit message, we generate a default message.
=item B<< $constraint->has_message >>
Returns true if the type has a message.
=item B<< $constraint->message >>
Returns the type's message as a subroutine reference.
=item B<< $constraint->coercion >>
Returns the type's L<Moose::Meta::TypeCoercion> object, if one
exists.
=item B<< $constraint->has_coercion >>
Returns true if the type has a coercion.
=item B<< $constraint->can_be_inlined >>
Returns true if this type constraint can be inlined. A type constraint which
subtypes an inlinable constraint and does not add an additional constraint
"inherits" its parent type's inlining.
=item B<< $constraint->hand_optimized_type_constraint >>
B<This method is deprecated.>
Returns the type's hand optimized constraint, as provided to the
constructor via the C<optimized> option.
=item B<< $constraint->has_hand_optimized_type_constraint >>
B<This method is deprecated.>
Returns true if the type has an optimized constraint.
=item B<< $constraint->create_child_type(%options) >>
This returns a new type constraint of the same class using the
provided C<%options>. The C<parent> option will be the current type.
This method exists so that subclasses of this class can override this
behavior and change how child types are created.
=back
=head1 BUGS
See L<Moose/BUGS> for details on reporting bugs.
=head1 AUTHOR
Moose is maintained by the Moose Cabal, along with the help of many contributors. See L<Moose/CABAL> and L<Moose/CONTRIBUTORS> for details.
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2011 by Infinity Interactive, Inc..
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__
Raw
Types.pm
package MooseX::Types;
{
$MooseX::Types::VERSION = '0.35';
}
use Moose;
# ABSTRACT: Organise your Moose types in libraries
use Moose::Util::TypeConstraints;
use MooseX::Types::TypeDecorator;
use MooseX::Types::Base ();
use MooseX::Types::Util qw( filter_tags );
use MooseX::Types::UndefinedType;
use MooseX::Types::CheckedUtilExports ();
use Carp::Clan qw( ^MooseX::Types );
use Sub::Name;
use Scalar::Util 'reftype';
use namespace::clean -except => [qw( meta )];
use 5.008;
my $UndefMsg = q{Action for type '%s' not yet defined in library '%s'};
sub import {
my ($class, %args) = @_;
my $caller = caller;
# everyone should want this
strict->import;
warnings->import;
# inject base class into new library
{ no strict 'refs';
unshift @{ $caller . '::ISA' }, 'MooseX::Types::Base';
}
# generate predeclared type helpers
if (my @orig_declare = @{ $args{ -declare } || [] }) {
my ($tags, $declare) = filter_tags @orig_declare;
my @to_export;
for my $type (@$declare) {
croak "Cannot create a type containing '::' ($type) at the moment"
if $type =~ /::/;
# add type to library and remember to export
$caller->add_type($type);
push @to_export, $type;
}
$caller->import({ -full => 1, -into => $caller }, @to_export);
}
# run type constraints import
Moose::Util::TypeConstraints->import({ into => $caller });
# override some with versions that check for syntax errors
MooseX::Types::CheckedUtilExports->import({ into => $caller });
1;
}
sub type_export_generator {
my ($class, $type, $name) = @_;
## Return an anonymous subroutine that will generate the proxied type
## constraint for you.
return subname "__TYPE__::$name" => sub {
my $type_constraint = $class->create_base_type_constraint($name);
if(defined(my $params = shift @_)) {
## We currently only allow a TC to accept a single, ArrayRef
## parameter, as in HashRef[Int], where [Int] is what's inside the
## ArrayRef passed.
if(reftype $params eq 'ARRAY') {
$type_constraint = $class->create_arged_type_constraint($name, @$params);
} elsif(!defined $type_constraint) {
croak "Syntax error in type definition (did you forget a comma"
. " after $type?)";
} else {
croak "Argument must be an ArrayRef to create a parameterized "
. "type, Eg.: ${type}[Int]. Got: ".ref($params)."."
}
}
$type_constraint = defined($type_constraint) ? $type_constraint
: MooseX::Types::UndefinedType->new($name);
my $type_decorator = $class->create_type_decorator($type_constraint);
## If there are additional args, that means it's probably stuff that
## needs to be returned to the subtype. Not an ideal solution here but
## doesn't seem to cause trouble.
if(@_) {
return ($type_decorator, @_);
} else {
return $type_decorator;
}
};
}
sub create_arged_type_constraint {
my ($class, $name, @args) = @_;
my $type_constraint = Moose::Util::TypeConstraints::find_or_create_type_constraint("$name");
my $parameterized = $type_constraint->parameterize(@args);
# It's obnoxious to have to parameterize before looking for the TC, but the
# alternative is to hard-code the assumption that the name is
# "$name[$args[0]]", which would be worse.
# This breaks MXMS, unfortunately, which relies on things like Tuple[...]
# creating new type objects each time.
# if (my $existing =
# Moose::Util::TypeConstraints::find_type_constraint($parameterized->name)) {
# return $existing;
# }
# Moose::Util::TypeConstraints::register_type_constraint($parameterized);
return $parameterized;
}
sub create_base_type_constraint {
my ($class, $name) = @_;
return find_type_constraint($name);
}
sub create_type_decorator {
my ($class, $type_constraint) = @_;
return MooseX::Types::TypeDecorator->new($type_constraint);
}
sub coercion_export_generator {
my ($class, $type, $full, $undef_msg) = @_;
return sub {
my ($value) = @_;
# we need a type object
my $tobj = find_type_constraint($full) or croak $undef_msg;
my $return = $tobj->coerce($value);
# non-successful coercion returns false
return unless $tobj->check($return);
return $return;
}
}
sub check_export_generator {
my ($class, $type, $full, $undef_msg) = @_;
return sub {
my ($value) = @_;
# we need a type object
my $tobj = find_type_constraint($full) or croak $undef_msg;
return $tobj->check($value);
}
}
1;
__END__
=pod
=head1 NAME
MooseX::Types - Organise your Moose types in libraries
=head1 VERSION
version 0.35
=head1 SYNOPSIS
=head2 Library Definition
package MyLibrary;
# predeclare our own types
use MooseX::Types -declare => [
qw(
PositiveInt
NegativeInt
ArrayRefOfPositiveInt
ArrayRefOfAtLeastThreeNegativeInts
LotsOfInnerConstraints
StrOrArrayRef
MyDateTime
)
];
# import builtin types
use MooseX::Types::Moose qw/Int HashRef/;
# type definition.
subtype PositiveInt,
as Int,
where { $_ > 0 },
message { "Int is not larger than 0" };
subtype NegativeInt,
as Int,
where { $_ < 0 },
message { "Int is not smaller than 0" };
# type coercion
coerce PositiveInt,
from Int,
via { 1 };
# with parameterized constraints.
subtype ArrayRefOfPositiveInt,
as ArrayRef[PositiveInt];
subtype ArrayRefOfAtLeastThreeNegativeInts,
as ArrayRef[NegativeInt],
where { scalar(@$_) > 2 };
subtype LotsOfInnerConstraints,
as ArrayRef[ArrayRef[HashRef[Int]]];
# with TypeConstraint Unions
subtype StrOrArrayRef,
as Str|ArrayRef;
# class types
class_type 'DateTime';
# or better
class_type MyDateTime, { class => 'DateTime' };
coerce MyDateTime,
from HashRef,
via { DateTime->new(%$_) };
1;
=head2 Usage
package Foo;
use Moose;
use MyLibrary qw( PositiveInt NegativeInt );
# use the exported constants as type names
has 'bar',
isa => PositiveInt,
is => 'rw';
has 'baz',
isa => NegativeInt,
is => 'rw';
sub quux {
my ($self, $value);
# test the value
print "positive\n" if is_PositiveInt($value);
print "negative\n" if is_NegativeInt($value);
# coerce the value, NegativeInt doesn't have a coercion
# helper, since it didn't define any coercions.
$value = to_PositiveInt($value) or die "Cannot coerce";
}
1;
=head1 DESCRIPTION
The type system provided by Moose effectively makes all of its builtin type
global, as are any types you declare with Moose. This means that every module
that declares a type named "PositiveInt" is sharing the same type object. This
can be a problem when different parts of the code base want to use the same
name for different things.
This package lets you declare types using short names, but behind the scenes
it namespaces all your type declarations, effectively prevent name clashes
between packages.
This is done by creating a type library module like C<MyApp::Types> and then
importing types from that module into other modules.
As a side effect, the declaration mechanism allows you to write type names as
barewords (really function calls), which catches typos in names at compile
time rather than run time.
This module also provides some helper functions for using Moose types outside
of attribute declarations.
If you mix string-based names with types created by this module, it will warn,
with a few exceptions. If you are declaring a C<class_type()> or
C<role_type()> within your type library, or if you use a fully qualified name
like C<"MyApp::Foo">.
=head1 LIBRARY DEFINITION
A MooseX::Types is just a normal Perl module. Unlike Moose
itself, it does not install C<use strict> and C<use warnings> in your
class by default, so this is up to you.
The only thing a library is required to do is
use MooseX::Types -declare => \@types;
with C<@types> being a list of types you wish to define in this library.
This line will install a proper base class in your package as well as the
full set of L<handlers|/"TYPE HANDLER FUNCTIONS"> for your declared
types. It will then hand control over to L<Moose::Util::TypeConstraints>'
C<import> method to export the functions you will need to declare your
types.
If you want to use Moose' built-in types (e.g. for subtyping) you will
want to
use MooseX::Types::Moose @types;
to import the helpers from the shipped L<MooseX::Types::Moose>
library which can export all types that come with Moose.
You will have to define coercions for your types or your library won't
export a L</to_$type> coercion helper for it.
Note that you currently cannot define types containing C<::>, since
exporting would be a problem.
You also don't need to use C<warnings> and C<strict>, since the
definition of a library automatically exports those.
=head1 LIBRARY USAGE
You can import the L<"type helpers"|/"TYPE HANDLER FUNCTIONS"> of a
library by C<use>ing it with a list of types to import as arguments. If
you want all of them, use the C<:all> tag. For example:
use MyLibrary ':all';
use MyOtherLibrary qw( TypeA TypeB );
MooseX::Types comes with a library of Moose' built-in types called
L<MooseX::Types::Moose>.
The exporting mechanism is, since version 0.5, implemented via a wrapper
around L<Sub::Exporter>. This means you can do something like this:
use MyLibrary TypeA => { -as => 'MyTypeA' },
TypeB => { -as => 'MyTypeB' };
=head1 TYPE HANDLER FUNCTIONS
=head2 $type
A constant with the name of your type. It contains the type's fully
qualified name. Takes no value, as all constants.
=head2 is_$type
This handler takes a value and tests if it is a valid value for this
C<$type>. It will return true or false.
=head2 to_$type
A handler that will take a value and coerce it into the C<$type>. It will
return a false value if the type could not be coerced.
B<Important Note>: This handler will only be exported for types that can
do type coercion. This has the advantage that a coercion to a type that
has not defined any coercions will lead to a compile-time error.
=head1 WRAPPING A LIBRARY
You can define your own wrapper subclasses to manipulate the behaviour
of a set of library exports. Here is an example:
package MyWrapper;
use strict;
use MRO::Compat;
use base 'MooseX::Types::Wrapper';
sub coercion_export_generator {
my $class = shift;
my $code = $class->next::method(@_);
return sub {
my $value = $code->(@_);
warn "Coercion returned undef!"
unless defined $value;
return $value;
};
}
1;
This class wraps the coercion generator (e.g., C<to_Int()>) and warns
if a coercion returned an undefined value. You can wrap any library
with this:
package Foo;
use strict;
use MyWrapper MyLibrary => [qw( Foo Bar )],
Moose => [qw( Str Int )];
...
1;
The C<Moose> library name is a special shortcut for L<MooseX::Types::Moose>.
=head2 Generator methods you can overload
=over 4
=item type_export_generator( $short, $full )
Creates a closure returning the type's L<Moose::Meta::TypeConstraint> object.
=item check_export_generator( $short, $full, $undef_message )
This creates the closure used to test if a value is valid for this type.
=item coercion_export_generator( $short, $full, $undef_message )
This is the closure that's doing coercions.
=back
=head2 Provided Parameters
=over 4
=item $short
The short, exported name of the type.
=item $full
The fully qualified name of this type as L<Moose> knows it.
=item $undef_message
A message that will be thrown when type functionality is used but the
type does not yet exist.
=back
=head1 RECURSIVE SUBTYPES
As of version 0.08, L<Moose::Types> has experimental support for Recursive
subtypes. This will allow:
subtype Tree() => as HashRef[Str|Tree];
Which validates things like:
{key=>'value'};
{key=>{subkey1=>'value', subkey2=>'value'}}
And so on. This feature is new and there may be lurking bugs so don't be afraid
to hunt me down with patches and test cases if you have trouble.
=head1 NOTES REGARDING TYPE UNIONS
L<MooseX::Types> uses L<MooseX::Types::TypeDecorator> to do some overloading
which generally allows you to easily create union types:
subtype StrOrArrayRef,
as Str|ArrayRef;
As with parameterized constrains, this overloading extends to modules using the
types you define in a type library.
use Moose;
use MooseX::Types::Moose qw(HashRef Int);
has 'attr' => ( isa => HashRef | Int );
And everything should just work as you'd think.
=head1 METHODS
=head2 import
Installs the L<MooseX::Types::Base> class into the caller and exports types
according to the specification described in L</"LIBRARY DEFINITION">. This
will continue to L<Moose::Util::TypeConstraints>' C<import> method to export
helper functions you will need to declare your types.
=head2 type_export_generator
Generate a type export, e.g. C<Int()>. This will return either a
L<Moose::Meta::TypeConstraint> object, or alternatively a
L<MooseX::Types::UndefinedType> object if the type was not yet defined.
=head2 create_arged_type_constraint ($name, @args)
Given a String $name with @args find the matching typeconstraint and parameterize
it with @args.
=head2 create_base_type_constraint ($name)
Given a String $name, find the matching type constraint.
=head2 create_type_decorator ($type_constraint)
Given a $type_constraint, return a lightweight L<MooseX::Types::TypeDecorator>
instance.
=head2 coercion_export_generator
This generates a coercion handler function, e.g. C<to_Int($value)>.
=head2 check_export_generator
Generates a constraint check closure, e.g. C<is_Int($value)>.
=head1 CAVEATS
The following are lists of gotchas and their workarounds for developers coming
from the standard string based type constraint names
=head2 Uniqueness
A library makes the types quasi-unique by prefixing their names with (by
default) the library package name. If you're only using the type handler
functions provided by MooseX::Types, you shouldn't ever have to use
a type's actual full name.
=head2 Argument separation ('=>' versus ',')
The L<perlop> manpage has this to say about the '=>' operator: "The => operator is
a synonym for the comma, but forces any word (consisting entirely of word
characters) to its left to be interpreted as a string (as of 5.001). This
includes words that might otherwise be considered a constant or function call."
Due to this stringification, the following will NOT work as you might think:
subtype StrOrArrayRef => as Str | ArrayRef;
The 'StrOrArrayRef' will have its stringification activated this causes the
subtype to not be created. Since the bareword type constraints are not strings
you really should not try to treat them that way. You will have to use the ','
operator instead. The author's of this package realize that all the L<Moose>
documention and examples nearly uniformly use the '=>' version of the comma
operator and this could be an issue if you are converting code.
Patches welcome for discussion.
=head2 Compatibility with Sub::Exporter
If you want to use L<Sub::Exporter> with a Type Library, you need to make sure
you export all the type constraints declared AS WELL AS any additional export
targets. For example if you do:
package TypeAndSubExporter;
use MooseX::Types::Moose qw(Str);
use MooseX::Types -declare => [qw(MyStr)];
use Sub::Exporter -setup => { exports => [qw(something)] };
subtype MyStr, as Str;
sub something {
return 1;
}
# then in another module ...
package Foo;
use TypeAndSubExporter qw(MyStr);
You'll get a '"MyStr" is not exported by the TypeAndSubExporter module' error.
Upi can workaround by:
- use Sub::Exporter -setup => { exports => [ qw(something) ] };
+ use Sub::Exporter -setup => { exports => [ qw(something MyStr) ] };
This is a workaround and I am exploring how to make these modules work better
together. I realize this workaround will lead a lot of duplication in your
export declarations and will be onerous for large type libraries. Patches and
detailed test cases welcome. See the tests directory for a start on this.
=head1 COMBINING TYPE LIBRARIES
You may want to combine a set of types for your application with other type
libraries, like L<MooseX::Types::Moose> or L<MooseX::Types::Common::String>.
The L<MooseX::Types::Combine> module provides a simple API for combining a set
of type libraries together.
=head1 SEE ALSO
L<Moose>, L<Moose::Util::TypeConstraints>, L<MooseX::Types::Moose>,
L<Sub::Exporter>
=head1 ACKNOWLEDGEMENTS
Many thanks to the C<#moose> cabal on C<irc.perl.org>.
=head1 CONTRIBUTORS
jnapiorkowski: John Napiorkowski <[email protected]>
caelum: Rafael Kitover <[email protected]>
rafl: Florian Ragwitz <[email protected]>
hdp: Hans Dieter Pearcey <[email protected]>
autarch: Dave Rolsky <[email protected]>
=head1 AUTHOR
Robert "phaylon" Sedlacek <[email protected]>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2012 by Robert "phaylon" Sedlacek.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment