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];
  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 export_type_contstraints_as_functions {
  73         my $pkg = caller();
  74             no strict 'refs';
  75         foreach my $constraint (keys %TYPES) {
  76                 *{"${pkg}::${constraint}"} = find_type_constraint($constraint)->_compiled_type_constraint;
  77         }
  78     }
  79 }
  80
  81 # type constructors
  82
  83 sub type ($$) {
  84         my ($name, $check) = @_;
  85         _create_type_constraint($name, undef, $check);
  86 }
  87
  88 sub subtype ($$;$$) {
  89         unshift @_ => undef if scalar @_ <= 2;
  90         _create_type_constraint(@_);
  91 }
  92
  93 sub coerce ($@) {
  94     my ($type_name, @coercion_map) = @_;
  95     _install_type_coercions($type_name, \@coercion_map);
  96 }
  97
  98 sub as      ($) { $_[0] }
  99 sub from    ($) { $_[0] }
 100 sub where   (&) { $_[0] }
 101 sub via     (&) { $_[0] }
 102 sub message (&) { $_[0] }
 103
 104 # define some basic types
 105
 106 type 'Any' => where { 1 };
 107
 108 subtype 'Value' => as 'Any' => where { !ref($_) };
 109 subtype 'Ref'   => as 'Any' => where {  ref($_) };
 110
 111 subtype 'Bool' => as 'Any' => where { "$_" eq '1' || "$_" eq '0' };
 112
 113 subtype 'Int' => as 'Value' => where {  Scalar::Util::looks_like_number($_) };
 114 subtype 'Str' => as 'Value' => where { !Scalar::Util::looks_like_number($_) };
 115
 116 subtype 'ScalarRef' => as 'Ref' => where { ref($_) eq 'SCALAR' };
 117
 118 subtype 'CollectionRef' => as 'Ref' => where { ref($_) eq 'ARRAY' || ref($_) eq 'HASH' };
 119
 120 subtype 'ArrayRef' => as 'CollectionRef' => where { ref($_) eq 'ARRAY'  };
 121 subtype 'HashRef'  => as 'CollectionRef' => where { ref($_) eq 'HASH'   };
 122
 123 subtype 'CodeRef'   => as 'Ref' => where { ref($_) eq 'CODE'   };
 124 subtype 'RegexpRef' => as 'Ref' => where { ref($_) eq 'Regexp' };
 125
 126 # NOTE:
 127 # blessed(qr/.../) returns true,.. how odd
 128 subtype 'Object' => as 'Ref' => where { blessed($_) && blessed($_) ne 'Regexp' };
 129
 130 subtype 'Role' => as 'Object' => where { $_->can('does') };
 131
 132 1;
 133
 134 __END__
 135
 136 =pod
 137
 138 =head1 NAME
 139
 140 Moose::Util::TypeConstraints - Type constraint system for Moose
 141
 142 =head1 SYNOPSIS
 143
 144   use Moose::Util::TypeConstraints;
 145
 146   type Num => where { Scalar::Util::looks_like_number($_) };
 147
 148   subtype Natural
 149       => as Num
 150       => where { $_ > 0 };
 151
 152   subtype NaturalLessThanTen
 153       => as Natural
 154       => where { $_ < 10 }
 155       => message { "This number ($_) is not less than ten!" };
 156
 157   coerce Num
 158       => from Str
 159         => via { 0+$_ };
 160
 161 =head1 DESCRIPTION
 162
 163 This module provides Moose with the ability to create type contraints
 164 to be are used in both attribute definitions and for method argument
 165 validation.
 166
 167 =head2 Important Caveat
 168
 169 This is B<NOT> a type system for Perl 5. These are type constraints,
 170 and they are not used by Moose unless you tell it to. No type
 171 inference is performed, expression are not typed, etc. etc. etc.
 172
 173 This is simply a means of creating small constraint functions which
 174 can be used to simplify your own type-checking code.
 175
 176 =head2 Default Type Constraints
 177
 178 This module also provides a simple hierarchy for Perl 5 types, this
 179 could probably use some work, but it works for me at the moment.
 180
 181   Any
 182       Bool
 183       Value
 184           Int
 185           Str
 186       Ref
 187           ScalarRef
 188           CollectionRef
 189               ArrayRef
 190               HashRef
 191           CodeRef
 192           RegexpRef
 193           Object
 194               Role
 195
 196 Suggestions for improvement are welcome.
 197
 198 =head1 FUNCTIONS
 199
 200 =head2 Type Constraint Registry
 201
 202 =over 4
 203
 204 =item B<find_type_constraint ($type_name)>
 205
 206 This function can be used to locate a specific type constraint
 207 meta-object. What you do with it from there is up to you :)
 208
 209 =item B<export_type_contstraints_as_functions>
 210
 211 This will export all the current type constraints as functions
 212 into the caller's namespace. Right now, this is mostly used for
 213 testing, but it might prove useful to others.
 214
 215 =back
 216
 217 =head2 Type Constraint Constructors
 218
 219 The following functions are used to create type constraints.
 220 They will then register the type constraints in a global store
 221 where Moose can get to them if it needs to.
 222
 223 See the L<SYNOPOSIS> for an example of how to use these.
 224
 225 =over 4
 226
 227 =item B<type ($name, $where_clause)>
 228
 229 This creates a base type, which has no parent.
 230
 231 =item B<subtype ($name, $parent, $where_clause, ?$message)>
 232
 233 This creates a named subtype.
 234
 235 =item B<subtype ($parent, $where_clause, ?$message)>
 236
 237 This creates an unnamed subtype and will return the type
 238 constraint meta-object, which will be an instance of
 239 L<Moose::Meta::TypeConstraint>.
 240
 241 =item B<as>
 242
 243 This is just sugar for the type constraint construction syntax.
 244
 245 =item B<where>
 246
 247 This is just sugar for the type constraint construction syntax.
 248
 249 =item B<message>
 250
 251 This is just sugar for the type constraint construction syntax.
 252
 253 =back
 254
 255 =head2 Type Coercion Constructors
 256
 257 Type constraints can also contain type coercions as well. In most
 258 cases Moose will run the type-coercion code first, followed by the
 259 type constraint check. This feature should be used carefully as it
 260 is very powerful and could easily take off a limb if you are not
 261 careful.
 262
 263 See the L<SYNOPOSIS> for an example of how to use these.
 264
 265 =over 4
 266
 267 =item B<coerce>
 268
 269 =item B<from>
 270
 271 This is just sugar for the type coercion construction syntax.
 272
 273 =item B<via>
 274
 275 This is just sugar for the type coercion construction syntax.
 276
 277 =back
 278
 279 =head1 BUGS
 280
 281 All complex software has bugs lurking in it, and this module is no
 282 exception. If you find a bug please either email me, or add the bug
 283 to cpan-RT.
 284
 285 =head1 AUTHOR
 286
 287 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 288
 289 =head1 COPYRIGHT AND LICENSE
 290
 291 Copyright 2006 by Infinity Interactive, Inc.
 292
 293 L<http://www.iinteractive.com>
 294
 295 This library is free software; you can redistribute it and/or modify
 296 it under the same terms as Perl itself.
 297
 298 =cut