lib/MooseX/Types/Structured.pm

   1 package MooseX::Types::Structured;
   2
   3 use Moose;
   4 use Moose::Util::TypeConstraints;
   5 use MooseX::Meta::TypeConstraint::Structured;
   6 use MooseX::Types -declare => [qw(Dict Tuple)];
   7
   8
   9 our $VERSION = '0.01';
  10 our $AUTHORITY = 'cpan:JJNAPIORK';
  11
  12 =head1 NAME
  13
  14 MooseX::Types::Structured; Structured Type Constraints for Moose
  15
  16 =head1 SYNOPSIS
  17
  18 The following is example usage for this module.  You can define a class that has
  19 an attribute with a structured type like so:
  20
  21         package MyApp::MyClass;
  22
  23         use Moose;
  24         use MooseX::Types::Moose qw(Str Int);
  25         use MooseX::Types::Structured qw(Dict Tuple);
  26
  27         has name => (isa=>Dict[first_name=>Str, last_name=>Str]);
  28
  29 Then you can instantiate this class with something like:
  30
  31         my $instance = MyApp::MyClass->new(
  32                 name=>{first_name=>'John', last_name=>'Napiorkowski'},
  33         );
  34
  35 But all of these would cause an error:
  36
  37         my $instance = MyApp::MyClass->new(name=>'John');
  38         my $instance = MyApp::MyClass->new(name=>{first_name=>'John'});
  39         my $instance = MyApp::MyClass->new(name=>{first_name=>'John', age=>39});
  40
  41 Please see the test cases for more examples.
  42
  43 =head1 DESCRIPTION
  44
  45 This type library enables structured type constraints. Basically, this is very
  46 similar to parameterized constraints that are built into the core Moose types,
  47 except that you are allowed to define the container's entire structure.  For
  48 example, you could define a parameterized constraint like so:
  49
  50         subtype HashOfInts, as Hashref[Int];
  51
  52 which would constraint a value to something like [1,2,3,...] and so one.  A
  53 structured constraint like so:
  54
  55         subtype StringFollowedByInt, as Tuple[Str,Int];
  56
  57 would constrain it's value to something like ['hello', 111];
  58
  59 These structures can be as simple or elaborate as you wish.  You can even
  60 combine various structured, parameterized and simple constraints all together:
  61
  62         subtype crazy, as Tuple[Int, Dict[name=>Str, age=>Int], ArrayRef[Int]];
  63
  64 Which would match "[1, {name=>'John', age=>25},[10,11,12]]".
  65
  66 You should exercise some care as to whether or not your complex structured
  67 constraints would be better off contained by a real object as in the following
  68 example:
  69
  70         {
  71                 package MyApp::MyStruct;
  72                 use Moose;
  73
  74                         has $_ for qw(name age);
  75
  76                 package MyApp::MyClass;
  77                 use Moose;
  78
  79                         has person => (isa=>'MyApp::MyStruct');
  80         }
  81
  82         my $instance = MyApp::MyClass
  83                 ->new( person=>MyApp::MyStruct->new(name=>'John', age=>39) );
  84
  85 This method may take some additional time to setup but will give you more
  86 flexibility.  However, structured constraints are highly compatible with this
  87 method, granting some interesting possibilities for coercion.  Try:
  88
  89         subtype 'MyStruct',
  90          as 'MyApp::MyStruct';
  91
  92         coerce 'MyStruct',
  93          from (Dict[name=>Str, age=>Int]),
  94          via {
  95                 MyApp::MyStruct->new(%$_);
  96          },
  97          from (Dict[last_name=>Str, first_name=>Str, dob=>DateTime]),
  98          via {
  99                 my $name = _->{first_name} .' '. $_->{last_name};
 100                 my $age = $_->{dob} - DateTime->now;
 101                 MyApp::MyStruct->new(
 102                         name=>$name,
 103                         age=>$age->years );
 104          };
 105
 106
 107 =head1 METHODS
 108
 109 This class defines the following methods
 110
 111 =head2 type_storage
 112
 113 Override the type_storage method so that we can inline the types.  We do this
 114 because if we try to say "type Dict, $dict" or similar, I found that
 115 L<Moose::Util::TypeConstraints> automatically wraps a L<Moose::Meta::TypeConstraint>
 116 object around my Structured type, which then throws an error since the base
 117 Type Constraint object doesn't have a parameterize method.
 118
 119 In the future, might make all these play more nicely with Parameterized types,
 120 and then this nasty override can go away.
 121
 122 =cut
 123
 124 sub type_storage {
 125         return {
 126                 Tuple => MooseX::Meta::TypeConstraint::Structured->new(
 127                         name => 'Tuple',
 128                         parent => find_type_constraint('ArrayRef'),
 129                         constraint_generator=> sub {
 130                                 ## Get the constraints and values to check
 131                                 my @type_constraints = @{shift @_};
 132                                 my @values = @{shift @_};
 133                                 ## Perform the checking
 134                                 while(@type_constraints) {
 135                                         my $type_constraint = shift @type_constraints;
 136                                         if(@values) {
 137                                                 my $value = shift @values;
 138                                                 unless($type_constraint->check($value)) {
 139                                                         return;
 140                                                 }
 141                                         } else {
 142                                                 return;
 143                                         }
 144                                 }
 145                                 ## Make sure there are no leftovers.
 146                                 if(@values) {
 147                                         return;
 148                                 } elsif(@type_constraints) {
 149                                         return;
 150                                 }else {
 151                                         return 1;
 152                                 }
 153                         }
 154                 ),
 155                 Dict => MooseX::Meta::TypeConstraint::Structured->new(
 156                         name => 'Dict',
 157                         parent => find_type_constraint('HashRef'),
 158                         constraint_generator=> sub {
 159                                 ## Get the constraints and values to check
 160                                 my %type_constraints = @{shift @_};
 161                                 my %values = %{shift @_};
 162                                 ## Perform the checking
 163                                 while(%type_constraints) {
 164                                         my($key, $type_constraint) = each %type_constraints;
 165                                         delete $type_constraints{$key};
 166                                         if(exists $values{$key}) {
 167                                                 my $value = $values{$key};
 168                                                 delete $values{$key};
 169                                                 unless($type_constraint->check($value)) {
 170                                                         return;
 171                                                 }
 172                                         } else {
 173                                                 return;
 174                                         }
 175                                 }
 176                                 ## Make sure there are no leftovers.
 177                                 if(%values) {
 178                                         return;
 179                                 } elsif(%type_constraints) {
 180                                         return;
 181                                 }else {
 182                                         return 1;
 183                                 }
 184                         },
 185                 ),
 186         };
 187 }
 188
 189 =head1 SEE ALSO
 190
 191 The following modules or resources may be of interest.
 192
 193 L<Moose>, L<MooseX::TypeLibrary>, L<Moose::Meta::TypeConstraint>,
 194 L<MooseX::Meta::TypeConstraint::Structured>
 195
 196 =head1 AUTHOR
 197
 198 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
 199
 200 =head1 COPYRIGHT & LICENSE
 201
 202 This program is free software; you can redistribute it and/or modify
 203 it under the same terms as Perl itself.
 204
 205 =cut
 206
 207 1;