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