lib/MooseX/AttributeHelpers/Collection.pm

   1
   2 package MooseX::AttributeHelpers::Collection;
   3 use Moose;
   4 use Moose::Util::TypeConstraints;
   5
   6 our $VERSION   = '0.01';
   7 our $AUTHORITY = 'cpan:STEVAN';
   8
   9 extends 'MooseX::AttributeHelpers::Base';
  10
  11 has 'container_type' => (
  12     is        => 'ro',
  13     isa       => 'Str',
  14     predicate => 'has_container_type',
  15 );
  16
  17 has 'container_type_constraint' => (
  18     is       => 'rw',
  19     isa      => 'Moose::Meta::TypeConstraint',
  20     required => 1,
  21 );
  22
  23 before 'process_options_for_provides' => sub {
  24     my ($self, $options) = @_;
  25
  26     if (exists $options->{isa}) {
  27         my $type = $options->{isa};
  28
  29         # ... we should check if the type exists already
  30         # and then we should use it,.. however, this means
  31         # we need to extract the container type constraint
  32         # as well, which is a little trickier
  33
  34         if ($type =~ /^(.*)\[(.*)\]$/) {
  35             my $core_type      = $1;
  36             my $container_type = $2;
  37
  38             $options->{container_type} = $container_type;
  39
  40             my $container_type_constraint = find_type_constraint($container_type);
  41
  42             # NOTE:
  43             # I am not sure DWIM-ery is a good thing
  44             # here, so i am going to err on the side
  45             # of caution, and blow up if you have
  46             # not made a type constraint for this yet.
  47             # - SL
  48             (defined $container_type_constraint)
  49                 || confess "You must predefine the '$container_type' constraint before you can use it as a container type";
  50
  51             $options->{container_type_constraint} = $container_type_constraint;
  52
  53             if ($core_type eq 'ArrayRef') {
  54                 $options->{isa} = subtype('ArrayRef' => where {
  55                     foreach my $x (@$_) { ($container_type_constraint->check($x)) || return } 1;
  56                 });
  57             }
  58             elsif ($core_type eq 'HashRef') {
  59                 $options->{isa} = subtype('HashRef' => where {
  60                     foreach my $x (values %$_) { ($container_type_constraint->check($x)) || return } 1;
  61                 });
  62             }
  63             else {
  64                 confess "Your isa must be either ArrayRef or HashRef (sorry no subtype support yet)";
  65             }
  66         }
  67     }
  68 };
  69
  70 no Moose;
  71 no Moose::Util::TypeConstraints;
  72
  73 1;
  74
  75 __END__
  76
  77 =pod
  78
  79 =head1 NAME
  80
  81 =head1 SYNOPSIS
  82
  83 =head1 DESCRIPTION
  84
  85 =head1 METHODS
  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 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