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 $parent_name = $self->parent->name;
  34
  35     if ($parent_name eq 'ArrayRef') {
  36         $constraint = sub {
  37             foreach my $x (@$_) {
  38                 ($type_parameter->check($x)) || return
  39             } 1;
  40         };
  41     }
  42     elsif ($parent_name eq 'HashRef') {
  43         $constraint = sub {
  44             foreach my $x (values %$_) {
  45                 ($type_parameter->check($x)) || return
  46             } 1;
  47         };
  48     }
  49     else {
  50         confess "Your isa must be either ArrayRef or HashRef (sorry no subtype support yet)";
  51     }
  52
  53     $self->_set_constraint($constraint);
  54
  55     $self->SUPER::compile_type_constraint;
  56 }
  57
  58 1;
  59
  60 __END__
  61
  62
  63 =pod
  64
  65 =head1 NAME
  66
  67 Moose::Meta::TypeConstraint::Parameterized - Higher Order type constraints for Moose
  68
  69 =head1 DESCRIPTION
  70
  71 =head1 METHODS
  72
  73 =over 4
  74
  75 =item B<compile_type_constraint>
  76
  77 =item B<type_parameter>
  78
  79 =item B<has_type_parameter>
  80
  81 =item B<meta>
  82
  83 =back
  84
  85 =head1 BUGS
  86
  87 All complex software has bugs lurking in it, and this module is no
  88 exception. If you find a bug please either email me, or add the bug
  89 to cpan-RT.
  90
  91 =head1 AUTHOR
  92
  93 Stevan Little E<lt>stevan@iinteractive.comE<gt>
  94
  95 =head1 COPYRIGHT AND LICENSE
  96
  97 Copyright 2006, 2007 by Infinity Interactive, Inc.
  98
  99 L<http://www.iinteractive.com>
 100
 101 This library is free software; you can redistribute it and/or modify
 102 it under the same terms as Perl itself.
 103
 104 =cut