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.10';
  13
  14 use Moose::Meta::TypeConstraint;
  15 use Moose::Meta::TypeCoercion;
  16
  17 my @exports = qw/
  18     type subtype as where message optimize_as
  19     coerce from via
  20     enum
  21     find_type_constraint
  22 /;
  23
  24 Sub::Exporter::setup_exporter({
  25     exports => \@exports,
  26     groups  => { default => [':all'] }
  27 });
  28
  29 sub unimport {
  30     no strict 'refs';
  31     my $class = caller();
  32     # loop through the exports ...
  33     foreach my $name (@exports) {
  34         # if we find one ...
  35         if (defined &{$class . '::' . $name}) {
  36             my $keyword = \&{$class . '::' . $name};
  37
  38             # make sure it is from Moose
  39             my $pkg_name = eval { svref_2object($keyword)->GV->STASH->NAME };
  40             next if $@;
  41             next if $pkg_name ne 'Moose::Util::TypeConstraints';
  42
  43             # and if it is from Moose then undef the slot
  44             delete ${$class . '::'}{$name};
  45         }
  46     }
  47 }
  48
  49 {
  50     my %TYPES;
  51     sub find_type_constraint ($) {
  52         return $TYPES{$_[0]}->[1]
  53             if exists $TYPES{$_[0]};
  54         return;
  55     }
  56
  57     sub _dump_type_constraints {
  58         require Data::Dumper;
  59         Data::Dumper::Dumper(\%TYPES);
  60     }
  61
  62     sub _create_type_constraint ($$$;$$) {
  63         my $name   = shift;
  64         my $parent = shift;
  65         my $check  = shift;;
  66
  67         my ($message, $optimized);
  68         for (@_) {
  69             $message   = $_->{message} if exists $_->{message};
  70             $optimized = $_->{optimized} if exists $_->{optimized};
  71         }
  72
  73         my $pkg_defined_in = scalar(caller(1));
  74         ($TYPES{$name}->[0] eq $pkg_defined_in)
  75             || confess "The type constraint '$name' has already been created "
  76                  if defined $name && exists $TYPES{$name};
  77         $parent = find_type_constraint($parent) if defined $parent;
  78         my $constraint = Moose::Meta::TypeConstraint->new(
  79             name       => $name || '__ANON__',
  80             parent     => $parent,
  81             constraint => $check,
  82             message    => $message,
  83             optimized  => $optimized,
  84         );
  85         $TYPES{$name} = [ $pkg_defined_in, $constraint ] if defined $name;
  86         return $constraint;
  87     }
  88
  89     sub _install_type_coercions ($$) {
  90         my ($type_name, $coercion_map) = @_;
  91         my $type = find_type_constraint($type_name);
  92         (!$type->has_coercion)
  93             || confess "The type coercion for '$type_name' has already been registered";
  94         my $type_coercion = Moose::Meta::TypeCoercion->new(
  95             type_coercion_map => $coercion_map,
  96             type_constraint   => $type
  97         );
  98         $type->coercion($type_coercion);
  99     }
 100
 101     sub create_type_constraint_union (@) {
 102         my (@type_constraint_names) = @_;
 103         return Moose::Meta::TypeConstraint->union(
 104             map {
 105                 find_type_constraint($_)
 106             } @type_constraint_names
 107         );
 108     }
 109
 110     sub export_type_contstraints_as_functions {
 111         my $pkg = caller();
 112             no strict 'refs';
 113         foreach my $constraint (keys %TYPES) {
 114                 *{"${pkg}::${constraint}"} = find_type_constraint($constraint)->_compiled_type_constraint;
 115         }
 116     }
 117 }
 118
 119 # type constructors
 120
 121 sub type ($$) {
 122         my ($name, $check) = @_;
 123         _create_type_constraint($name, undef, $check);
 124 }
 125
 126 sub subtype ($$;$$$) {
 127         unshift @_ => undef if scalar @_ <= 2;
 128         goto &_create_type_constraint;
 129 }
 130
 131 sub coerce ($@) {
 132     my ($type_name, @coercion_map) = @_;
 133     _install_type_coercions($type_name, \@coercion_map);
 134 }
 135
 136 sub as      ($) { $_[0] }
 137 sub from    ($) { $_[0] }
 138 sub where   (&) { $_[0] }
 139 sub via     (&) { $_[0] }
 140
 141 sub message     (&) { +{ message   => $_[0] } }
 142 sub optimize_as (&) { +{ optimized => $_[0] } }
 143
 144 sub enum ($;@) {
 145     my ($type_name, @values) = @_;
 146     (scalar @values >= 2)
 147         || confess "You must have at least two values to enumerate through";
 148     my $regexp = join '|' => @values;
 149         _create_type_constraint(
 150             $type_name,
 151             'Str',
 152             sub { qr/^$regexp$/i }
 153         );
 154 }
 155
 156 # define some basic types
 157
 158 type 'Any'  => where { 1 }; # meta-type including all
 159 type 'Item' => where { 1 }; # base-type
 160
 161 subtype 'Undef'   => as 'Item' => where { !defined($_) };
 162 subtype 'Defined' => as 'Item' => where {  defined($_) };
 163
 164 subtype 'Bool'
 165     => as 'Item'
 166     => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
 167
 168 subtype 'Value'
 169     => as 'Defined'
 170     => where { !ref($_) }
 171     => optimize_as { defined($_[0]) && !ref($_[0]) };
 172
 173 subtype 'Ref'
 174     => as 'Defined'
 175     => where {  ref($_) }
 176     => optimize_as { ref($_[0]) };
 177
 178 subtype 'Str'
 179     => as 'Value'
 180     => where { 1 }
 181     => optimize_as { defined($_[0]) && !ref($_[0]) };
 182
 183 subtype 'Num'
 184     => as 'Value'
 185     => where { Scalar::Util::looks_like_number($_) }
 186     => optimize_as { !ref($_[0]) && Scalar::Util::looks_like_number($_[0]) };
 187
 188 subtype 'Int'
 189     => as 'Num'
 190     => where { "$_" =~ /^-?[0-9]+$/ }
 191     => optimize_as { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ };
 192
 193 subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } => optimize_as { ref($_[0]) eq 'SCALAR' };
 194 subtype 'ArrayRef'  => as 'Ref' => where { ref($_) eq 'ARRAY'  } => optimize_as { ref($_[0]) eq 'ARRAY'  };
 195 subtype 'HashRef'   => as 'Ref' => where { ref($_) eq 'HASH'   } => optimize_as { ref($_[0]) eq 'HASH'   };
 196 subtype 'CodeRef'   => as 'Ref' => where { ref($_) eq 'CODE'   } => optimize_as { ref($_[0]) eq 'CODE'   };
 197 subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } => optimize_as { ref($_[0]) eq 'Regexp' };
 198 subtype 'GlobRef'   => as 'Ref' => where { ref($_) eq 'GLOB'   } => optimize_as { ref($_[0]) eq 'GLOB'   };
 199
 200 # NOTE:
 201 # scalar filehandles are GLOB refs,
 202 # but a GLOB ref is not always a filehandle
 203 subtype 'FileHandle'
 204     => as 'GlobRef'
 205     => where { Scalar::Util::openhandle($_) }
 206     => optimize_as { ref($_[0]) eq 'GLOB' && Scalar::Util::openhandle($_[0]) };
 207
 208 # NOTE:
 209 # blessed(qr/.../) returns true,.. how odd
 210 subtype 'Object'
 211     => as 'Ref'
 212     => where { blessed($_) && blessed($_) ne 'Regexp' }
 213     => optimize_as { blessed($_[0]) && blessed($_[0]) ne 'Regexp' };
 214
 215 subtype 'Role'
 216     => as 'Object'
 217     => where { $_->can('does') }
 218     => optimize_as { blessed($_[0]) && $_[0]->can('does') };
 219
 220 1;
 221
 222 __END__
 223
 224 =pod
 225
 226 =head1 NAME
 227
 228 Moose::Util::TypeConstraints - Type constraint system for Moose
 229
 230 =head1 SYNOPSIS
 231
 232   use Moose::Util::TypeConstraints;
 233
 234   type 'Num' => where { Scalar::Util::looks_like_number($_) };
 235
 236   subtype 'Natural'
 237       => as 'Num'
 238       => where { $_ > 0 };
 239
 240   subtype 'NaturalLessThanTen'
 241       => as 'Natural'
 242       => where { $_ < 10 }
 243       => message { "This number ($_) is not less than ten!" };
 244
 245   coerce 'Num'
 246       => from 'Str'
 247         => via { 0+$_ };
 248
 249   enum 'RGBColors' => qw(red green blue);
 250
 251 =head1 DESCRIPTION
 252
 253 This module provides Moose with the ability to create type contraints
 254 to be are used in both attribute definitions and for method argument
 255 validation.
 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 =back
 427
 428 =head2 Type Coercion Constructors
 429
 430 Type constraints can also contain type coercions as well. If you
 431 ask your accessor too coerce, the Moose will run the type-coercion
 432 code first, followed by the type constraint check. This feature
 433 should be used carefully as it is very powerful and could easily
 434 take off a limb if you are not careful.
 435
 436 See the L<SYNOPOSIS> for an example of how to use these.
 437
 438 =over 4
 439
 440 =item B<coerce>
 441
 442 =item B<from>
 443
 444 This is just sugar for the type coercion construction syntax.
 445
 446 =item B<via>
 447
 448 This is just sugar for the type coercion construction syntax.
 449
 450 =back
 451
 452 =head2 Namespace Management
 453
 454 =over 4
 455
 456 =item B<unimport>
 457
 458 This will remove all the type constraint keywords from the
 459 calling class namespace.
 460
 461 =back
 462
 463 =head1 BUGS
 464
 465 All complex software has bugs lurking in it, and this module is no
 466 exception. If you find a bug please either email me, or add the bug
 467 to cpan-RT.
 468
 469 =head1 AUTHOR
 470
 471 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 472
 473 =head1 COPYRIGHT AND LICENSE
 474
 475 Copyright 2006, 2007 by Infinity Interactive, Inc.
 476
 477 L<http://www.iinteractive.com>
 478
 479 This library is free software; you can redistribute it and/or modify
 480 it under the same terms as Perl itself.
 481
 482 =cut