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
  10 our $VERSION   = '0.01';
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use base 'Moose::Meta::TypeConstraint';
  14
  15 __PACKAGE__->meta->add_attribute('type_parameter' => (
  16     accessor  => 'type_parameter',
  17     predicate => 'has_type_parameter',
  18 ));
  19
  20 sub compile_type_constraint {
  21     my $self = shift;
  22
  23     ($self->has_type_parameter)
  24         || confess "You cannot create a Higher Order type without a type parameter";
  25
  26     my $type_parameter = $self->type_parameter;
  27
  28     (blessed $type_parameter && $type_parameter->isa('Moose::Meta::TypeConstraint'))
  29         || confess "The type parameter must be a Moose meta type";
  30
  31     my $constraint;
  32
  33     my $array_constraint = sub {
  34         foreach my $x (@$_) {
  35             ($type_parameter->check($x)) || return
  36         } 1;
  37     };
  38
  39     my $hash_constraint = sub {
  40         foreach my $x (values %$_) {
  41             ($type_parameter->check($x)) || return
  42         } 1;
  43     };
  44
  45     if ($self->is_subtype_of('ArrayRef')) {
  46         $constraint = $array_constraint;
  47     }
  48     elsif ($self->is_subtype_of('HashRef')) {
  49         $constraint = $hash_constraint;
  50     }
  51     else {
  52         confess "The " . $self->name . " constraint cannot be used, because " . $self->parent->name . " doesn't subtype ArrayRef or HashRef.";
  53     }
  54
  55     $self->_set_constraint($constraint);
  56
  57     $self->SUPER::compile_type_constraint;
  58 }
  59
  60 1;
  61
  62 __END__
  63
  64
  65 =pod
  66
  67 =head1 NAME
  68
  69 Moose::Meta::TypeConstraint::Parameterized - Higher Order type constraints for Moose
  70
  71 =head1 DESCRIPTION
  72
  73 =head1 METHODS
  74
  75 =over 4
  76
  77 =item B<compile_type_constraint>
  78
  79 =item B<type_parameter>
  80
  81 =item B<has_type_parameter>
  82
  83 =item B<meta>
  84
  85 =back
  86
  87 =head1 BUGS
  88
  89 All complex software has bugs lurking in it, and this module is no
  90 exception. If you find a bug please either email me, or add the bug
  91 to cpan-RT.
  92
  93 =head1 AUTHOR
  94
  95 Stevan Little E<lt>stevan@iinteractive.comE<gt>
  96
  97 =head1 COPYRIGHT AND LICENSE
  98
  99 Copyright 2006, 2007 by Infinity Interactive, Inc.
 100
 101 L<http://www.iinteractive.com>
 102
 103 This library is free software; you can redistribute it and/or modify
 104 it under the same terms as Perl itself.
 105
 106 =cut