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     my $array_constraint = sub {
  44         foreach my $x (@$_) {
  45             ($type_parameter->check($x)) || return
  46         } 1;
  47     };
  48
  49     my $hash_constraint = sub {
  50         foreach my $x (values %$_) {
  51             ($type_parameter->check($x)) || return
  52         } 1;
  53     };
  54
  55     if ($self->is_subtype_of('ArrayRef')) {
  56         $constraint = $array_constraint;
  57     }
  58     elsif ($self->is_subtype_of('HashRef')) {
  59         $constraint = $hash_constraint;
  60     }
  61     elsif ($array_coercion && $array_coercion->has_coercion_for_type($name)) {
  62         $constraint = sub {
  63             local $_ = $array_coercion->coerce($_);
  64             $array_constraint->(@_);
  65         };
  66     }
  67     elsif ($hash_coercion && $hash_coercion->has_coercion_for_type($name)) {
  68         $constraint = sub {
  69             local $_ = $hash_coercion->coerce($_);
  70             $hash_constraint->(@_);
  71         };
  72     }
  73     else {
  74         confess "The " . $self->name . " constraint cannot be used, because " . $name . " doesn't subtype or coerce ArrayRef or HashRef.";
  75     }
  76
  77     $self->_set_constraint($constraint);
  78
  79     $self->SUPER::compile_type_constraint;
  80 }
  81
  82 1;
  83
  84 __END__
  85
  86
  87 =pod
  88
  89 =head1 NAME
  90
  91 Moose::Meta::TypeConstraint::Parameterized - Higher Order type constraints for Moose
  92
  93 =head1 DESCRIPTION
  94
  95 =head1 METHODS
  96
  97 =over 4
  98
  99 =item B<compile_type_constraint>
 100
 101 =item B<type_parameter>
 102
 103 =item B<has_type_parameter>
 104
 105 =item B<meta>
 106
 107 =back
 108
 109 =head1 BUGS
 110
 111 All complex software has bugs lurking in it, and this module is no
 112 exception. If you find a bug please either email me, or add the bug
 113 to cpan-RT.
 114
 115 =head1 AUTHOR
 116
 117 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 118
 119 =head1 COPYRIGHT AND LICENSE
 120
 121 Copyright 2006, 2007 by Infinity Interactive, Inc.
 122
 123 L<http://www.iinteractive.com>
 124
 125 This library is free software; you can redistribute it and/or modify
 126 it under the same terms as Perl itself.
 127
 128 =cut