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