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