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.05';
  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 =head1 DESCRIPTION
 183
 184 This module provides Moose with the ability to create type contraints
 185 to be are used in both attribute definitions and for method argument
 186 validation.
 187
 188 =head2 Important Caveat
 189
 190 This is B<NOT> a type system for Perl 5. These are type constraints,
 191 and they are not used by Moose unless you tell it to. No type
 192 inference is performed, expression are not typed, etc. etc. etc.
 193
 194 This is simply a means of creating small constraint functions which
 195 can be used to simplify your own type-checking code.
 196
 197 =head2 Default Type Constraints
 198
 199 This module also provides a simple hierarchy for Perl 5 types, this
 200 could probably use some work, but it works for me at the moment.
 201
 202   Any
 203   Item
 204       Bool
 205       Undef
 206       Defined
 207           Value
 208               Num
 209                 Int
 210               Str
 211           Ref
 212               ScalarRef
 213               ArrayRef
 214               HashRef
 215               CodeRef
 216               RegexpRef
 217               Object
 218                   Role
 219
 220 Suggestions for improvement are welcome.
 221
 222 =head1 FUNCTIONS
 223
 224 =head2 Type Constraint Registry
 225
 226 =over 4
 227
 228 =item B<find_type_constraint ($type_name)>
 229
 230 This function can be used to locate a specific type constraint
 231 meta-object. What you do with it from there is up to you :)
 232
 233 =item B<create_type_constraint_union (@type_constraint_names)>
 234
 235 Given a list of C<@type_constraint_names>, this will return a
 236 B<Moose::Meta::TypeConstraint::Union> instance.
 237
 238 =item B<export_type_contstraints_as_functions>
 239
 240 This will export all the current type constraints as functions
 241 into the caller's namespace. Right now, this is mostly used for
 242 testing, but it might prove useful to others.
 243
 244 =back
 245
 246 =head2 Type Constraint Constructors
 247
 248 The following functions are used to create type constraints.
 249 They will then register the type constraints in a global store
 250 where Moose can get to them if it needs to.
 251
 252 See the L<SYNOPOSIS> for an example of how to use these.
 253
 254 =over 4
 255
 256 =item B<type ($name, $where_clause)>
 257
 258 This creates a base type, which has no parent.
 259
 260 =item B<subtype ($name, $parent, $where_clause, ?$message)>
 261
 262 This creates a named subtype.
 263
 264 =item B<subtype ($parent, $where_clause, ?$message)>
 265
 266 This creates an unnamed subtype and will return the type
 267 constraint meta-object, which will be an instance of
 268 L<Moose::Meta::TypeConstraint>.
 269
 270 =item B<enum ($name, @values)>
 271
 272 =item B<as>
 273
 274 This is just sugar for the type constraint construction syntax.
 275
 276 =item B<where>
 277
 278 This is just sugar for the type constraint construction syntax.
 279
 280 =item B<message>
 281
 282 This is just sugar for the type constraint construction syntax.
 283
 284 =back
 285
 286 =head2 Type Coercion Constructors
 287
 288 Type constraints can also contain type coercions as well. In most
 289 cases Moose will run the type-coercion code first, followed by the
 290 type constraint check. This feature should be used carefully as it
 291 is very powerful and could easily take off a limb if you are not
 292 careful.
 293
 294 See the L<SYNOPOSIS> for an example of how to use these.
 295
 296 =over 4
 297
 298 =item B<coerce>
 299
 300 =item B<from>
 301
 302 This is just sugar for the type coercion construction syntax.
 303
 304 =item B<via>
 305
 306 This is just sugar for the type coercion construction syntax.
 307
 308 =back
 309
 310 =head1 BUGS
 311
 312 All complex software has bugs lurking in it, and this module is no
 313 exception. If you find a bug please either email me, or add the bug
 314 to cpan-RT.
 315
 316 =head1 AUTHOR
 317
 318 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 319
 320 =head1 COPYRIGHT AND LICENSE
 321
 322 Copyright 2006 by Infinity Interactive, Inc.
 323
 324 L<http://www.iinteractive.com>
 325
 326 This library is free software; you can redistribute it and/or modify
 327 it under the same terms as Perl itself.
 328
 329 =cut