X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil%2FTypeConstraints.pm;h=bf70f32dc90f3808890a52e7f83e8498c12b583a;hb=cdacfaf381f5ad01b37a6ac069d82fcef38d2eaa;hp=6d486dd35d04fcea623fd0705a4624df46242171;hpb=a05c504e2afdd5b9b3934d36b8ce2b5e15f052ef;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 6d486dd..bf70f32 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -4,229 +4,768 @@ package Moose::Util::TypeConstraints; use strict; use warnings; -use Carp 'confess'; -use Scalar::Util 'blessed'; -use B 'svref_2object'; -use Sub::Exporter; +use Carp (); +use List::MoreUtils qw( all any ); +use Scalar::Util qw( blessed reftype ); +use Moose::Exporter; -our $VERSION = '0.12'; +our $VERSION = '0.73'; +$VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; +## -------------------------------------------------------- +# Prototyped subs must be predeclared because we have a +# circular dependency with Moose::Meta::Attribute et. al. +# so in case of us being use'd first the predeclaration +# ensures the prototypes are in scope when consumers are +# compiled. + +# dah sugah! +sub where (&); +sub via (&); +sub message (&); +sub optimize_as (&); + +## -------------------------------------------------------- + use Moose::Meta::TypeConstraint; +use Moose::Meta::TypeConstraint::Union; +use Moose::Meta::TypeConstraint::Parameterized; +use Moose::Meta::TypeConstraint::Parameterizable; +use Moose::Meta::TypeConstraint::Class; +use Moose::Meta::TypeConstraint::Role; +use Moose::Meta::TypeConstraint::Enum; use Moose::Meta::TypeCoercion; +use Moose::Meta::TypeCoercion::Union; +use Moose::Meta::TypeConstraint::Registry; +use Moose::Util::TypeConstraints::OptimizedConstraints; + +Moose::Exporter->setup_import_methods( + as_is => [ + qw( + type subtype class_type role_type maybe_type duck_type + as where message optimize_as + coerce from via + enum + find_type_constraint + register_type_constraint ) + ], + _export_to_main => 1, +); + +## -------------------------------------------------------- +## type registry and some useful functions for it +## -------------------------------------------------------- + +my $REGISTRY = Moose::Meta::TypeConstraint::Registry->new; + +sub get_type_constraint_registry {$REGISTRY} +sub list_all_type_constraints { keys %{ $REGISTRY->type_constraints } } + +sub export_type_constraints_as_functions { + my $pkg = caller(); + no strict 'refs'; + foreach my $constraint ( keys %{ $REGISTRY->type_constraints } ) { + my $tc = $REGISTRY->get_type_constraint($constraint) + ->_compiled_type_constraint; + *{"${pkg}::${constraint}"} + = sub { $tc->( $_[0] ) ? 1 : undef }; # the undef is for compat + } +} -my @exports = qw/ - type subtype as where message optimize_as - coerce from via - enum - find_type_constraint -/; - -Sub::Exporter::setup_exporter({ - exports => \@exports, - groups => { default => [':all'] } -}); - -sub unimport { - no strict 'refs'; - my $class = caller(); - # loop through the exports ... - foreach my $name (@exports) { - # if we find one ... - if (defined &{$class . '::' . $name}) { - my $keyword = \&{$class . '::' . $name}; - - # make sure it is from Moose - my $pkg_name = eval { svref_2object($keyword)->GV->STASH->NAME }; - next if $@; - next if $pkg_name ne 'Moose::Util::TypeConstraints'; - - # and if it is from Moose then undef the slot - delete ${$class . '::'}{$name}; - } +sub create_type_constraint_union { + my @type_constraint_names; + + if ( scalar @_ == 1 && _detect_type_constraint_union( $_[0] ) ) { + @type_constraint_names = _parse_type_constraint_union( $_[0] ); + } + else { + @type_constraint_names = @_; } + + ( scalar @type_constraint_names >= 2 ) + || __PACKAGE__->_throw_error( + "You must pass in at least 2 type names to make a union"); + + my @type_constraints = map { + find_or_parse_type_constraint($_) + || __PACKAGE__->_throw_error( + "Could not locate type constraint ($_) for the union"); + } @type_constraint_names; + + return Moose::Meta::TypeConstraint::Union->new( + type_constraints => \@type_constraints ); } -{ - my %TYPES; - sub find_type_constraint ($) { - return $TYPES{$_[0]}->[1] - if exists $TYPES{$_[0]}; - return; +sub create_parameterized_type_constraint { + my $type_constraint_name = shift; + my ( $base_type, $type_parameter ) + = _parse_parameterized_type_constraint($type_constraint_name); + + ( defined $base_type && defined $type_parameter ) + || __PACKAGE__->_throw_error( + "Could not parse type name ($type_constraint_name) correctly"); + + if ( $REGISTRY->has_type_constraint($base_type) ) { + my $base_type_tc = $REGISTRY->get_type_constraint($base_type); + return _create_parameterized_type_constraint( + $base_type_tc, + $type_parameter + ); } - - sub _dump_type_constraints { - require Data::Dumper; - Data::Dumper::Dumper(\%TYPES); - } - - sub _create_type_constraint ($$$;$$) { - my $name = shift; - my $parent = shift; - my $check = shift;; - - my ($message, $optimized); - for (@_) { - $message = $_->{message} if exists $_->{message}; - $optimized = $_->{optimized} if exists $_->{optimized}; - } + else { + __PACKAGE__->_throw_error( + "Could not locate the base type ($base_type)"); + } +} - my $pkg_defined_in = scalar(caller(0)); - - ($TYPES{$name}->[0] eq $pkg_defined_in) - || confess ("The type constraint '$name' has already been created in " - . $TYPES{$name}->[0] . " and cannot be created again in " - . $pkg_defined_in) - if defined $name && exists $TYPES{$name}; - - $parent = find_type_constraint($parent) if defined $parent; - my $constraint = Moose::Meta::TypeConstraint->new( - name => $name || '__ANON__', - parent => $parent, - constraint => $check, - message => $message, - optimized => $optimized, +sub _create_parameterized_type_constraint { + my ( $base_type_tc, $type_parameter ) = @_; + if ( $base_type_tc->can('parameterize') ) { + return $base_type_tc->parameterize($type_parameter); + } + else { + return Moose::Meta::TypeConstraint::Parameterized->new( + name => $base_type_tc->name . '[' . $type_parameter . ']', + parent => $base_type_tc, + type_parameter => + find_or_create_isa_type_constraint($type_parameter), ); - $TYPES{$name} = [ $pkg_defined_in, $constraint ] if defined $name; - return $constraint; } +} - sub _install_type_coercions ($$) { - my ($type_name, $coercion_map) = @_; - my $type = find_type_constraint($type_name); - (!$type->has_coercion) - || confess "The type coercion for '$type_name' has already been registered"; - my $type_coercion = Moose::Meta::TypeCoercion->new( - type_coercion_map => $coercion_map, - type_constraint => $type - ); - $type->coercion($type_coercion); +#should we also support optimized checks? +sub create_class_type_constraint { + my ( $class, $options ) = @_; + +# too early for this check +#find_type_constraint("ClassName")->check($class) +# || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name"); + + my %options = ( + class => $class, + name => $class, + %{ $options || {} }, + ); + + $options{name} ||= "__ANON__"; + + Moose::Meta::TypeConstraint::Class->new(%options); +} + +sub create_role_type_constraint { + my ( $role, $options ) = @_; + +# too early for this check +#find_type_constraint("ClassName")->check($class) +# || __PACKAGE__->_throw_error("Can't create a class type constraint because '$class' is not a class name"); + + my %options = ( + role => $role, + name => $role, + %{ $options || {} }, + ); + + $options{name} ||= "__ANON__"; + + Moose::Meta::TypeConstraint::Role->new(%options); +} + +sub find_or_create_type_constraint { + my ( $type_constraint_name, $options_for_anon_type ) = @_; + + if ( my $constraint + = find_or_parse_type_constraint($type_constraint_name) ) { + return $constraint; } - - sub create_type_constraint_union (@) { - my (@type_constraint_names) = @_; - return Moose::Meta::TypeConstraint->union( - map { - find_type_constraint($_) - } @type_constraint_names + elsif ( defined $options_for_anon_type ) { + + # NOTE: + # if there is no $options_for_anon_type + # specified, then we assume they don't + # want to create one, and return nothing. + + # otherwise assume that we should create + # an ANON type with the $options_for_anon_type + # options which can be passed in. It should + # be noted that these don't get registered + # so we need to return it. + # - SL + return Moose::Meta::TypeConstraint->new( + name => '__ANON__', + %{$options_for_anon_type} ); } - - sub export_type_contstraints_as_functions { - my $pkg = caller(); - no strict 'refs'; - foreach my $constraint (keys %TYPES) { - *{"${pkg}::${constraint}"} = find_type_constraint($constraint)->_compiled_type_constraint; - } - } - - sub list_all_type_constraints { keys %TYPES } + + return; +} + +sub find_or_create_isa_type_constraint { + my $type_constraint_name = shift; + find_or_parse_type_constraint($type_constraint_name) + || create_class_type_constraint($type_constraint_name); +} + +sub find_or_create_does_type_constraint { + my $type_constraint_name = shift; + find_or_parse_type_constraint($type_constraint_name) + || create_role_type_constraint($type_constraint_name); +} + +sub find_or_parse_type_constraint { + my $type_constraint_name = normalize_type_constraint_name(shift); + my $constraint; + + if ( $constraint = find_type_constraint($type_constraint_name) ) { + return $constraint; + } + elsif ( _detect_type_constraint_union($type_constraint_name) ) { + $constraint = create_type_constraint_union($type_constraint_name); + } + elsif ( _detect_parameterized_type_constraint($type_constraint_name) ) { + $constraint + = create_parameterized_type_constraint($type_constraint_name); + } + else { + return; + } + + $REGISTRY->add_type_constraint($constraint); + return $constraint; +} + +sub normalize_type_constraint_name { + my $type_constraint_name = shift; + $type_constraint_name =~ s/\s//g; + return $type_constraint_name; +} + +sub _confess { + my $error = shift; + + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + Carp::confess($error); +} + +## -------------------------------------------------------- +## exported functions ... +## -------------------------------------------------------- + +sub find_type_constraint { + my $type = shift; + + if ( blessed $type and $type->isa("Moose::Meta::TypeConstraint") ) { + return $type; + } + else { + return unless $REGISTRY->has_type_constraint($type); + return $REGISTRY->get_type_constraint($type); + } +} + +sub register_type_constraint { + my $constraint = shift; + __PACKAGE__->_throw_error("can't register an unnamed type constraint") + unless defined $constraint->name; + $REGISTRY->add_type_constraint($constraint); + return $constraint; } # type constructors -sub type ($$;$$) { - splice(@_, 1, 0, undef); - goto &_create_type_constraint; +sub type { + + # back-compat version, called without sugar + if ( !any { ( reftype($_) || '' ) eq 'HASH' } @_ ) { + return _create_type_constraint( $_[0], undef, $_[1] ); + } + + my $name = shift; + + my %p = map { %{$_} } @_; + + return _create_type_constraint( + $name, undef, $p{where}, $p{message}, + $p{optimize_as} + ); +} + +sub subtype { + + # crazy back-compat code for being called without sugar ... + # + # subtype 'Parent', sub { where }; + if ( scalar @_ == 2 && ( reftype( $_[1] ) || '' ) eq 'CODE' ) { + return _create_type_constraint( undef, @_ ); + } + + # subtype 'Parent', sub { where }, sub { message }; + # subtype 'Parent', sub { where }, sub { message }, sub { optimized }; + if ( scalar @_ >= 3 && all { ( reftype($_) || '' ) eq 'CODE' } + @_[ 1 .. $#_ ] ) { + return _create_type_constraint( undef, @_ ); + } + + # subtype 'Name', 'Parent', ... + if ( scalar @_ >= 2 && all { !ref } @_[ 0, 1 ] ) { + return _create_type_constraint(@_); + } + + if ( @_ == 1 && !ref $_[0] ) { + __PACKAGE__->_throw_error( + 'A subtype cannot consist solely of a name, it must have a parent' + ); + } + + # The blessed check is mostly to accommodate MooseX::Types, which + # uses an object which overloads stringification as a type name. + my $name = ref $_[0] && !blessed $_[0] ? undef : shift; + + my %p = map { %{$_} } @_; + + # subtype Str => where { ... }; + if ( !exists $p{as} ) { + $p{as} = $name; + $name = undef; + } + + return _create_type_constraint( + $name, $p{as}, $p{where}, $p{message}, + $p{optimize_as} + ); } -sub subtype ($$;$$$) { - unshift @_ => undef if scalar @_ <= 2; - goto &_create_type_constraint; +sub class_type { + register_type_constraint( + create_class_type_constraint( + $_[0], + ( defined( $_[1] ) ? $_[1] : () ), + ) + ); } -sub coerce ($@) { - my ($type_name, @coercion_map) = @_; - _install_type_coercions($type_name, \@coercion_map); +sub role_type ($;$) { + register_type_constraint( + create_role_type_constraint( + $_[0], + ( defined( $_[1] ) ? $_[1] : () ), + ) + ); } -sub as ($) { $_[0] } -sub from ($) { $_[0] } -sub where (&) { $_[0] } -sub via (&) { $_[0] } - -sub message (&) { +{ message => $_[0] } } -sub optimize_as (&) { +{ optimized => $_[0] } } - -sub enum ($;@) { - my ($type_name, @values) = @_; - (scalar @values >= 2) - || confess "You must have at least two values to enumerate through"; - my $regexp = join '|' => @values; - _create_type_constraint( - $type_name, - 'Str', - sub { qr/^$regexp$/i } - ); +sub maybe_type { + my ($type_parameter) = @_; + + register_type_constraint( + $REGISTRY->get_type_constraint('Maybe')->parameterize($type_parameter) + ); +} + +sub duck_type { + my ( $type_name, @methods ) = @_; + if ( ref $type_name eq 'ARRAY' && !@methods ) { + @methods = @$type_name; + $type_name = undef; + } + + register_type_constraint( + _create_type_constraint( + $type_name, + 'Object', + sub { + my $obj = $_; + for (@methods) { return 0 unless $obj->can($_) } + return 1; + }, + sub { + my $obj = $_; + my @missing_methods = grep { !$obj->can($_) } @methods; + return + "${\blessed($obj)} is missing methods '@missing_methods'"; + }, + ) + ); +} + +sub coerce { + my ( $type_name, @coercion_map ) = @_; + _install_type_coercions( $type_name, \@coercion_map ); +} + +# The trick of returning @_ lets us avoid having to specify a +# prototype. Perl will parse this: +# +# subtype 'Foo' +# => as 'Str' +# => where { ... } +# +# as this: +# +# subtype( 'Foo', as( 'Str', where { ... } ) ); +# +# If as() returns all it's extra arguments, this just works, and +# preserves backwards compatibility. +sub as { { as => shift }, @_ } +sub where (&) { { where => $_[0] } } +sub message (&) { { message => $_[0] } } +sub optimize_as (&) { { optimize_as => $_[0] } } + +sub from {@_} +sub via (&) { $_[0] } + +sub enum { + my ( $type_name, @values ) = @_; + + # NOTE: + # if only an array-ref is passed then + # you get an anon-enum + # - SL + if ( ref $type_name eq 'ARRAY' && !@values ) { + @values = @$type_name; + $type_name = undef; + } + ( scalar @values >= 2 ) + || __PACKAGE__->_throw_error( + "You must have at least two values to enumerate through"); + my %valid = map { $_ => 1 } @values; + + register_type_constraint( + create_enum_type_constraint( + $type_name, + \@values, + ) + ); +} + +sub create_enum_type_constraint { + my ( $type_name, $values ) = @_; + + Moose::Meta::TypeConstraint::Enum->new( + name => $type_name || '__ANON__', + values => $values, + ); +} + +## -------------------------------------------------------- +## desugaring functions ... +## -------------------------------------------------------- + +sub _create_type_constraint ($$$;$$) { + my $name = shift; + my $parent = shift; + my $check = shift; + my $message = shift; + my $optimized = shift; + + my $pkg_defined_in = scalar( caller(1) ); + + if ( defined $name ) { + my $type = $REGISTRY->get_type_constraint($name); + + ( $type->_package_defined_in eq $pkg_defined_in ) + || _confess( + "The type constraint '$name' has already been created in " + . $type->_package_defined_in + . " and cannot be created again in " + . $pkg_defined_in ) + if defined $type; + + $name =~ /^[\w:\.]+$/ + or die qq{$name contains invalid characters for a type name.} + . qq{ Names can contain alphanumeric character, ":", and "."\n}; + } + + my %opts = ( + name => $name, + package_defined_in => $pkg_defined_in, + + ( $check ? ( constraint => $check ) : () ), + ( $message ? ( message => $message ) : () ), + ( $optimized ? ( optimized => $optimized ) : () ), + ); + + my $constraint; + if ( + defined $parent + and $parent + = blessed $parent + ? $parent + : find_or_create_isa_type_constraint($parent) + ) { + $constraint = $parent->create_child_type(%opts); + } + else { + $constraint = Moose::Meta::TypeConstraint->new(%opts); + } + + $REGISTRY->add_type_constraint($constraint) + if defined $name; + + return $constraint; +} + +sub _install_type_coercions ($$) { + my ( $type_name, $coercion_map ) = @_; + my $type = find_type_constraint($type_name); + ( defined $type ) + || __PACKAGE__->_throw_error( + "Cannot find type '$type_name', perhaps you forgot to load it."); + if ( $type->has_coercion ) { + $type->coercion->add_type_coercions(@$coercion_map); + } + else { + my $type_coercion = Moose::Meta::TypeCoercion->new( + type_coercion_map => $coercion_map, + type_constraint => $type + ); + $type->coercion($type_coercion); + } } -# define some basic types +## -------------------------------------------------------- +## type notation parsing ... +## -------------------------------------------------------- + +{ + + # All I have to say is mugwump++ cause I know + # do not even have enough regexp-fu to be able + # to have written this (I can only barely + # understand it as it is) + # - SL + + use re "eval"; + + my $valid_chars = qr{[\w:\.]}; + my $type_atom = qr{ $valid_chars+ }; + + my $any; + + my $type = qr{ $valid_chars+ (?: \[ \s* (??{$any}) \s* \] )? }x; + my $type_capture_parts + = qr{ ($valid_chars+) (?: \[ \s* ((??{$any})) \s* \] )? }x; + my $type_with_parameter + = qr{ $valid_chars+ \[ \s* (??{$any}) \s* \] }x; + + my $op_union = qr{ \s* \| \s* }x; + my $union = qr{ $type (?: $op_union $type )+ }x; + + $any = qr{ $type | $union }x; + + sub _parse_parameterized_type_constraint { + { no warnings 'void'; $any; } # force capture of interpolated lexical + $_[0] =~ m{ $type_capture_parts }x; + return ( $1, $2 ); + } + + sub _detect_parameterized_type_constraint { + { no warnings 'void'; $any; } # force capture of interpolated lexical + $_[0] =~ m{ ^ $type_with_parameter $ }x; + } + + sub _parse_type_constraint_union { + { no warnings 'void'; $any; } # force capture of interpolated lexical + my $given = shift; + my @rv; + while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) { + push @rv => $1; + } + ( pos($given) eq length($given) ) + || __PACKAGE__->_throw_error( "'$given' didn't parse (parse-pos=" + . pos($given) + . " and str-length=" + . length($given) + . ")" ); + @rv; + } + + sub _detect_type_constraint_union { + { no warnings 'void'; $any; } # force capture of interpolated lexical + $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x; + } +} -type 'Any' => where { 1 }; # meta-type including all -type 'Item' => where { 1 }; # base-type +## -------------------------------------------------------- +# define some basic built-in types +## -------------------------------------------------------- + +# By making these classes immutable before creating all the types we +# below, we avoid repeatedly calling the slow MOP-based accessors. +$_->make_immutable( + inline_constructor => 1, + constructor_name => "_new", + + # these are Class::MOP accessors, so they need inlining + inline_accessors => 1 + ) for grep { $_->is_mutable } + map { $_->meta } + qw( + Moose::Meta::TypeConstraint + Moose::Meta::TypeConstraint::Union + Moose::Meta::TypeConstraint::Parameterized + Moose::Meta::TypeConstraint::Parameterizable + Moose::Meta::TypeConstraint::Class + Moose::Meta::TypeConstraint::Role + Moose::Meta::TypeConstraint::Enum + Moose::Meta::TypeConstraint::Registry +); + +type 'Any' => where {1}; # meta-type including all +type 'Item' => where {1}; # base-type subtype 'Undef' => as 'Item' => where { !defined($_) }; -subtype 'Defined' => as 'Item' => where { defined($_) }; - -subtype 'Bool' - => as 'Item' - => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' }; - -subtype 'Value' - => as 'Defined' - => where { !ref($_) } - => optimize_as { defined($_[0]) && !ref($_[0]) }; - -subtype 'Ref' - => as 'Defined' - => where { ref($_) } - => optimize_as { ref($_[0]) }; - -subtype 'Str' - => as 'Value' - => where { 1 } - => optimize_as { defined($_[0]) && !ref($_[0]) }; - -subtype 'Num' - => as 'Value' - => where { Scalar::Util::looks_like_number($_) } - => optimize_as { !ref($_[0]) && Scalar::Util::looks_like_number($_[0]) }; - -subtype 'Int' - => as 'Num' - => where { "$_" =~ /^-?[0-9]+$/ } - => optimize_as { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ }; - -subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } => optimize_as { ref($_[0]) eq 'SCALAR' }; -subtype 'ArrayRef' => as 'Ref' => where { ref($_) eq 'ARRAY' } => optimize_as { ref($_[0]) eq 'ARRAY' }; -subtype 'HashRef' => as 'Ref' => where { ref($_) eq 'HASH' } => optimize_as { ref($_[0]) eq 'HASH' }; -subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' } => optimize_as { ref($_[0]) eq 'CODE' }; -subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } => optimize_as { ref($_[0]) eq 'Regexp' }; -subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' } => optimize_as { ref($_[0]) eq 'GLOB' }; +subtype 'Defined' => as 'Item' => where { defined($_) }; + +subtype 'Bool' => as 'Item' => + where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' }; + +subtype 'Value' => as 'Defined' => where { !ref($_) } => + optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Value; + +subtype 'Ref' => as 'Defined' => where { ref($_) } => + optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Ref; + +subtype 'Str' => as 'Value' => where {1} => + optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Str; + +subtype 'Num' => as 'Value' => + where { Scalar::Util::looks_like_number($_) } => + optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Num; + +subtype 'Int' => as 'Num' => where { "$_" =~ /^-?[0-9]+$/ } => + optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Int; + +subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } => + optimize_as + \&Moose::Util::TypeConstraints::OptimizedConstraints::ScalarRef; +subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' } => + optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::CodeRef; +subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } => + optimize_as + \&Moose::Util::TypeConstraints::OptimizedConstraints::RegexpRef; +subtype 'GlobRef' => as 'Ref' => where { ref($_) eq 'GLOB' } => + optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::GlobRef; # NOTE: -# scalar filehandles are GLOB refs, +# scalar filehandles are GLOB refs, # but a GLOB ref is not always a filehandle -subtype 'FileHandle' - => as 'GlobRef' - => where { Scalar::Util::openhandle($_) } - => optimize_as { ref($_[0]) eq 'GLOB' && Scalar::Util::openhandle($_[0]) }; +subtype 'FileHandle' => as 'GlobRef' => where { + Scalar::Util::openhandle($_) || ( blessed($_) && $_->isa("IO::Handle") ); +} => optimize_as + \&Moose::Util::TypeConstraints::OptimizedConstraints::FileHandle; -# NOTE: +# NOTE: # blessed(qr/.../) returns true,.. how odd -subtype 'Object' - => as 'Ref' - => where { blessed($_) && blessed($_) ne 'Regexp' } - => optimize_as { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }; +subtype 'Object' => as 'Ref' => + where { blessed($_) && blessed($_) ne 'Regexp' } => + optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Object; + +subtype 'Role' => as 'Object' => where { $_->can('does') } => + optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Role; + +my $_class_name_checker = sub { }; + +subtype 'ClassName' => as 'Str' => + where { Class::MOP::is_class_loaded($_) } => optimize_as + \&Moose::Util::TypeConstraints::OptimizedConstraints::ClassName; + +subtype 'RoleName' => as 'ClassName' => where { + ( ( $_->can('meta') || return )->($_) || return ) + ->isa('Moose::Meta::Role'); +} => optimize_as + \&Moose::Util::TypeConstraints::OptimizedConstraints::RoleName; + +## -------------------------------------------------------- +# parameterizable types ... + +$REGISTRY->add_type_constraint( + Moose::Meta::TypeConstraint::Parameterizable->new( + name => 'ArrayRef', + package_defined_in => __PACKAGE__, + parent => find_type_constraint('Ref'), + constraint => sub { ref($_) eq 'ARRAY' }, + optimized => + \&Moose::Util::TypeConstraints::OptimizedConstraints::ArrayRef, + constraint_generator => sub { + my $type_parameter = shift; + my $check = $type_parameter->_compiled_type_constraint; + return sub { + foreach my $x (@$_) { + ( $check->($x) ) || return; + } + 1; + } + } + ) +); + +$REGISTRY->add_type_constraint( + Moose::Meta::TypeConstraint::Parameterizable->new( + name => 'HashRef', + package_defined_in => __PACKAGE__, + parent => find_type_constraint('Ref'), + constraint => sub { ref($_) eq 'HASH' }, + optimized => + \&Moose::Util::TypeConstraints::OptimizedConstraints::HashRef, + constraint_generator => sub { + my $type_parameter = shift; + my $check = $type_parameter->_compiled_type_constraint; + return sub { + foreach my $x ( values %$_ ) { + ( $check->($x) ) || return; + } + 1; + } + } + ) +); + +$REGISTRY->add_type_constraint( + Moose::Meta::TypeConstraint::Parameterizable->new( + name => 'Maybe', + package_defined_in => __PACKAGE__, + parent => find_type_constraint('Item'), + constraint => sub {1}, + constraint_generator => sub { + my $type_parameter = shift; + my $check = $type_parameter->_compiled_type_constraint; + return sub { + return 1 if not( defined($_) ) || $check->($_); + return; + } + } + ) +); + +my @PARAMETERIZABLE_TYPES + = map { $REGISTRY->get_type_constraint($_) } qw[ArrayRef HashRef Maybe]; + +sub get_all_parameterizable_types {@PARAMETERIZABLE_TYPES} + +sub add_parameterizable_type { + my $type = shift; + ( blessed $type + && $type->isa('Moose::Meta::TypeConstraint::Parameterizable') ) + || __PACKAGE__->_throw_error( + "Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type" + ); + push @PARAMETERIZABLE_TYPES => $type; +} -subtype 'Role' - => as 'Object' - => where { $_->can('does') } - => optimize_as { blessed($_[0]) && $_[0]->can('does') }; +## -------------------------------------------------------- +# end of built-in types ... +## -------------------------------------------------------- { my @BUILTINS = list_all_type_constraints(); - sub list_all_builtin_type_constraints { @BUILTINS } + sub list_all_builtin_type_constraints {@BUILTINS} +} + +sub _throw_error { + shift; + require Moose; + unshift @_, 'Moose'; + goto &Moose::throw_error; } 1; @@ -243,257 +782,469 @@ Moose::Util::TypeConstraints - Type constraint system for Moose use Moose::Util::TypeConstraints; - type 'Num' => where { Scalar::Util::looks_like_number($_) }; - - subtype 'Natural' - => as 'Num' + subtype 'Natural' + => as 'Int' => where { $_ > 0 }; - - subtype 'NaturalLessThanTen' + + subtype 'NaturalLessThanTen' => as 'Natural' => where { $_ < 10 } => message { "This number ($_) is not less than ten!" }; - - coerce 'Num' + + coerce 'Num' => from 'Str' - => via { 0+$_ }; - + => via { 0+$_ }; + enum 'RGBColors' => qw(red green blue); + no Moose::Util::TypeConstraints; + =head1 DESCRIPTION -This module provides Moose with the ability to create custom type -contraints to be used in attribute definition. +This module provides Moose with the ability to create custom type +constraints to be used in attribute definition. =head2 Important Caveat -This is B a type system for Perl 5. These are type constraints, -and they are not used by Moose unless you tell it to. No type -inference is performed, expression are not typed, etc. etc. etc. +This is B a type system for Perl 5. These are type constraints, +and they are not used by Moose unless you tell it to. No type +inference is performed, expressions are not typed, etc. etc. etc. -This is simply a means of creating small constraint functions which -can be used to simplify your own type-checking code. +A type constraint is at heart a small "check if a value is valid" +function. A constraint can be associated with an attribute. This +simplifies parameter validation, and makes your code clearer to read, +because you can refer to constraints by name. =head2 Slightly Less Important Caveat -It is almost always a good idea to quote your type and subtype names. -This is to prevent perl from trying to execute the call as an indirect -object call. This issue only seems to come up when you have a subtype -the same name as a valid class, but when the issue does arise it tends -to be quite annoying to debug. +It is B a good idea to quote your type names. + +This prevents Perl from trying to execute the call as an indirect +object call. This can be an issue when you have a subtype with the +same name as a valid class. + +For instance: -So for instance, this: - subtype DateTime => as Object => where { $_->isa('DateTime') }; -will I, while this: +will I, while this: use DateTime; subtype DateTime => as Object => where { $_->isa('DateTime') }; -will fail silently and cause many headaches. The simple way to solve -this, as well as future proof your subtypes from classes which have -yet to have been created yet, is to simply do this: +will fail silently and cause many headaches. The simple way to solve +this, as well as future proof your subtypes from classes which have +yet to have been created, is to quote the type name: use DateTime; subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') }; =head2 Default Type Constraints -This module also provides a simple hierarchy for Perl 5 types, this -could probably use some work, but it works for me at the moment. +This module also provides a simple hierarchy for Perl 5 types, here is +that hierarchy represented visually. Any - Item + Item Bool + Maybe[`a] Undef Defined Value Num Int Str + ClassName + RoleName Ref ScalarRef - ArrayRef - HashRef + ArrayRef[`a] + HashRef[`a] CodeRef RegexpRef GlobRef FileHandle - Object - Role + Object + Role + +B Any type followed by a type parameter C<[`a]> can be +parameterized, this means you can say: -Suggestions for improvement are welcome. + ArrayRef[Int] # an array of integers + HashRef[CodeRef] # a hash of str to CODE ref mappings + Maybe[Str] # value may be a string, may be undefined -B The C type constraint does not work correctly -in every occasion, please use it sparringly. +If Moose finds a name in brackets that it does not recognize as an +existing type, it assumes that this is a class name, for example +C. + +B Unless you parameterize a type, then it is invalid to include +the square brackets. I.e. C will be treated as a new type +name, I as a parameterization of C. + +B The C type constraint for the most part works +correctly now, but edge cases may still exist, please use it +sparingly. + +B The C type constraint does a complex package +existence check. This means that your class B be loaded for this +type constraint to pass. + +B The C constraint checks a string is a I which is a role, like C<'MyApp::Role::Comparable'>. The C +constraint checks that an I the named role. + +=head2 Type Constraint Naming + +Type name declared via this module can only contain alphanumeric +characters, colons (:), and periods (.). + +Since the types created by this module are global, it is suggested +that you namespace your types just as you would namespace your +modules. So instead of creating a I type for your +B module, you would call the type +I instead. =head2 Use with Other Constraint Modules -This module should play fairly nicely with other constraint -modules with only some slight tweaking. The C clause -in types is expected to be a C reference which checks -it's first argument and returns a bool. Since most constraint -modules work in a similar way, it should be simple to adapt -them to work with Moose. +This module can play nicely with other constraint modules with some +slight tweaking. The C clause in types is expected to be a +C reference which checks it's first argument and returns a +boolean. Since most constraint modules work in a similar way, it +should be simple to adapt them to work with Moose. -For instance, this is how you could use it with -L to declare a completely new type. +For instance, this is how you could use it with +L to declare a completely new type. - type 'HashOfArrayOfObjects' - => IsHashRef( + type 'HashOfArrayOfObjects', + { + where => IsHashRef( -keys => HasLength, - -values => IsArrayRef( IsObject )); + -values => IsArrayRef(IsObject) + ) + }; -For more examples see the F test file. +For more examples see the F test +file. -Here is an example of using L and it's non-test -related C function. +Here is an example of using L and it's non-test +related C function. - type 'ArrayOfHashOfBarsAndRandomNumbers' + type 'ArrayOfHashOfBarsAndRandomNumbers' => where { - eq_deeply($_, + eq_deeply($_, array_each(subhashof({ bar => isa('Bar'), random_number => ignore() - }))) + }))) }; -For a complete example see the F -test file. - +For a complete example see the +F test file. + =head1 FUNCTIONS -=head2 Type Constraint Registry +=head2 Type Constraint Constructors + +The following functions are used to create type constraints. They +will also register the type constraints your create in a global +registry that is used to look types up by name. + +See the L for an example of how to use these. =over 4 -=item B +=item B as 'Parent' => where { } ...> -This function can be used to locate a specific type constraint -meta-object. What you do with it from there is up to you :) +This creates a named subtype. -=item B +If you provide a parent that Moose does not recognize, it will +automatically create a new class type constraint for this name. -Given a list of C<@type_constraint_names>, this will return a -B instance. +When creating a named type, the C function should either be +called with the sugar helpers (C, C, etc), or with a +name and a hashref of parameters: -=item B + subtype( 'Foo', { where => ..., message => ... } ); -This will export all the current type constraints as functions -into the caller's namespace. Right now, this is mostly used for -testing, but it might prove useful to others. +The valid hashref keys are C (the parent), C, C, +and C. -=item B +=item B where { } ...> -This will return a list of type constraint names, you can then -fetch them using C if you -want to. +This creates an unnamed subtype and will return the type +constraint meta-object, which will be an instance of +L. -=item B +When creating an anonymous type, the C function should either +be called with the sugar helpers (C, C, etc), or with +just a hashref of parameters: -This will return a list of builtin type constraints, meaning, -those which are defined in this module. See the section -labeled L for a complete list. + subtype( { where => ..., message => ... } ); -=back +=item B -=head2 Type Constraint Constructors +Creates a new subtype of C with the name C<$class> and the +metaclass L. -The following functions are used to create type constraints. -They will then register the type constraints in a global store -where Moose can get to them if it needs to. +=item B -See the L for an example of how to use these. +Creates a C type constraint with the name C<$role> and the +metaclass L. -=over 4 +=item B -=item B +Creates a type constraint for either C or something of the +given type. -This creates a base type, which has no parent. +=item B -=item B +This will create a subtype of Object and test to make sure the value +C do the methods in C<@methods>. -This creates a named subtype. +This is intended as an easy way to accept non-Moose objects that +provide a certain interface. If you're using Moose classes, we +recommend that you use a C-only Role instead. -=item B +=item B -This creates an unnamed subtype and will return the type -constraint meta-object, which will be an instance of -L. +If passed an ARRAY reference instead of the C<$name>, C<@methods> +pair, this will create an unnamed duck type. This can be used in an +attribute definiton like so: + + has 'cache' => ( + is => 'ro', + isa => duck_type( [qw( get_set )] ), + ); =item B -This will create a basic subtype for a given set of strings. -The resulting constraint will be a subtype of C and -will match any of the items in C<@values>. See the L -for a simple example. +This will create a basic subtype for a given set of strings. +The resulting constraint will be a subtype of C and +will match any of the items in C<@values>. It is case sensitive. +See the L for a simple example. + +B This is not a true proper enum type, it is simply +a convenient constraint builder. -B This is not a true proper enum type, it is simple -a convient constraint builder. +=item B -=item B +If passed an ARRAY reference instead of the C<$name>, C<@values> pair, +this will create an unnamed enum. This can then be used in an attribute +definition like so: + + has 'sort_order' => ( + is => 'ro', + isa => enum([qw[ ascending descending ]]), + ); + +=item B This is just sugar for the type constraint construction syntax. -=item B +It takes a single argument, which is the name of a parent type. + +=item B This is just sugar for the type constraint construction syntax. -=item B +It takes a subroutine reference as an argument. When the type +constraint is tested, the reference is run with the value to be tested +in C<$_>. This reference should return true or false to indicate +whether or not the constraint check passed. + +=item B This is just sugar for the type constraint construction syntax. -=item B +It takes a subroutine reference as an argument. When the type +constraint fails, then the code block is run with the value provided +in C<$_>. This reference should return a string, which will be used in +the text of the exception thrown. -This can be used to define a "hand optimized" version of your +=item B + +This can be used to define a "hand optimized" version of your type constraint which can be used to avoid traversing a subtype -constraint heirarchy. +constraint hierarchy. -B You should only use this if you know what you are doing, -all the built in types use this, so your subtypes (assuming they +B You should only use this if you know what you are doing, +all the built in types use this, so your subtypes (assuming they are shallow) will not likely need to use this. +=item B where { } ... > + +This creates a base type, which has no parent. + +The C function should either be called with the sugar helpers +(C, C, etc), or with a name and a hashref of +parameters: + + type( 'Foo', { where => ..., message => ... } ); + +The valid hashref keys are C, C, and C. + =back =head2 Type Coercion Constructors -Type constraints can also contain type coercions as well. If you -ask your accessor too coerce, the Moose will run the type-coercion -code first, followed by the type constraint check. This feature -should be used carefully as it is very powerful and could easily -take off a limb if you are not careful. +You can define coercions for type constraints, which allow you to +automatically transform values to something valid for the type +constraint. If you ask your accessor to coerce, then Moose will run +the type-coercion code first, followed by the type constraint +check. This feature should be used carefully as it is very powerful +and could easily take off a limb if you are not careful. -See the L for an example of how to use these. +See the L for an example of how to use these. =over 4 -=item B +=item B<< coerce 'Name' => from 'OtherName' => via { ... } >> + +This defines a coercion from one type to another. The C argument +is the type you are coercing I. -=item B +=item B This is just sugar for the type coercion construction syntax. -=item B +It takes a single type name (or type object), which is the type being +coerced I. + +=item B This is just sugar for the type coercion construction syntax. +It takes a subroutine reference. This reference will be called with +the value to be coerced in C<$_>. It is expected to return a new value +of the proper type for the coercion. + =back -=head2 Namespace Management +=head2 Creating and Finding Type Constraints + +These are additional functions for creating and finding type +constraints. Most of these functions are not available for +importing. The ones that are importable as specified. =over 4 -=item B +=item B + +This function can be used to locate the L +object for a named type. + +This function is importable. + +=item B + +This function will register a L with the +global type registry. + +This function is importable. + +=item B + +This method takes a type constraint name and returns the normalized +form. This removes any whitespace in the string. + +=item B + +This can take a union type specification like C<'Int|ArrayRef[Int]'>, +or a list of names. It returns a new +L object. + +=item B + +Given a C<$type_name> in the form of C<'BaseType[ContainerType]'>, +this will create a new L +object. The C must exist already exist as a parameterizable +type. + +=item B + +Given a class name this function will create a new +L object for that class name. + +The C<$options> is a hash reference that will be passed to the +L constructor (as a hash). + +=item B + +Given a role name this function will create a new +L object for that role name. + +The C<$options> is a hash reference that will be passed to the +L constructor (as a hash). + +=item B + +Given a enum name this function will create a new +L object for that enum name. + +=item B + +Given a type name, this first attempts to find a matching constraint +in the global registry. + +If the type name is a union or parameterized type, it will create a +new object of the appropriate, but if given a "regular" type that does +not yet exist, it simply returns false. + +When given a union or parameterized type, the member or base type must +already exist. + +If it creates a new union or parameterized type, it will add it to the +global registry. + +=item B + +=item B + +These functions will first call C. If +that function does not return a type, a new anonymous type object will +be created. + +The C variant will use C and the +C variant will use C. + +=item B + +Returns the L object which +keeps track of all type constraints. + +=item B + +This will return a list of type constraint names in the global +registry. You can then fetch the actual type object using +C. + +=item B + +This will return a list of builtin type constraints, meaning those +which are defined in this module. See the L +section for a complete list. + +=item B + +This will export all the current type constraints as functions into +the caller's namespace (C, C, etc). Right now, this is +mostly used for testing, but it might prove useful to others. + +=item B + +This returns all the parameterizable types that have been registered, +as a list of type objects. + +=item B -This will remove all the type constraint keywords from the -calling class namespace. +Adds C<$type> to the list of parameterizable types =back =head1 BUGS -All complex software has bugs lurking in it, and this module is no +All complex software has bugs lurking in it, and this module is no exception. If you find a bug please either email me, or add the bug to cpan-RT. @@ -503,11 +1254,11 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006, 2007 by Infinity Interactive, Inc. +Copyright 2006-2009 by Infinity Interactive, Inc. L This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. +it under the same terms as Perl itself. =cut