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