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