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