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