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