X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoose%2FUtil%2FTypeConstraints.pm;h=655894d109061e294667d745fdfcd13dd5ce2774;hb=8ecb1fa00856ddb07f4e006c79fe4c48e08902c0;hp=dd6b7967b6a880ec83133853b6dd2c231d230a2b;hpb=446e850ff17832686a136e4363316a259783cb9c;p=gitmo%2FMoose.git diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm index dd6b796..655894d 100644 --- a/lib/Moose/Util/TypeConstraints.pm +++ b/lib/Moose/Util/TypeConstraints.pm @@ -1,4 +1,6 @@ +use lib '/Users/stevan/Projects/Moose/Moose/Class-MOP/branches/Class-MOP-tranformations/lib'; + package Moose::Util::TypeConstraints; use strict; @@ -6,25 +8,49 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed'; +use B 'svref_2object'; +use Sub::Exporter; -our $VERSION = '0.04'; +our $VERSION = '0.09'; use Moose::Meta::TypeConstraint; use Moose::Meta::TypeCoercion; -sub import { - shift; - my $pkg = shift || caller(); - return if $pkg eq '-no-export'; - no strict 'refs'; - foreach my $export (qw(type subtype as where message coerce from via find_type_constraint)) { - *{"${pkg}::${export}"} = \&{"${export}"}; - } +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}; + } + } } { my %TYPES; - sub find_type_constraint { + sub find_type_constraint ($) { return $TYPES{$_[0]}->[1] if exists $TYPES{$_[0]}; return; @@ -32,11 +58,20 @@ sub import { sub _dump_type_constraints { require Data::Dumper; - Data::Dumper::Dumper \%TYPES; + Data::Dumper::Dumper(\%TYPES); } - sub _create_type_constraint { - my ($name, $parent, $check, $message) = @_; + 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}; + } + my $pkg_defined_in = scalar(caller(1)); ($TYPES{$name}->[0] eq $pkg_defined_in) || confess "The type constraint '$name' has already been created " @@ -47,12 +82,13 @@ sub import { parent => $parent, constraint => $check, message => $message, + optimized => $optimized, ); $TYPES{$name} = [ $pkg_defined_in, $constraint ] if defined $name; return $constraint; } - sub _install_type_coercions { + sub _install_type_coercions ($$) { my ($type_name, $coercion_map) = @_; my $type = find_type_constraint($type_name); (!$type->has_coercion) @@ -64,6 +100,15 @@ sub import { $type->coercion($type_coercion); } + sub create_type_constraint_union (@) { + my (@type_constraint_names) = @_; + return Moose::Meta::TypeConstraint->union( + map { + find_type_constraint($_) + } @type_constraint_names + ); + } + sub export_type_contstraints_as_functions { my $pkg = caller(); no strict 'refs'; @@ -80,9 +125,9 @@ sub type ($$) { _create_type_constraint($name, undef, $check); } -sub subtype ($$;$$) { - unshift @_ => undef if scalar @_ <= 2; - _create_type_constraint(@_); +sub subtype ($$;$$$) { + unshift @_ => undef if scalar @_ <= 2; + goto &_create_type_constraint; } sub coerce ($@) { @@ -94,27 +139,85 @@ sub as ($) { $_[0] } sub from ($) { $_[0] } sub where (&) { $_[0] } sub via (&) { $_[0] } -sub message (&) { $_[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 } + ); +} # define some basic types -type 'Any' => where { 1 }; +type 'Any' => where { 1 }; # meta-type including all +type 'Item' => where { 1 }; # base-type -subtype 'Value' => as 'Any' => where { !ref($_) }; -subtype 'Ref' => as 'Any' => where { ref($_) }; +subtype 'Undef' => as 'Item' => where { !defined($_) }; +subtype 'Defined' => as 'Item' => where { defined($_) }; -subtype 'Int' => as 'Value' => where { Scalar::Util::looks_like_number($_) }; -subtype 'Str' => as 'Value' => where { !Scalar::Util::looks_like_number($_) }; +subtype 'Bool' + => as 'Item' + => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' }; -subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' }; -subtype 'ArrayRef' => as 'Ref' => where { ref($_) eq 'ARRAY' }; -subtype 'HashRef' => as 'Ref' => where { ref($_) eq 'HASH' }; -subtype 'CodeRef' => as 'Ref' => where { ref($_) eq 'CODE' }; -subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' }; +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' }; + +# 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]) }; # NOTE: # blessed(qr/.../) returns true,.. how odd -subtype 'Object' => as 'Ref' => where { blessed($_) && blessed($_) ne 'Regexp' }; +subtype 'Object' + => as 'Ref' + => where { blessed($_) && blessed($_) ne 'Regexp' } + => optimize_as { blessed($_[0]) && blessed($_[0]) ne 'Regexp' }; + +subtype 'Role' + => as 'Object' + => where { $_->can('does') } + => optimize_as { blessed($_[0]) && $_[0]->can('does') }; 1; @@ -130,20 +233,22 @@ Moose::Util::TypeConstraints - Type constraint system for Moose use Moose::Util::TypeConstraints; - type Num => where { Scalar::Util::looks_like_number($_) }; + type 'Num' => where { Scalar::Util::looks_like_number($_) }; - subtype Natural - => as Num + subtype 'Natural' + => as 'Num' => where { $_ > 0 }; - subtype NaturalLessThanTen - => as Natural + subtype 'NaturalLessThanTen' + => as 'Natural' => where { $_ < 10 } => message { "This number ($_) is not less than ten!" }; - coerce Num - => from Str + coerce 'Num' + => from 'Str' => via { 0+$_ }; + + enum 'RGBColors' => qw(red green blue); =head1 DESCRIPTION @@ -160,24 +265,59 @@ 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. +=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. + +So for instance, this: + + subtype DateTime => as Object => where { $_->isa('DateTime') }; + +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: + + 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. Any - Value - Int - Str - Ref - ScalarRef - ArrayRef - HashRef - CodeRef - RegexpRef - Object + Item + Bool + Undef + Defined + Value + Num + Int + Str + Ref + ScalarRef + ArrayRef + HashRef + CodeRef + RegexpRef + GlobRef + FileHandle + Object + Role Suggestions for improvement are welcome. + +B The C type constraint does not work correctly +in every occasion, please use it sparringly. =head1 FUNCTIONS @@ -190,6 +330,11 @@ Suggestions for improvement are welcome. This function can be used to locate a specific type constraint meta-object. What you do with it from there is up to you :) +=item B + +Given a list of C<@type_constraint_names>, this will return a +B instance. + =item B This will export all the current type constraints as functions @@ -222,6 +367,16 @@ 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 +will match any of the items in C<@values>. 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 This is just sugar for the type constraint construction syntax. @@ -234,6 +389,8 @@ This is just sugar for the type constraint construction syntax. This is just sugar for the type constraint construction syntax. +=item B + =back =head2 Type Coercion Constructors @@ -260,6 +417,17 @@ This is just sugar for the type coercion construction syntax. =back +=head2 Namespace Management + +=over 4 + +=item B + +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 @@ -279,4 +447,4 @@ L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=cut \ No newline at end of file +=cut