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