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