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