X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil%2FTypeConstraints.pm;h=d50936b15f9f1b8c4b4abf0f5fd373eb11ca1440;hb=82750a8aa67b0f6cd139537bef64162d7a7c4d52;hp=b0070f1b6ad7cd86c28812f1bf3230446f6ff71e;hpb=25374f018116dc632e1625bf401c8893c5df21ff;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index b0070f1..d50936b 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -4,11 +4,13 @@ package Moose::Util::TypeConstraints; use strict; use warnings; -use Carp 'confess'; -use Scalar::Util 'blessed', 'reftype'; -use Sub::Exporter; +use Carp (); +use List::MoreUtils qw( all ); +use Scalar::Util 'blessed'; +use Moose::Exporter; -our $VERSION = '0.18'; +our $VERSION = '0.62_01'; +$VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; ## -------------------------------------------------------- @@ -18,23 +20,11 @@ our $AUTHORITY = 'cpan:STEVAN'; # ensures the prototypes are in scope when consumers are # compiled. -# creation and location -sub find_type_constraint ($); -sub find_or_create_type_constraint ($;$); -sub create_type_constraint_union (@); -sub create_parameterized_type_constraint ($); - # dah sugah! -sub type ($$;$$); -sub subtype ($$;$$$); -sub coerce ($@); -sub as ($); -sub from ($); sub where (&); sub via (&); sub message (&); sub optimize_as (&); -sub enum ($;@); ## private stuff ... sub _create_type_constraint ($$$;$$); @@ -45,41 +35,26 @@ sub _install_type_coercions ($$); 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; - -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) = Class::MOP::get_code_info($keyword); - next if $@; - next if $pkg_name ne 'Moose::Util::TypeConstraints'; - - # and if it is from Moose then undef the slot - delete ${$class . '::'}{$name}; - } - } -} +use Moose::Util::TypeConstraints::OptimizedConstraints; + +Moose::Exporter->setup_import_methods( + as_is => [ + qw( + type subtype class_type role_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 @@ -93,12 +68,12 @@ sub export_type_constraints_as_functions { my $pkg = caller(); no strict 'refs'; foreach my $constraint (keys %{$REGISTRY->type_constraints}) { - *{"${pkg}::${constraint}"} = $REGISTRY->get_type_constraint($constraint) - ->_compiled_type_constraint; + my $tc = $REGISTRY->get_type_constraint($constraint)->_compiled_type_constraint; + *{"${pkg}::${constraint}"} = sub { $tc->($_[0]) ? 1 : undef }; # the undef is for compat } } -sub create_type_constraint_union (@) { +sub create_type_constraint_union { my @type_constraint_names; if (scalar @_ == 1 && _detect_type_constraint_union($_[0])) { @@ -107,68 +82,101 @@ sub create_type_constraint_union (@) { else { @type_constraint_names = @_; } - + (scalar @type_constraint_names >= 2) - || confess "You must pass in at least 2 type names to make a union"; + || Moose->throw_error("You must pass in at least 2 type names to make a union"); - ($REGISTRY->has_type_constraint($_)) - || confess "Could not locate type constraint ($_) for the union" - foreach @type_constraint_names; + my @type_constraints = map { + find_or_parse_type_constraint($_) || + Moose->throw_error("Could not locate type constraint ($_) for the union"); + } @type_constraint_names; return Moose::Meta::TypeConstraint::Union->new( - type_constraints => [ - map { - $REGISTRY->get_type_constraint($_) - } @type_constraint_names - ], + type_constraints => \@type_constraints ); } -sub create_parameterized_type_constraint ($) { +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) - || confess "Could not parse type name ($type_constraint_name) correctly"; - - ($REGISTRY->has_type_constraint($base_type)) - || confess "Could not locate the base type ($base_type)"; - - return Moose::Meta::TypeConstraint::Parameterized->new( - name => $type_constraint_name, - parent => $REGISTRY->get_type_constraint($base_type), - type_parameter => find_or_create_type_constraint( - $type_parameter => { - parent => $REGISTRY->get_type_constraint('Object'), - constraint => sub { $_[0]->isa($type_parameter) } - } - ), + || Moose->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 + ); + } else { + Moose->throw_error("Could not locate the base type ($base_type)"); + } +} + +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), + ); + } +} + +#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) + # || Moose->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 find_or_create_type_constraint ($;$) { - my ($type_constraint_name, $options_for_anon_type) = @_; +sub create_role_type_constraint { + my ( $role, $options ) = @_; - return $REGISTRY->get_type_constraint($type_constraint_name) - if $REGISTRY->has_type_constraint($type_constraint_name); + # too early for this check + #find_type_constraint("ClassName")->check($class) + # || Moose->throw_error("Can't create a class type constraint because '$class' is not a class name"); - my $constraint; + my %options = ( + role => $role, + name => $role, + %{ $options || {} }, + ); - if (_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); + $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; } - else { + elsif ( defined $options_for_anon_type ) { # NOTE: - # if there is no $options_for_anon_type - # specified, then we assume they don't + # if there is no $options_for_anon_type + # specified, then we assume they don't # want to create one, and return nothing. - return unless defined $options_for_anon_type; - # NOTE: # otherwise assume that we should create # an ANON type with the $options_for_anon_type # options which can be passed in. It should @@ -181,59 +189,159 @@ sub find_or_create_type_constraint ($;$) { ); } + 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 ($) { $REGISTRY->get_type_constraint(@_) } +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; + Moose->throw_error("can't register an unnamed type constraint") unless defined $constraint->name; + $REGISTRY->add_type_constraint($constraint); + return $constraint; +} # type constructors -sub type ($$;$$) { +sub type { splice(@_, 1, 0, undef); goto &_create_type_constraint; } -sub subtype ($$;$$$) { +sub subtype { # NOTE: # this adds an undef for the name # if this is an anon-subtype: # subtype(Num => where { $_ % 2 == 0 }) # anon 'even' subtype - # but if the last arg is not a code - # ref then it is a subtype alias: + # or + # subtype(Num => where { $_ % 2 == 0 }) message { "$_ must be an even number" } + # + # but if the last arg is not a code ref then it is a subtype + # alias: + # # subtype(MyNumbers => as Num); # now MyNumbers is the same as Num # ... yeah I know it's ugly code # - SL - unshift @_ => undef if scalar @_ <= 2 && (reftype($_[1]) || '') eq 'CODE'; + unshift @_ => undef if scalar @_ == 2 && ( 'CODE' eq ref( $_[-1] ) ); + unshift @_ => undef + if scalar @_ == 3 && all { ref($_) =~ /^(?:CODE|HASH)$/ } @_[ 1, 2 ]; goto &_create_type_constraint; } -sub coerce ($@) { +sub class_type { + register_type_constraint( + create_class_type_constraint( + $_[0], + ( defined($_[1]) ? $_[1] : () ), + ) + ); +} + +sub role_type ($;$) { + register_type_constraint( + create_role_type_constraint( + $_[0], + ( defined($_[1]) ? $_[1] : () ), + ) + ); +} + +sub coerce { my ($type_name, @coercion_map) = @_; _install_type_coercions($type_name, \@coercion_map); } -sub as ($) { $_[0] } -sub from ($) { $_[0] } +sub as { @_ } +sub from { @_ } sub where (&) { $_[0] } sub via (&) { $_[0] } sub message (&) { +{ message => $_[0] } } sub optimize_as (&) { +{ optimized => $_[0] } } -sub enum ($;@) { +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) - || confess "You must have at least two values to enumerate through"; + || Moose->throw_error("You must have at least two values to enumerate through"); my %valid = map { $_ => 1 } @values; - _create_type_constraint( - $type_name, - 'Str', - sub { $valid{$_} } + + 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, ); } @@ -246,50 +354,45 @@ sub _create_type_constraint ($$$;$$) { my $parent = shift; my $check = shift; - my ($message, $optimized); + my ( $message, $optimized ); for (@_) { $message = $_->{message} if exists $_->{message}; $optimized = $_->{optimized} if exists $_->{optimized}; } - my $pkg_defined_in = scalar(caller(0)); + my $pkg_defined_in = scalar( caller(0) ); - if (defined $name) { + 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; + ( $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; } - $parent = find_or_create_type_constraint($parent) if defined $parent; - - my $constraint = Moose::Meta::TypeConstraint->new( - name => $name || '__ANON__', + my %opts = ( + name => $name, package_defined_in => $pkg_defined_in, - ($parent ? (parent => $parent ) : ()), - ($check ? (constraint => $check) : ()), - ($message ? (message => $message) : ()), - ($optimized ? (optimized => $optimized) : ()), + ( $check ? ( constraint => $check ) : () ), + ( $message ? ( message => $message ) : () ), + ( $optimized ? ( optimized => $optimized ) : () ), ); - - # NOTE: - # if we have a type constraint union, and no - # type check, this means we are just aliasing - # the union constraint, which means we need to - # handle this differently. - # - SL - if (not(defined $check) - && $parent->isa('Moose::Meta::TypeConstraint::Union') - && $parent->has_coercion - ){ - $constraint->coercion(Moose::Meta::TypeCoercion::Union->new( - type_constraint => $parent - )); - } + + my $constraint; + if ( defined $parent + and $parent + = blessed $parent ? $parent : find_or_parse_type_constraint($parent) ) + { + $constraint = $parent->create_child_type(%opts); + } + else { + $constraint = Moose::Meta::TypeConstraint->new(%opts); + } $REGISTRY->add_type_constraint($constraint) if defined $name; @@ -299,9 +402,9 @@ sub _create_type_constraint ($$$;$$) { sub _install_type_coercions ($$) { my ($type_name, $coercion_map) = @_; - my $type = $REGISTRY->get_type_constraint($type_name); + my $type = find_type_constraint($type_name); (defined $type) - || confess "Cannot find type '$type_name', perhaps you forgot to load it."; + || Moose->throw_error("Cannot find type '$type_name', perhaps you forgot to load it."); if ($type->has_coercion) { $type->coercion->add_type_coercions(@$coercion_map); } @@ -330,40 +433,46 @@ sub _install_type_coercions ($$) { my $valid_chars = qr{[\w:]}; my $type_atom = qr{ $valid_chars+ }; - my $type = qr{ $valid_chars+ (?: \[ (??{$any}) \] )? }x; - my $type_capture_parts = qr{ ($valid_chars+) (?: \[ ((??{$any})) \] )? }x; - my $type_with_parameter = qr{ $valid_chars+ \[ (??{$any}) \] }x; + 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; - our $any = qr{ $type | $union }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; + push @rv => $1; } (pos($given) eq length($given)) - || confess "'$given' didn't parse (parse-pos=" + || Moose->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; } } @@ -372,6 +481,27 @@ sub _install_type_coercions ($$) { # 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 @@ -385,88 +515,130 @@ subtype 'Bool' subtype 'Value' => as 'Defined' => where { !ref($_) } - => optimize_as { defined($_[0]) && !ref($_[0]) }; + => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Value; subtype 'Ref' => as 'Defined' => where { ref($_) } - => optimize_as { ref($_[0]) }; + => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Ref; subtype 'Str' => as 'Value' => where { 1 } - => optimize_as { defined($_[0]) && !ref($_[0]) }; + => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Str; subtype 'Num' => as 'Value' => where { Scalar::Util::looks_like_number($_) } - => optimize_as { !ref($_[0]) && Scalar::Util::looks_like_number($_[0]) }; + => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Num; subtype 'Int' => as 'Num' => where { "$_" =~ /^-?[0-9]+$/ } - => optimize_as { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ }; + => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Int; -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 '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, # 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]) }; + => where { Scalar::Util::openhandle($_) || ( blessed($_) && $_->isa("IO::Handle") ) } + => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::FileHandle; # NOTE: # blessed(qr/.../) returns true,.. how odd subtype 'Object' => as 'Ref' => where { blessed($_) && blessed($_) ne 'Regexp' } - => optimize_as { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }; + => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Object; subtype 'Role' => as 'Object' => where { $_->can('does') } - => optimize_as { blessed($_[0]) && $_[0]->can('does') }; + => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::Role; my $_class_name_checker = sub { - return if ref($_[0]); - return unless defined($_[0]) && length($_[0]); - - # walk the symbol table tree to avoid autovififying - # \*{${main::}{"Foo::"}} == \*main::Foo:: - - my $pack = \*::; - foreach my $part (split('::', $_[0])) { - return unless exists ${$$pack}{"${part}::"}; - $pack = \*{${$$pack}{"${part}::"}}; - } - - # check for $VERSION or @ISA - return 1 if exists ${$$pack}{VERSION} - && defined *{${$$pack}{VERSION}}{SCALAR}; - return 1 if exists ${$$pack}{ISA} - && defined *{${$$pack}{ISA}}{ARRAY}; - - # check for any method - foreach ( keys %{$$pack} ) { - next if substr($_, -2, 2) eq '::'; - return 1 if defined *{${$$pack}{$_}}{CODE}; - } - - # fail - return; }; subtype 'ClassName' => as 'Str' - => $_class_name_checker # where ... - => { optimize => $_class_name_checker }; + => where { Class::MOP::is_class_loaded($_) } + => optimize_as \&Moose::Util::TypeConstraints::OptimizedConstraints::ClassName; + +## -------------------------------------------------------- +# 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')) + || Moose->throw_error("Type must be a Moose::Meta::TypeConstraint::Parameterizable not $type"); + push @PARAMETERIZABLE_TYPES => $type; +} ## -------------------------------------------------------- # end of built-in types ... @@ -494,7 +666,7 @@ Moose::Util::TypeConstraints - Type constraint system for Moose type 'Num' => where { Scalar::Util::looks_like_number($_) }; subtype 'Natural' - => as 'Num' + => as 'Int' => where { $_ > 0 }; subtype 'NaturalLessThanTen' @@ -520,11 +692,13 @@ 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 simply a means of creating small constraint functions which -can be used to simplify your own type-checking code. +can be used to simplify your own type-checking code, with the added +side benefit of making your intentions clearer through self-documentation. =head2 Slightly Less Important Caveat -It is almost always a good idea to quote your type and subtype names. +It is B 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 @@ -548,12 +722,13 @@ yet to have been created yet, is to simply do this: =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 Bool + Maybe[`a] Undef Defined Value @@ -563,8 +738,8 @@ could probably use some work, but it works for me at the moment. ClassName Ref ScalarRef - ArrayRef - HashRef + ArrayRef[`a] + HashRef[`a] CodeRef RegexpRef GlobRef @@ -572,23 +747,39 @@ could probably use some work, but it works for me at the moment. Object Role -Suggestions for improvement are welcome. +B Any type followed by a type parameter C<[`a]> can be +parameterized, this means you can say: + + 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 Unless you parameterize a type, then it is invalid to +include the square brackets. I.e. C will be +literally interpreted as a type name. + +B The C type constraint for the most part works +correctly now, but edge cases may still exist, please use it +sparringly. -B The C type constraint does not work correctly -in every occasion, please use it sparringly. +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. I know this is not ideal for all, +but it is a saner restriction than most others. -B The C type constraint is simply a subtype -of string which responds true to C. This means -that your class B be loaded for this type constraint to -pass. I know this is not ideal for all, but it is a saner -restriction than most others. +=head2 Type Constraint Naming + +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 +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. @@ -600,7 +791,8 @@ L to declare a completely new type. -keys => HasLength, -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. @@ -614,70 +806,11 @@ related C function. }))) }; -For a complete example see the F -test file. +For a complete example see the +F test file. =head1 FUNCTIONS -=head2 Type Constraint Construction & Locating - -=over 4 - -=item B - -Given string with C<$pipe_seperated_types> or a list of C<@type_constraint_names>, -this will return a L instance. - -=item B - -Given a C<$type_name> in the form of: - - BaseType[ContainerType] - -this will extract the base type and container type and build an instance of -L for it. - -=item B - -This will attempt to find or create a type constraint given the a C<$type_name>. -If it cannot find it in the registry, it will see if it should be a union or -container type an create one if appropriate, and lastly if nothing can be -found or created that way, it will create an anon-type using the -C<$options_for_anon_type> HASH ref to populate it. If the C<$options_for_anon_type> -is not specified (it is C), then it will not create anything and simply -return. - -=item B - -This function can be used to locate a specific type constraint -meta-object, of the class L or a -derivative. What you do with it from there is up to you :) - -=item B - -Fetch the L object which -keeps track of all type constraints. - -=item B - -This will return a list of type constraint names, you can then -fetch them using C if you -want to. - -=item B - -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. - -=item B - -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. - -=back - =head2 Type Constraint Constructors The following functions are used to create type constraints. @@ -702,6 +835,16 @@ This creates an unnamed subtype and will return the type constraint meta-object, which will be an instance of L. +=item B + +Creates a type constraint with the name C<$class> and the metaclass +L. + +=item B + +Creates a type constraint with the name C<$role> and the metaclass +L. + =item B This will create a basic subtype for a given set of strings. @@ -712,6 +855,17 @@ See the L for a simple example. B This is not a true proper enum type, it is simple a convient constraint builder. +=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. @@ -720,10 +874,20 @@ This is just sugar for the type constraint construction syntax. This is just sugar for the type constraint construction syntax. +Takes a block/code ref as an argument. When the type constraint is +tested, the supplied code is run with the value to be tested in +$_. This block 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. +Takes a block/code ref as an argument. When the type constraint fails, +then the code block is run (with the value provided in $_). This code +ref should return a string, which will be used in the text of the +exception thrown. + =item B This can be used to define a "hand optimized" version of your @@ -760,6 +924,111 @@ This is just sugar for the type coercion construction syntax. =back +=head2 Type Constraint Construction & Locating + +=over 4 + +=item B + +Given a string that is expected to match a type constraint, will normalize the +string so that extra whitespace and newlines are removed. + +=item B + +Given string with C<$pipe_seperated_types> or a list of C<@type_constraint_names>, +this will return a L instance. + +=item B + +Given a C<$type_name> in the form of: + + BaseType[ContainerType] + +this will extract the base type and container type and build an instance of +L for it. + +=item B + +Given a class name it will create a new L +object for that class name. + +=item B + +Given a role name it will create a new L +object for that role name. + +=item B + +=item B + +This will attempt to find or create a type constraint given the a C<$type_name>. +If it cannot find it in the registry, it will see if it should be a union or +container type an create one if appropriate + +=item B + +This function will first call C with the type name. + +If no type is found or created, but C<$options_for_anon_type> are provided, it +will create the corresponding type. + +This was used by the C and C parameters to L +and are now superseded by C and +C. + +=item B + +=item B + +Attempts to parse the type name using C and if +no appropriate constraint is found will create a new anonymous one. + +The C variant will use C and the C +variant will use C. + +=item B + +This function can be used to locate a specific type constraint +meta-object, of the class L or a +derivative. What you do with it from there is up to you :) + +=item B + +This function will register a named type constraint with the type registry. + +=item B + +Fetch the L object which +keeps track of all type constraints. + +=item B + +This will return a list of type constraint names, you can then +fetch them using C if you +want to. + +=item B + +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. + +=item B + +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. + +=item B + +This returns all the parameterizable types that have been registered. + +=item B + +Adds C<$type> to the list of parameterizable types + +=back + =head2 Namespace Management =over 4 @@ -783,7 +1052,7 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2006, 2007 by Infinity Interactive, Inc. +Copyright 2006-2008 by Infinity Interactive, Inc. L