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