lib/Moose/Util/TypeConstraints.pm

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