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