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 #use MooseX::Types::Moose qw();
   8 #use MooseX::Types -declare => [qw( Dict Tuple Optional )];
   9   use Sub::Exporter
  10     -setup => { exports => [ qw(Dict Tuple) ] };
  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 Tuple {
 117         my ($args, $optional) = @_;
 118         my @args = @$args;
 119         my @optional = ref $optional eq 'ARRAY' ? @$optional : ();
 120
 121         return MooseX::Meta::TypeConstraint::Structured::Positional->new(
 122                 name => 'Tuple',
 123                 parent => find_type_constraint('ArrayRef'),
 124                 package_defined_in => __PACKAGE__,
 125                 signature => [map {
 126                         _normalize_type_constraint($_);
 127                 } @args],
 128                 optional_signature => [map {
 129                         _normalize_type_constraint($_);
 130                 } @optional],
 131         );
 132 }
 133
 134 sub Dict {
 135         my ($args, $optional) = @_;
 136         my %args = @$args;
 137         my %optional = ref $optional eq 'ARRAY' ? @$optional : ();
 138
 139         return MooseX::Meta::TypeConstraint::Structured::Named->new(
 140                 name => 'Dict',
 141                 parent => find_type_constraint('HashRef'),
 142                 package_defined_in => __PACKAGE__,
 143                 signature => {map {
 144                         $_ => _normalize_type_constraint($args{$_});
 145                 } keys %args},
 146                 optional_signature => {map {
 147                         $_ => _normalize_type_constraint($optional{$_});
 148                 } keys %optional},
 149         );
 150 }
 151
 152 sub _normalize_type_constraint {
 153         my $tc = shift @_;
 154         if(defined $tc && blessed $tc && $tc->isa('Moose::Meta::TypeConstraint')) {
 155                 return $tc;
 156         } elsif($tc) {
 157                 return Moose::Util::TypeConstraints::find_or_parse_type_constraint($tc);
 158         }
 159 }
 160
 161 =head1 SEE ALSO
 162
 163 The following modules or resources may be of interest.
 164
 165 L<Moose>, L<MooseX::TypeLibrary>, L<Moose::Meta::TypeConstraint>
 166
 167 =head1 BUGS
 168
 169 No known or reported bugs.
 170
 171 =head1 AUTHOR
 172
 173 John Napiorkowski, C<< <jjnapiork@cpan.org> >>
 174
 175 =head1 COPYRIGHT & LICENSE
 176
 177 This program is free software; you can redistribute it and/or modify
 178 it under the same terms as Perl itself.
 179
 180 =cut
 181
 182 1;