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