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