lib/Moose/Util/TypeConstraints.pm

   1
   2 use lib '/Users/stevan/Projects/Moose/Moose/Class-MOP/branches/Class-MOP-tranformations/lib';
   3
   4 package Moose::Util::TypeConstraints;
   5
   6 use strict;
   7 use warnings;
   8
   9 use Carp         'confess';
  10 use Scalar::Util 'blessed';
  11 use B            'svref_2object';
  12 use Sub::Exporter;
  13
  14 our $VERSION = '0.09';
  15
  16 use Moose::Meta::TypeConstraint;
  17 use Moose::Meta::TypeCoercion;
  18
  19 my @exports = qw/
  20     type subtype as where message optimize_as
  21     coerce from via
  22     enum
  23     find_type_constraint
  24 /;
  25
  26 Sub::Exporter::setup_exporter({
  27     exports => \@exports,
  28     groups  => { default => [':all'] }
  29 });
  30
  31 sub unimport {
  32     no strict 'refs';
  33     my $class = caller();
  34     # loop through the exports ...
  35     foreach my $name (@exports) {
  36         # if we find one ...
  37         if (defined &{$class . '::' . $name}) {
  38             my $keyword = \&{$class . '::' . $name};
  39
  40             # make sure it is from Moose
  41             my $pkg_name = eval { svref_2object($keyword)->GV->STASH->NAME };
  42             next if $@;
  43             next if $pkg_name ne 'Moose::Util::TypeConstraints';
  44
  45             # and if it is from Moose then undef the slot
  46             delete ${$class . '::'}{$name};
  47         }
  48     }
  49 }
  50
  51 {
  52     my %TYPES;
  53     sub find_type_constraint ($) {
  54         return $TYPES{$_[0]}->[1]
  55             if exists $TYPES{$_[0]};
  56         return;
  57     }
  58
  59     sub _dump_type_constraints {
  60         require Data::Dumper;
  61         Data::Dumper::Dumper(\%TYPES);
  62     }
  63
  64     sub _create_type_constraint ($$$;$$) {
  65         my $name   = shift;
  66         my $parent = shift;
  67         my $check  = shift;;
  68
  69         my ($message, $optimized);
  70         for (@_) {
  71             $message   = $_->{message} if exists $_->{message};
  72             $optimized = $_->{optimized} if exists $_->{optimized};
  73         }
  74
  75         my $pkg_defined_in = scalar(caller(1));
  76         ($TYPES{$name}->[0] eq $pkg_defined_in)
  77             || confess "The type constraint '$name' has already been created "
  78                  if defined $name && exists $TYPES{$name};
  79         $parent = find_type_constraint($parent) if defined $parent;
  80         my $constraint = Moose::Meta::TypeConstraint->new(
  81             name       => $name || '__ANON__',
  82             parent     => $parent,
  83             constraint => $check,
  84             message    => $message,
  85             optimized  => $optimized,
  86         );
  87         $TYPES{$name} = [ $pkg_defined_in, $constraint ] if defined $name;
  88         return $constraint;
  89     }
  90
  91     sub _install_type_coercions ($$) {
  92         my ($type_name, $coercion_map) = @_;
  93         my $type = find_type_constraint($type_name);
  94         (!$type->has_coercion)
  95             || confess "The type coercion for '$type_name' has already been registered";
  96         my $type_coercion = Moose::Meta::TypeCoercion->new(
  97             type_coercion_map => $coercion_map,
  98             type_constraint   => $type
  99         );
 100         $type->coercion($type_coercion);
 101     }
 102
 103     sub create_type_constraint_union (@) {
 104         my (@type_constraint_names) = @_;
 105         return Moose::Meta::TypeConstraint->union(
 106             map {
 107                 find_type_constraint($_)
 108             } @type_constraint_names
 109         );
 110     }
 111
 112     sub export_type_contstraints_as_functions {
 113         my $pkg = caller();
 114             no strict 'refs';
 115         foreach my $constraint (keys %TYPES) {
 116                 *{"${pkg}::${constraint}"} = find_type_constraint($constraint)->_compiled_type_constraint;
 117         }
 118     }
 119 }
 120
 121 # type constructors
 122
 123 sub type ($$) {
 124         my ($name, $check) = @_;
 125         _create_type_constraint($name, undef, $check);
 126 }
 127
 128 sub subtype ($$;$$$) {
 129         unshift @_ => undef if scalar @_ <= 2;
 130         goto &_create_type_constraint;
 131 }
 132
 133 sub coerce ($@) {
 134     my ($type_name, @coercion_map) = @_;
 135     _install_type_coercions($type_name, \@coercion_map);
 136 }
 137
 138 sub as      ($) { $_[0] }
 139 sub from    ($) { $_[0] }
 140 sub where   (&) { $_[0] }
 141 sub via     (&) { $_[0] }
 142
 143 sub message     (&) { +{ message   => $_[0] } }
 144 sub optimize_as (&) { +{ optimized => $_[0] } }
 145
 146 sub enum ($;@) {
 147     my ($type_name, @values) = @_;
 148     (scalar @values >= 2)
 149         || confess "You must have at least two values to enumerate through";
 150     my $regexp = join '|' => @values;
 151         _create_type_constraint(
 152             $type_name,
 153             'Str',
 154             sub { qr/^$regexp$/i }
 155         );
 156 }
 157
 158 # define some basic types
 159
 160 type 'Any'  => where { 1 }; # meta-type including all
 161 type 'Item' => where { 1 }; # base-type
 162
 163 subtype 'Undef'   => as 'Item' => where { !defined($_) };
 164 subtype 'Defined' => as 'Item' => where {  defined($_) };
 165
 166 subtype 'Bool'
 167     => as 'Item'
 168     => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
 169
 170 subtype 'Value'
 171     => as 'Defined'
 172     => where { !ref($_) }
 173     => optimize_as { defined($_[0]) && !ref($_[0]) };
 174
 175 subtype 'Ref'
 176     => as 'Defined'
 177     => where {  ref($_) }
 178     => optimize_as { ref($_[0]) };
 179
 180 subtype 'Str'
 181     => as 'Value'
 182     => where { 1 }
 183     => optimize_as { defined($_[0]) && !ref($_[0]) };
 184
 185 subtype 'Num'
 186     => as 'Value'
 187     => where { Scalar::Util::looks_like_number($_) }
 188     => optimize_as { !ref($_[0]) && Scalar::Util::looks_like_number($_[0]) };
 189
 190 subtype 'Int'
 191     => as 'Num'
 192     => where { "$_" =~ /^-?[0-9]+$/ }
 193     => optimize_as { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ };
 194
 195 subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' } => optimize_as { ref($_[0]) eq 'SCALAR' };
 196 subtype 'ArrayRef'  => as 'Ref' => where { ref($_) eq 'ARRAY'  } => optimize_as { ref($_[0]) eq 'ARRAY'  };
 197 subtype 'HashRef'   => as 'Ref' => where { ref($_) eq 'HASH'   } => optimize_as { ref($_[0]) eq 'HASH'   };
 198 subtype 'CodeRef'   => as 'Ref' => where { ref($_) eq 'CODE'   } => optimize_as { ref($_[0]) eq 'CODE'   };
 199 subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' } => optimize_as { ref($_[0]) eq 'Regexp' };
 200 subtype 'GlobRef'   => as 'Ref' => where { ref($_) eq 'GLOB'   } => optimize_as { ref($_[0]) eq 'GLOB'   };
 201
 202 # NOTE:
 203 # scalar filehandles are GLOB refs,
 204 # but a GLOB ref is not always a filehandle
 205 subtype 'FileHandle'
 206     => as 'GlobRef'
 207     => where { Scalar::Util::openhandle($_) }
 208     => optimize_as { ref($_[0]) eq 'GLOB' && Scalar::Util::openhandle($_[0]) };
 209
 210 # NOTE:
 211 # blessed(qr/.../) returns true,.. how odd
 212 subtype 'Object'
 213     => as 'Ref'
 214     => where { blessed($_) && blessed($_) ne 'Regexp' }
 215     => optimize_as { blessed($_[0]) && blessed($_[0]) ne 'Regexp' };
 216
 217 subtype 'Role'
 218     => as 'Object'
 219     => where { $_->can('does') }
 220     => optimize_as { blessed($_[0]) && $_[0]->can('does') };
 221
 222 1;
 223
 224 __END__
 225
 226 =pod
 227
 228 =head1 NAME
 229
 230 Moose::Util::TypeConstraints - Type constraint system for Moose
 231
 232 =head1 SYNOPSIS
 233
 234   use Moose::Util::TypeConstraints;
 235
 236   type 'Num' => where { Scalar::Util::looks_like_number($_) };
 237
 238   subtype 'Natural'
 239       => as 'Num'
 240       => where { $_ > 0 };
 241
 242   subtype 'NaturalLessThanTen'
 243       => as 'Natural'
 244       => where { $_ < 10 }
 245       => message { "This number ($_) is not less than ten!" };
 246
 247   coerce 'Num'
 248       => from 'Str'
 249         => via { 0+$_ };
 250
 251   enum 'RGBColors' => qw(red green blue);
 252
 253 =head1 DESCRIPTION
 254
 255 This module provides Moose with the ability to create type contraints
 256 to be are used in both attribute definitions and for method argument
 257 validation.
 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 =head1 FUNCTIONS
 323
 324 =head2 Type Constraint Registry
 325
 326 =over 4
 327
 328 =item B<find_type_constraint ($type_name)>
 329
 330 This function can be used to locate a specific type constraint
 331 meta-object. What you do with it from there is up to you :)
 332
 333 =item B<create_type_constraint_union (@type_constraint_names)>
 334
 335 Given a list of C<@type_constraint_names>, this will return a
 336 B<Moose::Meta::TypeConstraint::Union> instance.
 337
 338 =item B<export_type_contstraints_as_functions>
 339
 340 This will export all the current type constraints as functions
 341 into the caller's namespace. Right now, this is mostly used for
 342 testing, but it might prove useful to others.
 343
 344 =back
 345
 346 =head2 Type Constraint Constructors
 347
 348 The following functions are used to create type constraints.
 349 They will then register the type constraints in a global store
 350 where Moose can get to them if it needs to.
 351
 352 See the L<SYNOPOSIS> for an example of how to use these.
 353
 354 =over 4
 355
 356 =item B<type ($name, $where_clause)>
 357
 358 This creates a base type, which has no parent.
 359
 360 =item B<subtype ($name, $parent, $where_clause, ?$message)>
 361
 362 This creates a named subtype.
 363
 364 =item B<subtype ($parent, $where_clause, ?$message)>
 365
 366 This creates an unnamed subtype and will return the type
 367 constraint meta-object, which will be an instance of
 368 L<Moose::Meta::TypeConstraint>.
 369
 370 =item B<enum ($name, @values)>
 371
 372 This will create a basic subtype for a given set of strings.
 373 The resulting constraint will be a subtype of C<Str> and
 374 will match any of the items in C<@values>. See the L<SYNOPSIS>
 375 for a simple example.
 376
 377 B<NOTE:> This is not a true proper enum type, it is simple
 378 a convient constraint builder.
 379
 380 =item B<as>
 381
 382 This is just sugar for the type constraint construction syntax.
 383
 384 =item B<where>
 385
 386 This is just sugar for the type constraint construction syntax.
 387
 388 =item B<message>
 389
 390 This is just sugar for the type constraint construction syntax.
 391
 392 =item B<optimize_as>
 393
 394 =back
 395
 396 =head2 Type Coercion Constructors
 397
 398 Type constraints can also contain type coercions as well. In most
 399 cases Moose will run the type-coercion code first, followed by the
 400 type constraint check. This feature should be used carefully as it
 401 is very powerful and could easily take off a limb if you are not
 402 careful.
 403
 404 See the L<SYNOPOSIS> for an example of how to use these.
 405
 406 =over 4
 407
 408 =item B<coerce>
 409
 410 =item B<from>
 411
 412 This is just sugar for the type coercion construction syntax.
 413
 414 =item B<via>
 415
 416 This is just sugar for the type coercion construction syntax.
 417
 418 =back
 419
 420 =head2 Namespace Management
 421
 422 =over 4
 423
 424 =item B<unimport>
 425
 426 This will remove all the type constraint keywords from the
 427 calling class namespace.
 428
 429 =back
 430
 431 =head1 BUGS
 432
 433 All complex software has bugs lurking in it, and this module is no
 434 exception. If you find a bug please either email me, or add the bug
 435 to cpan-RT.
 436
 437 =head1 AUTHOR
 438
 439 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 440
 441 =head1 COPYRIGHT AND LICENSE
 442
 443 Copyright 2006 by Infinity Interactive, Inc.
 444
 445 L<http://www.iinteractive.com>
 446
 447 This library is free software; you can redistribute it and/or modify
 448 it under the same terms as Perl itself.
 449
 450 =cut