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 subtype 'ClassName'
 250     => as 'Str'
 251     => where { eval { $_->isa('UNIVERSAL') } }
 252     => optimize_as { !ref($_[0]) && eval { $_[0]->isa('UNIVERSAL') } };
 253
 254 {
 255     my @BUILTINS = list_all_type_constraints();
 256     sub list_all_builtin_type_constraints { @BUILTINS }
 257 }
 258
 259 1;
 260
 261 __END__
 262
 263 =pod
 264
 265 =head1 NAME
 266
 267 Moose::Util::TypeConstraints - Type constraint system for Moose
 268
 269 =head1 SYNOPSIS
 270
 271   use Moose::Util::TypeConstraints;
 272
 273   type 'Num' => where { Scalar::Util::looks_like_number($_) };
 274
 275   subtype 'Natural'
 276       => as 'Num'
 277       => where { $_ > 0 };
 278
 279   subtype 'NaturalLessThanTen'
 280       => as 'Natural'
 281       => where { $_ < 10 }
 282       => message { "This number ($_) is not less than ten!" };
 283
 284   coerce 'Num'
 285       => from 'Str'
 286         => via { 0+$_ };
 287
 288   enum 'RGBColors' => qw(red green blue);
 289
 290 =head1 DESCRIPTION
 291
 292 This module provides Moose with the ability to create custom type
 293 contraints to be used in attribute definition.
 294
 295 =head2 Important Caveat
 296
 297 This is B<NOT> a type system for Perl 5. These are type constraints,
 298 and they are not used by Moose unless you tell it to. No type
 299 inference is performed, expression are not typed, etc. etc. etc.
 300
 301 This is simply a means of creating small constraint functions which
 302 can be used to simplify your own type-checking code.
 303
 304 =head2 Slightly Less Important Caveat
 305
 306 It is almost always a good idea to quote your type and subtype names.
 307 This is to prevent perl from trying to execute the call as an indirect
 308 object call. This issue only seems to come up when you have a subtype
 309 the same name as a valid class, but when the issue does arise it tends
 310 to be quite annoying to debug.
 311
 312 So for instance, this:
 313
 314   subtype DateTime => as Object => where { $_->isa('DateTime') };
 315
 316 will I<Just Work>, while this:
 317
 318   use DateTime;
 319   subtype DateTime => as Object => where { $_->isa('DateTime') };
 320
 321 will fail silently and cause many headaches. The simple way to solve
 322 this, as well as future proof your subtypes from classes which have
 323 yet to have been created yet, is to simply do this:
 324
 325   use DateTime;
 326   subtype 'DateTime' => as 'Object' => where { $_->isa('DateTime') };
 327
 328 =head2 Default Type Constraints
 329
 330 This module also provides a simple hierarchy for Perl 5 types, this
 331 could probably use some work, but it works for me at the moment.
 332
 333   Any
 334   Item
 335       Bool
 336       Undef
 337       Defined
 338           Value
 339               Num
 340                 Int
 341               Str
 342                 ClassName
 343           Ref
 344               ScalarRef
 345               ArrayRef
 346               HashRef
 347               CodeRef
 348               RegexpRef
 349               GlobRef
 350                 FileHandle
 351               Object
 352                   Role
 353
 354 Suggestions for improvement are welcome.
 355
 356 B<NOTE:> The C<Undef> type constraint does not work correctly
 357 in every occasion, please use it sparringly.
 358
 359 B<NOTE:> The C<ClassName> type constraint is simply a subtype
 360 of string which responds true to C<isa('UNIVERSAL')>. This means
 361 that your class B<must> be loaded for this type constraint to
 362 pass. I know this is not ideal for all, but it is a saner
 363 restriction then most others.
 364
 365 =head2 Use with Other Constraint Modules
 366
 367 This module should play fairly nicely with other constraint
 368 modules with only some slight tweaking. The C<where> clause
 369 in types is expected to be a C<CODE> reference which checks
 370 it's first argument and returns a bool. Since most constraint
 371 modules work in a similar way, it should be simple to adapt
 372 them to work with Moose.
 373
 374 For instance, this is how you could use it with
 375 L<Declare::Constraints::Simple> to declare a completely new type.
 376
 377   type 'HashOfArrayOfObjects'
 378       => IsHashRef(
 379           -keys   => HasLength,
 380           -values => IsArrayRef( IsObject ));
 381
 382 For more examples see the F<t/204_example_w_DCS.t> test file.
 383
 384 Here is an example of using L<Test::Deep> and it's non-test
 385 related C<eq_deeply> function.
 386
 387   type 'ArrayOfHashOfBarsAndRandomNumbers'
 388       => where {
 389           eq_deeply($_,
 390               array_each(subhashof({
 391                   bar           => isa('Bar'),
 392                   random_number => ignore()
 393               })))
 394         };
 395
 396 For a complete example see the F<t/205_example_w_TestDeep.t>
 397 test file.
 398
 399 =head1 FUNCTIONS
 400
 401 =head2 Type Constraint Registry
 402
 403 =over 4
 404
 405 =item B<find_type_constraint ($type_name)>
 406
 407 This function can be used to locate a specific type constraint
 408 meta-object. What you do with it from there is up to you :)
 409
 410 =item B<create_type_constraint_union (@type_constraint_names)>
 411
 412 Given a list of C<@type_constraint_names>, this will return a
 413 B<Moose::Meta::TypeConstraint::Union> instance.
 414
 415 =item B<export_type_constraints_as_functions>
 416
 417 This will export all the current type constraints as functions
 418 into the caller's namespace. Right now, this is mostly used for
 419 testing, but it might prove useful to others.
 420
 421 =item B<export_type_contstraints_as_functions>
 422
 423 Alias for the above function.
 424
 425 =item B<list_all_type_constraints>
 426
 427 This will return a list of type constraint names, you can then
 428 fetch them using C<find_type_constraint ($type_name)> if you
 429 want to.
 430
 431 =item B<list_all_builtin_type_constraints>
 432
 433 This will return a list of builtin type constraints, meaning,
 434 those which are defined in this module. See the section
 435 labeled L<Default Type Constraints> for a complete list.
 436
 437 =back
 438
 439 =head2 Type Constraint Constructors
 440
 441 The following functions are used to create type constraints.
 442 They will then register the type constraints in a global store
 443 where Moose can get to them if it needs to.
 444
 445 See the L<SYNOPSIS> for an example of how to use these.
 446
 447 =over 4
 448
 449 =item B<type ($name, $where_clause)>
 450
 451 This creates a base type, which has no parent.
 452
 453 =item B<subtype ($name, $parent, $where_clause, ?$message)>
 454
 455 This creates a named subtype.
 456
 457 =item B<subtype ($parent, $where_clause, ?$message)>
 458
 459 This creates an unnamed subtype and will return the type
 460 constraint meta-object, which will be an instance of
 461 L<Moose::Meta::TypeConstraint>.
 462
 463 =item B<enum ($name, @values)>
 464
 465 This will create a basic subtype for a given set of strings.
 466 The resulting constraint will be a subtype of C<Str> and
 467 will match any of the items in C<@values>. See the L<SYNOPSIS>
 468 for a simple example.
 469
 470 B<NOTE:> This is not a true proper enum type, it is simple
 471 a convient constraint builder.
 472
 473 =item B<as>
 474
 475 This is just sugar for the type constraint construction syntax.
 476
 477 =item B<where>
 478
 479 This is just sugar for the type constraint construction syntax.
 480
 481 =item B<message>
 482
 483 This is just sugar for the type constraint construction syntax.
 484
 485 =item B<optimize_as>
 486
 487 This can be used to define a "hand optimized" version of your
 488 type constraint which can be used to avoid traversing a subtype
 489 constraint heirarchy.
 490
 491 B<NOTE:> You should only use this if you know what you are doing,
 492 all the built in types use this, so your subtypes (assuming they
 493 are shallow) will not likely need to use this.
 494
 495 =back
 496
 497 =head2 Type Coercion Constructors
 498
 499 Type constraints can also contain type coercions as well. If you
 500 ask your accessor too coerce, the Moose will run the type-coercion
 501 code first, followed by the type constraint check. This feature
 502 should be used carefully as it is very powerful and could easily
 503 take off a limb if you are not careful.
 504
 505 See the L<SYNOPSIS> for an example of how to use these.
 506
 507 =over 4
 508
 509 =item B<coerce>
 510
 511 =item B<from>
 512
 513 This is just sugar for the type coercion construction syntax.
 514
 515 =item B<via>
 516
 517 This is just sugar for the type coercion construction syntax.
 518
 519 =back
 520
 521 =head2 Namespace Management
 522
 523 =over 4
 524
 525 =item B<unimport>
 526
 527 This will remove all the type constraint keywords from the
 528 calling class namespace.
 529
 530 =back
 531
 532 =head1 BUGS
 533
 534 All complex software has bugs lurking in it, and this module is no
 535 exception. If you find a bug please either email me, or add the bug
 536 to cpan-RT.
 537
 538 =head1 AUTHOR
 539
 540 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 541
 542 =head1 COPYRIGHT AND LICENSE
 543
 544 Copyright 2006, 2007 by Infinity Interactive, Inc.
 545
 546 L<http://www.iinteractive.com>
 547
 548 This library is free software; you can redistribute it and/or modify
 549 it under the same terms as Perl itself.
 550
 551 =cut