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