From: Guillermo Roditi Date: Tue, 6 Nov 2007 22:57:34 +0000 (+0000) Subject: last fix so far X-Git-Tag: 0_27~6^2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e85d2a5de17893fbc7baf3f6dc3f60b6d6c8a5da;p=gitmo%2FMoose.git last fix so far --- diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index 95bbfd7..807e61a 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -13,9 +13,9 @@ our $VERSION = '0.15'; 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 +# 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. @@ -37,7 +37,7 @@ sub message (&); sub optimize_as (&); sub enum ($;@); -## private stuff ... +## private stuff ... sub _create_type_constraint ($$$;$$); sub _install_type_coercions ($$); @@ -52,30 +52,30 @@ use Moose::Meta::TypeConstraint::Registry; my @exports = qw/ type subtype as where message optimize_as - coerce from via + coerce from via enum find_type_constraint /; -Sub::Exporter::setup_exporter({ +Sub::Exporter::setup_exporter({ exports => \@exports, groups => { default => [':all'] } }); sub unimport { - no strict 'refs'; + 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}; } @@ -89,53 +89,53 @@ sub unimport { my $REGISTRY = Moose::Meta::TypeConstraint::Registry->new; sub get_type_constraint_registry { $REGISTRY } -sub list_all_type_constraints { keys %{$REGISTRY->type_constraints} } +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}) { - *{"${pkg}::${constraint}"} = $REGISTRY->get_type_constraint($constraint) - ->_compiled_type_constraint; - } + foreach my $constraint (keys %{$REGISTRY->type_constraints}) { + *{"${pkg}::${constraint}"} = $REGISTRY->get_type_constraint($constraint) + ->_compiled_type_constraint; + } } 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) - || confess "You must pass in at least 2 type names to make a union"; - + || confess "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; - + return Moose::Meta::TypeConstraint::Union->new( type_constraints => [ - map { - $REGISTRY->get_type_constraint($_) - } @type_constraint_names + map { + $REGISTRY->get_type_constraint($_) + } @type_constraint_names ], - ); + ); } 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), @@ -145,39 +145,39 @@ sub create_parameterized_type_constraint ($) { constraint => sub { $_[0]->isa($type_parameter) } } ), - ); + ); } sub find_or_create_type_constraint ($;$) { my ($type_constraint_name, $options_for_anon_type) = @_; - + return $REGISTRY->get_type_constraint($type_constraint_name) if $REGISTRY->has_type_constraint($type_constraint_name); - + my $constraint; - + 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); + $constraint = create_parameterized_type_constraint($type_constraint_name); } else { # NOTE: # otherwise assume that we should create - # an ANON type with the $options_for_anon_type + # 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 + # 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} + %{$options_for_anon_type} ); } - + $REGISTRY->add_type_constraint($constraint); - return $constraint; + return $constraint; } ## -------------------------------------------------------- @@ -190,7 +190,7 @@ sub find_type_constraint ($) { $REGISTRY->get_type_constraint(@_) } sub type ($$;$$) { splice(@_, 1, 0, undef); - goto &_create_type_constraint; + goto &_create_type_constraint; } sub subtype ($$;$$$) { @@ -201,14 +201,14 @@ sub subtype ($$;$$$) { # 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 + # ... yeah I know it's ugly code # - SL - unshift @_ => undef if scalar @_ <= 2 && (reftype($_[1]) || '') eq 'CODE'; - goto &_create_type_constraint; + unshift @_ => undef if scalar @_ <= 2 && (reftype($_[1]) || '') eq 'CODE'; + goto &_create_type_constraint; } sub coerce ($@) { - my ($type_name, @coercion_map) = @_; + my ($type_name, @coercion_map) = @_; _install_type_coercions($type_name, \@coercion_map); } @@ -225,49 +225,50 @@ sub enum ($;@) { (scalar @values >= 2) || confess "You must have at least two values to enumerate through"; my %valid = map { $_ => 1 } @values; - _create_type_constraint( - $type_name, - 'Str', - sub { $valid{$_} } - ); + _create_type_constraint( + $type_name, + 'Str', + sub { $valid{$_} } + ); } ## -------------------------------------------------------- ## desugaring functions ... ## -------------------------------------------------------- -sub _create_type_constraint ($$$;$$) { +sub _create_type_constraint ($$$;$$) { my $name = shift; my $parent = shift; my $check = shift || sub { 1 }; - + my ($message, $optimized); for (@_) { $message = $_->{message} if exists $_->{message}; - $optimized = $_->{optimized} if exists $_->{optimized}; + $optimized = $_->{optimized} if exists $_->{optimized}; } my $pkg_defined_in = scalar(caller(0)); - + 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 " + || 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; - } - + if defined $type; + } + $parent = $REGISTRY->get_type_constraint($parent) if defined $parent; - + my $constraint = Moose::Meta::TypeConstraint->new( name => $name || '__ANON__', - parent => $parent, - constraint => $check, - message => $message, - optimized => $optimized, package_defined_in => $pkg_defined_in, + + ($parent ? (parent => $parent ) : ()), + ($check ? (constraint => $check) : ()), + ($message ? (message => $message) : ()), + ($optimized ? (optimized => $optimized) : ()), ); $REGISTRY->add_type_constraint($constraint) @@ -276,15 +277,15 @@ sub _create_type_constraint ($$$;$$) { return $constraint; } -sub _install_type_coercions ($$) { +sub _install_type_coercions ($$) { my ($type_name, $coercion_map) = @_; my $type = $REGISTRY->get_type_constraint($type_name); (!$type->has_coercion) - || confess "The type coercion for '$type_name' has already been registered"; + || 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); } @@ -293,12 +294,12 @@ sub _install_type_coercions ($$) { ## -------------------------------------------------------- { - # 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 + # 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 - + # - SL + use re "eval"; my $valid_chars = qr{[\w:]}; @@ -314,31 +315,31 @@ sub _install_type_coercions ($$) { our $any = qr{ $type | $union }x; sub _parse_parameterized_type_constraint { - $_[0] =~ m{ $type_capture_parts }x; - return ($1, $2); + $_[0] =~ m{ $type_capture_parts }x; + return ($1, $2); } sub _detect_parameterized_type_constraint { - $_[0] =~ m{ ^ $type_with_parameter $ }x; + $_[0] =~ m{ ^ $type_with_parameter $ }x; } sub _parse_type_constraint_union { - my $given = shift; - my @rv; - while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) { - push @rv => $1; - } - (pos($given) eq length($given)) - || confess "'$given' didn't parse (parse-pos=" - . pos($given) - . " and str-length=" - . length($given) - . ")"; - @rv; + my $given = shift; + my @rv; + while ( $given =~ m{ \G (?: $op_union )? ($type) }gcx ) { + push @rv => $1; + } + (pos($given) eq length($given)) + || confess "'$given' didn't parse (parse-pos=" + . pos($given) + . " and str-length=" + . length($given) + . ")"; + @rv; } sub _detect_type_constraint_union { - $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x; + $_[0] =~ m{^ $type $op_union $type ( $op_union .* )? $}x; } } @@ -347,71 +348,71 @@ sub _install_type_coercions ($$) { ## -------------------------------------------------------- type 'Any' => where { 1 }; # meta-type including all -type 'Item' => where { 1 }; # base-type +type 'Item' => where { 1 }; # base-type subtype 'Undef' => as 'Item' => where { !defined($_) }; subtype 'Defined' => as 'Item' => where { defined($_) }; subtype 'Bool' - => as 'Item' + => as 'Item' => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' }; -subtype 'Value' - => as 'Defined' - => where { !ref($_) } +subtype 'Value' + => as 'Defined' + => where { !ref($_) } => optimize_as { defined($_[0]) && !ref($_[0]) }; - + subtype 'Ref' - => as 'Defined' - => where { ref($_) } + => as 'Defined' + => where { ref($_) } => optimize_as { ref($_[0]) }; -subtype 'Str' - => as 'Value' - => where { 1 } +subtype 'Str' + => as 'Value' + => where { 1 } => optimize_as { defined($_[0]) && !ref($_[0]) }; -subtype 'Num' - => as 'Value' - => where { Scalar::Util::looks_like_number($_) } +subtype 'Num' + => as 'Value' + => where { Scalar::Util::looks_like_number($_) } => optimize_as { !ref($_[0]) && Scalar::Util::looks_like_number($_[0]) }; - -subtype 'Int' - => as 'Num' + +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 '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 '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' }; # NOTE: -# scalar filehandles are GLOB refs, +# scalar filehandles are GLOB refs, # but a GLOB ref is not always a filehandle -subtype 'FileHandle' - => as 'GlobRef' +subtype 'FileHandle' + => as 'GlobRef' => where { Scalar::Util::openhandle($_) } => optimize_as { ref($_[0]) eq 'GLOB' && Scalar::Util::openhandle($_[0]) }; -# NOTE: +# NOTE: # blessed(qr/.../) returns true,.. how odd -subtype 'Object' - => as 'Ref' +subtype 'Object' + => as 'Ref' => where { blessed($_) && blessed($_) ne 'Regexp' } => optimize_as { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }; -subtype 'Role' - => as 'Object' +subtype 'Role' + => as 'Object' => where { $_->can('does') } => optimize_as { blessed($_[0]) && $_[0]->can('does') }; - -subtype 'ClassName' - => as 'Str' + +subtype 'ClassName' + => as 'Str' => where { eval { $_->isa('UNIVERSAL') } } - => optimize_as { !ref($_[0]) && eval { $_[0]->isa('UNIVERSAL') } }; + => optimize_as { !ref($_[0]) && eval { $_[0]->isa('UNIVERSAL') } }; ## -------------------------------------------------------- # end of built-in types ... @@ -437,46 +438,46 @@ 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 'Num' => 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); =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 +contraints 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, expression are not typed, etc. etc. etc. -This is simply a means of creating small constraint functions which +This is simply a means of creating small constraint functions which can be used to simplify your own type-checking code. =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 +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. +the same name as a valid class, but when the issue does arise it tends +to be quite annoying to debug. So for instance, this: - + subtype DateTime => as Object => where { $_->isa('DateTime') }; will I, while this: @@ -484,8 +485,8 @@ 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 +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: use DateTime; @@ -493,11 +494,11 @@ 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 +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. Any - Item + Item Bool Undef Defined @@ -514,54 +515,54 @@ could probably use some work, but it works for me at the moment. RegexpRef GlobRef FileHandle - Object + Object Role Suggestions for improvement are welcome. -B The C type constraint does not work correctly +B The C type constraint does not work correctly in every occasion, please use it sparringly. -B The C type constraint is simply a subtype +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. +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 Use with Other Constraint Modules -This module should play fairly nicely with other constraint -modules with only some slight tweaking. The C clause +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 +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' + type 'HashOfArrayOfObjects' => IsHashRef( -keys => HasLength, -values => IsArrayRef( IsObject )); 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 Construction & Locating @@ -570,7 +571,7 @@ test file. =item B -Given string with C<$pipe_seperated_types> or a list of C<@type_constraint_names>, +Given string with C<$pipe_seperated_types> or a list of C<@type_constraint_names>, this will return a L instance. =item B @@ -579,15 +580,15 @@ 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 +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 +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. =item B @@ -598,34 +599,34 @@ derivative. What you do with it from there is up to you :) =item B -Fetch the L object which +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 +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 +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 +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. -They will then register the type constraints in a global store -where Moose can get to them if it needs to. +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. See the L for an example of how to use these. @@ -633,26 +634,26 @@ See the L for an example of how to use these. =item B -This creates a base type, which has no parent. +This creates a base type, which has no parent. =item B -This creates a named subtype. +This creates a named subtype. =item B -This creates an unnamed subtype and will return the type -constraint meta-object, which will be an instance of -L. +This creates an unnamed subtype and will return the type +constraint meta-object, which will be an instance of +L. =item B -This will create a basic subtype for a given set of strings. -The resulting constraint will be a subtype of C and +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 simple +B This is not a true proper enum type, it is simple a convient constraint builder. =item B @@ -669,22 +670,22 @@ This is just sugar for the type constraint construction syntax. =item B -This can be used to define a "hand optimized" version of your +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 heirarchy. -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. =back =head2 Type Coercion Constructors -Type constraints can also contain type coercions as well. 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 +Type constraints can also contain type coercions as well. 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. @@ -709,14 +710,14 @@ This is just sugar for the type coercion construction syntax. =item B -This will remove all the type constraint keywords from the +This will remove all the type constraint keywords from the calling class namespace. =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. @@ -731,6 +732,6 @@ Copyright 2006, 2007 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