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 =head1 FUNCTIONS
 321
 322 =head2 Type Constraint Registry
 323
 324 =over 4
 325
 326 =item B<find_type_constraint ($type_name)>
 327
 328 This function can be used to locate a specific type constraint
 329 meta-object. What you do with it from there is up to you :)
 330
 331 =item B<create_type_constraint_union (@type_constraint_names)>
 332
 333 Given a list of C<@type_constraint_names>, this will return a
 334 B<Moose::Meta::TypeConstraint::Union> instance.
 335
 336 =item B<export_type_contstraints_as_functions>
 337
 338 This will export all the current type constraints as functions
 339 into the caller's namespace. Right now, this is mostly used for
 340 testing, but it might prove useful to others.
 341
 342 =back
 343
 344 =head2 Type Constraint Constructors
 345
 346 The following functions are used to create type constraints.
 347 They will then register the type constraints in a global store
 348 where Moose can get to them if it needs to.
 349
 350 See the L<SYNOPOSIS> for an example of how to use these.
 351
 352 =over 4
 353
 354 =item B<type ($name, $where_clause)>
 355
 356 This creates a base type, which has no parent.
 357
 358 =item B<subtype ($name, $parent, $where_clause, ?$message)>
 359
 360 This creates a named subtype.
 361
 362 =item B<subtype ($parent, $where_clause, ?$message)>
 363
 364 This creates an unnamed subtype and will return the type
 365 constraint meta-object, which will be an instance of
 366 L<Moose::Meta::TypeConstraint>.
 367
 368 =item B<enum ($name, @values)>
 369
 370 This will create a basic subtype for a given set of strings.
 371 The resulting constraint will be a subtype of C<Str> and
 372 will match any of the items in C<@values>. See the L<SYNOPSIS>
 373 for a simple example.
 374
 375 B<NOTE:> This is not a true proper enum type, it is simple
 376 a convient constraint builder.
 377
 378 =item B<as>
 379
 380 This is just sugar for the type constraint construction syntax.
 381
 382 =item B<where>
 383
 384 This is just sugar for the type constraint construction syntax.
 385
 386 =item B<message>
 387
 388 This is just sugar for the type constraint construction syntax.
 389
 390 =item B<optimize_as>
 391
 392 =back
 393
 394 =head2 Type Coercion Constructors
 395
 396 Type constraints can also contain type coercions as well. In most
 397 cases Moose will run the type-coercion code first, followed by the
 398 type constraint check. This feature should be used carefully as it
 399 is very powerful and could easily take off a limb if you are not
 400 careful.
 401
 402 See the L<SYNOPOSIS> for an example of how to use these.
 403
 404 =over 4
 405
 406 =item B<coerce>
 407
 408 =item B<from>
 409
 410 This is just sugar for the type coercion construction syntax.
 411
 412 =item B<via>
 413
 414 This is just sugar for the type coercion construction syntax.
 415
 416 =back
 417
 418 =head2 Namespace Management
 419
 420 =over 4
 421
 422 =item B<unimport>
 423
 424 This will remove all the type constraint keywords from the
 425 calling class namespace.
 426
 427 =back
 428
 429 =head1 BUGS
 430
 431 All complex software has bugs lurking in it, and this module is no
 432 exception. If you find a bug please either email me, or add the bug
 433 to cpan-RT.
 434
 435 =head1 AUTHOR
 436
 437 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 438
 439 =head1 COPYRIGHT AND LICENSE
 440
 441 Copyright 2006 by Infinity Interactive, Inc.
 442
 443 L<http://www.iinteractive.com>
 444
 445 This library is free software; you can redistribute it and/or modify
 446 it under the same terms as Perl itself.
 447
 448 =cut