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.02';
  11
  12 use Moose::Meta::TypeConstraint;
  13 use Moose::Meta::TypeCoercion;
  14
  15 sub import {
  16         shift;
  17         my $pkg = shift || caller();
  18         no strict 'refs';
  19         foreach my $export (qw(type subtype as where coerce from via find_type_constraint)) {
  20                 *{"${pkg}::${export}"} = \&{"${export}"};
  21         }
  22 }
  23
  24 {
  25     my %TYPES;
  26     sub find_type_constraint { $TYPES{$_[0]} }
  27
  28     sub _create_type_constraint {
  29         my ($name, $parent, $check) = @_;
  30         (!exists $TYPES{$name})
  31             || confess "The type constraint '$name' has already been created"
  32                 if defined $name;
  33         $parent = $TYPES{$parent} if defined $parent;
  34         my $constraint = Moose::Meta::TypeConstraint->new(
  35             name       => $name || '__ANON__',
  36             parent     => $parent,
  37             constraint => $check,
  38         );
  39         $TYPES{$name} = $constraint if defined $name;
  40         return $constraint;
  41     }
  42
  43     sub _install_type_coercions {
  44         my ($type_name, $coercion_map) = @_;
  45         my $type = $TYPES{$type_name};
  46         (!$type->has_coercion)
  47             || confess "The type coercion for '$type_name' has already been registered";
  48         my $type_coercion = Moose::Meta::TypeCoercion->new(
  49             type_coercion_map => $coercion_map,
  50             type_constraint   => $type
  51         );
  52         $type->coercion($type_coercion);
  53     }
  54
  55     sub export_type_contstraints_as_functions {
  56         my $pkg = caller();
  57             no strict 'refs';
  58         foreach my $constraint (keys %TYPES) {
  59                 *{"${pkg}::${constraint}"} = $TYPES{$constraint}->_compiled_type_constraint;
  60         }
  61     }
  62 }
  63
  64 # type constructors
  65
  66 sub type ($$) {
  67         my ($name, $check) = @_;
  68         _create_type_constraint($name, undef, $check);
  69 }
  70
  71 sub subtype ($$;$) {
  72         unshift @_ => undef if scalar @_ == 2;
  73         _create_type_constraint(@_);
  74 }
  75
  76 sub coerce ($@) {
  77     my ($type_name, @coercion_map) = @_;
  78     _install_type_coercions($type_name, \@coercion_map);
  79 }
  80
  81 sub as    ($) { $_[0] }
  82 sub from  ($) { $_[0] }
  83 sub where (&) { $_[0] }
  84 sub via   (&) { $_[0] }
  85
  86 # define some basic types
  87
  88 type Any => where { 1 };
  89
  90 type Value => where { !ref($_) };
  91 type Ref   => where {  ref($_) };
  92
  93 subtype Int => as Value => where {  Scalar::Util::looks_like_number($_) };
  94 subtype Str => as Value => where { !Scalar::Util::looks_like_number($_) };
  95
  96 subtype ScalarRef => as Ref => where { ref($_) eq 'SCALAR' };
  97 subtype ArrayRef  => as Ref => where { ref($_) eq 'ARRAY'  };
  98 subtype HashRef   => as Ref => where { ref($_) eq 'HASH'   };
  99 subtype CodeRef   => as Ref => where { ref($_) eq 'CODE'   };
 100 subtype RegexpRef => as Ref => where { ref($_) eq 'Regexp' };
 101
 102 # NOTE:
 103 # blessed(qr/.../) returns true,.. how odd
 104 subtype Object => as Ref => where { blessed($_) && blessed($_) ne 'Regexp' };
 105
 106 1;
 107
 108 __END__
 109
 110 =pod
 111
 112 =head1 NAME
 113
 114 Moose::Util::TypeConstraints - Type constraint system for Moose
 115
 116 =head1 SYNOPSIS
 117
 118   use Moose::Util::TypeConstraints;
 119
 120   type Num => where { Scalar::Util::looks_like_number($_) };
 121
 122   subtype Natural
 123       => as Num
 124       => where { $_ > 0 };
 125
 126   subtype NaturalLessThanTen
 127       => as Natural
 128       => where { $_ < 10 };
 129
 130   coerce Num
 131       => from Str
 132         => via { 0+$_ };
 133
 134 =head1 DESCRIPTION
 135
 136 This module provides Moose with the ability to create type contraints
 137 to be are used in both attribute definitions and for method argument
 138 validation.
 139
 140 This is B<NOT> a type system for Perl 5.
 141
 142 This module also provides a simple hierarchy for Perl 5 types, this
 143 could probably use some work, but it works for me at the moment.
 144
 145   Any
 146       Value
 147           Int
 148           Str
 149       Ref
 150           ScalarRef
 151           ArrayRef
 152           HashRef
 153           CodeRef
 154           RegexpRef
 155           Object
 156
 157 Suggestions for improvement are welcome.
 158
 159 =head1 FUNCTIONS
 160
 161 =head2 Type Constraint Registry
 162
 163 =over 4
 164
 165 =item B<find_type_constraint ($type_name)>
 166
 167 =item B<_create_type_constraint ($type_name, $type_constraint)>
 168
 169 =item B<_install_type_coercions>
 170
 171 =item B<export_type_contstraints_as_functions>
 172
 173 =back
 174
 175 =head2 Type Constraint Constructors
 176
 177 =over 4
 178
 179 =item B<type>
 180
 181 =item B<subtype>
 182
 183 =item B<as>
 184
 185 =item B<where>
 186
 187 =item B<coerce>
 188
 189 =item B<from>
 190
 191 =item B<via>
 192
 193 =back
 194
 195 =head2 Built-in Type Constraints
 196
 197 =over 4
 198
 199 =item B<Any>
 200
 201 =item B<Value>
 202
 203 =item B<Int>
 204
 205 =item B<Str>
 206
 207 =item B<Ref>
 208
 209 =item B<ArrayRef>
 210
 211 =item B<CodeRef>
 212
 213 =item B<HashRef>
 214
 215 =item B<RegexpRef>
 216
 217 =item B<ScalarRef>
 218
 219 =item B<Object>
 220
 221 =back
 222
 223 =head1 BUGS
 224
 225 All complex software has bugs lurking in it, and this module is no
 226 exception. If you find a bug please either email me, or add the bug
 227 to cpan-RT.
 228
 229 =head1 AUTHOR
 230
 231 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 232
 233 =head1 COPYRIGHT AND LICENSE
 234
 235 Copyright 2006 by Infinity Interactive, Inc.
 236
 237 L<http://www.iinteractive.com>
 238
 239 This library is free software; you can redistribute it and/or modify
 240 it under the same terms as Perl itself.
 241
 242 =cut