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