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::Positional;
   6 use MooseX::Meta::TypeConstraint::Structured::Named;
   7
   8 #use MooseX::Types -declare => [qw(Dict  Tuple  Optional)];
   9 use Sub::Exporter
  10   -setup => { exports => [ qw( Dict  Tuple  Optional) ] };
  11
  12 our $VERSION = '0.01';
  13 our $AUTHORITY = 'cpan:JJNAPIORK';
  14
  15 =head1 NAME
  16
  17 MooseX::Types::Structured; Structured Type Constraints for Moose
  18
  19 =head1 SYNOPSIS
  20
  21 The following is example usage for this module.  You can define a class that has
  22 an attribute with a structured type like so:
  23
  24         package MyApp::MyClass;
  25
  26         use Moose;
  27         use MooseX::Types::Moose qw(Str Int);
  28         use MooseX::Types::Structured qw(Dict Tuple);
  29
  30         has name => (isa=>Dict[first_name=>Str, last_name=>Str]);
  31
  32 Then you can instantiate this class with something like:
  33
  34         my $instance = MyApp::MyClass->new(
  35                 name=>{first_name=>'John', last_name=>'Napiorkowski'},
  36         );
  37
  38 But all of these would cause an error:
  39
  40         my $instance = MyApp::MyClass->new(name=>'John');
  41         my $instance = MyApp::MyClass->new(name=>{first_name=>'John'});
  42         my $instance = MyApp::MyClass->new(name=>{first_name=>'John', age=>39});
  43
  44 Please see the test cases for more examples.
  45
  46 =head1 DESCRIPTION
  47
  48 This type library enables structured type constraints. Basically, this is very
  49 similar to parameterized constraints that are built into the core Moose types,
  50 except that you are allowed to define the container's entire structure.  For
  51 example, you could define a parameterized constraint like so:
  52
  53         subtype HashOfInts, as Hashref[Int];
  54
  55 which would constraint a value to something like [1,2,3,...] and so one.  A
  56 structured constraint like so:
  57
  58         subtype StringFollowedByInt, as Tuple[Str,Int];
  59
  60 would constrain it's value to something like ['hello', 111];
  61
  62 These structures can be as simple or elaborate as you wish.  You can even
  63 combine various structured, parameterized and simple constraints all together:
  64
  65         subtype crazy, as Tuple[Int, Dict[name=>Str, age=>Int], ArrayRef[Int]];
  66
  67 Which would match "[1, {name=>'John', age=>25},[10,11,12]]".
  68
  69 You should exercise some care as to whether or not your complex structured
  70 constraints would be better off contained by a real object as in the following
  71 example:
  72
  73         {
  74                 package MyApp::MyStruct;
  75                 use Moose;
  76
  77                         has $_ for qw(name age);
  78
  79                 package MyApp::MyClass;
  80                 use Moose;
  81
  82                         has person => (isa=>'MyApp::MyStruct');
  83         }
  84
  85         my $instance = MyApp::MyClass
  86                 ->new( person=>MyApp::MyStruct->new(name=>'John', age=>39) );
  87
  88 This method may take some additional time to setup but will give you more
  89 flexibility.  However, structured constraints are highly compatible with this
  90 method, granting some interesting possibilities for coercion.  Try:
  91
  92         subtype 'MyStruct',
  93          as 'MyApp::MyStruct';
  94
  95         coerce 'MyStruct',
  96          from (Dict[name=>Str, age=>Int]),
  97          via {
  98                 MyApp::MyStruct->new(%$_);
  99          },
 100          from (Dict[last_name=>Str, first_name=>Str, dob=>DateTime]),
 101          via {
 102                 my $name = _->{first_name} .' '. $_->{last_name};
 103                 my $age = $_->{dob} - DateTime->now;
 104                 MyApp::MyStruct->new(
 105                         name=>$name,
 106                         age=>$age->years );
 107          };
 108
 109
 110 =head1 TYPES
 111
 112 This class defines the following types and subtypes.
 113
 114 =cut
 115
 116 sub Optional($) {
 117     return bless {args=>shift}, 'MooseX::Types::Optional';
 118 }
 119
 120 sub Tuple($) {
 121         my ($args, $optional) = _normalize_args(@_);
 122         my @args = @$args;
 123         my @optional = ref $optional eq 'ARRAY' ? @$optional : ();
 124
 125         return MooseX::Meta::TypeConstraint::Structured::Positional->new(
 126                 name => 'Tuple',
 127                 parent => find_type_constraint('ArrayRef'),
 128                 package_defined_in => __PACKAGE__,
 129                 signature => [map {
 130                         _normalize_type_constraint($_);
 131                 } @args],
 132                 optional_signature => [map {
 133                         _normalize_type_constraint($_);
 134                 } @optional],
 135         );
 136 }
 137 use Data::Dump qw/dump/;
 138 sub Dict($) {
 139         my ($args, $optional) = _normalize_args(@_);
 140         my %args = @$args;
 141         my %optional = ref $optional eq 'ARRAY' ? @$optional : ();
 142
 143
 144         return MooseX::Meta::TypeConstraint::Structured::Named->new(
 145                 name => 'Dict',
 146                 parent => find_type_constraint('HashRef'),
 147                 package_defined_in => __PACKAGE__,
 148                 signature => {map {
 149                         $_ => _normalize_type_constraint($args{$_});
 150                 } keys %args},
 151                 optional_signature => {map {
 152
 153                         warn dump $_;
 154                         warn dump $optional{$_};
 155                         warn dump _normalize_type_constraint($optional{$_});
 156
 157                         $_ => _normalize_type_constraint($optional{$_});
 158
 159                 } keys %optional},
 160         );
 161 }
 162
 163 sub _normalize_args {
 164     my $args = shift @_;
 165     confess "Structured Type Constraints can only accept an ArrayRef as arguments"
 166      unless ref $args eq 'ARRAY';
 167
 168     my @args = @$args;
 169     my $last = pop @args;
 170
 171     if(blessed $last && $last->isa('MooseX::Types::Optional')) {
 172         return ([@args], $last->{args});
 173     } else {
 174         return ([@args, $last]);
 175     }
 176
 177 }
 178 sub _normalize_type_constraint {
 179         my ($tc) = @_;
 180
 181         ## If incoming is an object, we will assume it's something that implements
 182         ## what a type constraint is.  We should probably have a Role for this...
 183         if(defined $tc && blessed $tc) {
 184                 return $tc;
 185         } elsif($tc) {
 186                 return Moose::Util::TypeConstraints::find_or_parse_type_constraint($tc);
 187         }
 188 }
 189
 190 =head1 SEE ALSO
 191
 192 The following modules or resources may be of interest.
 193
 194 L<Moose>, L<MooseX::TypeLibrary>, L<Moose::Meta::TypeConstraint>
 195
 196 =head1 BUGS
 197
 198 No known or reported bugs.
 199
 200 =head1 AUTHOR
 201
 202 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
 203
 204 =head1 COPYRIGHT & LICENSE
 205
 206 This program is free software; you can redistribute it and/or modify
 207 it under the same terms as Perl itself.
 208
 209 =cut
 210
 211 1;