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