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