lib/Moose/Meta/TypeConstraint/Parameterized.pm

   1 package Moose::Meta::TypeConstraint::Parameterized;
   2
   3 use strict;
   4 use warnings;
   5 use metaclass;
   6
   7 use Scalar::Util 'blessed';
   8 use Carp         'confess';
   9 use Moose::Util::TypeConstraints;
  10
  11 our $VERSION   = '0.02';
  12 our $AUTHORITY = 'cpan:STEVAN';
  13
  14 use base 'Moose::Meta::TypeConstraint';
  15
  16 __PACKAGE__->meta->add_attribute('type_parameter' => (
  17     accessor  => 'type_parameter',
  18     predicate => 'has_type_parameter',
  19 ));
  20
  21 sub compile_type_constraint {
  22     my $self = shift;
  23
  24     ($self->has_type_parameter)
  25         || confess "You cannot create a Higher Order type without a type parameter";
  26
  27     my $type_parameter = $self->type_parameter;
  28
  29     (blessed $type_parameter && $type_parameter->isa('Moose::Meta::TypeConstraint'))
  30         || confess "The type parameter must be a Moose meta type";
  31
  32     my $constraint;
  33     my $name = $self->parent->name;
  34
  35     my $array_coercion =
  36         Moose::Util::TypeConstraints::find_type_constraint('ArrayRef')
  37         ->coercion;
  38
  39     my $hash_coercion =
  40         Moose::Util::TypeConstraints::find_type_constraint('HashRef')
  41         ->coercion;
  42
  43     # ArrayRef[Foo] will check each element for the Foo constraint
  44     my $array_constraint = sub {
  45         foreach my $x (@$_) {
  46             ($type_parameter->check($x)) || return
  47         } 1;
  48     };
  49
  50     # HashRef[Foo] will check each value for the Foo constraint
  51     my $hash_constraint = sub {
  52         foreach my $x (values %$_) {
  53             ($type_parameter->check($x)) || return
  54         } 1;
  55     };
  56
  57     # if this is a subtype of ArrayRef, then we can use the ArrayRef[Foo]
  58     # constraint directly
  59     if ($self->is_subtype_of('ArrayRef')) {
  60         $constraint = $array_constraint;
  61     }
  62     # if this is a subtype of HashRef, then we can use the HashRef[Foo]
  63     # constraint directly
  64     elsif ($self->is_subtype_of('HashRef')) {
  65         $constraint = $hash_constraint;
  66     }
  67     # if we can coerce this type to an ArrayRef, do it and use the regular
  68     # ArrayRef[Foo] constraint
  69     elsif ($array_coercion && $array_coercion->has_coercion_for_type($name)) {
  70         $constraint = sub {
  71             local $_ = $array_coercion->coerce($_);
  72             $array_constraint->(@_);
  73         };
  74     }
  75     # if we can coerce this type to a HashRef, do it and use the regular
  76     # HashRef[Foo] constraint
  77     elsif ($hash_coercion && $hash_coercion->has_coercion_for_type($name)) {
  78         $constraint = sub {
  79             local $_ = $hash_coercion->coerce($_);
  80             $hash_constraint->(@_);
  81         };
  82     }
  83     else {
  84         confess "The " . $self->name . " constraint cannot be used, because " . $name . " doesn't subtype or coerce ArrayRef or HashRef.";
  85     }
  86
  87     $self->_set_constraint($constraint);
  88
  89     $self->SUPER::compile_type_constraint;
  90 }
  91
  92 1;
  93
  94 __END__
  95
  96
  97 =pod
  98
  99 =head1 NAME
 100
 101 Moose::Meta::TypeConstraint::Parameterized - Higher Order type constraints for Moose
 102
 103 =head1 DESCRIPTION
 104
 105 =head1 METHODS
 106
 107 =over 4
 108
 109 =item B<compile_type_constraint>
 110
 111 =item B<type_parameter>
 112
 113 =item B<has_type_parameter>
 114
 115 =item B<meta>
 116
 117 =back
 118
 119 =head1 BUGS
 120
 121 All complex software has bugs lurking in it, and this module is no
 122 exception. If you find a bug please either email me, or add the bug
 123 to cpan-RT.
 124
 125 =head1 AUTHOR
 126
 127 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 128
 129 =head1 COPYRIGHT AND LICENSE
 130
 131 Copyright 2006, 2007 by Infinity Interactive, Inc.
 132
 133 L<http://www.iinteractive.com>
 134
 135 This library is free software; you can redistribute it and/or modify
 136 it under the same terms as Perl itself.
 137
 138 =cut