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 use B            'svref_2object';
  10 use Sub::Exporter;
  11
  12 our $VERSION   = '0.12';
  13 our $AUTHORITY = 'cpan:STEVAN';
  14
  15 use Moose::Meta::TypeConstraint;
  16 use Moose::Meta::TypeCoercion;
  17
  18 my @exports = qw/
  19     type subtype as where message optimize_as
  20     coerce from via
  21     enum
  22     find_type_constraint
  23 /;
  24
  25 Sub::Exporter::setup_exporter({
  26     exports => \@exports,
  27     groups  => { default => [':all'] }
  28 });
  29
  30 sub unimport {
  31     no strict 'refs';
  32     my $class = caller();
  33     # loop through the exports ...
  34     foreach my $name (@exports) {
  35         # if we find one ...
  36         if (defined &{$class . '::' . $name}) {
  37             my $keyword = \&{$class . '::' . $name};
  38
  39             # make sure it is from Moose
  40             my $pkg_name = eval { svref_2object($keyword)->GV->STASH->NAME };
  41             next if $@;
  42             next if $pkg_name ne 'Moose::Util::TypeConstraints';
  43
  44             # and if it is from Moose then undef the slot
  45             delete ${$class . '::'}{$name};
  46         }
  47     }
  48 }
  49
  50 {
  51     my %TYPES;
  52     sub find_type_constraint ($) {
  53         return $TYPES{$_[0]}->[1]
  54             if exists $TYPES{$_[0]};
  55         return;
  56     }
  57
  58     sub _dump_type_constraints {
  59         require Data::Dumper;
  60         Data::Dumper::Dumper(\%TYPES);
  61     }
  62
  63     sub _create_type_constraint ($$$;$$) {
  64         my $name   = shift;
  65         my $parent = shift;
  66         my $check  = shift;;
  67
  68         my ($message, $optimized);
  69         for (@_) {
  70             $message   = $_->{message}   if exists $_->{message};
  71             $optimized = $_->{optimized} if exists $_->{optimized};
  72         }
  73
  74         my $pkg_defined_in = scalar(caller(0));
  75
  76         ($TYPES{$name}->[0] eq $pkg_defined_in)
  77             || confess ("The type constraint '$name' has already been created in "
  78                        . $TYPES{$name}->[0] . " and cannot be created again in "
  79                        . $pkg_defined_in)
  80                  if defined $name && exists $TYPES{$name};
  81
  82         $parent = find_type_constraint($parent) if defined $parent;
  83         my $constraint = Moose::Meta::TypeConstraint->new(
  84             name       => $name || '__ANON__',
  85             parent     => $parent,
  86             constraint => $check,
  87             message    => $message,
  88             optimized  => $optimized,
  89         );
  90         $TYPES{$name} = [ $pkg_defined_in, $constraint ] if defined $name;
  91         return $constraint;
  92     }
  93
  94     sub _install_type_coercions ($$) {
  95         my ($type_name, $coercion_map) = @_;
  96         my $type = find_type_constraint($type_name);
  97         (!$type->has_coercion)
  98             || confess "The type coercion for '$type_name' has already been registered";
  99         my $type_coercion = Moose::Meta::TypeCoercion->new(
 100             type_coercion_map => $coercion_map,
 101             type_constraint   => $type
 102         );
 103         $type->coercion($type_coercion);
 104     }
 105
 106     sub create_type_constraint_union (@) {
 107         my (@type_constraint_names) = @_;
 108         return Moose::Meta::TypeConstraint->union(
 109             map {
 110                 find_type_constraint($_)
 111             } @type_constraint_names
 112         );
 113     }
 114
 115     sub export_type_contstraints_as_functions {
 116         my $pkg = caller();
 117             no strict 'refs';
 118         foreach my $constraint (keys %TYPES) {
 119                 *{"${pkg}::${constraint}"} = find_type_constraint($constraint)->_compiled_type_constraint;
 120         }
 121     }
 122
 123     sub list_all_type_constraints { keys %TYPES }
 124 }
 125
 126 # type constructors
 127
 128 sub type ($$;$$) {
 129     splice(@_, 1, 0, undef);
 130         goto &_create_type_constraint;
 131 }
 132
 133 sub subtype ($$;$$$) {
 134         unshift @_ => undef if scalar @_ <= 2;
 135         goto &_create_type_constraint;
 136 }
 137
 138 sub coerce ($@) {
 139     my ($type_name, @coercion_map) = @_;
 140     _install_type_coercions($type_name, \@coercion_map);
 141 }
 142
 143 sub as      ($) { $_[0] }
 144 sub from    ($) { $_[0] }
 145 sub where   (&) { $_[0] }
 146 sub via     (&) { $_[0] }
 147
 148 sub message     (&) { +{ message   => $_[0] } }
 149 sub optimize_as (&) { +{ optimized => $_[0] } }
 150
 151 sub enum ($;@) {
 152     my ($type_name, @values) = @_;
 153     (scalar @values >= 2)
 154         || confess "You must have at least two values to enumerate through";
 155     my $regexp = join '|' => @values;
 156         _create_type_constraint(
 157             $type_name,
 158             'Str',
 159             sub { qr/^$regexp$/i }
 160         );
 161 }
 162
 163 # define some basic types
 164
 165 type 'Any'  => where { 1 }; # meta-type including all
 166 type 'Item' => where { 1 }; # base-type
 167
 168 subtype 'Undef'   => as 'Item' => where { !defined($_) };
 169 subtype 'Defined' => as 'Item' => where {  defined($_) };
 170
 171 subtype 'Bool'
 172     => as 'Item'
 173     => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
 174
 175 subtype 'Value'
 176     => as 'Defined'
 177     => where { !ref($_) }
 178     => optimize_as { defined($_[0]) && !ref($_[0]) };
 179
 180 subtype 'Ref'
 181     => as 'Defined'
 182     => where {  ref($_) }
 183     => optimize_as { ref($_[0]) };
 184
 185 subtype 'Str'
 186     => as 'Value'
 187     => where { 1 }
 188     => optimize_as { defined($_[0]) && !ref($_[0]) };
 189
 190 subtype 'Num'
 191     => as 'Value'
 192     => where { Scalar::Util::looks_like_number($_) }
 193     => optimize_as { !ref($_[0]) && Scalar::Util::looks_like_number($_[0]) };
 194
 195 subtype 'Int'
 196     => as 'Num'
 197     => where { "$_" =~ /^-?[0-9]+$/ }
 198     => optimize_as { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ };
 199
 200 subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } => optimize_as { ref($_[0]) eq 'SCALAR' };
 201 subtype 'ArrayRef'  => as 'Ref' => where { ref($_) eq 'ARRAY'  } => optimize_as { ref($_[0]) eq 'ARRAY'  };
 202 subtype 'HashRef'   => as 'Ref' => where { ref($_) eq 'HASH'   } => optimize_as { ref($_[0]) eq 'HASH'   };
 203 subtype 'CodeRef'   => as 'Ref' => where { ref($_) eq 'CODE'   } => optimize_as { ref($_[0]) eq 'CODE'   };
 204 subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } => optimize_as { ref($_[0]) eq 'Regexp' };
 205 subtype 'GlobRef'   => as 'Ref' => where { ref($_) eq 'GLOB'   } => optimize_as { ref($_[0]) eq 'GLOB'   };
 206
 207 # NOTE:
 208 # scalar filehandles are GLOB refs,
 209 # but a GLOB ref is not always a filehandle
 210 subtype 'FileHandle'
 211     => as 'GlobRef'
 212     => where { Scalar::Util::openhandle($_) }
 213     => optimize_as { ref($_[0]) eq 'GLOB' && Scalar::Util::openhandle($_[0]) };
 214
 215 # NOTE:
 216 # blessed(qr/.../) returns true,.. how odd
 217 subtype 'Object'
 218     => as 'Ref'
 219     => where { blessed($_) && blessed($_) ne 'Regexp' }
 220     => optimize_as { blessed($_[0]) && blessed($_[0]) ne 'Regexp' };
 221
 222 subtype 'Role'
 223     => as 'Object'
 224     => where { $_->can('does') }
 225     => optimize_as { blessed($_[0]) && $_[0]->can('does') };
 226
 227 {
 228     my @BUILTINS = list_all_type_constraints();
 229     sub list_all_builtin_type_constraints { @BUILTINS }
 230 }
 231
 232 1;
 233
 234 __END__
 235
 236 =pod
 237
 238 =head1 NAME
 239
 240 Moose::Util::TypeConstraints - Type constraint system for Moose
 241
 242 =head1 SYNOPSIS
 243
 244   use Moose::Util::TypeConstraints;
 245
 246   type 'Num' => where { Scalar::Util::looks_like_number($_) };
 247
 248   subtype 'Natural'
 249       => as 'Num'
 250       => where { $_ > 0 };
 251
 252   subtype 'NaturalLessThanTen'
 253       => as 'Natural'
 254       => where { $_ < 10 }
 255       => message { "This number ($_) is not less than ten!" };
 256
 257   coerce 'Num'
 258       => from 'Str'
 259         => via { 0+$_ };
 260
 261   enum 'RGBColors' => qw(red green blue);
 262
 263 =head1 DESCRIPTION
 264
 265 This module provides Moose with the ability to create custom type
 266 contraints to be used in attribute definition.
 267
 268 =head2 Important Caveat
 269
 270 This is B<NOT> a type system for Perl 5. These are type constraints,
 271 and they are not used by Moose unless you tell it to. No type
 272 inference is performed, expression are not typed, etc. etc. etc.
 273
 274 This is simply a means of creating small constraint functions which
 275 can be used to simplify your own type-checking code.
 276
 277 =head2 Slightly Less Important Caveat
 278
 279 It is almost always a good idea to quote your type and subtype names.
 280 This is to prevent perl from trying to execute the call as an indirect
 281 object call. This issue only seems to come up when you have a subtype
 282 the same name as a valid class, but when the issue does arise it tends
 283 to be quite annoying to debug.
 284
 285 So for instance, this:
 286
 287   subtype DateTime => as Object => where { $_->isa('DateTime') };
 288
 289 will I<Just Work>, while this:
 290
 291   use DateTime;
 292   subtype DateTime => as Object => where { $_->isa('DateTime') };
 293
 294 will fail silently and cause many headaches. The simple way to solve
 295 this, as well as future proof your subtypes from classes which have
 296 yet to have been created yet, is to simply do this:
 297
 298   use DateTime;
 299   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 300
 301 =head2 Default Type Constraints
 302
 303 This module also provides a simple hierarchy for Perl 5 types, this
 304 could probably use some work, but it works for me at the moment.
 305
 306   Any
 307   Item
 308       Bool
 309       Undef
 310       Defined
 311           Value
 312               Num
 313                 Int
 314               Str
 315           Ref
 316               ScalarRef
 317               ArrayRef
 318               HashRef
 319               CodeRef
 320               RegexpRef
 321               GlobRef
 322                 FileHandle
 323               Object
 324                   Role
 325
 326 Suggestions for improvement are welcome.
 327
 328 B<NOTE:> The C<Undef> type constraint does not work correctly
 329 in every occasion, please use it sparringly.
 330
 331 =head2 Use with Other Constraint Modules
 332
 333 This module should play fairly nicely with other constraint
 334 modules with only some slight tweaking. The C<where> clause
 335 in types is expected to be a C<CODE> reference which checks
 336 it's first argument and returns a bool. Since most constraint
 337 modules work in a similar way, it should be simple to adapt
 338 them to work with Moose.
 339
 340 For instance, this is how you could use it with
 341 L<Declare::Constraints::Simple> to declare a completely new type.
 342
 343   type 'HashOfArrayOfObjects'
 344       => IsHashRef(
 345           -keys   => HasLength,
 346           -values => IsArrayRef( IsObject ));
 347
 348 For more examples see the F<t/204_example_w_DCS.t> test file.
 349
 350 Here is an example of using L<Test::Deep> and it's non-test
 351 related C<eq_deeply> function.
 352
 353   type 'ArrayOfHashOfBarsAndRandomNumbers'
 354       => where {
 355           eq_deeply($_,
 356               array_each(subhashof({
 357                   bar           => isa('Bar'),
 358                   random_number => ignore()
 359               })))
 360         };
 361
 362 For a complete example see the F<t/205_example_w_TestDeep.t>
 363 test file.
 364
 365 =head1 FUNCTIONS
 366
 367 =head2 Type Constraint Registry
 368
 369 =over 4
 370
 371 =item B<find_type_constraint ($type_name)>
 372
 373 This function can be used to locate a specific type constraint
 374 meta-object. What you do with it from there is up to you :)
 375
 376 =item B<create_type_constraint_union (@type_constraint_names)>
 377
 378 Given a list of C<@type_constraint_names>, this will return a
 379 B<Moose::Meta::TypeConstraint::Union> instance.
 380
 381 =item B<export_type_contstraints_as_functions>
 382
 383 This will export all the current type constraints as functions
 384 into the caller's namespace. Right now, this is mostly used for
 385 testing, but it might prove useful to others.
 386
 387 =item B<list_all_type_constraints>
 388
 389 This will return a list of type constraint names, you can then
 390 fetch them using C<find_type_constraint ($type_name)> if you
 391 want to.
 392
 393 =item B<list_all_builtin_type_constraints>
 394
 395 This will return a list of builtin type constraints, meaning,
 396 those which are defined in this module. See the section
 397 labeled L<Default Type Constraints> for a complete list.
 398
 399 =back
 400
 401 =head2 Type Constraint Constructors
 402
 403 The following functions are used to create type constraints.
 404 They will then register the type constraints in a global store
 405 where Moose can get to them if it needs to.
 406
 407 See the L<SYNOPOSIS> for an example of how to use these.
 408
 409 =over 4
 410
 411 =item B<type ($name, $where_clause)>
 412
 413 This creates a base type, which has no parent.
 414
 415 =item B<subtype ($name, $parent, $where_clause, ?$message)>
 416
 417 This creates a named subtype.
 418
 419 =item B<subtype ($parent, $where_clause, ?$message)>
 420
 421 This creates an unnamed subtype and will return the type
 422 constraint meta-object, which will be an instance of
 423 L<Moose::Meta::TypeConstraint>.
 424
 425 =item B<enum ($name, @values)>
 426
 427 This will create a basic subtype for a given set of strings.
 428 The resulting constraint will be a subtype of C<Str> and
 429 will match any of the items in C<@values>. See the L<SYNOPSIS>
 430 for a simple example.
 431
 432 B<NOTE:> This is not a true proper enum type, it is simple
 433 a convient constraint builder.
 434
 435 =item B<as>
 436
 437 This is just sugar for the type constraint construction syntax.
 438
 439 =item B<where>
 440
 441 This is just sugar for the type constraint construction syntax.
 442
 443 =item B<message>
 444
 445 This is just sugar for the type constraint construction syntax.
 446
 447 =item B<optimize_as>
 448
 449 This can be used to define a "hand optimized" version of your
 450 type constraint which can be used to avoid traversing a subtype
 451 constraint heirarchy.
 452
 453 B<NOTE:> You should only use this if you know what you are doing,
 454 all the built in types use this, so your subtypes (assuming they
 455 are shallow) will not likely need to use this.
 456
 457 =back
 458
 459 =head2 Type Coercion Constructors
 460
 461 Type constraints can also contain type coercions as well. If you
 462 ask your accessor too coerce, the Moose will run the type-coercion
 463 code first, followed by the type constraint check. This feature
 464 should be used carefully as it is very powerful and could easily
 465 take off a limb if you are not careful.
 466
 467 See the L<SYNOPOSIS> for an example of how to use these.
 468
 469 =over 4
 470
 471 =item B<coerce>
 472
 473 =item B<from>
 474
 475 This is just sugar for the type coercion construction syntax.
 476
 477 =item B<via>
 478
 479 This is just sugar for the type coercion construction syntax.
 480
 481 =back
 482
 483 =head2 Namespace Management
 484
 485 =over 4
 486
 487 =item B<unimport>
 488
 489 This will remove all the type constraint keywords from the
 490 calling class namespace.
 491
 492 =back
 493
 494 =head1 BUGS
 495
 496 All complex software has bugs lurking in it, and this module is no
 497 exception. If you find a bug please either email me, or add the bug
 498 to cpan-RT.
 499
 500 =head1 AUTHOR
 501
 502 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 503
 504 =head1 COPYRIGHT AND LICENSE
 505
 506 Copyright 2006, 2007 by Infinity Interactive, Inc.
 507
 508 L<http://www.iinteractive.com>
 509
 510 This library is free software; you can redistribute it and/or modify
 511 it under the same terms as Perl itself.
 512
 513 =cut