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 to coerce)) {
  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                 return find_type_constraint($name) unless defined $_[0];
  69                 local $_ = $_[0];
  70                 return undef unless $check->($_[0]);
  71                 $_[0];
  72         });
  73 }
  74
  75 sub subtype ($$;$) {
  76         my ($name, $parent, $check) = @_;
  77         if (defined $check) {
  78             my $full_name = caller() . "::${name}";
  79                 $parent = find_type_constraint($parent)
  80                     unless $parent && ref($parent) eq 'CODE';
  81                 register_type_constraint($name => subname $full_name => sub {
  82                         return find_type_constraint($name) unless defined $_[0];
  83                         local $_ = $_[0];
  84                         return undef unless defined $parent->($_[0]) && $check->($_[0]);
  85                         $_[0];
  86                 });
  87         }
  88         else {
  89                 ($parent, $check) = ($name, $parent);
  90                 $parent = find_type_constraint($parent)
  91                     unless $parent && ref($parent) eq 'CODE';
  92                 return subname '__anon_subtype__' => sub {
  93                         local $_ = $_[0];
  94                         return undef unless defined $parent->($_[0]) && $check->($_[0]);
  95                         $_[0];
  96                 };
  97         }
  98 }
  99
 100 sub coerce ($@) {
 101     my ($type_name, @coercion_map) = @_;
 102     #use Data::Dumper;
 103     #warn Dumper \@coercion_map;
 104     my @coercions;
 105     while (@coercion_map) {
 106         my ($constraint_name, $action) = splice(@coercion_map, 0, 2);
 107         my $constraint = find_type_constraint($constraint_name);
 108         (defined $constraint)
 109             || confess "Could not find the type constraint ($constraint_name)";
 110         push @coercions => [  $constraint, $action ];
 111     }
 112     register_type_coercion($type_name, sub {
 113         my $thing = shift;
 114         foreach my $coercion (@coercions) {
 115             my ($constraint, $converter) = @$coercion;
 116             if (defined $constraint->($thing)) {
 117                 return $converter->($thing);
 118             }
 119         }
 120         return $thing;
 121     });
 122 }
 123
 124 sub as    ($) { $_[0] }
 125 sub where (&) { $_[0] }
 126 sub to    (&) { $_[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 =head1 DESCRIPTION
 173
 174 This module provides Moose with the ability to create type contraints
 175 to be are used in both attribute definitions and for method argument
 176 validation.
 177
 178 This is B<NOT> a type system for Perl 5.
 179
 180 The type and subtype constraints are basically functions which will
 181 validate their first argument. If called with no arguments, they will
 182 return themselves (this is syntactic sugar for Moose attributes).
 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<to>
 236
 237 =back
 238
 239 =head2 Built-in Type Constraints
 240
 241 =over 4
 242
 243 =item B<Any>
 244
 245 =item B<Value>
 246
 247 =item B<Int>
 248
 249 =item B<Str>
 250
 251 =item B<Ref>
 252
 253 =item B<ArrayRef>
 254
 255 =item B<CodeRef>
 256
 257 =item B<HashRef>
 258
 259 =item B<RegexpRef>
 260
 261 =item B<ScalarRef>
 262
 263 =item B<Object>
 264
 265 =back
 266
 267 =head1 BUGS
 268
 269 All complex software has bugs lurking in it, and this module is no
 270 exception. If you find a bug please either email me, or add the bug
 271 to cpan-RT.
 272
 273 =head1 AUTHOR
 274
 275 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 276
 277 =head1 COPYRIGHT AND LICENSE
 278
 279 Copyright 2006 by Infinity Interactive, Inc.
 280
 281 L<http://www.iinteractive.com>
 282
 283 This library is free software; you can redistribute it and/or modify
 284 it under the same terms as Perl itself.
 285
 286 =cut