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 -
 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 =head1 FUNCTIONS
 129
 130 =head2 Type Constraint Constructors
 131
 132 =over 4
 133
 134 =item B<type>
 135
 136 =item B<subtype>
 137
 138 =item B<as>
 139
 140 =item B<where>
 141
 142 =back
 143
 144 =head2 Built-in Type Constraints
 145
 146 =over 4
 147
 148 =item B<Any>
 149
 150 =item B<Value>
 151
 152 =item B<Int>
 153
 154 =item B<Str>
 155
 156 =item B<Ref>
 157
 158 =item B<ArrayRef>
 159
 160 =item B<CodeRef>
 161
 162 =item B<HashRef>
 163
 164 =item B<RegexpRef>
 165
 166 =item B<ScalarRef>
 167
 168 =item B<Object>
 169
 170 =back
 171
 172 =head1 BUGS
 173
 174 All complex software has bugs lurking in it, and this module is no
 175 exception. If you find a bug please either email me, or add the bug
 176 to cpan-RT.
 177
 178 =head1 CODE COVERAGE
 179
 180 I use L<Devel::Cover> to test the code coverage of my tests, below is the
 181 L<Devel::Cover> report on this module's test suite.
 182
 183 =head1 ACKNOWLEDGEMENTS
 184
 185 =head1 AUTHOR
 186
 187 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 188
 189 =head1 COPYRIGHT AND LICENSE
 190
 191 Copyright 2006 by Infinity Interactive, Inc.
 192
 193 L<http://www.iinteractive.com>
 194
 195 This library is free software; you can redistribute it and/or modify
 196 it under the same terms as Perl itself.
 197
 198 =cut