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