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                 return $converter->($thing);
 116             }
 117         }
 118         return $thing;
 119     });
 120 }
 121
 122 sub as    ($) { $_[0] }
 123 sub from  ($) { $_[0] }
 124 sub where (&) { $_[0] }
 125 sub via   (&) { $_[0] }
 126
 127 # define some basic types
 128
 129 type Any => where { 1 };
 130
 131 type Value => where { !ref($_) };
 132 type Ref   => where {  ref($_) };
 133
 134 subtype Int => as Value => where {  Scalar::Util::looks_like_number($_) };
 135 subtype Str => as Value => where { !Scalar::Util::looks_like_number($_) };
 136
 137 subtype ScalarRef => as Ref => where { ref($_) eq 'SCALAR' };
 138 subtype ArrayRef  => as Ref => where { ref($_) eq 'ARRAY'  };
 139 subtype HashRef   => as Ref => where { ref($_) eq 'HASH'   };
 140 subtype CodeRef   => as Ref => where { ref($_) eq 'CODE'   };
 141 subtype RegexpRef => as Ref => where { ref($_) eq 'Regexp' };
 142
 143 # NOTE:
 144 # blessed(qr/.../) returns true,.. how odd
 145 subtype Object => as Ref => where { blessed($_) && blessed($_) ne 'Regexp' };
 146
 147 1;
 148
 149 __END__
 150
 151 =pod
 152
 153 =head1 NAME
 154
 155 Moose::Util::TypeConstraints - Type constraint system for Moose
 156
 157 =head1 SYNOPSIS
 158
 159   use Moose::Util::TypeConstraints;
 160
 161   type Num => where { Scalar::Util::looks_like_number($_) };
 162
 163   subtype Natural
 164       => as Num
 165       => where { $_ > 0 };
 166
 167   subtype NaturalLessThanTen
 168       => as Natural
 169       => where { $_ < 10 };
 170
 171   coerce Num
 172       => from Str
 173         => via { 0+$_ };
 174
 175 =head1 DESCRIPTION
 176
 177 This module provides Moose with the ability to create type contraints
 178 to be are used in both attribute definitions and for method argument
 179 validation.
 180
 181 This is B<NOT> a type system for Perl 5.
 182
 183 This module also provides a simple hierarchy for Perl 5 types, this
 184 could probably use some work, but it works for me at the moment.
 185
 186   Any
 187       Value
 188           Int
 189           Str
 190       Ref
 191           ScalarRef
 192           ArrayRef
 193           HashRef
 194           CodeRef
 195           RegexpRef
 196           Object
 197
 198 Suggestions for improvement are welcome.
 199
 200 =head1 FUNCTIONS
 201
 202 =head2 Type Constraint Registry
 203
 204 =over 4
 205
 206 =item B<find_type_constraint ($type_name)>
 207
 208 =item B<register_type_constraint ($type_name, $type_constraint)>
 209
 210 =item B<find_type_coercion>
 211
 212 =item B<register_type_coercion>
 213
 214 =item B<export_type_contstraints_as_functions>
 215
 216 =item B<dump_type_constraints>
 217
 218 =back
 219
 220 =head2 Type Constraint Constructors
 221
 222 =over 4
 223
 224 =item B<type>
 225
 226 =item B<subtype>
 227
 228 =item B<as>
 229
 230 =item B<where>
 231
 232 =item B<coerce>
 233
 234 =item B<from>
 235
 236 =item B<via>
 237
 238 =back
 239
 240 =head2 Built-in Type Constraints
 241
 242 =over 4
 243
 244 =item B<Any>
 245
 246 =item B<Value>
 247
 248 =item B<Int>
 249
 250 =item B<Str>
 251
 252 =item B<Ref>
 253
 254 =item B<ArrayRef>
 255
 256 =item B<CodeRef>
 257
 258 =item B<HashRef>
 259
 260 =item B<RegexpRef>
 261
 262 =item B<ScalarRef>
 263
 264 =item B<Object>
 265
 266 =back
 267
 268 =head1 BUGS
 269
 270 All complex software has bugs lurking in it, and this module is no
 271 exception. If you find a bug please either email me, or add the bug
 272 to cpan-RT.
 273
 274 =head1 AUTHOR
 275
 276 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 277
 278 =head1 COPYRIGHT AND LICENSE
 279
 280 Copyright 2006 by Infinity Interactive, Inc.
 281
 282 L<http://www.iinteractive.com>
 283
 284 This library is free software; you can redistribute it and/or modify
 285 it under the same terms as Perl itself.
 286
 287 =cut