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 Sub::Name    'subname';
   9 use Scalar::Util 'blessed';
  10
  11 our $VERSION = '0.02';
  12
  13 sub import {
  14         shift;
  15         my $pkg = shift || caller();
  16         return if $pkg eq ':no_export';
  17         no strict 'refs';
  18         foreach my $export (qw(type subtype coerce as where to)) {
  19                 *{"${pkg}::${export}"} = \&{"${export}"};
  20         }
  21 }
  22
  23 {
  24     my %TYPES;
  25     sub find_type_constraint {
  26         my $type_name = shift;
  27         $TYPES{$type_name};
  28     }
  29
  30     sub register_type_constraint {
  31         my ($type_name, $type_constraint) = @_;
  32         $TYPES{$type_name} = $type_constraint;
  33     }
  34
  35     sub export_type_contstraints_as_functions {
  36         my $pkg = caller();
  37             no strict 'refs';
  38         foreach my $constraint (keys %TYPES) {
  39                 *{"${pkg}::${constraint}"} = $TYPES{$constraint};
  40         }
  41     }
  42 }
  43
  44 {
  45     my %COERCIONS;
  46     sub find_type_coercion {
  47         my $type_name = shift;
  48         $COERCIONS{$type_name};
  49     }
  50
  51     sub register_type_coercion {
  52         my ($type_name, $type_coercion) = @_;
  53         $COERCIONS{$type_name} = $type_coercion;
  54     }
  55 }
  56
  57
  58 sub type ($$) {
  59         my ($name, $check) = @_;
  60         my $full_name = caller() . "::${name}";
  61         register_type_constraint($name => subname $full_name => sub {
  62                 return find_type_constraint($name) unless defined $_[0];
  63                 local $_ = $_[0];
  64                 return undef unless $check->($_[0]);
  65                 $_[0];
  66         });
  67 }
  68
  69 sub subtype ($$;$) {
  70         my ($name, $parent, $check) = @_;
  71         if (defined $check) {
  72             my $full_name = caller() . "::${name}";
  73                 $parent = find_type_constraint($parent)
  74                     unless $parent && ref($parent) eq 'CODE';
  75                 register_type_constraint($name => subname $full_name => sub {
  76                         return find_type_constraint($name) unless defined $_[0];
  77                         local $_ = $_[0];
  78                         return undef unless defined $parent->($_[0]) && $check->($_[0]);
  79                         $_[0];
  80                 });
  81         }
  82         else {
  83                 ($parent, $check) = ($name, $parent);
  84                 $parent = find_type_constraint($parent)
  85                     unless $parent && ref($parent) eq 'CODE';
  86                 return subname '__anon_subtype__' => sub {
  87                         local $_ = $_[0];
  88                         return undef unless defined $parent->($_[0]) && $check->($_[0]);
  89                         $_[0];
  90                 };
  91         }
  92 }
  93
  94 sub coerce {
  95     my ($type_name, @coercion_map) = @_;
  96     my @coercions;
  97     while (@coercion_map) {
  98         my ($constraint_name, $action) = splice(@coercion_map, 0, 2);
  99         my $constraint = find_type_constraint($constraint_name);
 100         (defined $constraint)
 101             || confess "Could not find the type constraint ($constraint_name)";
 102         push @coercions => [  $constraint, $action ];
 103     }
 104     register_type_coercion($type_name, sub {
 105         my $thing = shift;
 106         foreach my $coercion (@coercions) {
 107             my ($constraint, $converter) = @$coercion;
 108             if (defined $constraint->($thing)) {
 109                 return $converter->($thing);
 110             }
 111         }
 112         return $thing;
 113     });
 114 }
 115
 116 sub as    ($) { $_[0] }
 117 sub where (&) { $_[0] }
 118 sub to    (&) { $_[0] }
 119
 120 # define some basic types
 121
 122 type Any => where { 1 };
 123
 124 type Value => where { !ref($_) };
 125 type Ref   => where {  ref($_) };
 126
 127 subtype Int => as Value => where {  Scalar::Util::looks_like_number($_) };
 128 subtype Str => as Value => where { !Scalar::Util::looks_like_number($_) };
 129
 130 subtype ScalarRef => as Ref => where { ref($_) eq 'SCALAR' };
 131 subtype ArrayRef  => as Ref => where { ref($_) eq 'ARRAY'  };
 132 subtype HashRef   => as Ref => where { ref($_) eq 'HASH'   };
 133 subtype CodeRef   => as Ref => where { ref($_) eq 'CODE'   };
 134 subtype RegexpRef => as Ref => where { ref($_) eq 'Regexp' };
 135
 136 # NOTE:
 137 # blessed(qr/.../) returns true,.. how odd
 138 subtype Object => as Ref => where { blessed($_) && blessed($_) ne 'Regexp' };
 139
 140 1;
 141
 142 __END__
 143
 144 =pod
 145
 146 =head1 NAME
 147
 148 Moose::Util::TypeConstraints - Type constraint system for Moose
 149
 150 =head1 SYNOPSIS
 151
 152   use Moose::Util::TypeConstraints;
 153
 154   type Num => where { Scalar::Util::looks_like_number($_) };
 155
 156   subtype Natural
 157       => as Num
 158       => where { $_ > 0 };
 159
 160   subtype NaturalLessThanTen
 161       => as Natural
 162       => where { $_ < 10 };
 163
 164 =head1 DESCRIPTION
 165
 166 This module provides Moose with the ability to create type contraints
 167 to be are used in both attribute definitions and for method argument
 168 validation.
 169
 170 This is B<NOT> a type system for Perl 5.
 171
 172 The type and subtype constraints are basically functions which will
 173 validate their first argument. If called with no arguments, they will
 174 return themselves (this is syntactic sugar for Moose attributes).
 175
 176 This module also provides a simple hierarchy for Perl 5 types, this
 177 could probably use some work, but it works for me at the moment.
 178
 179   Any
 180       Value
 181           Int
 182           Str
 183       Ref
 184           ScalarRef
 185           ArrayRef
 186           HashRef
 187           CodeRef
 188           RegexpRef
 189           Object
 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 =item B<register_type_constraint ($type_name, $type_constraint)>
 202
 203 =item B<find_type_coercion>
 204
 205 =item B<register_type_coercion>
 206
 207 =item B<export_type_contstraints_as_functions>
 208
 209 =back
 210
 211 =head2 Type Constraint Constructors
 212
 213 =over 4
 214
 215 =item B<type>
 216
 217 =item B<subtype>
 218
 219 =item B<as>
 220
 221 =item B<where>
 222
 223 =item B<coerce>
 224
 225 =item B<to>
 226
 227 =back
 228
 229 =head2 Built-in Type Constraints
 230
 231 =over 4
 232
 233 =item B<Any>
 234
 235 =item B<Value>
 236
 237 =item B<Int>
 238
 239 =item B<Str>
 240
 241 =item B<Ref>
 242
 243 =item B<ArrayRef>
 244
 245 =item B<CodeRef>
 246
 247 =item B<HashRef>
 248
 249 =item B<RegexpRef>
 250
 251 =item B<ScalarRef>
 252
 253 =item B<Object>
 254
 255 =back
 256
 257 =head1 BUGS
 258
 259 All complex software has bugs lurking in it, and this module is no
 260 exception. If you find a bug please either email me, or add the bug
 261 to cpan-RT.
 262
 263 =head1 AUTHOR
 264
 265 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 266
 267 =head1 COPYRIGHT AND LICENSE
 268
 269 Copyright 2006 by Infinity Interactive, Inc.
 270
 271 L<http://www.iinteractive.com>
 272
 273 This library is free software; you can redistribute it and/or modify
 274 it under the same terms as Perl itself.
 275
 276 =cut