lib/Moose/Meta/TypeConstraint.pm

   1
   2 package Moose::Meta::TypeConstraint;
   3
   4 use strict;
   5 use warnings;
   6 use metaclass;
   7
   8 use Sub::Name 'subname';
   9 use Carp      'confess';
  10
  11 our $VERSION = '0.01';
  12
  13 my %TYPE_CONSTRAINT_REGISTRY;
  14
  15 __PACKAGE__->meta->add_attribute('name'       => (reader => 'name'      ));
  16 __PACKAGE__->meta->add_attribute('parent'     => (reader => 'parent'    ));
  17 __PACKAGE__->meta->add_attribute('constraint' => (reader => 'constraint'));
  18
  19 # private accessor
  20 __PACKAGE__->meta->add_attribute('compiled_type_constraint' => (
  21     accessor => '_compiled_type_constraint'
  22 ));
  23
  24 __PACKAGE__->meta->add_attribute('coercion_code' => (
  25     reader    => 'coercion_code',
  26     writer    => 'set_coercion_code',
  27     predicate => 'has_coercion'
  28 ));
  29
  30 sub new {
  31     my $class  = shift;
  32     my $self = $class->meta->new_object(@_);
  33     $self->compile_type_constraint();
  34     return $self;
  35 }
  36
  37 sub compile_type_constraint () {
  38     my $self   = shift;
  39     my $check  = $self->constraint;
  40     (defined $check)
  41         || confess "Could not compile type constraint '" . $self->name . "' because no constraint check";
  42     my $parent = $self->parent;
  43     if (defined $parent) {
  44         $parent = $parent->_compiled_type_constraint;
  45                 $self->_compiled_type_constraint(subname $self->name => sub {
  46                         local $_ = $_[0];
  47                         return undef unless defined $parent->($_[0]) && $check->($_[0]);
  48                         $_[0];
  49                 });
  50     }
  51     else {
  52         $self->_compiled_type_constraint(subname $self->name => sub {
  53                 local $_ = $_[0];
  54                 return undef unless $check->($_[0]);
  55                 $_[0];
  56         });
  57     }
  58 }
  59
  60 # backwards for now
  61 sub constraint_code { (shift)->_compiled_type_constraint }
  62
  63 1;
  64
  65 __END__
  66
  67 =pod
  68
  69 =head1 NAME
  70
  71 Moose::Meta::TypeConstraint - The Moose Type Constraint metaobject
  72
  73 =head1 SYNOPSIS
  74
  75 =head1 DESCRIPTION
  76
  77 =head1 METHODS
  78
  79 =over 4
  80
  81 =item B<meta>
  82
  83 =item B<new>
  84
  85 =item B<name>
  86
  87 =item B<parent>
  88
  89 =item B<check>
  90
  91 =item B<constraint>
  92
  93 =item B<coerce>
  94
  95 =item B<coercion_code>
  96
  97 =item B<set_coercion_code>
  98
  99 =item B<constraint_code>
 100
 101 =item B<has_coercion>
 102
 103 =item B<compile_type_constraint>
 104
 105 =back
 106
 107 =head1 BUGS
 108
 109 All complex software has bugs lurking in it, and this module is no
 110 exception. If you find a bug please either email me, or add the bug
 111 to cpan-RT.
 112
 113 =head1 AUTHOR
 114
 115 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 116
 117 =head1 COPYRIGHT AND LICENSE
 118
 119 Copyright 2006 by Infinity Interactive, Inc.
 120
 121 L<http://www.iinteractive.com>
 122
 123 This library is free software; you can redistribute it and/or modify
 124 it under the same terms as Perl itself.
 125
 126 =cut