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