lib/Moose/Util/TypeConstraints.pm

   1
   2 package Moose::Util::TypeConstraints;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp         'confess';
   8 use Scalar::Util 'blessed';
   9
  10 our $VERSION = '0.07';
  11
  12 use Moose::Meta::TypeConstraint;
  13 use Moose::Meta::TypeCoercion;
  14
  15 use Sub::Exporter
  16     -setup => {
  17         exports => qw[type subtype as where message coerce from via find_type_constraint enum],
  18         groups  => {
  19             default => [':all']
  20         }
  21     }
  22 );
  23
  24 {
  25     my %TYPES;
  26     sub find_type_constraint ($) {
  27         return $TYPES{$_[0]}->[1]
  28             if exists $TYPES{$_[0]};
  29         return;
  30     }
  31
  32     sub _dump_type_constraints {
  33         require Data::Dumper;
  34         Data::Dumper::Dumper(\%TYPES);
  35     }
  36
  37     sub _create_type_constraint ($$$;$) {
  38         my ($name, $parent, $check, $message) = @_;
  39         my $pkg_defined_in = scalar(caller(1));
  40         ($TYPES{$name}->[0] eq $pkg_defined_in)
  41             || confess "The type constraint '$name' has already been created "
  42                  if defined $name && exists $TYPES{$name};
  43         $parent = find_type_constraint($parent) if defined $parent;
  44         my $constraint = Moose::Meta::TypeConstraint->new(
  45             name       => $name || '__ANON__',
  46             parent     => $parent,
  47             constraint => $check,
  48             message    => $message,
  49         );
  50         $TYPES{$name} = [ $pkg_defined_in, $constraint ] if defined $name;
  51         return $constraint;
  52     }
  53
  54     sub _install_type_coercions ($$) {
  55         my ($type_name, $coercion_map) = @_;
  56         my $type = find_type_constraint($type_name);
  57         (!$type->has_coercion)
  58             || confess "The type coercion for '$type_name' has already been registered";
  59         my $type_coercion = Moose::Meta::TypeCoercion->new(
  60             type_coercion_map => $coercion_map,
  61             type_constraint   => $type
  62         );
  63         $type->coercion($type_coercion);
  64     }
  65
  66     sub create_type_constraint_union (@) {
  67         my (@type_constraint_names) = @_;
  68         return Moose::Meta::TypeConstraint->union(
  69             map {
  70                 find_type_constraint($_)
  71             } @type_constraint_names
  72         );
  73     }
  74
  75     sub export_type_contstraints_as_functions {
  76         my $pkg = caller();
  77             no strict 'refs';
  78         foreach my $constraint (keys %TYPES) {
  79                 *{"${pkg}::${constraint}"} = find_type_constraint($constraint)->_compiled_type_constraint;
  80         }
  81     }
  82 }
  83
  84 # type constructors
  85
  86 sub type ($$) {
  87         my ($name, $check) = @_;
  88         _create_type_constraint($name, undef, $check);
  89 }
  90
  91 sub subtype ($$;$$) {
  92         unshift @_ => undef if scalar @_ <= 2;
  93         goto &_create_type_constraint;
  94 }
  95
  96 sub coerce ($@) {
  97     my ($type_name, @coercion_map) = @_;
  98     _install_type_coercions($type_name, \@coercion_map);
  99 }
 100
 101 sub as      ($) { $_[0] }
 102 sub from    ($) { $_[0] }
 103 sub where   (&) { $_[0] }
 104 sub via     (&) { $_[0] }
 105 sub message (&) { $_[0] }
 106
 107 sub enum ($;@) {
 108     my ($type_name, @values) = @_;
 109     (scalar @values >= 2)
 110         || confess "You must have at least two values to enumerate through";
 111     my $regexp = join '|' => @values;
 112         _create_type_constraint(
 113             $type_name,
 114             'Str',
 115             sub { qr/^$regexp$/i }
 116         );
 117 }
 118
 119 # define some basic types
 120
 121 type 'Any'  => where { 1 }; # meta-type including all
 122 type 'Item' => where { 1 }; # base-type
 123
 124 subtype 'Undef'   => as 'Item' => where { !defined($_) };
 125 subtype 'Defined' => as 'Item' => where {  defined($_) };
 126
 127 subtype 'Bool'  => as 'Item' => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
 128
 129 subtype 'Value' => as 'Defined' => where { !ref($_) };
 130 subtype 'Ref'   => as 'Defined' => where {  ref($_) };
 131
 132 subtype 'Str' => as 'Value' => where { 1 };
 133
 134 subtype 'Num' => as 'Value' => where { Scalar::Util::looks_like_number($_) };
 135 subtype 'Int' => as 'Num'   => where { "$_" =~ /^-?[0-9]+$/ };
 136
 137 subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' };
 138 subtype 'ArrayRef'  => as 'Ref' => where { ref($_) eq 'ARRAY'  };
 139 subtype 'HashRef'   => as 'Ref' => where { ref($_) eq 'HASH'   };
 140 subtype 'CodeRef'   => as 'Ref' => where { ref($_) eq 'CODE'   };
 141 subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' };
 142
 143 # NOTE:
 144 # blessed(qr/.../) returns true,.. how odd
 145 subtype 'Object' => as 'Ref' => where { blessed($_) && blessed($_) ne 'Regexp' };
 146
 147 subtype 'Role' => as 'Object' => where { $_->can('does') };
 148
 149 1;
 150
 151 __END__
 152
 153 =pod
 154
 155 =head1 NAME
 156
 157 Moose::Util::TypeConstraints - Type constraint system for Moose
 158
 159 =head1 SYNOPSIS
 160
 161   use Moose::Util::TypeConstraints;
 162
 163   type 'Num' => where { Scalar::Util::looks_like_number($_) };
 164
 165   subtype 'Natural'
 166       => as 'Num'
 167       => where { $_ > 0 };
 168
 169   subtype 'NaturalLessThanTen'
 170       => as 'Natural'
 171       => where { $_ < 10 }
 172       => message { "This number ($_) is not less than ten!" };
 173
 174   coerce 'Num'
 175       => from 'Str'
 176         => via { 0+$_ };
 177
 178   enum 'RGBColors' => qw(red green blue);
 179
 180 =head1 DESCRIPTION
 181
 182 This module provides Moose with the ability to create type contraints
 183 to be are used in both attribute definitions and for method argument
 184 validation.
 185
 186 =head2 Important Caveat
 187
 188 This is B<NOT> a type system for Perl 5. These are type constraints,
 189 and they are not used by Moose unless you tell it to. No type
 190 inference is performed, expression are not typed, etc. etc. etc.
 191
 192 This is simply a means of creating small constraint functions which
 193 can be used to simplify your own type-checking code.
 194
 195 =head2 Slightly Less Important Caveat
 196
 197 It is almost always a good idea to quote your type and subtype names.
 198 This is to prevent perl from trying to create the call as an indirect
 199 object call. This issue only seems to come up when you have a subtype
 200 the same name as a valid class, but when the issue does arise it tends
 201 to be quite annoying to debug.
 202
 203 So for instance, this:
 204
 205   subtype DateTime => as Object => where { $_->isa('DateTime') };
 206
 207 will I<Just Work>, while this:
 208
 209   use DateTime;
 210   subtype DateTime => as Object => where { $_->isa('DateTime') };
 211
 212 will fail silently and cause many headaches. The simple way to solve
 213 this, as well as future proof your subtypes from classes which have
 214 yet to have been created yet, is to simply do this:
 215
 216   use DateTime;
 217   subtype 'DateTime' => as Object => where { $_->isa('DateTime') };
 218
 219 =head2 Default Type Constraints
 220
 221 This module also provides a simple hierarchy for Perl 5 types, this
 222 could probably use some work, but it works for me at the moment.
 223
 224   Any
 225   Item
 226       Bool
 227       Undef
 228       Defined
 229           Value
 230               Num
 231                 Int
 232               Str
 233           Ref
 234               ScalarRef
 235               ArrayRef
 236               HashRef
 237               CodeRef
 238               RegexpRef
 239               Object
 240                   Role
 241
 242 Suggestions for improvement are welcome.
 243
 244 B<NOTE:> The C<Undef> type constraint does not work correctly
 245 in every occasion, please use it sparringly.
 246
 247 =head1 FUNCTIONS
 248
 249 =head2 Type Constraint Registry
 250
 251 =over 4
 252
 253 =item B<find_type_constraint ($type_name)>
 254
 255 This function can be used to locate a specific type constraint
 256 meta-object. What you do with it from there is up to you :)
 257
 258 =item B<create_type_constraint_union (@type_constraint_names)>
 259
 260 Given a list of C<@type_constraint_names>, this will return a
 261 B<Moose::Meta::TypeConstraint::Union> instance.
 262
 263 =item B<export_type_contstraints_as_functions>
 264
 265 This will export all the current type constraints as functions
 266 into the caller's namespace. Right now, this is mostly used for
 267 testing, but it might prove useful to others.
 268
 269 =back
 270
 271 =head2 Type Constraint Constructors
 272
 273 The following functions are used to create type constraints.
 274 They will then register the type constraints in a global store
 275 where Moose can get to them if it needs to.
 276
 277 See the L<SYNOPOSIS> for an example of how to use these.
 278
 279 =over 4
 280
 281 =item B<type ($name, $where_clause)>
 282
 283 This creates a base type, which has no parent.
 284
 285 =item B<subtype ($name, $parent, $where_clause, ?$message)>
 286
 287 This creates a named subtype.
 288
 289 =item B<subtype ($parent, $where_clause, ?$message)>
 290
 291 This creates an unnamed subtype and will return the type
 292 constraint meta-object, which will be an instance of
 293 L<Moose::Meta::TypeConstraint>.
 294
 295 =item B<enum ($name, @values)>
 296
 297 This will create a basic subtype for a given set of strings.
 298 The resulting constraint will be a subtype of C<Str> and
 299 will match any of the items in C<@values>. See the L<SYNOPSIS>
 300 for a simple example.
 301
 302 B<NOTE:> This is not a true proper enum type, it is simple
 303 a convient constraint builder.
 304
 305 =item B<as>
 306
 307 This is just sugar for the type constraint construction syntax.
 308
 309 =item B<where>
 310
 311 This is just sugar for the type constraint construction syntax.
 312
 313 =item B<message>
 314
 315 This is just sugar for the type constraint construction syntax.
 316
 317 =back
 318
 319 =head2 Type Coercion Constructors
 320
 321 Type constraints can also contain type coercions as well. In most
 322 cases Moose will run the type-coercion code first, followed by the
 323 type constraint check. This feature should be used carefully as it
 324 is very powerful and could easily take off a limb if you are not
 325 careful.
 326
 327 See the L<SYNOPOSIS> for an example of how to use these.
 328
 329 =over 4
 330
 331 =item B<coerce>
 332
 333 =item B<from>
 334
 335 This is just sugar for the type coercion construction syntax.
 336
 337 =item B<via>
 338
 339 This is just sugar for the type coercion construction syntax.
 340
 341 =back
 342
 343 =head1 BUGS
 344
 345 All complex software has bugs lurking in it, and this module is no
 346 exception. If you find a bug please either email me, or add the bug
 347 to cpan-RT.
 348
 349 =head1 AUTHOR
 350
 351 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 352
 353 =head1 COPYRIGHT AND LICENSE
 354
 355 Copyright 2006 by Infinity Interactive, Inc.
 356
 357 L<http://www.iinteractive.com>
 358
 359 This library is free software; you can redistribute it and/or modify
 360 it under the same terms as Perl itself.
 361
 362 =cut