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
  10 our $VERSION = '0.08';
  11
  12 use Moose::Meta::TypeConstraint;
  13 use Moose::Meta::TypeCoercion;
  14
  15 use Sub::Exporter -setup => {
  16     exports => [qw/
  17         type subtype as where message
  18         coerce from via
  19         enum
  20         find_type_constraint
  21     /],
  22     groups  => {
  23         default => [':all']
  24     }
  25 };
  26
  27 {
  28     my %TYPES;
  29     sub find_type_constraint ($) {
  30         return $TYPES{$_[0]}->[1]
  31             if exists $TYPES{$_[0]};
  32         return;
  33     }
  34
  35     sub _dump_type_constraints {
  36         require Data::Dumper;
  37         Data::Dumper::Dumper(\%TYPES);
  38     }
  39
  40     sub _create_type_constraint ($$$;$) {
  41         my ($name, $parent, $check, $message) = @_;
  42         my $pkg_defined_in = scalar(caller(1));
  43         ($TYPES{$name}->[0] eq $pkg_defined_in)
  44             || confess "The type constraint '$name' has already been created "
  45                  if defined $name && exists $TYPES{$name};
  46         $parent = find_type_constraint($parent) if defined $parent;
  47         my $constraint = Moose::Meta::TypeConstraint->new(
  48             name       => $name || '__ANON__',
  49             parent     => $parent,
  50             constraint => $check,
  51             message    => $message,
  52         );
  53         $TYPES{$name} = [ $pkg_defined_in, $constraint ] if defined $name;
  54         return $constraint;
  55     }
  56
  57     sub _install_type_coercions ($$) {
  58         my ($type_name, $coercion_map) = @_;
  59         my $type = find_type_constraint($type_name);
  60         (!$type->has_coercion)
  61             || confess "The type coercion for '$type_name' has already been registered";
  62         my $type_coercion = Moose::Meta::TypeCoercion->new(
  63             type_coercion_map => $coercion_map,
  64             type_constraint   => $type
  65         );
  66         $type->coercion($type_coercion);
  67     }
  68
  69     sub create_type_constraint_union (@) {
  70         my (@type_constraint_names) = @_;
  71         return Moose::Meta::TypeConstraint->union(
  72             map {
  73                 find_type_constraint($_)
  74             } @type_constraint_names
  75         );
  76     }
  77
  78     sub export_type_contstraints_as_functions {
  79         my $pkg = caller();
  80             no strict 'refs';
  81         foreach my $constraint (keys %TYPES) {
  82                 *{"${pkg}::${constraint}"} = find_type_constraint($constraint)->_compiled_type_constraint;
  83         }
  84     }
  85 }
  86
  87 # type constructors
  88
  89 sub type ($$) {
  90         my ($name, $check) = @_;
  91         _create_type_constraint($name, undef, $check);
  92 }
  93
  94 sub subtype ($$;$$) {
  95         unshift @_ => undef if scalar @_ <= 2;
  96         goto &_create_type_constraint;
  97 }
  98
  99 sub coerce ($@) {
 100     my ($type_name, @coercion_map) = @_;
 101     _install_type_coercions($type_name, \@coercion_map);
 102 }
 103
 104 sub as      ($) { $_[0] }
 105 sub from    ($) { $_[0] }
 106 sub where   (&) { $_[0] }
 107 sub via     (&) { $_[0] }
 108 sub message (&) { $_[0] }
 109
 110 sub enum ($;@) {
 111     my ($type_name, @values) = @_;
 112     (scalar @values >= 2)
 113         || confess "You must have at least two values to enumerate through";
 114     my $regexp = join '|' => @values;
 115         _create_type_constraint(
 116             $type_name,
 117             'Str',
 118             sub { qr/^$regexp$/i }
 119         );
 120 }
 121
 122 # define some basic types
 123
 124 type 'Any'  => where { 1 }; # meta-type including all
 125 type 'Item' => where { 1 }; # base-type
 126
 127 subtype 'Undef'   => as 'Item' => where { !defined($_) };
 128 subtype 'Defined' => as 'Item' => where {  defined($_) };
 129
 130 subtype 'Bool'  => as 'Item' => where { !defined($_) || $_ eq "" || "$_" eq '1' || "$_" eq '0' };
 131
 132 subtype 'Value' => as 'Defined' => where { !ref($_) };
 133 subtype 'Ref'   => as 'Defined' => where {  ref($_) };
 134
 135 subtype 'Str' => as 'Value' => where { 1 };
 136
 137 subtype 'Num' => as 'Value' => where { Scalar::Util::looks_like_number($_) };
 138 subtype 'Int' => as 'Num'   => where { "$_" =~ /^-?[0-9]+$/ };
 139
 140 subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' };
 141 subtype 'ArrayRef'  => as 'Ref' => where { ref($_) eq 'ARRAY'  };
 142 subtype 'HashRef'   => as 'Ref' => where { ref($_) eq 'HASH'   };
 143 subtype 'CodeRef'   => as 'Ref' => where { ref($_) eq 'CODE'   };
 144 subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' };
 145 subtype 'GlobRef'   => as 'Ref' => where { ref($_) eq 'GLOB'   };
 146
 147 # NOTE:
 148 # scalar filehandles are GLOB refs,
 149 # but a GLOB ref is not always a filehandle
 150 subtype 'FileHandle' => as 'GlobRef' => where { Scalar::Util::openhandle($_) };
 151
 152 # NOTE:
 153 # blessed(qr/.../) returns true,.. how odd
 154 subtype 'Object' => as 'Ref' => where { blessed($_) && blessed($_) ne 'Regexp' };
 155
 156 subtype 'Role' => as 'Object' => where { $_->can('does') };
 157
 158 1;
 159
 160 __END__
 161
 162 =pod
 163
 164 =head1 NAME
 165
 166 Moose::Util::TypeConstraints - Type constraint system for Moose
 167
 168 =head1 SYNOPSIS
 169
 170   use Moose::Util::TypeConstraints;
 171
 172   type 'Num' => where { Scalar::Util::looks_like_number($_) };
 173
 174   subtype 'Natural'
 175       => as 'Num'
 176       => where { $_ > 0 };
 177
 178   subtype 'NaturalLessThanTen'
 179       => as 'Natural'
 180       => where { $_ < 10 }
 181       => message { "This number ($_) is not less than ten!" };
 182
 183   coerce 'Num'
 184       => from 'Str'
 185         => via { 0+$_ };
 186
 187   enum 'RGBColors' => qw(red green blue);
 188
 189 =head1 DESCRIPTION
 190
 191 This module provides Moose with the ability to create type contraints
 192 to be are used in both attribute definitions and for method argument
 193 validation.
 194
 195 =head2 Important Caveat
 196
 197 This is B<NOT> a type system for Perl 5. These are type constraints,
 198 and they are not used by Moose unless you tell it to. No type
 199 inference is performed, expression are not typed, etc. etc. etc.
 200
 201 This is simply a means of creating small constraint functions which
 202 can be used to simplify your own type-checking code.
 203
 204 =head2 Slightly Less Important Caveat
 205
 206 It is almost always a good idea to quote your type and subtype names.
 207 This is to prevent perl from trying to execute the call as an indirect
 208 object call. This issue only seems to come up when you have a subtype
 209 the same name as a valid class, but when the issue does arise it tends
 210 to be quite annoying to debug.
 211
 212 So for instance, this:
 213
 214   subtype DateTime => as Object => where { $_->isa('DateTime') };
 215
 216 will I<Just Work>, while this:
 217
 218   use DateTime;
 219   subtype DateTime => as Object => where { $_->isa('DateTime') };
 220
 221 will fail silently and cause many headaches. The simple way to solve
 222 this, as well as future proof your subtypes from classes which have
 223 yet to have been created yet, is to simply do this:
 224
 225   use DateTime;
 226   subtype 'DateTime' => as Object => where { $_->isa('DateTime') };
 227
 228 =head2 Default Type Constraints
 229
 230 This module also provides a simple hierarchy for Perl 5 types, this
 231 could probably use some work, but it works for me at the moment.
 232
 233   Any
 234   Item
 235       Bool
 236       Undef
 237       Defined
 238           Value
 239               Num
 240                 Int
 241               Str
 242           Ref
 243               ScalarRef
 244               ArrayRef
 245               HashRef
 246               CodeRef
 247               RegexpRef
 248               GlobRef
 249                 FileHandle
 250               Object
 251                   Role
 252
 253 Suggestions for improvement are welcome.
 254
 255 B<NOTE:> The C<Undef> type constraint does not work correctly
 256 in every occasion, please use it sparringly.
 257
 258 =head1 FUNCTIONS
 259
 260 =head2 Type Constraint Registry
 261
 262 =over 4
 263
 264 =item B<find_type_constraint ($type_name)>
 265
 266 This function can be used to locate a specific type constraint
 267 meta-object. What you do with it from there is up to you :)
 268
 269 =item B<create_type_constraint_union (@type_constraint_names)>
 270
 271 Given a list of C<@type_constraint_names>, this will return a
 272 B<Moose::Meta::TypeConstraint::Union> instance.
 273
 274 =item B<export_type_contstraints_as_functions>
 275
 276 This will export all the current type constraints as functions
 277 into the caller's namespace. Right now, this is mostly used for
 278 testing, but it might prove useful to others.
 279
 280 =back
 281
 282 =head2 Type Constraint Constructors
 283
 284 The following functions are used to create type constraints.
 285 They will then register the type constraints in a global store
 286 where Moose can get to them if it needs to.
 287
 288 See the L<SYNOPOSIS> for an example of how to use these.
 289
 290 =over 4
 291
 292 =item B<type ($name, $where_clause)>
 293
 294 This creates a base type, which has no parent.
 295
 296 =item B<subtype ($name, $parent, $where_clause, ?$message)>
 297
 298 This creates a named subtype.
 299
 300 =item B<subtype ($parent, $where_clause, ?$message)>
 301
 302 This creates an unnamed subtype and will return the type
 303 constraint meta-object, which will be an instance of
 304 L<Moose::Meta::TypeConstraint>.
 305
 306 =item B<enum ($name, @values)>
 307
 308 This will create a basic subtype for a given set of strings.
 309 The resulting constraint will be a subtype of C<Str> and
 310 will match any of the items in C<@values>. See the L<SYNOPSIS>
 311 for a simple example.
 312
 313 B<NOTE:> This is not a true proper enum type, it is simple
 314 a convient constraint builder.
 315
 316 =item B<as>
 317
 318 This is just sugar for the type constraint construction syntax.
 319
 320 =item B<where>
 321
 322 This is just sugar for the type constraint construction syntax.
 323
 324 =item B<message>
 325
 326 This is just sugar for the type constraint construction syntax.
 327
 328 =back
 329
 330 =head2 Type Coercion Constructors
 331
 332 Type constraints can also contain type coercions as well. In most
 333 cases Moose will run the type-coercion code first, followed by the
 334 type constraint check. This feature should be used carefully as it
 335 is very powerful and could easily take off a limb if you are not
 336 careful.
 337
 338 See the L<SYNOPOSIS> for an example of how to use these.
 339
 340 =over 4
 341
 342 =item B<coerce>
 343
 344 =item B<from>
 345
 346 This is just sugar for the type coercion construction syntax.
 347
 348 =item B<via>
 349
 350 This is just sugar for the type coercion construction syntax.
 351
 352 =back
 353
 354 =head1 BUGS
 355
 356 All complex software has bugs lurking in it, and this module is no
 357 exception. If you find a bug please either email me, or add the bug
 358 to cpan-RT.
 359
 360 =head1 AUTHOR
 361
 362 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 363
 364 =head1 COPYRIGHT AND LICENSE
 365
 366 Copyright 2006 by Infinity Interactive, Inc.
 367
 368 L<http://www.iinteractive.com>
 369
 370 This library is free software; you can redistribute it and/or modify
 371 it under the same terms as Perl itself.
 372
 373 =cut