1 package MooseX::Meta::TypeConstraint::Structured::Positional;
4 use Moose::Meta::TypeConstraint ();
6 extends 'Moose::Meta::TypeConstraint';
7 with 'MooseX::Meta::TypeConstraint::Role::Structured';
11 MooseX::Meta::TypeConstraint::Structured::Positional - Structured Type Constraints
15 The follow is example usage:
17 use Moose::Util::TypeConstraints;
18 use MooseX::Meta::TypeConstraint::Structured::Positional;
20 my @required = ('Str', 'Int');
21 my @optional = ('Object');
23 my $tc = MooseX::Meta::TypeConstraint::Structured::Positional->new(
25 parent => find_type_constraint('ArrayRef'),
27 find_type_constraint($_);
29 optional_signature => [map {
30 find_type_constraint($_);
36 Positionally structured Constraints expect the internal constraints to be in
37 'positioned' or ArrayRef style order. This allows you to add type constraints
38 to the internal values of the Arrayref.
42 This class defines the following attributes.
46 This is a signature of internal contraints for the contents of the outer
51 has '+signature' => (isa=>'ArrayRef[Moose::Meta::TypeConstraint]');
53 =head2 optional_signature
55 This is a signature of internal contraints for the contents of the outer
56 contraint container. These are optional constraints.
60 has '+optional_signature' => (isa=>'ArrayRef[Moose::Meta::TypeConstraint]');
64 This class defines the following methods.
66 =head2 _normalize_args
68 Get arguments into a known state or die trying. Ideally we try to make this
69 into a HashRef so we can match it up with the L</signature> HashRef.
74 my ($self, $args) = @_;
76 if(ref $args eq 'ARRAY') {
79 confess 'Signature must be an ArrayRef type';
82 confess 'Signature cannot be empty';
88 The constraint is basically validating the L</signature> against the incoming
95 my @args = $self->_normalize_args(shift);
96 my @signature = @{$self->signature};
97 my @optional_signature;
99 if($signature[-1]->isa('MooseX::Meta::TypeConstraint::Structured::Optional')) {
100 my $optional = pop @signature;
101 @optional_signature = @{$optional->signature};
104 ## First make sure all the required type constraints match
105 while( my $type_constraint = shift @signature) {
106 if(my $error = $type_constraint->validate(shift @args)) {
111 ## Now test the option type constraints.
112 while( my $arg = shift @args) {
113 if(my $optional_type_constraint = shift @optional_signature) {
114 if(my $error = $optional_type_constraint->validate($arg)) {
118 confess "Too Many arguments for the available type constraints";
122 ## If we got this far we passed!
127 =head2 _parse_type_parameter ($str)
129 Given a $string that is the parameter information part of a parameterized
130 constraint, parses it for internal constraint information. For example:
134 has a parameter string of "Int,Int,Str" (whitespace will automatically be
135 removed during normalization that happens in L<Moose::Util::TypeConstraints>)
136 and we need to convert that to ['Int','Int','Str'] which then has any type
137 constraints converted to true objects.
145 my $valid_chars = qr{[\w:]};
146 my $type_atom = qr{ $valid_chars+ };
148 my $type = qr{ $valid_chars+ (?: \[ (??{$any}) \] )? }x;
149 my $type_capture_parts = qr{ ($valid_chars+) (?: \[ ((??{$any})) \] )? }x;
150 my $type_with_parameter = qr{ $valid_chars+ \[ (??{$any}) \] }x;
152 my $op_union = qr{ \s* \| \s* }x;
153 my $union = qr{ $type (?: $op_union $type )+ }x;
155 ## New Stuff for structured types.
157 my $indirection = qr{=>};
158 my $divider_ops = qr{ $comma | $indirection }x;
159 my $structure_divider = qr{\s* $divider_ops \s*}x;
160 my $structure_elements = qr{ $valid_chars+ $structure_divider $type | $union }x;
162 $any = qr{ $union | $structure_elements+ | $type }x;
164 sub _parse_type_parameter {
165 my ($class, $type_str) = @_;
168 my @type_strs = ($type_str=~m/$union | $type/gx);
170 Moose::Util::TypeConstraints::find_or_create_type_constraint($_);
176 =head2 signature_equals
178 Check that the signature equals another signature.
182 sub signature_equals {
183 my ($self, $compared_type_constraint) = @_;
185 foreach my $idx (0..$#{$self->signature}) {
186 my $this = $self->signature->[$idx];
187 my $that = $compared_type_constraint->signature->[$idx];
188 return unless $this->equals($that);
191 if($self->has_optional_signature) {
192 foreach my $idx (0..$#{$self->optional_signature}) {
193 my $this = $self->optional_signature->[$idx];
194 my $that = $compared_type_constraint->optional_signature->[$idx];
195 return unless $this->equals($that);
204 John James Napiorkowski <jjnapiork@cpan.org>
208 You may distribute this code under the same terms as Perl itself.