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
 138 sub Dict($) {
 139         my ($args, $optional) = _normalize_args(@_);
 140         my %args = @$args;
 141         my %optional = ref $optional eq 'ARRAY' ? @$optional : ();
 142
 143         return MooseX::Meta::TypeConstraint::Structured::Named->new(
 144                 name => 'Dict',
 145                 parent => find_type_constraint('HashRef'),
 146                 package_defined_in => __PACKAGE__,
 147                 signature => {map {
 148                         $_ => _normalize_type_constraint($args{$_});
 149                 } keys %args},
 150                 optional_signature => {map {
 151                         $_ => _normalize_type_constraint($optional{$_});
 152                 } keys %optional},
 153         );
 154 }
 155
 156 sub _normalize_args {
 157     my $args = shift @_;
 158     confess "Structured Type Constraints can only accept an ArrayRef as arguments"
 159      unless ref $args eq 'ARRAY';
 160
 161     my @args = @$args;
 162     my $last = pop @args;
 163
 164     if(blessed $last && $last->isa('MooseX::Types::Optional')) {
 165         return ([@args], $last->{args});
 166     } else {
 167         return ([@args, $last]);
 168     }
 169
 170 }
 171 sub _normalize_type_constraint {
 172         my $tc = shift @_;
 173
 174         ## If incoming is an object, we will assume it's something that implements
 175         ## what a type constraint is.  We should probably have a Role for this...
 176         if(defined $tc && blessed $tc) {
 177                 return $tc;
 178         } elsif($tc) {
 179                 return Moose::Util::TypeConstraints::find_or_parse_type_constraint($tc);
 180         }
 181 }
 182
 183 =head1 SEE ALSO
 184
 185 The following modules or resources may be of interest.
 186
 187 L<Moose>, L<MooseX::TypeLibrary>, L<Moose::Meta::TypeConstraint>
 188
 189 =head1 BUGS
 190
 191 No known or reported bugs.
 192
 193 =head1 AUTHOR
 194
 195 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
 196
 197 =head1 COPYRIGHT & LICENSE
 198
 199 This program is free software; you can redistribute it and/or modify
 200 it under the same terms as Perl itself.
 201
 202 =cut
 203
 204 1;